{-# 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,
    --setRoomDesc,
    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,
    addNearImplication,
    addCarryImplication,
    addWearImplication,
    addDescSeg,
    -- * Object forms
    registerForm,
    instanciateForm,
    -- * Object investigation
    getObjectTitle,
    getObjectDesc,
    getObjectNames,
    matchObjectName,
    getObjectIsMob,
    getObjectIsAcquirable,
    roomOfObject,
    -- * Object actions
    setMobRoute,
    continueMobRoute,
    -- * Scheduling
    schedule,
    -- * Players
    subscribePlayer,
    modifyPlayerState,
    setPlayerRoom,
    acquireObject,
    dropObject,
    -- * Masquerades
    withRoom,
    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.AVL
import Game.Antisplice.Utils.Atoms
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.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 (DescSeg a) = getAtom a
      descseg _ = return []
  is <- mapM descseg $ concatMap objectNearImplicationsOf $ 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
  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

-- | 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 :: (Monad m,MonadDungeon (t m),MonadTrans t) => RoomT m a -> t m NodeId
constructRoom m = do
  (_,rs) <- lift $ runRoomT m $ RoomState (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

-- | 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 -> m ()
establishWay f t d = do
  s <- getDungeonState
  let g = addEdge f t 0 d $ 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 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 <- countOn
  o <- constructObject m
  insertRoomObject o{objectIdOf=ObjectId i}
  return $ ObjectId i

-- | Construct a room object (but don't add it)
constructObject :: Monad m => ObjectT m a -> m ObjectState
constructObject m = do
  (_,o) <- runObjectT m $ ObjectState
       FalseObject -- id
       (pack "Something") -- title
       (pack "I don't know what this is.") -- desc
       [] [] False False False False -- names, attr, 1seen?, 1acq?, 1insp?, 1eq?
       100 100 -- maxhp, curhp
       EmptyAVL [] -- stats, route
       EmptyAVL [] [] [] -- feat, impl (n,i,w)
       Nothing -- faction
       (return ()) -- on 1 sight
       (return ()) -- on sight
       (return ()) -- on 1 acq
       (return ()) -- on acq
       (return ()) -- on 1 insp
       (return ()) -- 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
       (return ()) -- on enter room
       (return ()) -- on leave room
       (return ()) -- on announce
       (return ()) -- on drop
       (return ()) -- on 1 eq
       (return ()) -- on eq
       (return ()) -- on uneq
  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 (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 [] EmptyAVL
  putDungeonState s{playerOf=Just a}

-- | Modify the player state
modifyPlayerState :: MonadPlayer m => (PlayerState -> PlayerState) -> m ()
modifyPlayerState f = do
  s <- getPlayerState
  putPlayerState $ f 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 -> 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}

-- | 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 -> 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

-- | 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
      o <- withRoom r $ removeRoomObject i
      modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}
    [] -> 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 implication to the current object that is valid for all players in the room
addNearImplication :: MonadObject m => Implication -> m ()
addNearImplication i = modifyObjectState $ \o -> o{objectNearImplicationsOf=i:objectNearImplicationsOf o}

-- | Add an implication to the current object that is valid for all carrying players
addCarryImplication :: MonadObject m => Implication -> m ()
addCarryImplication i = modifyObjectState $ \o -> o{objectCarryImplicationsOf=i:objectCarryImplicationsOf o}

-- | Add an implication to the current object that is valid for all wearing players
addWearImplication :: MonadObject m => Implication -> m ()
addWearImplication i = modifyObjectState $ \o -> o{objectWearImplicationsOf=i:objectWearImplicationsOf o}

-- | Add a room description segment to the current object
addDescSeg :: (MonadObject m,MonadAtoms m) => String -> m ()
addDescSeg s = do
  a <- newAtom
  putAtom a s
  addNearImplication $ DescSeg 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
  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