module Wumpus.Basic.Monads.TurtleMonad
(
module Wumpus.Basic.Monads.TurtleClass
, TurtleT
, runTurtleT
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Monads.TurtleClass
import Control.Applicative
import Control.Monad
data TurtleState = TurtleState
{ _turtle_origin :: (Int,Int)
, _current_coord :: (Int,Int)
}
type TurtleScalingT u m a = ScalingT Int Int u m a
newtype TurtleT u m a = TurtleT {
getTurtleT :: TurtleState -> TurtleScalingT u m (a, TurtleState) }
type instance MonUnit (TurtleT u m) = u
instance Monad m => Functor (TurtleT u m) where
fmap f m = TurtleT $ \s -> getTurtleT m 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 $ \s -> getTurtleT mf s >>= \(f,s') ->
getTurtleT ma 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 $ \s -> getTurtleT m s >>= \(a,s') ->
(getTurtleT . k) a 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 =
runScalingT cfg (getTurtleT mf 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 $ \s -> localize upd (getTurtleT mf 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 $ \s@(TurtleState _ (x,y)) -> scalePt x y >>= \pt -> return (pt,s)