module Game.Antisplice.Rooms (
modifyRoomState,
getRoomDesc,
getRoomTitle,
setRoomTitle,
markRoom,
enterRoom,
reenterCurrentRoom,
enterAndAnnounce,
changeRoom,
constructRoom,
establishWay,
addRoomObject,
removeRoomObject,
insertRoomObject,
modifyObjectState,
setObjectDesc,
setObjectTitle,
addObjectName,
addObjectAttr,
setObjectIsMob,
setObjectIsAcquirable,
addFeature,
addDescSeg,
addEquipSlot,
registerForm,
instanciateForm,
getObjectTitle,
getObjectDesc,
getObjectNames,
matchObjectName,
getObjectIsMob,
getObjectIsAcquirable,
roomOfObject,
setMobRoute,
continueMobRoute,
schedule,
subscribePlayer,
setPlayerRoom,
acquireObject,
dropObject,
equipObject,
equipObjectAt,
getEquipment,
getCooldown,
setCooldown,
getCurrency,
modifyCurrency,
damage,
focusOpponent,
dealDamage,
withRoom,
withPlayer,
withObject,
guardVisible
) 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.BST
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.Atoms
import Game.Antisplice.Utils.None
import Game.Antisplice.Errors
import Control.Arrow
import Control.Monad
import Control.Monad.Error
import Control.Monad.Trans.Class
import Data.Text (pack)
import Data.Maybe
import Data.List
import Data.Time.Clock
import Text.Printf
modifyRoomState :: MonadRoom m => (RoomState -> RoomState) -> m ()
modifyRoomState f = do
s <- getRoomState
putRoomState (f s)
getRoomDesc :: (MonadRoom m,MonadAtoms m) => m String
getRoomDesc = do
s <- getRoomState
let descseg (Described a) = getAtom a
descseg _ = return none
is <- liftM (filter $ not.null) $ mapM descseg $ concatMap (avlInorder.objectFeaturesOf) $ avlInorder $ roomObjectsOf s
return $ concat $ intersperse " " is
getRoomTitle :: (MonadRoom m,IsText t) => m t
getRoomTitle = do
s <- getRoomState
return (fromText $ roomTitleOf s)
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
modifyPlayerState $ \p -> p{playerRoomOf=n}
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 :: (MonadDungeon m) => RoomT m a -> m NodeId
constructRoom m = do
(_,rs) <- runRoomT m $ RoomState none none noneM noneM noneM noneM noneM
s <- getDungeonState
let (nid,g) = addNode' rs $ roomsOf s
putDungeonState s{roomsOf=g}
when (isNothing $ currentRoomOf s) $ modifyPlayerState $ \p -> p{playerRoomOf=nid}
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 -> PathState -> m ()
establishWay f t d c = do
s <- getDungeonState
let g = addEdge f t 0 d c $ roomsOf s
putDungeonState s{roomsOf=g}
changeRoom :: Direction -> ChattyDungeonM ()
changeRoom d = do
s <- getDungeonState
case currentRoomOf s of
Just r -> case queryEdge r d (roomsOf s) of
Just c -> do
b <- pathPrerequisiteOf c
unless b $ throwError CantWalkThereError
case followEdge r d (roomsOf s) of
Just n -> enterAndAnnounce n
Nothing -> throwError CantWalkThereError
addRoomObject :: (MonadCounter m,MonadRoom m) => ObjectT m a -> m ObjectId
addRoomObject m = do
i <- liftM ObjectId countOn
o <- constructObject m $ Just i
insertRoomObject o
return i
constructObject :: Monad m => ObjectT m a -> Maybe ObjectId -> m ObjectState
constructObject m j = do
(_,o) <- runObjectT m $ ObjectState
(if isJust j then (\(Just j) -> j) j else none)
(pack "Something")
(pack "I don't know what this is.")
none none False False False False
100 100
none none
none
noneM
noneM
noneM
noneM
noneM
noneM
(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.")
noneM
noneM
noneM
noneM
noneM
noneM
noneM
noneM
noneM
return o
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 m,MonadCounter m) => PlayerT m a -> m ()
subscribePlayer m = do
s <- getDungeonState
i <- liftM PlayerId countOn
let r = rootNode $ roomsOf s
(_,a) <- runPlayerT m $ PlayerState i r 100 none none none none none (avlInsert (Health,100) none) none none
putDungeonState s{playersOf=anyBstInsert a $ playersOf 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 -> Handler -> m ()
schedule ms t = do
now <- mgetstamp
let t' = now + (realToFrac ms / 1000)
s <- getDungeonState
putDungeonState s{timeTriggersOf=avlInsert (t',Handler t) $ timeTriggersOf s}
setMobRoute :: MonadObject m => [NodeId] -> m ()
setMobRoute rs = modifyObjectState $ \s -> s{objectRouteOf=rs}
continueMobRoute :: ObjectId -> Handler
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
addFeature :: MonadObject m => Feature -> m ()
addFeature f = modifyObjectState $ \s -> s{objectFeaturesOf=avlInsert f $ objectFeaturesOf s}
addDescSeg :: (MonadObject m,MonadAtoms m) => String -> m ()
addDescSeg s = do
a <- newAtom
putAtom a s
addFeature $ Described a
registerForm :: (MonadAtoms m) => ObjectT m () -> m (Atom ObjectState)
registerForm m = do
a <- newAtom
o <- constructObject m Nothing
putAtom a o
return a
instanciateForm :: (MonadAtoms m,MonadRoom m,MonadCounter m) => Atom ObjectState -> m ObjectId
instanciateForm a = do
i <- countOn
o <- getAtom a
insertRoomObject o{objectIdOf=ObjectId i}
return $ ObjectId i
equipObjectAt :: (MonadPlayer m,MonadError SplErr m) => EquipKey -> ObjectState -> m (Maybe ObjectState)
equipObjectAt k o
| isJust (avlLookup (Equipable k) $ objectFeaturesOf o) = do
p <- getPlayerState
let o1 = avlLookup k $ playerEquipOf p
putPlayerState p{playerEquipOf=avlInsert (k,o) $ playerEquipOf p, playerInventoryOf=avlRemove (indexOf o) $ playerInventoryOf p}
return o1
| otherwise = throwError CantEquipThatThereError
equipObject :: (MonadPlayer m,MonadError SplErr m) => ObjectState -> m (Maybe ObjectState)
equipObject o =
let equ (Equipable k) = [k]
equ _ = none
in case concatMap equ $ avlInorder $ objectFeaturesOf o of
[] -> throwError CantEquipThatError
[k] -> equipObjectAt k o
ks -> do
p <- getPlayerState
case filter (isJust.flip avlLookup (playerEquipOf p)) ks of
[] -> throwError WhereToEquipError
[k] -> equipObjectAt k o
_ -> throwError WhereToEquipError
getEquipment :: MonadPlayer m => EquipKey -> m (Maybe ObjectState)
getEquipment k = liftM (avlLookup k.playerEquipOf) getPlayerState
addEquipSlot :: MonadObject m => EquipKey -> m ()
addEquipSlot = addFeature . Equipable
setCooldown :: MonadPlayer m => CooldownId -> Bool -> m ()
setCooldown c b = modifyPlayerState $ \p -> p{playerCooldownsOf=(if b then avlInsert else avlRemove) c $ playerCooldownsOf p}
getCooldown :: MonadPlayer m => CooldownId -> m Bool
getCooldown c = liftM (isJust . avlLookup c . playerCooldownsOf) getPlayerState
getCurrency :: MonadPlayer m => CurrencyId -> m Int
getCurrency c = liftM (joinMaybe . avlLookup c . playerCurrenciesOf) getPlayerState
modifyCurrency :: MonadPlayer m => CurrencyId -> (Int -> Int) -> m ()
modifyCurrency c f = modifyPlayerState $ \p ->
let c1 = joinMaybe $ avlLookup c $ playerCurrenciesOf p
in p{playerCurrenciesOf=avlInsert (c,f c1) $ playerCurrenciesOf p}
withPlayer :: MonadDungeon m => PlayerId -> PlayerT (RoomT m) a -> m a
withPlayer i m = do
d <- getDungeonState
case anyBstLookup i $ playersOf d of
Just p -> do
(a,p') <- withRoom (playerRoomOf p) $ runPlayerT m p
d <- getDungeonState
putDungeonState d{playersOf=anyBstInsert p' $ playersOf d}
return a
withObject :: MonadDungeon m => ObjectId -> ObjectT (RoomT m) a -> m a
withObject i m = do
rs <- roomOfObject i
case rs of
[r] -> withRoom r $ do
rs <- getRoomState
case anyBstLookup i $ roomObjectsOf rs of
Just o -> do
(a,o') <- runObjectT m o
modifyRoomState $ \r -> r{roomObjectsOf=anyBstInsert o' $ roomObjectsOf r}
return a
damage :: MonadDungeon m => DamageTarget -> Int -> m ()
damage (TargetPlayer p) v = withPlayer p $ modifyCurrency Health $ subtract v
damage (TargetObject o) v = withObject o $ modifyObjectState $ \o -> o{objectCurHealthOf=objectCurHealthOf o v}
focusOpponent :: MonadPlayer m => ObjectId -> m ()
focusOpponent o = modifyPlayerState $ \p -> p{playerOpponentOf=o}
dealDamage :: (MonadRandom m,MonadDungeon m) => Int -> m ()
dealDamage d = do
let dmin = truncate (fromIntegral d * 0.8)
dmax = truncate (fromIntegral d * 1.2)
r <- mrandomR (dmin,dmax)
o <- liftM playerOpponentOf getPlayerState
damage (TargetObject o) r
instance MonadExpand m => MonadExpand (DungeonT m) where
expand = lift . expand <=< expandDun
expandDun [] = return []
expandDun ('#':'?':'{':ss) =
let nm = takeBrace 0 ss
rm = drop (length nm + 1) ss
takeBrace 0 ('}':ss) = ""
takeBrace n ('}':ss) = '}' : takeBrace (n1) ss
takeBrace n ('{':ss) = '{' : takeBrace (n+1) ss
takeBrace n (s:ss) = s : takeBrace n ss
in do
o <- liftM playerOpponentOf getPlayerState
case o of
FalseObject -> expandDun rm
_ -> do
r <- expandDun nm
s <- expandDun rm
return (r ++ s)
expandDun ('#':'{':ss) =
let (nm,rm) = (takeWhile (/='}') &&& tail.dropWhile (/='}')) ss
replace "health" = liftM (show . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState
replace "ohealth" = do
i <- liftM playerOpponentOf getPlayerState
o <- withObject i getObjectState
return $ show $ objectCurHealthOf o
replace "otitle" = do
i <- liftM playerOpponentOf getPlayerState
o <- withObject i getObjectState
return $ show $ objectTitleOf o
replace s = do
cs <- liftM (avlInorder . currenciesOf) getDungeonState
case filter ((==s).currencyNameOf) cs of
[] -> return []
[c] -> liftM (show . joinMaybe . avlLookup (currencyIdOf c) . playerCurrenciesOf) getPlayerState
in do
r <- replace nm
s <- expandDun rm
return (r ++ s)
expandDun ('#':ss) =
let (nm,rm) = (takeWhile isAnum &&& dropWhile isAnum) ss
isAnum = flip elem (['A'..'Z']++['a'..'z']++['0'..'9'])
in expandDun ("#{"++nm++"}"++rm)
expandDun (s:ss) = return . (s:) =<< expandDun ss