--------------------------------------------------
-- Bachelorvoorlichting, 11 november 2006.      --
-- Software Technology, Turtle Graphics         --
--------------------------------------------------

module Main where

import Graphics.UI.WX hiding (position)
import Data.Char
import Data.List
import Data.Maybe

--------------------------------------------------
-- Part 1: The turtle commands

type Commands = [Command]
data Command  = Forward | TurnLeft | TurnRight | PenUp | PenDown 
   deriving Show

commandTable :: [(Char, Commands)]
commandTable = 
   [ ('F', [Forward])
   , ('L', [TurnLeft])
   , ('R', [TurnRight])
   , ('U', [PenUp])
   , ('D', [PenDown])
   ]

findCommands :: String -> Commands
findCommands = concat . catMaybes . map search . dealWithDigits
 where search c = lookup (toUpper c) commandTable

dealWithDigits :: String -> String
dealWithDigits xs 
   | null rest = xs
   | otherwise = begin ++ makeCopies (dealWithDigits ps) ++ dealWithDigits qs
 where 
   (begin, rest) = break isDigit xs
   (digits, end) = break (not . isDigit) rest
   (ps, qs)      = findClosing end
   makeCopies    = concat . replicate (read digits)

findClosing :: String -> (String, String)
findClosing ('(':xs) = rec 0 xs
 where add x (xs, ys) = (x:xs, ys)
       rec 0 (')':xs) = ([], xs)
       rec n (x:xs)   = add x (rec m xs)
        where m | x == '('  = n+1
                | x == ')'  = n-1
                | otherwise = n
       rec _ _ = error "unbalanced parentheses"
findClosing xs = splitAt 1 xs

--------------------------------------------------
-- Part 2: Moving the turtle

type Position = (Double, Double)
type Angle    = Double
type Figure   = [[Position]]

data Turtle = Turtle
   { position  :: Position
   , direction :: Angle
   , figure    :: Figure
   , penIsDown :: Bool
   }
   
alpha :: Double
alpha = pi/2

startTurtle :: Turtle
startTurtle = Turtle 
   { position  = (0, 0) 
   , direction = pi/2
   , figure    = [] 
   , penIsDown = False
   }

forwardSteps, turnSteps :: Int
forwardSteps = 4
turnSteps    = round (alpha / turnAngle)

turnAngle :: Double
turnAngle = pi/8

makeTurtleList :: Commands -> [Turtle]
makeTurtleList = scanl executeCommand startTurtle . turtleSpeed

turtleSpeed :: Commands -> Commands
turtleSpeed list = concat [ replicate (stepsFor cmd) cmd | cmd <- list ]
 where 
    stepsFor Forward   = forwardSteps
    stepsFor TurnLeft  = turnSteps
    stepsFor TurnRight = turnSteps
    stepsFor _         = 1

executeCommand :: Turtle -> Command -> Turtle
executeCommand turtle cmd = change turtle
 where 
   change = 
      case cmd of
         Forward   -> let dx = cos (direction turtle) / fromIntegral forwardSteps
                          dy = sin (direction turtle) / fromIntegral forwardSteps
                      in moveTurtle (dx, dy)
         TurnLeft  -> turnTurtle ( alpha / fromIntegral turnSteps)
         TurnRight -> turnTurtle (-alpha / fromIntegral turnSteps)
         PenUp     -> setTurtlePen False
         PenDown   -> setTurtlePen True

moveTurtle :: Position -> Turtle -> Turtle
moveTurtle (dx, dy) turtle = addToFigure (turtle {position = (x+dx, y+dy)})
 where (x, y) = position turtle

turnTurtle :: Angle -> Turtle -> Turtle
turnTurtle angle turtle = turtle {direction = direction turtle + angle}

setTurtlePen :: Bool -> Turtle -> Turtle
setTurtlePen b turtle = addToFigure (turtle {penIsDown = b, figure = change (figure turtle)})
 where change | b && not (penIsDown turtle) = ([]:) 
              | otherwise                   = id

addToFigure :: Turtle -> Turtle
addToFigure turtle =
   case figure turtle of 
      ps:rest | penIsDown turtle -> turtle {figure = (position turtle:ps):rest}
      _ -> turtle
      
--------------------------------------------------
-- Part 3: The Graphical User Interface (GUI)

test :: String -> IO ()
test txt = start $ 
   do ref <- varCreate turtles
      -- create widgets
      f   <- frame    [text := "Turtle Graphics"]
      p   <- panel  f [size := sz 600 600, bgcolor := white, on paint := paintHandler ref]
      t   <- timer  f [interval := 100, enabled := False]
      b1  <- button f [text := "Start"]
      b2  <- button f [text := "Reset", on command := clickResetButton ref f t b1]
      b3  <- button f [text := "Exit", on command := close f]
      -- install event handlers
      set t [on command := timerHandler ref p t]
      clickStopButton t b1
      -- arrange layout 
      set f [layout := column 10 [widget p, margin 25 $ row 10 $
                          intersperse (stretch glue) $ map widget [b1, b2, b3]]]
 where
   turtles  = makeTurtleList (findCommands txt)
   view     = makeView turtles
   drawing  = figure (last turtles)
   rendered = map (map (render view)) drawing
   
   -- event handlers
   paintHandler ref dc _ = 
      do turtle:_ <- varGet ref
         drawGrid   dc view
         drawFigure dc rendered
         drawTurtle dc view turtle

   timerHandler ref f t = 
      do _:as <- varGet ref
         if null as
            then set t [enabled := False]
            else varSet ref as
         repaint f

   clickStopButton t b = 
      do set t [enabled := False]
         set b [text := "Start", on command := clickStartButton t b]

   clickStartButton t b =
      do set b [text := "Stop", on command := clickStopButton t b]
         set t [enabled := True]
   
   clickResetButton ref f t b = 
      do clickStopButton t b
         varSet ref turtles
         repaint f

drawGrid :: DC () -> View -> IO ()
drawGrid dc info@(_, zoom) = 
   when (zoom >= 10) $
   do mapM_ (uncurry horLine) (makeList renderY)
      mapM_ (uncurry verLine) (makeList renderX)
 where
   horLine c y = line dc (point 0 y) (point 600 y) [color := c]
   verLine c x = line dc (point x 0) (point x 600) [color := c]
   inRange n   = n >= 0 && n <= 600
   lineColor n = if n==0 then lightred else lightblue
   makeList f  =  
      let g ns = takeWhile (inRange . snd) [ (lineColor n, f info n) | n <- ns ]
      in g [0..] ++ g [-1,-2..]
      
drawFigure :: DC () -> [[Point]] -> IO ()
drawFigure dc = mapM_ drawPolyLine
 where drawPolyLine [p] = circle dc p 3 [brushKind := BrushSolid, bgcolor := black]
       drawPolyLine ps  = polyline dc ps [penWidth := 2]
 
drawTurtle :: DC () -> View -> Turtle -> IO ()
drawTurtle dc view turtle = do
    circle dc center 10     [color := darkgreen, penWidth := 2]
    line   dc center facing [color := darkgreen, penWidth := 4]
    when (penIsDown turtle) $ 
       circle dc center 6 [color := darkgreen, bgcolor := darkgreen, brushKind := BrushSolid]
 where
   (x, y) = position turtle
   angle  = direction turtle
   center = render view (position turtle)
   facing = pointAdd center $ pt (round $ 20*cos angle) (negate $ round $ 20*sin angle)

lightblue, lightred, darkgreen :: Color
lightblue = rgb 191 191 255
lightred  = rgb 255 127 127
darkgreen = rgb 0 191 0

type View = (Point, Double) -- origin and zoom
   
render :: View -> Position -> Point
render view (x, y) = point (renderX view x) (renderY view y)

renderX, renderY :: View -> Double -> Int
renderX (origin, zoom) x = pointX origin + round (zoom*x)
renderY (origin, zoom) y = pointY origin - round (zoom*y)

makeView :: [Turtle] -> View
makeView turtles = (pt (round ptx) (round pty), zoom)
 where 
   (xs, ys)     = unzip ((0, 0) : map position turtles)
   spread list  = (minimum list - 2.5, maximum list + 2.5)
   (minx, maxx) = spread xs
   (miny, maxy) = spread ys
   dx   = maxx - minx
   dy   = maxy - miny
   diff = max dx dy
   zoom = 600/diff
   ptx  = zoom * ((diff-dx)/2 - minx)
   pty  = zoom * ((diff-dy)/2 + maxy)
   
--------------------------------------------------
-- Theme 1: Drawing text

main :: IO ()
main = test (drawWord "hello!")

drawWord :: String -> String
drawWord = concat . intersperse "FL" . map drawLetter

 -- Convention: start North, end East
drawLetter :: Char -> String
drawLetter c = 
   case c of
      'e' -> "DFFRFRRFLFLFRRFLFLFU"
      'h' -> "DFFRRFLFLFRRFFLU"
      'l' -> "DFFRRFFLFU"
      'o' -> "DFFRFRFFRFRRFU"
      '!' -> "DUFDFURRFFL"
      _   -> error ("drawOneLetter: unknown letter " ++ show c)

--------------------------------------------------
-- Theme 2: Drawing stars

rectangles :: String 
rectangles = "5(D4(3FR)U2FR2FL)"

--------------------------------------------------
-- Example 3: Mandelbrot

rewrites :: String -> [(Char, String)] -> Int -> String
rewrites begin table n = "D" ++ iterate next begin !! n
 where change c = maybe [c] id (lookup c table)  
       next     = concatMap change

koch, kochrect :: Int -> String
koch     = rewrites "FRFRFRF" [('F', "FRFLFLFFRFRFLF")]     
kochrect = rewrites "FRFRFRF" [('F', "FFRFLFRFRFF")]