module Game.Antisplice.Rooms (
modifyRoomState,
getRoomDesc,
getRoomTitle,
setRoomTitle,
markRoom,
enterRoom,
reenterCurrentRoom,
enterAndAnnounce,
changeRoom,
constructRoom,
establishWay,
addRoomObject,
removeRoomObject,
insertRoomObject,
constructObject,
modifyObjectState,
setObjectDesc,
setObjectTitle,
addObjectName,
addObjectAttr,
setObjectIsMob,
setObjectIsAcquirable,
addFeature,
addDescSeg,
addEquipSlot,
registerForm,
instanciateForm,
registerKind,
setObjectKind,
getObjectTitle,
getObjectDesc,
getObjectNames,
matchObjectName,
getObjectIsMob,
getObjectIsAcquirable,
roomOfObject,
setMobRoute,
continueMobRoute,
schedule,
subscribePlayer,
setPlayerRoom,
acquireObject,
dropObject,
equipObject,
equipObjectAt,
getEquipment,
getCooldown,
setCooldown,
consumeAlcohol,
registerCurrency,
getCurrency,
modifyCurrency,
damage,
focusOpponent,
dealDamage,
withRoom,
withPlayer,
withObject,
guardRoom,
guardObject,
guardObjectInRoom,
guardObjectNotInRoom,
guardKindInRoom,
guardKindNotInRoom,
drunken
) 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 Data.Chatty.Graph
import Data.Chatty.Counter
import Data.Chatty.BST
import Data.Chatty.AVL
import Data.Chatty.Atoms
import Data.Chatty.None
import Game.Antisplice.Errors
import Control.Arrow
import Control.Monad
import Control.Monad.Error
import Control.Monad.Trans.Class
import Data.Text (pack,unpack)
import Data.Maybe
import Data.List
import Data.Char
import Data.Time.Clock
import Text.Printf
modifyRoomState :: MonadRoom m => (RoomState -> RoomState) -> m ()
modifyRoomState f = do
s <- getRoomState
putRoomState (f s)
getRoomDesc :: (MonadRoom m,ChAtoms 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,playerOpponentOf=FalseObject}
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
id $
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 -> do
pathTriggerBeforeWalkOf c
enterAndAnnounce n
pathTriggerAfterWalkOf c
Nothing -> throwError CantWalkThereError
addRoomObject :: (ChCounter m,MonadRoom m) => ObjectT m a -> m ObjectId
addRoomObject m = do
i <- liftM ObjectId countOn
k <- liftM KindId countOn
o <- constructObject m (Just i) k
insertRoomObject o
return i
constructObject :: Monad m => ObjectT m a -> Maybe ObjectId -> KindId -> m ObjectState
constructObject m j k = do
(_,o) <- runObjectT m $ ObjectState
(if isJust j then (\(Just j) -> j) j else none)
k
(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
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,ChCounter 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 none 0 False
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 Mobile $ objectFeaturesOf o}
where a True = avlInsert
a False = avlRemove
setObjectKind :: MonadObject m => KindId -> m ()
setObjectKind k = modifyObjectState $ \o -> o{objectKindOf=k}
registerKind :: ChCounter m => m KindId
registerKind = liftM KindId countOn
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,ChClock 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
guardRoom r $ objectTriggerOnRoomLeaveOf o
let (n:rs) = objectRouteOf o
withRoom n $ insertRoomObject o{objectRouteOf=rs++[n]}
guardRoom n $ objectTriggerOnRoomEnterOf o
modifyPlayerState $ \s -> if playerOpponentOf s == i then s{playerOpponentOf=FalseObject} else s
return ()
guardRoom :: MonadDungeon m => NodeId -> m () -> m ()
guardRoom n m = do
s <- getDungeonState
when (currentRoomOf s == Just n) m
guardObject :: MonadDungeon m => ObjectId -> m () -> m ()
guardObject o m = do
rs <- roomOfObject o
case rs of
[] -> return ()
_ -> m
guardObjectInRoom :: MonadDungeon m => ObjectId -> NodeId -> m () -> m ()
guardObjectInRoom o r m = do
rs <- roomOfObject o
case rs of
[r1] | r1 == r -> m
_ -> return ()
guardObjectNotInRoom :: MonadDungeon m => ObjectId -> NodeId -> m () -> m ()
guardObjectNotInRoom o r m = do
rs <- roomOfObject o
case rs of
[r1] | r1 == r -> return ()
_ -> m
guardKindInRoom :: MonadDungeon m => KindId -> NodeId -> m () -> m ()
guardKindInRoom k r m = do
rs <- withRoom r getRoomState
let b = null $ filter ((==k).objectKindOf) $ avlPreorder $ roomObjectsOf rs
unless b m
guardKindNotInRoom :: MonadDungeon m => KindId -> NodeId -> m () -> m ()
guardKindNotInRoom k r m = do
rs <- withRoom r getRoomState
let b = null $ filter ((==k).objectKindOf) $ avlPreorder $ roomObjectsOf rs
when b 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
s <- withObject i getObjectState
if isJust $ avlLookup Acquirable $ objectFeaturesOf s
then do
o <- withRoom r $ removeRoomObject i
modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}
objectTriggerOnEachAcquireOf o
else throwError CantAcquireThatError
[] -> 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,ChAtoms m) => String -> m ()
addDescSeg s = do
a <- newAtom
putAtom a s
addFeature $ Described a
registerForm :: (ChAtoms m) => ObjectT m () -> m (Atom ObjectState)
registerForm m = do
a <- newAtom
k <- liftM KindId countOn
o <- constructObject m Nothing k
putAtom a o
return a
instanciateForm :: (ChAtoms m,MonadRoom 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}
registerCurrency :: (ChCounter m,MonadDungeon m) => String -> String -> m CurrencyId
registerCurrency n d = do
s <- getDungeonState
i <- liftM CurrencyId countOn
putDungeonState s{currenciesOf=avlInsert (Currency i d n) $ currenciesOf s}
return i
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
ps <- getPlayerState
case rs of
[] -> case avlLookup i $ playerInventoryOf ps of
Nothing -> error "Wtf, that object does not exist. Neither in a room nor in your inventory."
Just o -> withRoom (playerRoomOf ps) $ do
(a,o') <- runObjectT m o
lift $ modifyPlayerState $ \p -> p{playerInventoryOf=avlInsert o' $ playerInventoryOf p}
return a
[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 :: DamageTarget -> Int -> ChattyDungeonM ()
damage (TargetPlayer p) v = withPlayer p $ modifyCurrency Health $ subtract v
damage (TargetObject o) v = do
d <- withObject o $ do
modifyObjectState $ \o -> o{objectCurHealthOf=objectCurHealthOf o v}
liftM ((<=0).objectCurHealthOf) getObjectState
when d $ do
objectTriggerOnDieOf =<< withObject o getObjectState
s <- getPlayerState
when (playerOpponentOf s == o) $ putPlayerState s{playerOpponentOf=FalseObject}
void $ removeRoomObject o
focusOpponent :: ObjectId -> ChattyDungeonM ()
focusOpponent o = do
os <- withObject o getObjectState
if (isJust $ avlLookup Damagable $ objectFeaturesOf os)
then modifyPlayerState $ \p -> p{playerOpponentOf=o}
else throwError WontHitThatError
dealDamage :: Int -> ChattyDungeonM ()
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 (Functor m,ChExpand m) => ChExpand (DungeonT m) where
expand = lift . expand <=< liftM (replay.snd) . runRecorderT . expandDun
expandDun :: (ChPrinter m,MonadDungeon m) => String -> m ()
expandDun [] = return ()
expandDun ('\\':'#':ss) = do
mprint "#"
expandDun ss
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
expandDun nm
expandDun rm
expandDun ('#':'{':ss) =
let (nm,rm) = (takeWhile (/='}') &&& tail.dropWhile (/='}')) ss
prnum Nothing Nothing i = show i
prnum (Just d) Nothing i = show (i `div` d)
prnum Nothing (Just m) i = let exp s l = replicate (llength s) '0' ++ s in exp (show (i `mod` m)) (length $ show (m1))
prnum (Just d) (Just m) i = prnum (Just d) Nothing i ++ "." ++ prnum Nothing (Just m) i
prstr Nothing Nothing s = s
prstr (Just d) _ s = take d s
prstr Nothing (Just m) s = drop m s
numfun (Just "inc") i = i + 1
numfun (Just "dec") i = i 1
numfun Nothing i = i
numfun _ _ = 0
strfun (Just "up") s = map toUpper s
strfun (Just "down") s = map toLower s
strfun (Just "capital") "" = ""
strfun (Just "capital") (s:ss) = toUpper s : ss
strfun Nothing s = s
strfun _ _ = ""
replace :: (ChPrinter m,MonadDungeon m) => String -> Maybe Int -> Maybe Int -> Maybe String -> m ()
replace "health" d m f = liftM (prnum d m . numfun f . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState >>= mprint
replace "ohealth" d m f = do
i <- liftM playerOpponentOf getPlayerState
o <- withObject i getObjectState
mprint $ prnum d m $ numfun f $ objectCurHealthOf o
replace "otitle" d m f = do
i <- liftM playerOpponentOf getPlayerState
o <- withObject i getObjectState
mprint $ prstr d m $ strfun f $ unpack $ objectTitleOf o
replace s d m f = do
cs <- liftM (avlInorder . currenciesOf) getDungeonState
case filter ((==s).currencyNameOf) cs of
[] -> return ()
[c] -> liftM (prnum d m . numfun f . joinMaybe . avlLookup (currencyIdOf c) . playerCurrenciesOf) getPlayerState >>= mprint
cs -> mprintLn $ concat $ map currencyNameOf cs
(cm,nmc)
| '!' `elem` nm = (Just $ takeWhile (/='!') nm, tail $ dropWhile (/='!') nm)
| otherwise = (Nothing, nm)
(nm1,dm1,mm1)
| '/' `elem` nmc = (takeWhile (/='/') nmc, Just $ read $ tail $ dropWhile (/='/') nmc, Nothing)
| '%' `elem` nmc = (takeWhile (/='%') nmc, Nothing, Just $ read $ tail $ dropWhile (/='%') nmc)
| '.' `elem` nmc = let xz = Just $ read $ tail $ dropWhile (/='.') nmc in (takeWhile (/='.') nmc, xz, xz)
| otherwise = (nmc,Nothing,Nothing)
in do
replace nm1 dm1 mm1 cm
expandDun rm
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) = do
mprint [s]
expandDun ss
drunken :: (ChRandom m,MonadPlayer m) => String -> m String
drunken [] = return []
drunken ('}':cs) = do
cx <- drunken cs
return ('}':cx)
drunken ('\n':cs) = do
cx <- drunken cs
return ('\n':cx)
drunken ('%':'{':a:b:';':cs)
| (a `elem` "DV") && (b `elem` ['0'..'7']) = do
cx <- drunken cs
return ('%':'{':a:b:';':cx)
drunken (c:cs) = do
p <- liftM playerAlcoholOf getPlayerState
r <- mrandomR (0,100)
cx <- drunken cs
return $ if r < p then '_' : cx else c : cx
consumeAlcohol :: (ChPrinter m,ChRandom m,MonadPlayer m,MonadDungeon m,ChClock m) => Int -> m ()
consumeAlcohol r = do
modifyPlayerState $ \p -> p{playerAlcoholOf=r+playerAlcoholOf p}
p <- getPlayerState
case playerAlcoholOf p of
a | a > 50 -> mprintLn =<< drunken "You really feel very, very drunk."
| a > 30 -> mprintLn =<< drunken "You definitely feel drunk."
| a > 15 -> mprintLn =<< drunken "You feel kind of drunk."
_ -> return ()
unless (playerSoberingActiveOf p) $ do
modifyPlayerState $ \p -> p{playerSoberingActiveOf=True}
let sobering :: Handler
sobering = do
modifyPlayerState $ \p -> p{playerAlcoholOf=max 0 (playerAlcoholOf p 5)}
schedule 120000 sobering
schedule 120000 sobering