module Koch where

import System
import Char
import Tcl

-- a turtle based drawing example

type Pos   = (Int,Int)                      

test :: IO ()
test = start $
     do koch
	w <- rootWin
	bind w "<Escape>" (tcl_ ["destroy .koch"])
	return ()


koch :: GUI ()
koch = runTurtle $
     do penUp
	moveBy (-121,70)
	turnTo 90
	penDown
	guiTurtle (tcl_ ["update"])
	penColour "blue"
	kcurve depth 243
	turn 120
	kcurve depth 243
	turn 120
	kcurve depth 243
      where
	depth = 3

kcurve :: Int -> Int -> Turtle ()
kcurve 0 len = move len
kcurve n len =
     do kcurve n' len'
	turn (-60)
	kcurve n' len'
	turn 120
	kcurve n' len'
	turn (-60)
	kcurve n' len'
      where
	len' = len `div` 3
	n'   = n-1



data Turtle a = Trtl (Status->GUI a)

type Status = GUIRef State

data State = St Canvas Pos Int Bool String Int

instance Monad Turtle where
  return a      = Trtl (\s -> return a)
  Trtl am >>= f = Trtl (\s -> am s >>= \a ->
                              let {Trtl g = f a} in g s)

rcycle :: Int -> Int
rcycle m = (m+1) `mod` 20


peekTurtle :: Turtle State
peekTurtle = Trtl pt
      where
	pt rf = readState rf

pokeTurtle :: State -> Turtle ()
pokeTurtle st = Trtl pt
      where
	pt rf = writeState rf st

guiTurtle :: GUI a -> Turtle a
guiTurtle gui = Trtl (\rf->gui)

runTurtle :: Turtle () -> GUI ()
runTurtle trtl = runTurtle0 "Turtles" (300,300) "DarkGreen" trtl

runTurtle0 :: String -> Pos -> String -> Turtle () -> GUI ()
runTurtle0 ttl (sx,sy) bgcol trtl =
     do top <- window' ".koch" []
	title top "turtles"
	c  <- canvas' ".koch.can" [background bgcol, height sx, 
				   width sy]
	rf <- newState (St c (0,0) 0 False "black" (rcycle 0))
	tcl_ ["pack .koch.can"]
	tcl_ ["focus .koch.can"]
	f rf
      where
	Trtl f = do moveTo (ox,oy); penDown; trtl

	ox = sx `div` 2
	oy = sy `div` 2
	



penUp :: Turtle ()
penUp =
     do St c p a _ col m <- peekTurtle
	pokeTurtle (St c p a False col m)

penDown :: Turtle ()
penDown =
     do St c p a _ col m <- peekTurtle
	pokeTurtle (St c p a True col m)

penColour :: String -> Turtle ()
penColour col =
     do St c p a pd _ m <- peekTurtle
	pokeTurtle (St c p a pd col m)


turn :: Int -> Turtle ()
turn ad =
     do St c p a pd col m <- peekTurtle
	pokeTurtle (St c p ((a+ad) `mod` 360) pd col m)

turnTo :: Int -> Turtle ()
turnTo a =
     do St c p _ pd col m <- peekTurtle
	pokeTurtle (St c p (a `mod` 360) pd col m)

moveTo :: Pos -> Turtle ()
moveTo (x',y') =
     do St c p a pd col m <- peekTurtle
	guiTurtle (drawIt c pd col p p' m)
	pokeTurtle (St c p' a pd col (rcycle m))
      where
	p' = (x'*10,y'*10)

moveBy :: Pos -> Turtle ()
moveBy (dx,dy) =
     do St c p a pd col m <- peekTurtle
	let (x,y) = p
	    p' = (x+dx*10,y+dy*10)
	guiTurtle (drawIt c pd col p p' m)
	pokeTurtle (St c p' a pd col (rcycle m))

move :: Int -> Turtle ()
move len =
     do	St c p@(x,y) a pd col m <- peekTurtle
	let dx = round(fromIntegral len'*sin' a)
	    dy = round(fromIntegral len'*cos' a)
	    p' = (x+dx,y+dy)
	guiTurtle (drawIt c pd col p p' m)
	pokeTurtle (St c p' a pd col (rcycle m))
      where
	sin' a = sin(fromIntegral a*pi/180.0)
	cos' a = cos(fromIntegral a*pi/180.0)

	len'   = 10 * len

drawIt :: Canvas -> Bool -> String -> Pos -> Pos -> Int -> GUI ()
drawIt c False col p p' m = return ()
drawIt c True  col p p' m =
     do _ <- cline c [(sc p), (sc p')] [fill col]
	case m of
	  0 -> tcl_ ["update"]
	  _ -> return ()
      where
	sc (x,y) = (x `div` 10, y `div` 10)

