Prototypes.hs

{-# LANGUAGE TupleSections, 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/>.
-}

-- | Provides prototypes for common entities (rooms, objects, mobs).
module Game.Antisplice.Prototypes where

import Text.Chatty.Printer
import Text.Chatty.Expansion
import Text.Chatty.Extended.Printer
import Control.Monad
import Control.Monad.Error.Class
import Game.Antisplice.Monad
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Utils.Atoms
import Game.Antisplice.Utils.Fail
import Game.Antisplice.Utils.AVL
import Game.Antisplice.Utils.Graph
import Game.Antisplice.Rooms
import Game.Antisplice.Events
import Game.Antisplice.Errors
import Text.Printf
import Data.Text (pack,unpack)
import Data.List

-- | Construct a simple room from a title and a description.
ctorRoom :: MonadAtoms m => String -> String -> RoomT m ()
ctorRoom t d = do
  setRoomTitle t
  addRoomDesc d
  onAnnounce $ getRoomTitle >>= eprintLn (Dull Magenta)
  onLook $ do
    rs <- getRoomState
    eprintLn (Dull Green) =<< expand =<< getRoomDesc
    sequence_ $ avlInorder $ flip fmap (roomObjectsOf rs) $ \os -> objectTriggerOnAnnounceOf os

-- | Construct a sign from a text and some attributes.
ctorSign :: (MonadAtoms m,MonadVocab m,MonadError SplErr m) => String -> [String] -> ObjectT m ()
ctorSign t as = do
  onRead $ eprintLn (Vivid White) =<< expand t
  lookCountA <- newAtom
  putAtom lookCountA 0
  onLook $ do
    c <- getAtom lookCountA
    case c :: Int of
      0 -> mprintLn "This is just a regular sign. There is nothing special about this one in particular."
      1 -> mprintLn "This REALLY is just a regular sign."
      2 -> mprintLn "Stop looking at me!"
      3 -> mprintLn "I'll call the police if you don't stop!"
      4 -> mprintLn "You hear the sounds of an arriving police car. This is your end :P" >> throwError QuitError
    putAtom lookCountA (c+1)
  setObjectTitle "a sign"
  setObjectDesc "This is a sign with a text written on it."
  addObjectName "sign"
  addObjectName "caption"
  mapM_ (uncurry insertVocab) [("sign",Noun),("caption",Noun)]
  forM_ as addObjectAttr
  forM_ as $ uncurry insertVocab . (,Adj)

-- | Construct a mob from a title, some names, a description and some attributes.
ctorMob :: MonadVocab m => String -> [String] -> String -> [String] -> ObjectT m ()
ctorMob t ns d as = do
  onLook $ mprintLn d
  onRoomEnter $ mprintLn $ printf "%s has entered the room." t
  onRoomLeave $ mprintLn $ printf "%s has left the room." t
  onAnnounce $ eprintLn (Dull Cyan) $ printf "  %s is here." t
  setObjectIsMob True
  setObjectTitle t
  setObjectDesc d
  forM_ ns addObjectName
  forM_ ns $ uncurry insertVocab . (,Noun)
  forM_ as addObjectAttr
  forM_ as $ uncurry insertVocab . (,Adj)

-- | Construct a mob route from some room IDs and a time delay in milliseconds.
ctorRoute :: (Monad m,Functor m) => [NodeId] -> Integer -> ObjectT m ()
ctorRoute rs d = do
  i <- fmap objectIdOf getObjectState
  setMobRoute rs
  let cmr :: Trigger
      cmr = continueMobRoute i >> schedule d cmr
  onFirstSight $ schedule d cmr

-- | Construct a room nesting object from a title, a description, some names, some attributes and the target room ID.
ctorRoomNesting :: MonadVocab m => String -> String -> [String] -> [String] -> NodeId -> ObjectT m ()
ctorRoomNesting t d ns as r = do
  setObjectTitle t
  setObjectDesc d
  forM_ ns addObjectName
  forM_ ns $ uncurry insertVocab . (,Noun)
  forM_ as addObjectAttr
  forM_ as $ uncurry insertVocab . (,Adj)
  onEnter $ enterAndAnnounce r

-- | Construct an acquirable object from a title, a description, some names and some attributes.
ctorAcq :: MonadVocab m => String -> String -> [String] -> [String] -> ObjectT m ()
ctorAcq t d ns as = do
  setObjectTitle t
  setObjectDesc d
  forM_ ns addObjectName
  forM_ as addObjectAttr
  forM_ ns $ uncurry insertVocab . (,Noun)
  forM_ as $ uncurry insertVocab . (,Adj)
  onLook $ mprintLn d
  setObjectIsAcquirable True

-- | Add a room descriptor object to the current room
addRoomDesc :: MonadAtoms m => String -> RoomT m ObjectId
addRoomDesc = addRoomObject . addDescSeg