module Game.Antisplice.Rooms where
import Text.Chatty.Printer
import Text.Chatty.Scanner
import Text.Chatty.Expansion
import System.Chatty.Misc
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad
import Game.Antisplice.Utils.Graph
import Game.Antisplice.Utils.Counter
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Errors
import Control.Monad
import Control.Monad.Error
import Control.Monad.Trans.Class
import Data.Text (pack)
import Data.Maybe
import Data.Time.Clock
import Text.Printf
modifyRoomState :: MonadRoom m => (RoomState -> RoomState) -> m ()
modifyRoomState f = do
s <- getRoomState
putRoomState (f s)
getRoomDesc :: (MonadRoom m,IsText t) => m t
getRoomDesc = do
s <- getRoomState
return (fromText $ roomDescOf s)
getRoomTitle :: (MonadRoom m,IsText t) => m t
getRoomTitle = do
s <- getRoomState
return (fromText $ roomTitleOf s)
setRoomDesc :: (MonadRoom m,IsText t) => t -> m ()
setRoomDesc t = modifyRoomState $ \s -> s{roomDescOf=toText t}
setRoomTitle :: (MonadRoom m,IsText t) => t -> m ()
setRoomTitle t = modifyRoomState $ \s -> s{roomTitleOf=toText t}
markRoom :: MonadDungeon m => m ()
markRoom = do
s <- getDungeonState
case currentRoomOf s of
Just r -> putDungeonState s{roomsOf=markNode r $ roomsOf s}
enterRoom :: NodeId -> ChattyDungeonM Bool
enterRoom n = do
rs0 <- getRoomState
roomTriggerOnLeaveOf rs0
s <- getDungeonState
putDungeonState s{playerOf=fmap (\p -> p{playerRoomOf=n}) $ playerOf s}
let marked = nodeMarked $ getNode' n $ roomsOf s
rs <- getRoomState
unless marked $ do
markRoom
roomTriggerOnFirstEnterOf rs
roomTriggerOnEachEnterOf rs
sequence_ $ avlInorder $ flip fmap (roomObjectsOf rs) $ \os -> do
unless (objectOnceSeenOf os) $ objectTriggerOnFirstSightOf os
objectTriggerOnEachSightOf os
putRoomState rs{roomObjectsOf=fmap (\os -> os{objectOnceSeenOf=True}) $ roomObjectsOf rs}
return $ not marked
reenterCurrentRoom :: ChattyDungeonM ()
reenterCurrentRoom = do
s <- getDungeonState
case currentRoomOf s of
Just r -> void $ enterRoom r
enterAndAnnounce :: NodeId -> ChattyDungeonM ()
enterAndAnnounce n = do
r <- enterRoom n
rs <- getRoomState
roomTriggerOnAnnounceOf rs
when r $ roomTriggerOnLookOf rs
constructRoom :: (Monad m,MonadDungeon (t m),MonadTrans t) => RoomT m a -> t m NodeId
constructRoom m = do
(_,rs) <- lift $ runRoomT m $ RoomState (pack "") (pack "") EmptyAVL (return ()) (return ()) (return ()) (return ()) (return ())
s <- getDungeonState
let (nid,g) = addNode' rs $ roomsOf s
s' = if isNothing $ currentRoomOf s then s{roomsOf=g,playerOf=fmap (\p -> p{playerRoomOf=nid}) $ playerOf s} else s{roomsOf=g}
putDungeonState s'
return nid
withRoom :: MonadDungeon m => NodeId -> RoomT m a -> m a
withRoom n m = do
s <- getDungeonState
let rs = getNode n $ roomsOf s
(a,rs') <- runRoomT m rs
putDungeonState s{roomsOf=setNode n rs' $ roomsOf s}
return a
establishWay :: MonadDungeon m => NodeId -> NodeId -> Direction -> m ()
establishWay f t d = do
s <- getDungeonState
let g = addEdge f t 0 d $ roomsOf s
putDungeonState s{roomsOf=g}
changeRoom :: Direction -> ChattyDungeonM ()
changeRoom d = do
s <- getDungeonState
case currentRoomOf s of
Just r -> case followEdge r d (roomsOf s) of
Just n -> enterAndAnnounce n
Nothing -> throwError CantWalkThereError
addRoomObject :: (Monad m,MonadCounter (t m),MonadRoom (t m),MonadTrans t) => ObjectT m a -> t m ObjectId
addRoomObject m = do
i <- countOn
(_,o) <- lift $ runObjectT m $ ObjectState
(ObjectId i)
(pack "Something")
(pack "I don't know what this is.")
[] [] False False False False
100 100
EmptyAVL []
EmptyAVL []
(return ())
(return ())
(return ())
(return ())
(return ())
(return ())
(mprintLn "There is nothing special about this.")
(mprintLn "There is nothing inside this.")
(mprintLn "There is nothing written on this.")
(mprintLn "You cannot enter this.")
(return ())
(return ())
(return ())
(return ())
(return ())
(return ())
(return ())
insertRoomObject o
return $ ObjectId i
removeRoomObject :: MonadRoom m => ObjectId -> m ObjectState
removeRoomObject i = do
s <- getRoomState
let Just o = avlLookup i $ roomObjectsOf s
putRoomState s{roomObjectsOf=avlRemove i $ roomObjectsOf s}
return o
insertRoomObject :: MonadRoom m => ObjectState -> m ()
insertRoomObject o = modifyRoomState $ \s -> s{roomObjectsOf=avlInsert o $ roomObjectsOf s}
modifyObjectState :: MonadObject m => (ObjectState -> ObjectState) -> m ()
modifyObjectState f = do
s <- getObjectState
putObjectState $ f s
getObjectTitle :: (MonadObject m,IsText t) => m t
getObjectTitle = do
s <- getObjectState
return (fromText $ objectTitleOf s)
setObjectTitle :: (MonadObject m,IsText t) => t -> m ()
setObjectTitle t = modifyObjectState $ \s -> s{objectTitleOf=toText t}
getObjectDesc :: (MonadObject m,IsText t) => m t
getObjectDesc = do
s <- getObjectState
return (fromText $ objectDescOf s)
setObjectDesc :: (MonadObject m,IsText t) => t -> m ()
setObjectDesc t = modifyObjectState $ \s -> s{objectDescOf=toText t}
getObjectNames :: MonadObject m => m [String]
getObjectNames = do
s <- getObjectState
return $ objectNamesOf s
addObjectName :: MonadObject m => String -> m ()
addObjectName t = modifyObjectState $ \s -> s{objectNamesOf=t:objectNamesOf s}
matchObjectName :: MonadObject m => String -> m Bool
matchObjectName t = do
s <- getObjectState
return $ elem t $ objectNamesOf s
addObjectAttr :: MonadObject m => String -> m ()
addObjectAttr t = modifyObjectState $ \s -> s{objectAttributesOf=t:objectAttributesOf s}
subscribePlayer :: (MonadDungeon (t m),MonadTrans t,Monad m) => PlayerT m a -> t m ()
subscribePlayer m = do
s <- getDungeonState
(_,a) <- lift $ runPlayerT m $ PlayerState (rootNode $ roomsOf s) 100 100 EmptyAVL EmptyAVL EmptyAVL
putDungeonState s{playerOf=Just a}
modifyPlayerState :: MonadPlayer m => (PlayerState -> PlayerState) -> m ()
modifyPlayerState f = do
s <- getPlayerState
putPlayerState $ f s
setPlayerRoom :: MonadPlayer m => NodeId -> m ()
setPlayerRoom r = modifyPlayerState $ \p -> p{playerRoomOf=r}
getObjectIsMob :: (MonadObject m,Functor m) => m Bool
getObjectIsMob = fmap (isJust . avlLookup Mobile . objectFeaturesOf) getObjectState
setObjectIsMob :: MonadObject m => Bool -> m ()
setObjectIsMob b = modifyObjectState $ \o -> o{objectFeaturesOf=a b $ objectFeaturesOf o}
where a True = avlInsert (Mobile,())
a False = avlRemove Mobile
getObjectIsAcquirable :: (MonadObject m,Functor m) => m Bool
getObjectIsAcquirable = fmap (isJust . avlLookup Acquirable . objectFeaturesOf) getObjectState
setObjectIsAcquirable :: MonadObject m => Bool -> m ()
setObjectIsAcquirable b = modifyObjectState $ \o -> o{objectFeaturesOf=a b $ objectFeaturesOf o}
where a True = avlInsert (Acquirable,())
a False = avlRemove Acquirable
schedule :: (MonadDungeon m,MonadClock m) => Integer -> Trigger -> m ()
schedule ms t = do
now <- mgetstamp
let t' = now + (realToFrac ms / 1000)
s <- getDungeonState
putDungeonState s{timeTriggersOf=avlInsert (t',TriggerBox t) $ timeTriggersOf s}
setMobRoute :: MonadObject m => [NodeId] -> m ()
setMobRoute rs = modifyObjectState $ \s -> s{objectRouteOf=rs}
continueMobRoute :: ObjectId -> Trigger
continueMobRoute i = do
rs <- roomOfObject i
case rs of
[r] -> do
o <- withRoom r $ removeRoomObject i
guardVisible r $ objectTriggerOnRoomLeaveOf o
let (n:rs) = objectRouteOf o
withRoom n $ insertRoomObject o{objectRouteOf=rs++[n]}
guardVisible n $ objectTriggerOnRoomEnterOf o
return ()
[] -> throwError CantSeeOneError
_ -> throwError WhichOneError
guardVisible :: MonadDungeon m => NodeId -> m () -> m ()
guardVisible n m = do
s <- getDungeonState
when (currentRoomOf s == Just n) m
roomOfObject :: MonadDungeon m => ObjectId -> m [NodeId]
roomOfObject o = (return . map nodeId . filter (isJust . avlLookup o . roomObjectsOf . nodeContent) . allNodes . roomsOf) =<< getDungeonState
acquireObject :: ObjectId -> ChattyDungeonM ()
acquireObject i = do
rs <- roomOfObject i
case rs of
[r] -> do
o <- withRoom r $ removeRoomObject i
modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}
[] -> throwError CantSeeOneError
_ -> throwError WhichOneError
dropObject :: ObjectId -> ChattyDungeonM ()
dropObject i = do
Just r <- (return . currentRoomOf) =<< getDungeonState
ps <- getPlayerState
let Just o = avlLookup i $ playerInventoryOf ps
putPlayerState ps{playerInventoryOf=avlRemove i $ playerInventoryOf ps}
insertRoomObject o