module Game.Goatee.Sgf.Monad (
GoT, GoM,
runGoT, runGo,
evalGoT, evalGo,
execGoT, execGo,
getCursor, getCoordState,
Step(..), goUp, goDown, goToRoot, goToGameInfoNode,
pushPosition, popPosition, dropPosition,
getProperties,
modifyProperties,
getProperty,
getPropertyValue,
putProperty,
deleteProperty,
modifyProperty,
modifyPropertyValue,
modifyPropertyString,
modifyPropertyCoords,
modifyGameInfo,
modifyVariationMode,
getMark,
modifyMark,
addChild,
Event, on, fire,
childAddedEvent, ChildAddedHandler,
gameInfoChangedEvent, GameInfoChangedHandler,
navigationEvent, NavigationHandler,
propertiesModifiedEvent, PropertiesModifiedHandler,
variationModeChangedEvent, VariationModeChangedHandler,
) where
import Control.Applicative ((<$>), Applicative ((<*>), pure))
import Control.Monad (ap, liftM, when)
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)
import qualified Control.Monad.State as State
import Control.Monad.State (StateT)
import Data.List (delete, find, mapAccumL, nub)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Game.Goatee.Common
import Game.Goatee.Sgf.Board
import Game.Goatee.Sgf.Property
import Game.Goatee.Sgf.Tree hiding (addChild)
import Game.Goatee.Sgf.Types
data GoState go = GoState { stateCursor :: Cursor
, statePathStack :: PathStack
, stateChildAddedHandlers :: [ChildAddedHandler go]
, stateGameInfoChangedHandlers :: [GameInfoChangedHandler go]
, stateNavigationHandlers :: [NavigationHandler go]
, statePropertiesModifiedHandlers :: [PropertiesModifiedHandler go]
, stateVariationModeChangedHandlers :: [VariationModeChangedHandler go]
}
type PathStack = [[Step]]
initialState :: Cursor -> GoState m
initialState cursor = GoState { stateCursor = cursor
, statePathStack = []
, stateChildAddedHandlers = []
, stateGameInfoChangedHandlers = []
, stateNavigationHandlers = []
, statePropertiesModifiedHandlers = []
, stateVariationModeChangedHandlers = []
}
data Step = GoUp Int
| GoDown Int
deriving (Eq, Show)
reverseStep :: Step -> Step
reverseStep step = case step of
GoUp index -> GoDown index
GoDown index -> GoUp index
takeStep :: Step -> Cursor -> Cursor
takeStep (GoUp _) cursor = fromMaybe (error $ "takeStep: Can't go up from " ++ show cursor ++ ".") $
cursorParent cursor
takeStep (GoDown index) cursor = cursorChild cursor index
takeStepM :: Monad m => Step -> (PathStack -> PathStack) -> GoT m ()
takeStepM step = case step of
GoUp _ -> goUp'
GoDown index -> goDown' index
class Monad go => MonadGo go where
getCursor :: go Cursor
getCoordState :: Coord -> go CoordState
getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor
goUp :: go ()
goDown :: Int -> go ()
goToRoot :: go ()
goToGameInfoNode :: Bool
-> go Bool
pushPosition :: go ()
popPosition :: go ()
dropPosition :: go ()
getProperties :: go [Property]
getProperties = liftM cursorProperties getCursor
modifyProperties :: ([Property] -> go [Property]) -> go ()
getProperty :: Descriptor d => d -> go (Maybe Property)
getPropertyValue :: ValuedDescriptor d v => d -> go (Maybe v)
getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor
putProperty :: Property -> go ()
putProperty property = modifyProperty (propertyInfo property) $ const $ Just property
deleteProperty :: Descriptor d => d -> go ()
deleteProperty descriptor = modifyProperty descriptor $ const Nothing
modifyProperty :: Descriptor d => d -> (Maybe Property -> Maybe Property) -> go ()
modifyPropertyValue :: ValuedDescriptor d v => d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old ->
propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)
modifyPropertyString :: (Stringlike s, ValuedDescriptor d s) => d -> (String -> String) -> go ()
modifyPropertyString descriptor fn =
modifyPropertyValue descriptor $ \value -> case fn (maybe "" sgfToString value) of
"" -> Nothing
str -> let sgf = stringToSgf str
in if null $ sgfToString sgf then Nothing else Just sgf
modifyPropertyCoords :: ValuedDescriptor d CoordList => d -> ([Coord] -> [Coord]) -> go ()
modifyPropertyCoords descriptor fn =
modifyPropertyValue descriptor $ \value -> case fn $ maybe [] expandCoordList value of
[] -> Nothing
coords -> Just $ buildCoordList coords
modifyGameInfo :: (GameInfo -> GameInfo) -> go GameInfo
modifyVariationMode :: (VariationMode -> VariationMode) -> go ()
getMark :: Coord -> go (Maybe Mark)
getMark = liftM coordMark . getCoordState
modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()
modifyMark fn coord = do
maybeOldMark <- getMark coord
case (maybeOldMark, fn maybeOldMark) of
(Just oldMark, Nothing) -> remove oldMark
(Nothing, Just newMark) -> add newMark
(Just oldMark, Just newMark) | oldMark /= newMark -> remove oldMark >> add newMark
(Just _, Just _) -> return ()
(Nothing, Nothing) -> return ()
where remove mark = modifyPropertyCoords (markProperty mark) (delete coord)
add mark = modifyPropertyCoords (markProperty mark) (coord:)
addChild :: Int -> Node -> go ()
on :: Event go h -> h -> go ()
newtype GoT m a = GoT { goState :: StateT (GoState (GoT m)) m a }
type GoM = GoT Identity
instance Monad m => Functor (GoT m) where
fmap = liftM
instance Monad m => Applicative (GoT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (GoT m) where
return x = GoT $ return x
m >>= f = GoT $ goState . f =<< goState m
fail = lift . fail
instance MonadTrans GoT where
lift = GoT . lift
instance MonadIO m => MonadIO (GoT m) where
liftIO = lift . liftIO
instance MonadWriter w m => MonadWriter w (GoT m) where
writer = lift . writer
tell = lift . tell
listen = GoT . listen . goState
pass = GoT . pass . goState
runGoT :: Monad m => GoT m a -> Cursor -> m (a, Cursor)
runGoT go cursor = do
(value, state) <- State.runStateT (goState go) (initialState cursor)
return (value, stateCursor state)
evalGoT :: Monad m => GoT m a -> Cursor -> m a
evalGoT go cursor = liftM fst $ runGoT go cursor
execGoT :: Monad m => GoT m a -> Cursor -> m Cursor
execGoT go cursor = liftM snd $ runGoT go cursor
runGo :: GoM a -> Cursor -> (a, Cursor)
runGo go = runIdentity . runGoT go
evalGo :: GoM a -> Cursor -> a
evalGo m cursor = fst $ runGo m cursor
execGo :: GoM a -> Cursor -> Cursor
execGo m cursor = snd $ runGo m cursor
getState :: Monad m => GoT m (GoState (GoT m))
getState = GoT State.get
putState :: Monad m => GoState (GoT m) -> GoT m ()
putState = GoT . State.put
modifyState :: Monad m => (GoState (GoT m) -> GoState (GoT m)) -> GoT m ()
modifyState = GoT . State.modify
instance Monad m => MonadGo (GoT m) where
getCursor = liftM stateCursor getState
goUp = do
index <- liftM cursorChildIndex getCursor
goUp' $ \pathStack -> case pathStack of
[] -> pathStack
path:paths -> (GoDown index:path):paths
goDown index = goDown' index $ \pathStack -> case pathStack of
[] -> pathStack
path:paths -> (GoUp index:path):paths
goToRoot = whileM (isJust . cursorParent <$> getCursor) goUp
goToGameInfoNode goToRootIfNotFound = pushPosition >> findGameInfoNode
where findGameInfoNode = do
cursor <- getCursor
if hasGameInfo cursor
then dropPosition >> return True
else if isNothing $ cursorParent cursor
then do if goToRootIfNotFound then dropPosition else popPosition
return False
else goUp >> findGameInfoNode
hasGameInfo cursor = internalIsGameInfoNode $ cursorNode cursor
pushPosition = modifyState $ \state ->
state { statePathStack = []:statePathStack state }
popPosition = do
getPathStack >>= \stack -> when (null stack) $
fail "popPosition: No position to pop from the stack."
whileM' (do path:_ <- getPathStack
return $ if null path then Nothing else Just $ head path) $
flip takeStepM $ \((_:steps):paths) -> steps:paths
modifyState $ \state -> case statePathStack state of
[]:rest -> state { statePathStack = rest }
_ -> error "popPosition: Internal failure, top of path stack is not empty."
dropPosition = do
state <- getState
case statePathStack state of
x:y:xs -> putState $ state { statePathStack = (x ++ y):xs }
_:[] -> putState $ state { statePathStack = [] }
[] -> fail "dropPosition: No position to drop from the stack."
modifyProperties fn = do
oldCursor <- getCursor
let oldProperties = cursorProperties oldCursor
newProperties <- fn oldProperties
modifyState $ \state ->
state { stateCursor = cursorModifyNode
(\node -> node { nodeProperties = newProperties })
oldCursor
}
fire propertiesModifiedEvent (\f -> f oldProperties newProperties)
let filterToGameInfo = nub . filter ((GameInfoProperty ==) . propertyType)
oldGameInfo = filterToGameInfo oldProperties
newGameInfo = filterToGameInfo newProperties
when (newGameInfo /= oldGameInfo) $ do
newCursor <- getCursor
fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard oldCursor)
(boardGameInfo $ cursorBoard newCursor))
getProperty descriptor = find (propertyPredicate descriptor) <$> getProperties
modifyProperty descriptor fn = do
cursor <- getCursor
let node = cursorNode cursor
old = findProperty descriptor node
new = fn old
when (maybe False (not . propertyPredicate descriptor) new) $
fail $ "modifyProperty: May not change property type: " ++
show old ++ " -> " ++ show new ++ "."
case (old, new) of
(Just _, Nothing) -> modifyProperties $ return . remove descriptor
(Nothing, Just value') -> modifyProperties $ return . add value'
(Just value, Just value') | value /= value' ->
modifyProperties $ return . add value' . remove descriptor
_ -> return ()
where remove descriptor = filter (not . propertyPredicate descriptor)
add value = (value:)
modifyGameInfo fn = do
cursor <- getCursor
let info = boardGameInfo $ cursorBoard cursor
info' = fn info
when (gameInfoRootInfo info /= gameInfoRootInfo info') $
fail "Illegal modification of root info in modifyGameInfo."
pushPosition
goToGameInfoNode True
modifyProperties $ \props ->
return $ gameInfoToProperties info' ++ filter ((GameInfoProperty /=) . propertyType) props
popPosition
return info'
modifyVariationMode fn = do
pushPosition
goToRoot
modifyPropertyValue propertyST $ \maybeOld ->
let old = fromMaybe defaultVariationMode maybeOld
new = fn old
in if new == old
then maybeOld
else if new == defaultVariationMode
then Nothing
else Just new
popPosition
addChild index node = do
cursor <- getCursor
let childCount = cursorChildCount cursor
when (index < 0 || index > childCount) $ fail $
"Monad.addChild: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."
let cursor' = cursorModifyNode (addChildAt index node) cursor
modifyState $ \state ->
state { stateCursor = cursor'
, statePathStack = updatePathStackCurrentNode
(\step -> case step of
GoUp n -> GoUp $ if n < index then n else n + 1
down@(GoDown _) -> down)
(\step -> case step of
up@(GoUp _) -> up
GoDown n -> GoDown $ if n < index then n else n + 1)
cursor'
(statePathStack state)
}
fire childAddedEvent (\f -> f index (cursorChild cursor' index))
on event handler = modifyState $ addHandler event handler
goUp' :: Monad m => (PathStack -> PathStack) -> GoT m ()
goUp' pathStackFn = do
state@(GoState { stateCursor = cursor
, statePathStack = pathStack
}) <- getState
case cursorParent cursor of
Nothing -> fail $ "goUp': Can't go up from a root cursor: " ++ show cursor
Just parent -> do
let index = cursorChildIndex cursor
putState state { stateCursor = parent
, statePathStack = pathStackFn pathStack
}
fire navigationEvent ($ GoUp index)
when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties cursor) $
fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)
(boardGameInfo $ cursorBoard parent))
goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m ()
goDown' index pathStackFn = do
state@(GoState { stateCursor = cursor
, statePathStack = pathStack
}) <- getState
case drop index $ cursorChildren cursor of
[] -> fail $ "goDown': Cursor does not have a child #" ++ show index ++ ": " ++ show cursor
child:_ -> do
putState state { stateCursor = child
, statePathStack = pathStackFn pathStack
}
fire navigationEvent ($ GoDown index)
when (any ((GameInfoProperty ==) . propertyType) $ cursorProperties child) $
fire gameInfoChangedEvent (\f -> f (boardGameInfo $ cursorBoard cursor)
(boardGameInfo $ cursorBoard child))
getPathStack :: Monad m => GoT m PathStack
getPathStack = liftM statePathStack getState
updatePathStackCurrentNode :: (Step -> Step)
-> (Step -> Step)
-> Cursor
-> PathStack
-> PathStack
updatePathStackCurrentNode _ _ _ [] = []
updatePathStackCurrentNode onEnter onExit cursor0 paths =
snd $ mapAccumL updatePath (cursor0, []) paths
where updatePath :: (Cursor, [Step]) -> [Step] -> ((Cursor, [Step]), [Step])
updatePath = mapAccumL updateStep
updateStep :: (Cursor, [Step]) -> Step -> ((Cursor, [Step]), Step)
updateStep (cursor, []) step = ((takeStep step cursor, [reverseStep step]), onExit step)
updateStep (cursor, pathToInitial@(stepToInitial:restToInitial)) step =
let pathToInitial' = if stepToInitial == step
then restToInitial
else reverseStep step:pathToInitial
in ((takeStep step cursor, pathToInitial'),
if null pathToInitial' then onEnter step else step)
fire :: Monad m => Event (GoT m) h -> (h -> GoT m ()) -> GoT m ()
fire event handlerGenerator = do
state <- getState
mapM_ handlerGenerator $ eventStateGetter event state
data Event go h = Event { eventName :: String
, eventStateGetter :: GoState go -> [h]
, eventStateSetter :: [h] -> GoState go -> GoState go
}
instance Show (Event go h) where
show = eventName
addHandler :: Event go h -> h -> GoState go -> GoState go
addHandler event handler state =
eventStateSetter event (eventStateGetter event state ++ [handler]) state
childAddedEvent :: Event go (ChildAddedHandler go)
childAddedEvent = Event {
eventName = "childAddedEvent"
, eventStateGetter = stateChildAddedHandlers
, eventStateSetter = \handlers state -> state { stateChildAddedHandlers = handlers }
}
type ChildAddedHandler go = Int -> Cursor -> go ()
gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)
gameInfoChangedEvent = Event {
eventName = "gameInfoChangedEvent"
, eventStateGetter = stateGameInfoChangedHandlers
, eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers }
}
type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()
navigationEvent :: Event go (NavigationHandler go)
navigationEvent = Event {
eventName = "navigationEvent"
, eventStateGetter = stateNavigationHandlers
, eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers }
}
type NavigationHandler go = Step -> go ()
propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)
propertiesModifiedEvent = Event {
eventName = "propertiesModifiedEvent"
, eventStateGetter = statePropertiesModifiedHandlers
, eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers }
}
type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()
variationModeChangedEvent :: Event go (VariationModeChangedHandler go)
variationModeChangedEvent = Event {
eventName = "variationModeChangedEvent"
, eventStateGetter = stateVariationModeChangedHandlers
, eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers }
}
type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()