module Wumpus.Basic.Monads.TurtleMonad
(
Turtle
, TurtleT
, runTurtle
, runTurtleT
) where
import Wumpus.Basic.Monads.DrawingCtxClass
import Wumpus.Basic.Monads.TraceClass
import Wumpus.Basic.Monads.TurtleClass
import MonadLib ( MonadT(..) )
import Control.Applicative
import Control.Monad
data TurtleState = TurtleState
{ _turtle_origin :: (Int,Int)
, _current_coord :: (Int,Int)
}
newtype Turtle u a = Turtle {
getTurtle :: TurtleConfig u -> TurtleState -> (a, TurtleState) }
newtype TurtleT u m a = TurtleT {
getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) }
instance Functor (Turtle u) where
fmap f m = Turtle $ \r s -> let (a,s') = getTurtle m r s in (f a, s')
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 Applicative (Turtle u) where
pure a = Turtle $ \_ s -> (a,s)
mf <*> ma = Turtle $ \r s -> let (f,s') = getTurtle mf r s
(a,s'') = getTurtle ma r s'
in (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 (Turtle u) where
return a = Turtle $ \_ s -> (a,s)
m >>= k = Turtle $ \r s -> let (a,s') = getTurtle m r s
in (getTurtle . k) a r 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 MonadT (TurtleT u) where
lift m = TurtleT $ \_ s -> m >>= \a -> return (a,s)
instance TurtleM (Turtle u) where
getLoc = Turtle $ \_ s@(TurtleState _ c) -> (c,s)
setLoc c = Turtle $ \_ (TurtleState o _) -> ((),TurtleState o c)
getOrigin = Turtle $ \_ s@(TurtleState o _) -> (o,s)
setOrigin o = Turtle $ \_ (TurtleState _ c) -> ((),TurtleState o c)
instance TurtleScaleM (Turtle u) u where
xStep = Turtle $ \r s -> (xstep r,s)
yStep = Turtle $ \r s -> (ystep r,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)
instance Monad m => TurtleScaleM (TurtleT u m) u where
xStep = TurtleT $ \r s -> return (xstep r,s)
yStep = TurtleT $ \r s -> return (ystep r,s)
runTurtle :: Num u => TurtleConfig u -> (Int,Int) -> Turtle u a -> a
runTurtle cfg ogin mf = fst $ getTurtle mf cfg (TurtleState ogin ogin)
runTurtleT :: (Monad m, Num u)
=> TurtleConfig u -> (Int,Int) -> TurtleT u m a -> m a
runTurtleT cfg ogin mf = liftM fst $ getTurtleT mf cfg (TurtleState ogin ogin)
instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where
askDrawingCtx = TurtleT $ \_ s -> askDrawingCtx >>= \ ctx -> return (ctx,s)
localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s)
instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where
trace a = TurtleT $ \_ s -> trace a >> return ((),s)
trace1 a = TurtleT $ \_ s -> trace1 a >> return ((),s)