module Wumpus.Drawing.Turtle.TurtleMonad
(
module Wumpus.Drawing.Turtle.TurtleClass
, TurtleT
, runTurtleT
) where
import Wumpus.Basic.Kernel
import Wumpus.Drawing.Turtle.TurtleClass
import Control.Applicative
import Control.Monad
data TurtleState = TurtleState
{ _turtle_origin :: (Int,Int)
, _current_coord :: (Int,Int)
}
newtype TurtleT u m a = TurtleT {
getTurtleT :: ScalingContext Int Int u
-> TurtleState
-> m (a, TurtleState) }
type instance MonUnit (TurtleT u m) = u
instance Monad m => Functor (TurtleT u m) where
fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->
return (f a, s')
instance Monad m => Applicative (TurtleT u m) where
pure a = TurtleT $ \_ s -> return (a,s)
mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s >>= \(f,s') ->
getTurtleT ma r s' >>= \(a,s'') ->
return (f a,s'')
instance Monad m => Monad (TurtleT u m) where
return a = TurtleT $ \_ s -> return (a,s)
m >>= k = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') ->
(getTurtleT . k) a r s' >>= \(b,s'') ->
return (b,s'')
instance Monad m => TurtleM (TurtleT u m) where
getLoc = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s)
setLoc c = TurtleT $ \_ (TurtleState o _) -> return ((),TurtleState o c)
getOrigin = TurtleT $ \_ s@(TurtleState o _) -> return (o,s)
setOrigin o = TurtleT $ \_ (TurtleState _ c) -> return ((),TurtleState o c)
runTurtleT :: (Monad m, Num u)
=> (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a
runTurtleT ogin cfg mf = getTurtleT mf cfg st0 >>= \(a,_) -> return a
where
st0 = TurtleState ogin ogin
instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where
askDC = TurtleT $ \_ s -> askDC >>= \ ctx -> return (ctx,s)
localize upd mf = TurtleT $ \r s -> localize upd (getTurtleT mf r s)
instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where
trace a = TurtleT $ \_ s -> trace a >> return ((),s)
instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where
position = TurtleT $ \r s@(TurtleState _ (x,y)) -> return (scalePt r x y,s)