module Wumpus.Basic.Monads.TurtleClass
(
Coord
, TurtleConfig(..)
, regularConfig
, TurtleM(..)
, TurtleScaleM(..)
, askSteps
, setsLoc
, setsLoc_
, resetLoc
, moveLeft
, moveRight
, moveUp
, moveDown
, nextLine
, getPos
, scaleCoord
) where
import Wumpus.Core
import Control.Monad
type Coord = (Int,Int)
data TurtleConfig u = TurtleConfig
{ xstep :: !u
, ystep :: !u
}
deriving (Eq,Show)
regularConfig :: u -> TurtleConfig u
regularConfig u = TurtleConfig u u
class Monad m => TurtleM m where
getLoc :: m (Int,Int)
setLoc :: (Int,Int) -> m ()
getOrigin :: m (Int,Int)
setOrigin :: (Int,Int) -> m ()
class TurtleM m => TurtleScaleM m u | m -> u where
xStep :: m u
yStep :: m u
askSteps :: TurtleScaleM m u => m (u,u)
askSteps = liftM2 (,) xStep yStep
setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a
setsLoc f = getLoc >>= \coord ->
let (a,coord') = f coord in setLoc coord' >> return a
setsLoc_ :: TurtleM m => (Coord -> Coord) -> m ()
setsLoc_ f = getLoc >>= \coord -> setLoc (f coord)
resetLoc :: TurtleM m => m ()
resetLoc = getOrigin >>= setLoc
moveRight :: TurtleM m => m ()
moveRight = setsLoc_ $ \(x,y)-> (x+1, y)
moveLeft :: TurtleM m => m ()
moveLeft = setsLoc_ $ \(x,y) -> (x1,y)
moveUp :: TurtleM m => m ()
moveUp = setsLoc_ $ \(x,y) -> (x,y+1)
moveDown :: TurtleM m => m ()
moveDown = setsLoc_ $ \(x,y) -> (x ,y1)
nextLine :: TurtleM m => m ()
nextLine = getOrigin >>= \(ox,_) ->
setsLoc_ $ \(_,y) -> (ox,y1)
getPos :: (TurtleScaleM m u, Num u) => m (Point2 u)
getPos = getLoc >>= \(x,y) ->
askSteps >>= \(sx,sy) ->
return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)
scaleCoord :: (TurtleScaleM m u, Num u) => (Int,Int) -> m (Point2 u)
scaleCoord (x,y) = askSteps >>= \(sx,sy) ->
return $ P2 (sx * fromIntegral x) (sy * fromIntegral y)