packages feed

antisplice 0.7.2.0 → 0.8.0.1

raw patch · 14 files changed

+521/−97 lines, 14 filesdep −comonad

Dependencies removed: comonad

Files

antisplice.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.7.2.0+version:             0.8.0.1  -- A short (one-line) description of the package. synopsis:            An engine for text-based dungeons.@@ -48,7 +48,7 @@  library   -- Modules exported by the library.-  exposed-modules:     Game.Antisplice.Prototypes, Game.Antisplice.Templates, Game.Antisplice.Lang, Game.Antisplice.Monad, Game.Antisplice.Rooms, Game.Antisplice.Errors, Game.Antisplice.Utils.TST, Game.Antisplice.Utils.AVL, Game.Antisplice.Utils.Run, Game.Antisplice.Utils.BST, Game.Antisplice.Utils.Graph, Game.Antisplice.Utils.Counter, Game.Antisplice.Utils.Fail, Game.Antisplice.Monad.Dungeon, Game.Antisplice.Terminal.Repl, Game.Antisplice.Events, Game.Antisplice.Monad.Vocab, Game.Antisplice.Utils.Atoms, Game.Antisplice.Stats+  exposed-modules:     Game.Antisplice.Prototypes, Game.Antisplice.Templates, Game.Antisplice.Lang, Game.Antisplice.Monad, Game.Antisplice.Rooms, Game.Antisplice.Errors, Game.Antisplice.Utils.TST, Game.Antisplice.Utils.AVL, Game.Antisplice.Utils.Run, Game.Antisplice.Utils.BST, Game.Antisplice.Utils.Graph, Game.Antisplice.Utils.Counter, Game.Antisplice.Utils.Fail, Game.Antisplice.Monad.Dungeon, Game.Antisplice.Terminal.Repl, Game.Antisplice.Events, Game.Antisplice.Monad.Vocab, Game.Antisplice.Utils.Atoms, Game.Antisplice.Stats, Game.Antisplice.Utils.None, Game.Antisplice.Utils.Focus, Game.Antisplice.SingleUser, Game.Antisplice      -- Modules included in this library but not exported.   -- other-modules:       @@ -57,10 +57,11 @@   other-extensions:    TemplateHaskell, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeFamilies, FunctionalDependencies      -- Other library packages from which modules are imported.-  build-depends:       base >=4.6 && <4.7, chatty >=0.2 && <0.3, text >=0.11 && <0.12, template-haskell >=2.8 && <2.9, mtl >=2.1 && <2.2, transformers >=0.3 && <0.4, haskeline >= 0.7 && < 0.8, time >= 1.4 && < 1.5, comonad >=4.0 && <4.1+  build-depends:       base >=4.6 && <4.7, chatty >=0.2 && <0.3, text >=0.11 && <0.12, template-haskell >=2.8 && <2.9, mtl >=2.1 && <2.2, transformers >=0.3 && <0.4, haskeline >= 0.7 && < 0.8, time >= 1.4 && < 1.5      -- Directories containing source files.   hs-source-dirs:      src      -- Base language which the package is written in.   default-language:    Haskell2010+
+ src/Game/Antisplice.hs view
@@ -0,0 +1,69 @@+{-# 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/>.+-}++-- | Reexports all relevant modules++module Game.Antisplice (+  -- * Reexported modules+  module Game.Antisplice.Monad,+  module Game.Antisplice.Monad.Dungeon,+  module Game.Antisplice.Monad.Vocab,+  module Game.Antisplice.Utils.Fail,+  module Game.Antisplice.Utils.Atoms,+  module Game.Antisplice.Utils.None,+  module Game.Antisplice.Utils.BST,+  module Game.Antisplice.Utils.Counter,+  module Game.Antisplice.Rooms,+  module Game.Antisplice.Stats,+  module Game.Antisplice.Prototypes,+  module Game.Antisplice.Lang,+  module Game.Antisplice.Errors,+  module Game.Antisplice.Terminal.Repl,+  module Game.Antisplice.Events,+  -- * Type abbreviations+  Constructor) where++import Text.Chatty.Printer+import Text.Chatty.Scanner+import Text.Chatty.Expansion+import Text.Chatty.Extended.Printer+import System.Chatty.Misc+import Game.Antisplice.Monad+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Monad.Vocab+import Game.Antisplice.Utils.Fail+import Game.Antisplice.Utils.Atoms+import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.BST+import Game.Antisplice.Utils.Counter+import Game.Antisplice.Rooms+import Game.Antisplice.Stats+import Game.Antisplice.Prototypes+import Game.Antisplice.Lang+import Game.Antisplice.Errors+import Game.Antisplice.Terminal.Repl+import Game.Antisplice.Events+import Control.Monad.Error.Class++-- | A dungeon constructor function+type Constructor = forall m.(Functor m,ExtendedPrinter m,MonadExpand m,ExpanderEnv m,MonadScanner m,MonadAtoms m,MonadClock m,MonadVocab m,MonadError SplErr m) => DungeonT m ()
src/Game/Antisplice/Errors.hs view
@@ -32,7 +32,10 @@             | VerbMustFirstError             | CantSeeOneError             | DontCarryOneError-            | WhichOneError  +            | WhichOneError+            | CantEquipThatError+            | CantEquipThatThereError+            | WhereToEquipError             | CantWalkThereError deriving Show  -- | Alias for 'FailT' 'SplErr'
src/Game/Antisplice/Lang.hs view
@@ -27,6 +27,7 @@ import Text.Chatty.Printer import Text.Chatty.Scanner import Text.Chatty.Expansion+import Text.Chatty.Extended.Printer import Game.Antisplice.Errors import Game.Antisplice.Monad import Game.Antisplice.Monad.Dungeon@@ -34,6 +35,8 @@ import Game.Antisplice.Utils.Graph import Game.Antisplice.Utils.AVL import Game.Antisplice.Utils.TST+import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.ListBuilder import Game.Antisplice.Rooms import Game.Antisplice.Stats import Control.Monad.Error@@ -41,59 +44,76 @@ import Data.Text (unpack)  aliases :: [(String,String)]-aliases =-  ("l","look"):-  ("n","go north"):-  ("ne","go northeast"):-  ("e","go east"):-  ("se","go southeast"):-  ("s","go south"):-  ("sw","go southwest"):-  ("w","go west"):-  ("nw","go northwest"):-  ("u","ascend"):-  ("d","descend"):-  ("q","quit"):-  ("i","list inventory"):-  ("ex","list exits"):-  ("get","acquire"):-  ("take","acquire"):-  ("show","list"):-  ("sco","list score"):-  []+aliases = strictBuild $ do+  lit "l" "look"+  lit "n" "go north"+  lit "ne" "go northeast"+  lit "e"  "go east"+  lit "se" "go southeast"+  lit "s" "go south"+  lit "sw" "go southwest"+  lit "w" "go west"+  lit "nw" "go northwest"+  lit "u" "ascend"+  lit "d" "descend"+  lit "q" "quit"+  lit "i" "list inventory"+  lit "ex" "list exits"+  lit "get" "acquire"+  lit "take" "acquire"+  lit "show" "list"+  lit "sco" "list score"+  lit "eq" "list equipment"  defVocab :: TST Token-defVocab = foldr (\(k,v) -> tstInsert k (v k)) EmptyTST (-  ("look",Verb):-  ("quit",Verb):-  ("read",Verb):-  ("acquire",Verb):-  ("drop",Verb):-  ("idiot",Noun):-  ("first",Ordn 1):-  ("next",Ordn 1):-  ("primary",Ordn 1):-  ("second",Ordn 2):-  ("commit",Verb):-  ("suicide",Noun):-  ("go",Verb):-  ("ascend",Verb):-  ("descend",Verb):-  ("north",Fixe):-  ("south",Fixe):-  ("east",Fixe):-  ("west",Fixe):-  ("northeast",Fixe):-  ("northwest",Fixe):-  ("southeast",Fixe):-  ("southwest",Fixe):-  ("at",Prep):-  ("enter",Verb):-  ("list",Verb):-  ("exits",Fixe):-  ("inventory",Fixe):-  ("score",Fixe):-  [])+defVocab = foldr (\(k,v) -> tstInsert k (v k)) EmptyTST $ strictBuild $ do+  lit "look" Verb+  lit "quit" Verb+  lit "read" Verb+  lit "acquire" Verb+  lit "drop" Verb+  lit "idiot" Noun+  lit "first" $ Ordn 1+  lit "next" $ Ordn 1+  lit "primary" $ Ordn 1+  lit "second" $ Ordn 2+  lit "third" $ Ordn 3+  lit "commit" Verb+  lit "suicide" Noun+  lit "go" Verb+  lit "ascend" Verb+  lit "descend" Verb+  lit "north" Fixe+  lit "south" Fixe+  lit "east" Fixe+  lit "west" Fixe+  lit "northeast" Fixe+  lit "northwest" Fixe+  lit "southeast" Fixe+  lit "southwest" Fixe+  lit "at" Prep+  lit "enter" Verb+  lit "list" Verb+  lit "exits" Fixe+  lit "inventory" Fixe+  lit "score" Fixe+  lit "main" Fixe+  lit "hand" Fixe+  lit "off" Fixe+  lit "chest" Fixe+  lit "feet" Fixe+  lit "wrists" Fixe+  lit "waist" Fixe+  lit "head" Fixe+  lit "legs" Fixe+  lit "back" Fixe+  lit "hands" Fixe+  lit "neck" Fixe+  lit "finger" Fixe+  lit "left" Fixe+  lit "right" Fixe+  lit "equipment" Fixe+  lit "equip" Verb  replaceAliases :: [String] -> [String] replaceAliases [] = []@@ -144,8 +164,11 @@   return ()  act' (Verb "quit":[]) = throwError QuitError+act' (Verb "commit":Nounc _ _ "suicide":[]) = do+  eprintLn (Vivid Red) "You stab yourself in the chest, finally dying."+  throwError QuitError act' (Verb "look":[]) = roomTriggerOnLookOf =<< getRoomState-act' (Verb "look":Prep "at":n@Nounc{}:[]) = getAvailableObject n >>=  objectTriggerOnLookAtOf+act' (Verb "look":Prep "at":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnLookAtOf act' (Verb "read":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnReadOf act' (Verb "enter":n@Nounc{}:[]) = getAvailableObject n >>= objectTriggerOnEnterOf act' (Verb "ascend":[]) = changeRoom Up@@ -178,6 +201,31 @@   mprintLn $ printf "Intelligence: %5i   Spirit:  %5i" int spi   mprintLn $ printf "Stamina:      %5i   Armor:   %5i" sta arm   mprintLn $ printf "Attack power: %5i" akp+act' (Verb "equip":n@Nounc{}:[]) = do+  o <- getCarriedObject n >>= equipObject+  case o of+    Nothing -> noneM+    Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s}+act' (Verb "equip":n@Nounc{}:Prep "at":ps) = do+  k <- case ps of+              [Fixe "main",Fixe "hand"] -> return MainHand+              [Fixe "off",Fixe "hand"] -> return OffHand+              [Fixe "chest"] -> return Chest+              [Fixe "feet"] -> return Feet+              [Fixe "wrists"] -> return Wrists+              [Fixe "waist"] -> return Waist+              [Fixe "head"] -> return Head+              [Fixe "legs"] -> return Legs+              [Fixe "back"] -> return Back+              [Fixe "hands"] -> return Hands+              [Fixe "neck"] -> return Neck+              [Fixe "right",Fixe "finger"] -> return Finger1+              [Fixe "left",Fixe "finger"] -> return Finger2+              _ -> throwError UnintellegibleError+  o <- getCarriedObject n >>= equipObjectAt k+  case o of+    Nothing -> noneM+    Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s} act' (Verb "acquire":n@Nounc{}:[]) = getSeenObject n >>= (acquireObject . objectIdOf) act' (Verb "drop":n@Nounc{}:[]) = getCarriedObject n >>= (dropObject . objectIdOf) act' _ = throwError UnintellegibleError
src/Game/Antisplice/Monad/Dungeon.hs view
@@ -48,6 +48,7 @@     Faction (..),     Attitude (..),     -- * Players+    PlayerId (..),     PlayerStereo (..),     PlayerState (..),     PlayerT (..),@@ -55,6 +56,7 @@     -- * Dungeons     DungeonState (..),     currentRoomOf,+    playerOf,     DungeonT (..),     MonadDungeon (..)   ) where@@ -71,15 +73,17 @@ import Game.Antisplice.Errors import Game.Antisplice.Utils.Fail import Game.Antisplice.Utils.Counter+import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.Focus import Game.Antisplice.Monad.Vocab import Control.Arrow import Control.Monad.Error import Control.Monad.Trans.Class-import Control.Comonad import Data.Text import Control.Monad import Data.Time.Clock import Data.Typeable+import Debug.Trace  -- | Matches any 'MonadDungeon' context type DungeonM a = forall m.(MonadDungeon m) => m a@@ -102,6 +106,12 @@ -- | Key for equipment slot data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq) +instance Indexable EquipKey EquipKey EquipKey where+  type ValueOf EquipKey = EquipKey+  type IndexOf EquipKey = EquipKey+  indexOf = id+  valueOf = id+ -- | State type for RoomT data RoomState = RoomState {     roomTitleOf :: !Text,@@ -170,9 +180,18 @@              | Mobile  -- ^ May move around.              deriving (Ord,Eq) +instance Indexable Feature Feature Feature where+  type IndexOf Feature = Feature+  type ValueOf Feature = Feature+  indexOf = id+  valueOf = id+ -- | Phantom ID type for objects. data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord) +instance None ObjectId where+  none = FalseObject+ -- | State type for ObjectT data ObjectState = ObjectState {     objectIdOf :: !ObjectId,@@ -188,7 +207,8 @@     objectCurHealthOf :: !Int,     objectStatsOf :: AVL (StatKey,Int),     objectRouteOf :: ![NodeId],-    objectFeaturesOf :: AVL (Feature,()),+    objectFeaturesOf :: AVL Feature,+    objectWearableAtOf :: AVL EquipKey,     objectNearImplicationsOf :: [Implication],     objectCarryImplicationsOf :: [Implication],     objectWearImplicationsOf :: [Implication],@@ -247,8 +267,12 @@     stereoCalcStatBonus :: (StatKey -> Int) -> StatKey -> Int   } deriving Typeable +-- | Phantom ID type for players+newtype PlayerId = PlayerId Int deriving (Eq,Ord)+ -- | State type for PlayerT data PlayerState = PlayerState {+    playerIdOf :: !PlayerId,     playerRoomOf :: !NodeId,     playerMaxHealthOf :: !Int,     playerCurHealthOf :: !Int,@@ -259,6 +283,12 @@     playerReputationOf :: AVL (Atom Faction,Int)   } +instance Indexable PlayerState PlayerId PlayerState where+  type IndexOf PlayerState = PlayerId+  type ValueOf PlayerState = PlayerState+  indexOf = playerIdOf+  valueOf = id+ -- | The player monad. Used to create or modify players. newtype PlayerT m a = Player { runPlayerT :: PlayerState -> m (a,PlayerState) } @@ -278,6 +308,11 @@   getPlayerState :: m PlayerState   -- | Put the player state.   putPlayerState :: PlayerState -> m ()+  -- | Modify the player state.+  modifyPlayerState :: (PlayerState -> PlayerState) -> m ()+  modifyPlayerState f = do+    s <- getPlayerState+    putPlayerState $ f s  instance Monad m => MonadPlayer (PlayerT m) where   getPlayerState = Player $ \s -> return (s,s)@@ -289,13 +324,19 @@ -- | State type for DungeonT data DungeonState = DungeonState {     roomsOf :: Graph RoomState Direction,-    playerOf :: Maybe PlayerState,+    playersOf :: Focus PlayerState,     timeTriggersOf :: AVL (NominalDiffTime,TriggerBox)   } +instance None DungeonState where+  none = DungeonState none none none+ -- | For compatibility. Earlier versions of DungeonT had a field for that. currentRoomOf = fmap playerRoomOf . playerOf +-- | For compatibility. Earlier versions of DungeonT had a field for that.+playerOf = anyBstHead . playersOf+ -- | The dungeon monad. Everything runs inside this. newtype DungeonT m a = Dungeon { runDungeonT :: DungeonState -> m (a,DungeonState) } @@ -318,8 +359,11 @@ instance Monad m => MonadPlayer (DungeonT m) where   getPlayerState = Dungeon $ \s -> case playerOf s of     Just p -> return (p,s)-  putPlayerState s' = Dungeon $ \s -> return ((),s{playerOf=Just s'})-+  putPlayerState s' = Dungeon $ \s -> return (none,s{playersOf=anyBstInsert s' $ playersOf s})+  modifyPlayerState f = Dungeon $ \s -> case playerOf s of+    Just p -> return ((),s{playersOf=anyBstInsert (f p) $ playersOf s})+    Nothing -> return ((),s)+     -- | Typeclass for all dungeon monads. class (MonadRoom m,MonadPlayer m) => MonadDungeon m where   -- | Get the dungeon state.
src/Game/Antisplice/Rooms.hs view
@@ -26,7 +26,6 @@     -- * Room modification     modifyRoomState,     getRoomDesc,-    --setRoomDesc,     getRoomTitle,     setRoomTitle,     markRoom,@@ -71,10 +70,11 @@     schedule,     -- * Players     subscribePlayer,-    modifyPlayerState,     setPlayerRoom,     acquireObject,     dropObject,+    equipObject,+    equipObjectAt,     -- * Masquerades     withRoom,     guardVisible@@ -88,8 +88,10 @@ 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.Monad import Control.Monad.Error@@ -112,7 +114,7 @@   s <- getRoomState   --return (fromText $ roomDescOf s)   let descseg (DescSeg a) = getAtom a-      descseg _ = return []+      descseg _ = return none   is <- mapM descseg $ concatMap objectNearImplicationsOf $ avlInorder $ roomObjectsOf s   return $ concat $ intersperse " " is @@ -143,7 +145,7 @@   rs0 <- getRoomState   roomTriggerOnLeaveOf rs0   s <- getDungeonState-  putDungeonState s{playerOf=fmap (\p -> p{playerRoomOf=n}) $ playerOf s}+  modifyPlayerState $ \p -> p{playerRoomOf=n}   let marked = nodeMarked $ getNode' n $ roomsOf s   rs <- getRoomState   unless marked $ do@@ -174,11 +176,11 @@ -- | 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 ())+  (_,rs) <- lift $ runRoomT m $ RoomState none none noneM noneM noneM noneM noneM   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'+  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.@@ -218,31 +220,31 @@ constructObject :: Monad m => ObjectT m a -> m ObjectState constructObject m = do   (_,o) <- runObjectT m $ ObjectState-       FalseObject -- id+       none -- id        (pack "Something") -- title        (pack "I don't know what this is.") -- desc-       [] [] False False False False -- names, attr, 1seen?, 1acq?, 1insp?, 1eq?+       none none 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+       none none none -- stats, route, feat+       none none none none -- wear, impl (n,i,w)+       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-       (return ()) -- on enter room-       (return ()) -- on leave room-       (return ()) -- on announce-       (return ()) -- on drop-       (return ()) -- on 1 eq-       (return ()) -- on eq-       (return ()) -- on uneq+       noneM -- on enter room+       noneM -- on leave room+       noneM -- on announce+       noneM -- on drop+       noneM -- on 1 eq+       noneM -- on eq+       noneM -- on uneq   return o  -- | Remove an object from the current room and return its state.@@ -304,17 +306,12 @@ 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 :: (MonadDungeon (t m),MonadTrans t,MonadCounter (t m),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+  i <- countOn+  (_,a) <- lift $ runPlayerT m $ PlayerState (PlayerId i) (rootNode $ roomsOf s) 100 100 none 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 ()@@ -327,7 +324,7 @@ -- | 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,())+  where a True = avlInsert Mobile         a False = avlRemove Mobile  -- | Check if the current object is acquirable.@@ -337,7 +334,7 @@ -- | 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,())+  where a True = avlInsert Acquirable         a False = avlRemove Acquirable  -- | Schedule an event for a given time offset (in milliseconds).@@ -431,3 +428,27 @@   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 k $ objectWearableAtOf o) = do+      p <- getPlayerState+      let o1 = avlLookup k $ playerEquipOf p+      putPlayerState p{playerEquipOf=avlInsert (k,o) $ playerEquipOf p}+      return o1+  | otherwise = throwError CantEquipThatThereError++-- | Equip the given object somewhere+equipObject :: (MonadPlayer m,MonadError SplErr m) => ObjectState -> m (Maybe ObjectState)+equipObject o =+  case avlInorder $ objectWearableAtOf 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+
+ src/Game/Antisplice/SingleUser.hs view
@@ -0,0 +1,65 @@+{-+  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/>.+-}++module Game.Antisplice.SingleUser where++import Text.Chatty.Printer+import Text.Chatty.Finalizer+import Text.Chatty.Interactor+import Text.Chatty.Expansion+import Text.Chatty.Extended.Printer+import Text.Chatty.Extended.ANSI+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Monad.Vocab+import Game.Antisplice.Utils.Fail+import Game.Antisplice.Utils.Counter+import Game.Antisplice.Utils.Atoms+import Game.Antisplice.Utils.None+import Game.Antisplice.Errors+import Game.Antisplice.Monad+import Game.Antisplice.Rooms+import Game.Antisplice.Lang+import Game.Antisplice.Terminal.Repl+import Text.Printf+import System.IO+import Control.Monad+import Control.Monad.IO.Class++singleUser :: DungeonT (FailT SplErr (VocabT (AtomStoreT (CounterT (AnsiPrinterT (ExpanderT (HandleCloserT IO))))))) () -> IO ()+singleUser init =+  void $+  withLazyIO $+  localEnvironment $+  flip runAnsiPrinterT (Dull White) $+  withCounter $+  flip runAtomStoreT none $+  flip runVocabT defVocab $+  do+    r <- runFailT $ flip runDungeonT none $ do+      init+      reenterCurrentRoom+      roomTriggerOnAnnounceOf =<< getRoomState+      roomTriggerOnLookOf =<< getRoomState+      repl+    case r :: Either SplErr ((),DungeonState) of+      Left QuitError -> mprintLn "Bye bye!"+      Left e -> mprintLn $ printf "Error occured: %s\n" $ show e+      Right x -> noneM
src/Game/Antisplice/Terminal/Repl.hs view
@@ -78,6 +78,9 @@             Left WhichOneError -> mprintLn "Which one do you mean?"             Left CantSeeOneError -> mprintLn "I can't see one here."             Left DontCarryOneError -> mprintLn "You don't carry one."+            Left CantEquipThatError -> mprintLn "I can't equip that."+            Left CantEquipThatThereError -> mprintLn "I can't wear that there. You might want to try some other place?"+            Left WhereToEquipError -> mprintLn "Where?"             Left e -> throwError e           throwError DoneError         Just Nothing -> liftIO (killThread thr) >> mprintLn "quit" >> throwError QuitError
src/Game/Antisplice/Utils/AVL.hs view
@@ -25,6 +25,7 @@ module Game.Antisplice.Utils.AVL (avlMax,avlMin,avlLookup,avlHeight,avlSize,avlInsert,avlRemove,AVL (EmptyAVL,AVL),avlRoot,avlPreorder,avlPostorder,avlInorder) where  import Game.Antisplice.Utils.BST+import Game.Antisplice.Utils.None  instance Indexable i o v => AnyBST AVL i o v where   anyBstMax = avlMax@@ -33,7 +34,11 @@   anyBstEmpty = EmptyAVL   anyBstInsert = avlInsert   anyBstRemove = avlRemove+  anyBstHead = avlHead +instance None (AVL a) where+  none = EmptyAVL+ -- | An AVL tree. data AVL a = EmptyAVL | AVL a Int Int !(AVL a) !(AVL a) @@ -142,6 +147,11 @@ avlRoot :: AVL i -> i avlRoot EmptyAVL = error "Trying to get the root of an empty AVL tree." avlRoot (AVL a _ _ _ _) = a++-- | Get the root of the tree (safely)+avlHead :: AVL i -> Maybe i+avlHead EmptyAVL = Nothing+avlHead t = Just $ avlRoot t  -- | Traverse the tree, order (head, left, right) avlPreorder :: AVL i -> [i]
src/Game/Antisplice/Utils/BST.hs view
@@ -24,6 +24,8 @@ -- | Provides a typeclass for all binary search trees and an unbalanced implementation module Game.Antisplice.Utils.BST where +import Game.Antisplice.Utils.None+ -- | Only instances of Indexable may be saved in a BST class Ord o => Indexable i o v | i -> o, i -> v where   type IndexOf i@@ -59,6 +61,8 @@   anyBstLookup :: o -> t i -> Maybe v   -- | An empty tree   anyBstEmpty :: t i+  -- | The root of the tree+  anyBstHead :: t i -> Maybe i  instance Indexable i o v => AnyBST BST i o v where   anyBstInsert = bstInsert@@ -67,7 +71,11 @@   anyBstMin =  bstMin   anyBstLookup = bstLookup   anyBstEmpty = EmptyBST+  anyBstHead = bstHead +instance None (BST a) where+  none = EmptyBST+ -- | An unbalanced binary search tree data BST a = EmptyBST | BST a !(BST a) !(BST a) @@ -108,3 +116,8 @@   | o == indexOf a = Just $ valueOf a   | o < indexOf a = bstLookup o l   | o > indexOf a = bstLookup o r++-- | Return the tree's root+bstHead :: Indexable i o v => BST i -> Maybe i+bstHead EmptyBST = Nothing+bstHead (BST a _ _) = Just a
+ src/Game/Antisplice/Utils/Focus.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}++{-+  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 an unbalanced BST with a focus on the root.+module Game.Antisplice.Utils.Focus (Focus, focusSelect) where++import Game.Antisplice.Utils.BST+import Game.Antisplice.Utils.None++-- | An unbalanced BST with a focus on the root.+newtype Focus a = Focus { runFocus :: BST a }++instance None (Focus a) where+  none = Focus none++instance Indexable i o v => AnyBST Focus i o v where+  anyBstInsert i t = Focus $ focusInsert' i $ runFocus t+  anyBstRemove o t = Focus $ bstRemove o $ runFocus t+  anyBstMax t = bstMax $ runFocus t+  anyBstMin t = bstMin $ runFocus t+  anyBstLookup o t = bstLookup o $ runFocus t+  anyBstHead t = bstHead $ runFocus t+  anyBstEmpty = Focus none++focusSelect' :: Indexable i o v => o -> BST i -> Maybe (BST i)+focusSelect' _ EmptyBST = Nothing+focusSelect' o t@(BST a l r)+  | o == indexOf a = Just t+  | o < indexOf a = case focusSelect' o l of+      Just (BST a' l' r') -> Just $ BST a' l' (BST a r' r)+      Nothing -> Nothing+  | otherwise = case focusSelect' o r of+      Nothing -> Nothing+      Just (BST a' l' r') -> Just $ BST a' (BST a l l') r'++focusInsert' :: Indexable i o v => i -> BST i -> BST i+focusInsert' i = unjust . focusSelect' (indexOf i) . bstInsert i+  where unjust (Just j) = j++-- | Rotate the tree such that the given element becomes the root node.+focusSelect o t = fmap Focus $ focusSelect' o $ runFocus t
src/Game/Antisplice/Utils/Graph.hs view
@@ -26,6 +26,7 @@  import Game.Antisplice.Utils.BST import Game.Antisplice.Utils.AVL+import Game.Antisplice.Utils.None  -- | Phantom type for a node ID newtype NodeId = NodeId Int deriving (Eq,Show,Ord)@@ -61,6 +62,9 @@ -- | An empty graph emptyGraph :: Graph a b emptyGraph = Graph EmptyAVL [] (NodeId 0)++instance None (Graph a b) where+  none = emptyGraph  -- | Add a node to the graph addNode :: a -> Graph a b -> Graph a b
+ src/Game/Antisplice/Utils/None.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}++{-+  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 a typeclass for everything that may carry a void value+module Game.Antisplice.Utils.None where++import Data.Maybe+import Data.Text (pack, Text)++-- | Typeclass for everything that may carry a void value+class None n where+  none :: n++instance None [a] where+  none = []++instance None (Maybe a) where+  none = Nothing++instance None () where+  none = ()++instance None Text where+  none = pack ""++instance None (a -> a) where+  none = id++instance Monad m => None (a -> m a) where+  none = return++-- | Wrap the void into a monad.+noneM :: (Monad m,None n) => m n+noneM = return none++-- | Join a maybe into the underlying type. 'Nothing' becomes 'none'.+joinMaybe :: None n => Maybe n -> n+joinMaybe (Just j) = j+joinMaybe Nothing = none++-- | Wrap the value into a maybe. 'none' becomes 'Nothing'.+expandMaybe :: (Eq n,None n) => n -> Maybe n+expandMaybe n+  | n == none = Nothing+  | otherwise = Just n++-- | Clean the maybe by pulling wrapped 'none's to the outside (as a 'Nothing').+cleanMaybe :: (Eq n,None n) => Maybe n -> Maybe n+cleanMaybe = expandMaybe . joinMaybe++-- | Eliminate all void elements from the list.+reduce :: (Eq n,None n) => [n] -> [n]+reduce = filter (/=none)++-- | Eliminate all 'Nothing's from the list and unjust all remaining values.+reduceMaybe :: [Maybe a] -> [a]+reduceMaybe = map unjust . filter isJust+  where unjust (Just j) = j
src/Game/Antisplice/Utils/TST.hs view
@@ -23,6 +23,7 @@ module Game.Antisplice.Utils.TST where  import Data.Maybe+import Game.Antisplice.Utils.None  -- | A ternary search trie data TST a = EmptyTST | TST Char (Maybe a) (TST a) (TST a) (TST a)@@ -49,3 +50,6 @@ -- | Check if the TST contains the given key tstContains :: String -> TST a -> Bool tstContains cs = isJust . tstLookup cs++instance None (TST a) where+  none = EmptyTST