module FMP.Turtle (
Turtle(..), TurtleAttrib(..),spreadAttrib,figure,
turtle,
home, toleft, toright, turn, turnl, turnr, forward, backward,
penUp, penDown, plot, fork
) where
import FMP.Types
import FMP.Picture
import FMP.Canvas
import FMP.Color
type PicPos = ((Numeric,Numeric),Picture)
data Turtle = TConc Turtle Turtle
| TDropPic Picture
| TColor Color Turtle
| TPen Pen Turtle
| THide Turtle
| TForward Numeric
| TTurn Numeric
| TPenUp
| TPenDown
| THome
| TFork Turtle Turtle
deriving Show
data TurtleDescr = TurtleDescr {tPos :: (Numeric,Numeric),
tOrientation :: Numeric,
tColor :: Maybe Color,
tPen :: Maybe Pen,
tPenDown :: Bool }
instance HasDefault TurtleDescr where
default' = TurtleDescr {tPos = (0.0, 0.0),
tOrientation = 0,
tColor = Nothing,
tPen = Nothing,
tPenDown = True }
stdTurtleDescr :: TurtleDescr
stdTurtleDescr = TurtleDescr {tPos = (0.0, 0.0),
tOrientation = 0,
tColor = Nothing,
tPen = Nothing,
tPenDown = True }
data TurtleAttrib = TAttrib PathElemDescr Turtle
| TAttribFork [TurtleAttrib] [TurtleAttrib]
deriving Show
instance IsHideable Turtle where
hide = THide
instance HasConcat Turtle where
(&) = TConc
instance HasRelax Turtle where
relax = TTurn 0.0
instance HasPicture Turtle where
fromPicture = TDropPic . toPicture
instance HasColor Turtle where
setColor = TColor
setDefaultColor = setColor DefaultColor
getColor (TColor c _) = c
getColor _ = DefaultColor
instance HasPen Turtle where
setPen = TPen
setDefaultPen = TPen DefaultPen
getPen (TPen c _) = c
getPen _ = DefaultPen
instance IsPicture Turtle where
toPicture tp = toPicture (cdraws paths & foldl (&) relax cs)
where
cs = [ cdrop pos pic | (pos, pic) <- pics ]
(paths, pics) = figure tp stdPathElemDescr
turtle :: IsPicture a => a -> Picture
turtle = toPicture
home :: Turtle
home = THome
toleft :: Turtle
toleft = turn 90.0
toright :: Turtle
toright = turn (90.0)
turn :: Numeric -> Turtle
turn = TTurn
turnl :: Numeric -> Turtle
turnl a = TTurn a
turnr :: Numeric -> Turtle
turnr a = TTurn (a)
forward :: Numeric -> Turtle
forward = TForward
backward :: Numeric -> Turtle
backward a = forward (a)
penUp :: Turtle
penUp = TPenUp
penDown :: Turtle
penDown = TPenDown
plot :: [Turtle] -> Turtle
plot = foldr (&) relax
fork :: Turtle -> Turtle -> Turtle
fork = TFork
spreadAttrib :: PathElemDescr -> Turtle -> [TurtleAttrib]
-> [TurtleAttrib]
spreadAttrib ped (TConc p1 p2) ps
= spreadAttrib ped p1 (spreadAttrib ped p2 ps)
spreadAttrib ped (TColor c p) ps
= spreadAttrib (setColor c ped) p ps
spreadAttrib ped (TPen pen p) ps
= spreadAttrib (setPen pen ped) p ps
spreadAttrib ped (THide p ) ps
= spreadAttrib (hide ped) p ps
spreadAttrib ped (TFork p1 p2) ps
= [TAttribFork (spreadAttrib ped p1 ps)
(spreadAttrib ped p2 ps)]
spreadAttrib ped p ps = TAttrib ped p : ps
figure :: Turtle -> PathElemDescr -> ([Path], [PicPos])
figure t ped = renderPath default' (spreadAttrib ped t []) ([], [])
renderPath :: TurtleDescr -> [TurtleAttrib] -> ([Path],[PicPos])
-> ([Path],[PicPos])
renderPath td (TAttrib _ (TTurn d):ps) tp
= renderPath td' ps tp
where
td' = td{ tOrientation = tOrientation td + d }
renderPath td (TAttrib ped (TForward d):ps) tp
= (PathJoin (actualPos td) ped' rp:rps, pics)
where
(rp:rps, pics) = renderPath td' ps tp
td' = td{tPos = (x + d*cos phi, y + d*sin phi)}
(x, y) = tPos td
phi = tOrientation td
ped' = if (tPenDown td)
then ped
else hide ped
renderPath td (TAttrib _ TPenUp:ps) tp
= renderPath td{tPenDown = False} ps tp
renderPath td (TAttrib _ TPenDown:ps) tp
= renderPath td{tPenDown = True} ps tp
renderPath td (TAttrib ped THome:ps) tp
= (PathJoin (actualPos td) (hide ped)
rp:rps, pics)
where
(rp:rps, pics) = renderPath td' ps tp
td' = td{ tPos = (0.0, 0.0),
tOrientation = 0 }
renderPath td (TAttrib _ (TDropPic p):ps) tp
= (rps, (tPos td, p):pics)
where
(rps, pics) = renderPath td ps tp
renderPath td (TAttribFork ta1 ta2:ps) _
= (actualPos td:rps1++rps2, pics1++pics2)
where
(rps1, pics1) = renderPath td ta1 (renderPath td ps ([], []))
(rps2, pics2) = renderPath td ta2 (renderPath td ps ([], []))
renderPath td (TAttrib _ _:ps) tp
= renderPath td ps tp
renderPath td [] tp = (actualPos td:fst tp, snd tp)
actualPos :: TurtleDescr -> Path
actualPos td = toPath $ vec $ tPos td