-- Sierpinski Carpet                                   --
-- Copied from Paul Hudak's Haskell School of Expression --

import SOE

hexLine :: (Floating a) => Window -> a -> a -> Int -> a -> Color -> IO ()
hexLine w x y size theta color =
  drawInWindow w (withColor color 
                    (polygon (offset x y (rotaterad theta [(-size/2,-1 * size * (sqrt 3)/2), (size/2,-1 * size * (sqrt 3)/2), (size, 0), (size/2, size*(sqrt 3)/2),(size/2, -1 * size * (sqrt 3)/2), (size, 0)]))))
  where offset :: (Floating a) => a -> a -> [Point] -> [Point]
        offset _ _ [] = []
        offset x2 y ((a2,b):t) = (x+a2, y+b):offset x y t

rotaterad :: (Floating a) => a -> [Point] -> [Point]
rotaterad _ [] = []
rotaterad theta ((x,y):xs) = (x * (cos theta) + y * (sin theta), y * (cos theta) - x * (sin theta)) : rotaterad theta xs

minSize :: Int
minSize = 1

colorList :: [Color]
colorList = [Red, Blue, Yellow, Green] ++ colorList

hexa :: (Floating a) => Window -> Int -> Int -> Int -> a -> [Color] -> IO ()
hexa w x y size theta (c:cl) =
  if size <= minSize then 
    do hexLine w x y size theta c
  else 
    let size3 = size `div` 3
        s36 = size*(sqrt 3)/6
        s = size
        in
    do hexa w x (y-size3) size3 0 cl
       hexa w x (y+size3) size3 pi cl
       hexa w (x-s/2) (y-s36) size3 (pi/6) cl
       hexa w (x-s/2) (y+s36) size3 (11*pi/6) cl
       hexa w (x+s/2) (y-s36) size3 (7*pi/6) cl
       hexa w (x+s/2) (y+s36) size3 (5*pi/6) cl
       hexLine w x y size3 0 c

spaceClose :: Window -> IO ()
spaceClose w =
  do k <- getKey w
     if k == ' ' then closeWindow w
 		 else spaceClose w

main =
  runGraphics $ do
    w <- openWindow "Sierpinski's Carpet" (360, 360)
    hexa w 180 180 256 0 colorList
    spaceClose w