{-# LANGUAGE CPP #-}
module Game.Goatee.Lib.Monad (
MonadGo (..),
GoT, GoM,
runGoT, runGo,
evalGoT, evalGo,
execGoT, execGo,
Step (..),
NodeDeleteResult (..),
Event, AnyEvent (..), eventName, fire, eventHandlerFromAction,
childAddedEvent, ChildAddedHandler,
childDeletedEvent, ChildDeletedHandler,
gameInfoChangedEvent, GameInfoChangedHandler,
navigationEvent, NavigationHandler,
propertiesModifiedEvent, PropertiesModifiedHandler,
variationModeChangedEvent, VariationModeChangedHandler,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), Applicative ((<*>), pure))
#endif
#if !MIN_VERSION_containers(0,5,0)
import Control.Arrow (second)
#endif
import Control.Monad ((<=<), ap, forM, forM_, liftM, msum, unless, when)
import Control.Monad.Identity (Identity, runIdentity)
import qualified Control.Monad.State as State
import Control.Monad.State (MonadState, StateT, get, put)
import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)
import Control.Monad.Writer.Class (MonadWriter, listen, pass, tell, writer)
import qualified Data.Function as F
import Data.List (delete, find, mapAccumL, nub, sortBy)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing)
import Data.Ord (comparing)
import Game.Goatee.Common
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Property
import qualified Game.Goatee.Lib.Tree as Tree
import Game.Goatee.Lib.Tree hiding (addChild, addChildAt, deleteChildAt)
import Game.Goatee.Lib.Types
data GoState go = GoState
{ stateCursor :: Cursor
, statePathStack :: PathStack
, stateChildAddedHandlers :: [ChildAddedHandler go]
, stateChildDeletedHandlers :: [ChildDeletedHandler 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 = []
, stateChildDeletedHandlers = []
, 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 Bool
takeStepM step = case step of
GoUp _ -> goUp'
GoDown index -> goDown' index
class (Functor go, Applicative go, Monad go) => MonadGo go where
getCursor :: go Cursor
getCoordState :: Coord -> go CoordState
getCoordState coord = liftM (boardCoordState coord . cursorBoard) getCursor
goUp :: go Bool
goDown :: Int -> go Bool
goLeft :: go Bool
goRight :: go Bool
goToRoot :: go ()
goToGameInfoNode :: Bool
-> go Bool
pushPosition :: go ()
popPosition :: go ()
dropPosition :: go ()
getProperties :: go [Property]
getProperties = liftM cursorProperties getCursor
modifyProperties :: ([Property] -> [Property]) -> go ()
getProperty :: Descriptor d => d -> go (Maybe Property)
getPropertyValue :: ValuedDescriptor v d => d -> go (Maybe v)
getPropertyValue descriptor = liftM (liftM $ propertyValue descriptor) $ getProperty descriptor
putProperty :: Property -> go ()
putProperty property = modifyProperty 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 v d => d -> (Maybe v -> Maybe v) -> go ()
modifyPropertyValue descriptor fn = modifyProperty descriptor $ \old ->
propertyBuilder descriptor <$> fn (propertyValue descriptor <$> old)
modifyPropertyString :: (Stringlike s, ValuedDescriptor s d) => 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
modifyPropertyList :: ValuedDescriptor [v] d => d -> ([v] -> [v]) -> go ()
modifyPropertyList descriptor fn =
modifyPropertyValue descriptor $ \value -> case fn $ fromMaybe [] value of
[] -> Nothing
value' -> Just value'
modifyPropertyCoords :: ValuedDescriptor CoordList d => 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 ()
getAssignedStone :: Coord -> go (Maybe (Maybe Color))
getAssignedStone coord =
fmap msum $ forM stoneAssignmentProperties $ \descriptor ->
((\coords -> if coord `elem` coords
then Just $ stoneAssignmentPropertyToStone descriptor
else Nothing) <=<
fmap expandCoordList) <$>
getPropertyValue descriptor
getAllAssignedStones :: go (Map Coord (Maybe Color))
getAllAssignedStones =
fmap Map.unions $ forM stoneAssignmentProperties $ \descriptor ->
let stone = stoneAssignmentPropertyToStone descriptor
in Map.fromList . map (\coord -> (coord, stone)) . maybe [] expandCoordList <$>
getPropertyValue descriptor
modifyAssignedStones :: [Coord] -> (Maybe (Maybe Color) -> Maybe (Maybe Color)) -> go ()
modifyAssignedStones coords f = do
needChild <- ((&&) <$> notElem SetupProperty <*> elem MoveProperty) .
map propertyType <$>
getProperties
if needChild
then case f Nothing of
Nothing -> return ()
Just assignedStone -> do
addChild emptyNode { nodeProperties =
[propertyBuilder (stoneToStoneAssignmentProperty assignedStone) $
buildCoordList coords]
}
ok <- goDown =<< subtract 1 . length . cursorChildren <$> getCursor
unless ok $ fail "GoT.modifyAssignedStones: Failed to move to new child."
else do
allAssignedStones <- getAllAssignedStones
let
allAssignedStones' = foldr (Map.alter f) allAssignedStones coords
byStone, byStone' :: Map (Maybe Color) [Coord]
byStone = mapInvert allAssignedStones
byStone' = mapInvert allAssignedStones'
diff :: Map (Maybe Color) ([Coord], [Coord])
#if MIN_VERSION_containers(0,5,0)
diff = Map.mergeWithKey
(\_ oldCoords newCoords -> if newCoords == oldCoords
then Nothing
else Just (oldCoords, newCoords))
(Map.map $ \oldCoords -> (oldCoords, []))
(Map.map $ \newCoords -> ([], newCoords))
byStone
byStone'
#else
diff = (\partialDiff ->
foldr (\(stone, new) ->
Map.alter (Just . maybe ([], new) (second $ const new))
stone)
partialDiff
(Map.assocs byStone')) $
Map.map (\old -> (old, [])) byStone
#endif
forM_ (Map.assocs diff) $ \(stone, (oldCoords, newCoords)) ->
when (newCoords /= oldCoords) $
modifyPropertyCoords (stoneToStoneAssignmentProperty stone) $ const newCoords
getMark :: Coord -> go (Maybe Mark)
getMark = liftM coordMark . getCoordState
modifyMark :: (Maybe Mark -> Maybe Mark) -> Coord -> go ()
modifyMark f coord = do
maybeOldMark <- getMark coord
case (maybeOldMark, f 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 :: Node -> go ()
addChild node = do
childCount <- liftM (length . cursorChildren) getCursor
addChildAt childCount node
addChildAt :: Int -> Node -> go ()
deleteChildAt :: Int -> go NodeDeleteResult
on :: Event go h -> h -> go ()
on0 :: Event go h -> go () -> go ()
on0 event handler = on event $ eventHandlerFromAction event handler
data NodeDeleteResult =
NodeDeleteOk
| NodeDeleteBadIndex
| NodeDeleteOnPathStack
deriving (Bounded, Enum, Eq, Show)
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 MonadState s m => MonadState s (GoT m) where
get = lift get
put = lift . put
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
goLeft = do
cursor <- getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
(Just _, 0) -> return False
(Just _, n) -> do True <- goUp
True <- goDown $ n - 1
return True
goRight = do
cursor <- getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
(Just parent, n) | n == cursorChildCount parent - 1 -> return False
(Just _, n) -> do True <- goUp
True <- goDown $ n + 1
return True
goToRoot = whileM goUp $ return ()
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) $ \step -> do
ok <- takeStepM step $ \((_:steps):paths) -> steps:paths
unless ok $ fail "popPosition: Failed to retrace steps."
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
}
when (sortBy (comparing propertyName) newProperties /=
sortBy (comparing propertyName) oldProperties) $
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 $ remove descriptor
(Nothing, Just value') -> modifyProperties $ add value'
(Just value, Just value') | value /= value' ->
modifyProperties $ 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 ->
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
addChildAt index node = do
cursor <- getCursor
let childCount = cursorChildCount cursor
when (index < 0 || index > childCount) $ fail $
"Monad.addChildAt: Index " ++ show index ++ " is not in [0, " ++ show childCount ++ "]."
let cursor' = cursorModifyNode (Tree.addChildAt index node) cursor
modifyState $ \state ->
state { stateCursor = cursor'
, statePathStack = foldPathStack
(\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)
id
cursor'
(statePathStack state)
}
fire childAddedEvent ($ index)
deleteChildAt index = do
childCount <- cursorChildCount <$> getCursor
if index < 0 || index >= childCount
then return NodeDeleteBadIndex
else do goDown index >>=
\ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, index isn't valid."
childCursor <- getCursor
deletingNodeOnPath <- doesPathStackEnterCurrentNode <$>
pure childCursor <*> getPathStack
goUp >>= \ok -> unless ok $ fail "GoT.deleteChildAt: Internal error, can't go up."
if deletingNodeOnPath
then return NodeDeleteOnPathStack
else do cursor <- getCursor
let cursor' = cursorModifyNode (Tree.deleteChildAt index) cursor
modifyState $ \state ->
state { stateCursor = cursor'
, statePathStack =
foldPathStack
(\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)
id
cursor'
(statePathStack state)
}
fire childDeletedEvent ($ childCursor)
return NodeDeleteOk
on event handler = modifyState $ addHandler event handler
goUp' :: Monad m => (PathStack -> PathStack) -> GoT m Bool
goUp' pathStackFn = do
state@(GoState { stateCursor = cursor
, statePathStack = pathStack
}) <- getState
case cursorParent cursor of
Nothing -> return False
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))
return True
goDown' :: Monad m => Int -> (PathStack -> PathStack) -> GoT m Bool
goDown' index pathStackFn = do
state@(GoState { stateCursor = cursor
, statePathStack = pathStack
}) <- getState
case drop index $ cursorChildren cursor of
[] -> return False
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))
return True
getPathStack :: Monad m => GoT m PathStack
getPathStack = liftM statePathStack getState
doesPathStackEnterCurrentNode :: Cursor -> PathStack -> Bool
doesPathStackEnterCurrentNode cursor pathStack =
or $ or <$> foldPathStack (const True) (const False) (const False) cursor pathStack
foldPathStack :: (Step -> a)
-> (Step -> a)
-> (Step -> a)
-> Cursor
-> PathStack
-> [[a]]
foldPathStack _ _ _ _ [] = []
foldPathStack onEnter onExit onOther cursor0 paths =
snd $ mapAccumL updatePath (cursor0, []) paths
where
updatePath = mapAccumL updateStep
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 onOther 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
, eventHandlerFromAction :: go () -> h
}
instance Eq (Event go h) where
(==) = (==) `F.on` eventName
instance Ord (Event go h) where
compare = comparing eventName
instance Show (Event go h) where
show = eventName
data AnyEvent go = forall h. AnyEvent (Event go h)
instance Eq (AnyEvent go) where
(AnyEvent e) == (AnyEvent e') = eventName e == eventName e'
instance Ord (AnyEvent go) where
compare (AnyEvent e) (AnyEvent e') = compare (eventName e) (eventName e')
instance Show (AnyEvent go) where
show (AnyEvent e) = eventName e
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 }
, eventHandlerFromAction = const
}
type ChildAddedHandler go = Int -> go ()
childDeletedEvent :: Event go (ChildDeletedHandler go)
childDeletedEvent = Event
{ eventName = "childDeletedEvent"
, eventStateGetter = stateChildDeletedHandlers
, eventStateSetter = \handlers state -> state { stateChildDeletedHandlers = handlers }
, eventHandlerFromAction = const
}
type ChildDeletedHandler go = Cursor -> go ()
gameInfoChangedEvent :: Event go (GameInfoChangedHandler go)
gameInfoChangedEvent = Event
{ eventName = "gameInfoChangedEvent"
, eventStateGetter = stateGameInfoChangedHandlers
, eventStateSetter = \handlers state -> state { stateGameInfoChangedHandlers = handlers }
, eventHandlerFromAction = const . const
}
type GameInfoChangedHandler go = GameInfo -> GameInfo -> go ()
navigationEvent :: Event go (NavigationHandler go)
navigationEvent = Event
{ eventName = "navigationEvent"
, eventStateGetter = stateNavigationHandlers
, eventStateSetter = \handlers state -> state { stateNavigationHandlers = handlers }
, eventHandlerFromAction = const
}
type NavigationHandler go = Step -> go ()
propertiesModifiedEvent :: Event go (PropertiesModifiedHandler go)
propertiesModifiedEvent = Event
{ eventName = "propertiesModifiedEvent"
, eventStateGetter = statePropertiesModifiedHandlers
, eventStateSetter = \handlers state -> state { statePropertiesModifiedHandlers = handlers }
, eventHandlerFromAction = const . const
}
type PropertiesModifiedHandler go = [Property] -> [Property] -> go ()
variationModeChangedEvent :: Event go (VariationModeChangedHandler go)
variationModeChangedEvent = Event
{ eventName = "variationModeChangedEvent"
, eventStateGetter = stateVariationModeChangedHandlers
, eventStateSetter = \handlers state -> state { stateVariationModeChangedHandlers = handlers }
, eventHandlerFromAction = const . const
}
type VariationModeChangedHandler go = VariationMode -> VariationMode -> go ()