Rooms.hs

{-# LANGUAGE RankNTypes, FlexibleContexts #-}

{-
  This module is part of Antisplice.
  Copyleft (c) 2014 Marvin Cohrs

  All wrongs reversed. Sharing is an act of love, not crime.
  Please share Antisplice with everyone you like.

  Antisplice is free software: you can redistribute it and/or modify
  it under the terms of the GNU Affero General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Antisplice is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  GNU Affero General Public License for more details.

  You should have received a copy of the GNU Affero General Public License
  along with Antisplice. If not, see <http://www.gnu.org/licenses/>.
-}

-- | A huge pile of utility functions for building our dungeon.
module Game.Antisplice.Rooms (
    -- * Room modification
    modifyRoomState,
    getRoomDesc,
    getRoomTitle,
    setRoomTitle,
    markRoom,
    -- * Moving around
    enterRoom,
    reenterCurrentRoom,
    enterAndAnnounce,
    changeRoom,
    -- * Room construction
    constructRoom,
    establishWay,
    addRoomObject,
    removeRoomObject,
    insertRoomObject,
    -- * Object construction
    modifyObjectState,
    setObjectDesc,
    setObjectTitle,
    addObjectName,
    addObjectAttr,
    setObjectIsMob,
    setObjectIsAcquirable,
    addFeature,
    addDescSeg,
    addEquipSlot,
    -- * Object forms
    registerForm,
    instanciateForm,
    -- * Object investigation
    getObjectTitle,
    getObjectDesc,
    getObjectNames,
    matchObjectName,
    getObjectIsMob,
    getObjectIsAcquirable,
    roomOfObject,
    -- * Object actions
    setMobRoute,
    continueMobRoute,
    -- * Scheduling
    schedule,
    -- * Players
    subscribePlayer,
    setPlayerRoom,
    acquireObject,
    dropObject,
    equipObject,
    equipObjectAt,
    getEquipment,
    getCooldown,
    setCooldown,
    getCurrency,
    modifyCurrency,
    -- * Fight
    damage,
    focusOpponent,
    dealDamage,
    -- * Masquerades
    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,unpack)
import Data.Maybe
import Data.List
import Data.Time.Clock
import Text.Printf

-- | Modify the room state.
modifyRoomState :: MonadRoom m => (RoomState -> RoomState) -> m ()
modifyRoomState f = do
  s <- getRoomState
  putRoomState (f s)

-- | Get the current room's description
getRoomDesc :: (MonadRoom m,MonadAtoms m) => m String
getRoomDesc = do
  s <- getRoomState
  --return (fromText $ roomDescOf s)
  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

-- | Get the current room's title
getRoomTitle :: (MonadRoom m,IsText t) => m t
getRoomTitle = do
  s <- getRoomState
  return (fromText $ roomTitleOf s)

{- | Set the current room's description
setRoomDesc :: (MonadRoom m,IsText t) => t -> m ()
setRoomDesc t = modifyRoomState $ \s -> s{roomDescOf=toText t}-}

-- | Set the current room's title
setRoomTitle :: (MonadRoom m,IsText t) => t -> m ()
setRoomTitle t = modifyRoomState $ \s -> s{roomTitleOf=toText t}

-- | Mark the current room as visited
markRoom :: MonadDungeon m => m ()
markRoom = do
  s <- getDungeonState
  case currentRoomOf s of
    Just r -> putDungeonState s{roomsOf=markNode r $ roomsOf s}

-- | Enter the given room and trigger most events, but don't announce it. Result tells whether this room is visited the first time.
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

-- | Reenter the current room and trigger all events (but don't announce it).
reenterCurrentRoom :: ChattyDungeonM ()
reenterCurrentRoom = do
  s <- getDungeonState
  case currentRoomOf s of
    Just r -> void $ enterRoom r

-- | Enter the given room, trigger all events and announce it. On the first visit, look around.
enterAndAnnounce :: NodeId -> ChattyDungeonM ()
enterAndAnnounce n = do
  r <- enterRoom n
  rs <- getRoomState
  roomTriggerOnAnnounceOf rs
  when r $ roomTriggerOnLookOf rs

-- | Construct a new room using the room monad.
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

-- | Run a function in the context of the given room.
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

-- | Establish a path from one room to another one (one-way only).
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}

-- | Enter a neighbouring room by its direction.
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

-- | Add a new object to the current room. It is contructed using the object monad.
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

-- | Construct a room object (but don't add it)
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) -- id
       (pack "Something") -- title
       (pack "I don't know what this is.") -- desc
       none none False False False False -- names, attr, 1seen?, 1acq?, 1insp?, 1eq?
       100 100 -- maxhp, curhp
       none none -- route, feat
       none -- faction
       noneM -- on 1 sight
       noneM -- on sight
       noneM -- on 1 acq
       noneM -- on acq
       noneM -- on 1 insp
       noneM -- on insp
       (mprintLn "There is nothing special about this.") -- on look at
       (mprintLn "There is nothing inside this.") -- on look in
       (mprintLn "There is nothing written on this.") -- on read
       (mprintLn "You cannot enter this.") -- on enter
       noneM -- on enter room
       noneM -- on leave room
       noneM -- on announce
       noneM -- on drop
       noneM -- on 1 eq
       noneM -- on eq
       noneM -- on uneq
       noneM -- on die
       noneM -- on take damage
  return o

-- | Remove an object from the current room and return its state.
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

-- | Insert an already constructed object to the current room.
insertRoomObject :: MonadRoom m => ObjectState -> m ()
insertRoomObject o = modifyRoomState $ \s -> s{roomObjectsOf=avlInsert o $ roomObjectsOf s}

-- | Modify the object state
modifyObjectState :: MonadObject m => (ObjectState -> ObjectState) -> m ()
modifyObjectState f = do
  s <- getObjectState
  putObjectState $ f s

-- | Get the object's title
getObjectTitle :: (MonadObject m,IsText t) => m t
getObjectTitle = do
  s <- getObjectState
  return (fromText $ objectTitleOf s)

-- | Set the object's title
setObjectTitle :: (MonadObject m,IsText t) => t -> m ()
setObjectTitle t = modifyObjectState $ \s -> s{objectTitleOf=toText t}

-- | Get the object's description
getObjectDesc :: (MonadObject m,IsText t) => m t
getObjectDesc = do
  s <- getObjectState
  return (fromText $ objectDescOf s)

-- | Set the object's description
setObjectDesc :: (MonadObject m,IsText t) => t -> m ()
setObjectDesc t = modifyObjectState $ \s -> s{objectDescOf=toText t}

-- | Get the object's names
getObjectNames :: MonadObject m => m [String]
getObjectNames = do
  s <- getObjectState
  return $ objectNamesOf s

-- | Add a name for the current object
addObjectName :: MonadObject m => String -> m ()
addObjectName t = modifyObjectState $ \s -> s{objectNamesOf=t:objectNamesOf s}

-- | Check if the given name matches our current object
matchObjectName :: MonadObject m => String -> m Bool
matchObjectName t = do
  s <- getObjectState
  return $ elem t $ objectNamesOf s

-- | Add an attribute for the current object
addObjectAttr :: MonadObject m => String -> m ()
addObjectAttr t = modifyObjectState $ \s -> s{objectAttributesOf=t:objectAttributesOf s}

-- | Create a new player using the player monad
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 none
  putDungeonState s{playersOf=anyBstInsert a $ playersOf s}

-- | Move the current player to the given room, but don't trigger anything.
setPlayerRoom :: MonadPlayer m => NodeId -> m ()
setPlayerRoom r = modifyPlayerState $ \p -> p{playerRoomOf=r}

-- | Check if the current object is a mob.
getObjectIsMob :: (MonadObject m,Functor m) => m Bool
getObjectIsMob = fmap (isJust . avlLookup Mobile . objectFeaturesOf) getObjectState

-- | Set whether the current object is a mob.
setObjectIsMob :: MonadObject m => Bool -> m ()
setObjectIsMob b = modifyObjectState $ \o -> o{objectFeaturesOf=a b $ objectFeaturesOf o}
  where a True = avlInsert Mobile
        a False = avlRemove Mobile

-- | Check if the current object is acquirable.
getObjectIsAcquirable :: (MonadObject m,Functor m) => m Bool
getObjectIsAcquirable = fmap (isJust . avlLookup Acquirable . objectFeaturesOf) getObjectState

-- | Set whether the current object is acquirable.
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 an event for a given time offset (in milliseconds).
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}

-- | Set the current mob's route
setMobRoute :: MonadObject m => [NodeId] -> m ()
setMobRoute rs = modifyObjectState $ \s -> s{objectRouteOf=rs}

-- | The given object may continue its route
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
      modifyPlayerState $ \s -> if playerOpponentOf s == i then s{playerOpponentOf=FalseObject} else s
      return ()

-- | Only run the given function if the player is inside the also given room.
guardVisible :: MonadDungeon m => NodeId -> m () -> m ()
guardVisible n m = do
  s <- getDungeonState
  when (currentRoomOf s == Just n) m

-- | Determine which rooms contain the given object (won't be more than one, but we're careful)
roomOfObject :: MonadDungeon m => ObjectId -> m [NodeId]
roomOfObject o = (return . map nodeId . filter (isJust . avlLookup o . roomObjectsOf . nodeContent) . allNodes . roomsOf) =<< getDungeonState

-- | Acquire the given object and put it in the player's inventory
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}
        else throwError CantAcquireThatError
    [] -> throwError CantSeeOneError
    _ -> throwError WhichOneError

-- | Drop the given object and remove it from the player's inventory
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

-- | Add an object feature to the current object
addFeature :: MonadObject m => Feature -> m ()
addFeature f = modifyObjectState $ \s -> s{objectFeaturesOf=avlInsert f $ objectFeaturesOf s}

-- | Add a room description segment to the current object
addDescSeg :: (MonadObject m,MonadAtoms m) => String -> m ()
addDescSeg s = do
  a <- newAtom
  putAtom a s
  addFeature $ Described a

-- | Register an object form and return its atom
registerForm :: (MonadAtoms m) => ObjectT m () -> m (Atom ObjectState)
registerForm m = do
  a <- newAtom
  o <- constructObject m Nothing
  putAtom a o
  return a

-- | Instanciate a registered form
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

-- | Equip the given object at a given key
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

-- | Equip the given object somewhere
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
    
-- | Get equipped object
getEquipment :: MonadPlayer m => EquipKey -> m (Maybe ObjectState)
getEquipment k = liftM (avlLookup k.playerEquipOf) getPlayerState

-- | Add equippable slot
addEquipSlot :: MonadObject m => EquipKey -> m ()
addEquipSlot = addFeature . Equipable

-- | Set/unset cooldown
setCooldown :: MonadPlayer m => CooldownId -> Bool -> m ()
setCooldown c b = modifyPlayerState $ \p -> p{playerCooldownsOf=(if b then avlInsert else avlRemove) c $ playerCooldownsOf p}

-- | Get cooldown state
getCooldown :: MonadPlayer m => CooldownId -> m Bool
getCooldown c = liftM (isJust . avlLookup c . playerCooldownsOf) getPlayerState

-- | Get currency state
getCurrency :: MonadPlayer m => CurrencyId -> m Int
getCurrency c = liftM (joinMaybe . avlLookup c . playerCurrenciesOf) getPlayerState

-- | Modify currency state
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}

-- | Run a function in the context of a given player
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

-- | Run a function in the context of a given object
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 a target (no matter whether player or mob) without setting focus
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

-- | Focus an opponent
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

-- | Deal damage to an opponent. Real damage is influenced by random.
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,MonadExpand m) => MonadExpand (DungeonT m) where
  expand = lift . expand <=< liftM (replay.snd) . runRecorderT . expandDun

expandDun :: (MonadPrinter m,MonadDungeon m) => String -> m ()
expandDun [] = return ()
expandDun ('#':'?':'{':ss) =
  let nm = takeBrace 0 ss
      rm = drop (length nm + 1) ss
      takeBrace 0 ('}':ss) = ""
      takeBrace n ('}':ss) = '}' : takeBrace (n-1) 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
      replace "health" = liftM (show . joinMaybe . avlLookup Health . playerCurrenciesOf) getPlayerState >>= mprint
      replace "ohealth" = do
        i <- liftM playerOpponentOf getPlayerState
        o <- withObject i getObjectState
        mprint $ show $ objectCurHealthOf o
      replace "otitle" = do
        i <- liftM playerOpponentOf getPlayerState
        o <- withObject i getObjectState
        mprint $ unpack $ 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 >>= mprint
  in do
    replace nm
    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