antisplice 0.15.0.1 → 0.16.0.1

raw patch · 16 files changed

+819/−318 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• antisplice.cabal +3/−4
• src/Game/Antisplice.hs +2/−0
• src/Game/Antisplice/Action.hs +81/−18
• src/Game/Antisplice/Call.hs +258/−116
• src/Game/Antisplice/Errors.hs +8/−0
• src/Game/Antisplice/Lang.hs +112/−104
• src/Game/Antisplice/MaskedSkills.hs +75/−0
• src/Game/Antisplice/Monad/Dungeon.hs +49/−1
• src/Game/Antisplice/Monad/Vocab.hs +21/−1
• src/Game/Antisplice/Paths.hs +4/−2
• src/Game/Antisplice/Skills.hs +85/−52
• src/Game/Antisplice/Stereos.hs +9/−7
• src/Game/Antisplice/Terminal/Repl.hs +16/−13
• src/Game/Antisplice/Utils/Fail.hs +2/−0
• src/Game/Antisplice/Utils/Hetero.hs +91/−0
• src/Game/Antisplice/Utils/ListBuilder.hs +3/−0

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.15.0.1+version:             0.16.0.1  -- A short (one-line) description of the package. synopsis:            An engine for text-based dungeons.@@ -48,13 +48,13 @@  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, Game.Antisplice.Utils.None, Game.Antisplice.Utils.Focus, Game.Antisplice.SingleUser, Game.Antisplice, Game.Antisplice.Skills, Game.Antisplice.Stereos, Game.Antisplice.Paths, Game.Antisplice.Action, Game.Antisplice.Utils.ListBuilder, Game.Antisplice.Call+  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, Game.Antisplice.Skills, Game.Antisplice.Stereos, Game.Antisplice.Paths, Game.Antisplice.Action, Game.Antisplice.Utils.ListBuilder, Game.Antisplice.Call, Game.Antisplice.MaskedSkills, Game.Antisplice.Utils.Hetero      -- Modules included in this library but not exported.   -- other-modules:             -- LANGUAGE extensions used by modules in this package.-  other-extensions:    TemplateHaskell, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeFamilies, FunctionalDependencies+  other-extensions:    TemplateHaskell, QuasiQuotes, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, UndecidableInstances, RankNTypes, TypeFamilies, FunctionalDependencies, LambdaCase, ScopedTypeVariables, ExistentialQuantification, TupleSections, RecordWildCards, DeriveDataTypeable      -- Other library packages from which modules are imported.   build-depends:       base >=4.6 && <4.7, chatty >=0.5.4 && <0.6, 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@@ -66,4 +66,3 @@   default-language:    Haskell2010    ghc-options: -fprof-auto-

@@ -45,6 +45,7 @@   module Game.Antisplice.Events,   module Game.Antisplice.Paths,   module Game.Antisplice.Action,+  module Game.Antisplice.Utils.Hetero,   -- * Type abbreviations   Constructor) where @@ -62,6 +63,7 @@ import Game.Antisplice.Utils.None import Game.Antisplice.Utils.BST import Game.Antisplice.Utils.Counter+import Game.Antisplice.Utils.Hetero import Game.Antisplice.Rooms import Game.Antisplice.Stats import Game.Antisplice.Stereos

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, FlexibleContexts, LambdaCase, FlexibleInstances #-}  {-   This module is part of Antisplice.@@ -26,8 +26,10 @@  import Control.Monad import Data.Monoid+import Data.Maybe import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Rooms+import Game.Antisplice.Errors import Game.Antisplice.Stats import Game.Antisplice.Utils.Counter import Game.Antisplice.Utils.None@@ -37,16 +39,16 @@ -- | A typeclass for all action types carrying an execution condition. class IsAction a where   -- | Conjunction _with_ short evaluation.-  infixl 6 #&&+  infixl 5 #&&   (#&&) :: a -> a -> a   -- | Disjunction _with_ short evaulation.-  infixl 6 #||+  infixl 5 #||   (#||) :: a -> a -> a   -- | Conjunction _without_ short evaluation.-  infixl 6 !&&+  infixl 5 !&&   (!&&) :: a -> a -> a   -- | Disjunction _without_ short evaluation.-  infixl 6 !||+  infixl 5 !||   (!||) :: a -> a -> a  instance Monoid PrerequisiteBox where@@ -71,27 +73,62 @@     b <- runPrerequisite q     return (a || b) +instance Monoid PredicateBox where+  mempty = none+  p `mappend` q = Predicate $ do+    a <- runPredicate p+    b <- runPredicate q+    return $ case (a,b) of+      (Just (Unint i s), Just (Unint j _)) | i >= j -> Just $ Unint i s+      (Nothing, k) -> k+      (k, _) -> k++instance IsAction PredicateBox where+  p #&& q = Predicate $+    runPredicate p >>= \case+      Nothing -> runPredicate q+      Just (Unint i s) -> runPredicate q >>= \case+        Nothing -> return $ Just $ Unint i s+        Just (Unint j _) | i >= j -> return $ Just $ Unint i s+        e -> return e+      e -> return e+  p #|| q = Predicate $+    runPredicate p >>= \case+      Nothing -> return Nothing+      Just (Unint i s) -> runPredicate q >>= \case+        Just (Unint j _) | i >= j -> return $ Just $ Unint i s+        e -> return e+      e -> runPredicate q+  p !&& q = p <> q+  p !|| q = Predicate $ do+    a <- runPredicate p+    b <- runPredicate q+    return $ case (a,b) of+      (Nothing, _) -> Nothing+      (Just (Unint i s), Just (Unint j _)) | i >= j -> Just $ Unint i s+      (_, k) -> k+ -- | A general action, which may be used for skills and gates.-data Action = Action { askAction :: Prerequisite, runAction :: Handler }+data Action = Action { askAction :: Predicate, runAction :: Handler }  instance None Action where-  none = Action (return True) noneM+  none = Action (return Nothing) noneM  instance Monoid Action where   mempty = none-  a `mappend` b = Action (runPrerequisite $ Prerequisite (askAction a) <> Prerequisite (askAction b)) (runAction a >> runAction b)+  a `mappend` b = Action (runPredicate $ Predicate (askAction a) <> Predicate (askAction b)) (runAction a >> runAction b)  instance IsAction Action where   a #&& b = Action-    (runPrerequisite $ Prerequisite (askAction a) #&& Prerequisite (askAction b))+    (runPredicate $ Predicate (askAction a) #&& Predicate (askAction b))     (runAction a >> runAction b)   a #|| b = Action-    (runPrerequisite $ Prerequisite (askAction a) #|| Prerequisite (askAction b))-    (askAction a >>= \q -> if q then runAction a else runAction b)+    (runPredicate $ Predicate (askAction a) #|| Predicate (askAction b))+    (askAction a >>= \q -> if isNothing q then runAction a else runAction b)   a !&& b = a <> b   a !|| b = Action-    (runPrerequisite $ Prerequisite (askAction a) !|| Prerequisite (askAction b))-    (askAction a >>= \q -> askAction b >> if q then runAction a else runAction b)+    (runPredicate $ Predicate (askAction a) !|| Predicate (askAction b))+    (askAction a >>= \q -> askAction b >> if isNothing q then runAction a else runAction b)  -- | An action that is run /after/ a specific event. newtype ActionAfter = ActionAfter { runActionAfter :: Action }@@ -121,12 +158,38 @@   a !&& b = ActionBefore $ runActionBefore a !&& runActionBefore b   a !|| b = ActionBefore $ runActionBefore a !|| runActionBefore b +instance IsAction (Maybe ReError) where+  -- #&&+  Nothing #&& Nothing = Nothing+  Just (Unint i s) #&& Just (Unint j _) | i >= j = Just $ Unint i s+  a #&& Nothing = a+  _ #&& e = e+  -- #||+  Nothing #|| _ = Nothing+  Just (Unint i s) #|| Just (Unint j _) | i >= j = Just $ Unint i s+  _ #|| e = e+  -- !&&, !||+  (!&&) = (#&&)+  (!||) = (#||)++ands :: (None a,IsAction a) => [a] -> a+ands = foldr (!&&) none++andl :: (None a,IsAction a) => [a] -> a+andl = foldr (#&&) none++ors :: (None a,IsAction a) => [a] -> a+ors = foldr (!||) none++orl :: (None a,IsAction a) => [a] -> a+orl = foldr (#||) none+ -- | Use for actions that consume a given currency. consumeCurrencyA :: CurrencyId -> Int -> Action consumeCurrencyA c h = Action   (do       c1 <- getCurrency c-      return (c1 > h))+      return (if c1 > h then Nothing else Just $ Uncon "You can't cast that now (check your currencies)"))   (modifyCurrency c (subtract h))  -- | Use for actions that consume an object of the given kind.@@ -137,27 +200,27 @@   in Action     (do         objs <- getObjs-        return (length objs >= h))+        return (if length objs >= h then Nothing else Just $ Uncon "You can't cast that now (check your inventory)"))     (do         objs <- getObjs         modifyPlayerState $ \p -> p{playerInventoryOf=foldr avlRemove (playerInventoryOf p) $ take h objs})  -- | Deal damage to opponent dealDamageA :: ChattyDungeonM Int -> Action-dealDamageA m = Action (return True) (dealDamage =<< m)+dealDamageA m = Action (return Nothing) (dealDamage =<< m)  -- | Use for actions that require a cooldown time. implyCooldownA :: MonadCounter m => Integer -> m Action implyCooldownA ms = do   cid <- liftM CooldownId countOn   return (Action-    (liftM not $ getCooldown cid)+    (liftM (\b -> if not b then Nothing else Just $ Uncon "You can't cast that now (check your cooldowns)") $ getCooldown cid)     (setCooldown cid True >> schedule ms (setCooldown cid False)))  -- | Use for actions that suffer from global cooldown. implyGlobalCooldownA :: Action implyGlobalCooldownA = Action-  (liftM not $ getCooldown GlobalCooldown)+  (liftM (\b -> if not b then Nothing else Just $ Uncon "You can't cast that now (check your global cooldown)") $ getCooldown GlobalCooldown)   (do     setCooldown GlobalCooldown True     cd <- calcStat CooldownDuration

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, RankNTypes, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, RankNTypes, FlexibleContexts, LambdaCase, ScopedTypeVariables #-}  {-   This module is part of Antisplice.@@ -23,51 +23,51 @@  -- | Provides a powerful language for user input evaluation module Game.Antisplice.Call (-  -- * Heterogenous list-  Cons (..),-  Nil (..),-  Append (..),-  Tuplify (..),   -- * Using call masks   processMask,   tryMask,-  -- * Call mask segments+  -- * Mask classes   CallMask (..),+  PredMask (..),+  PostMask (..),+  CombiMask (..),+  -- * Mask segments   EnsureLineEnd (..),   CatchByType (..),   CatchToken (..),   CatchOrd (..),   Remaining (..),   CatchObj (..),+  Which (..),+  Optional (..),+  Ignore (..),+  Pass (..)   ) where  import Control.Monad import Control.Monad.State import Control.Monad.Identity import Control.Monad.Error.Class+import Data.Either+import Data.List import Data.Maybe import Game.Antisplice.Errors import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Monad.Vocab import Game.Antisplice.Utils.AVL+import Game.Antisplice.Utils.BST+import Game.Antisplice.Utils.Hetero -infixr 8 :-:--- | The Cons type for a heterogenous list-data Cons a b = (:-:) a b--- | The empty list-data Nil = Nil+unint :: Monad m => String -> m (Either ReError a)+unint = return . Left . Unint 0 --- | Typeclass for appending one heterogenous list to another one-class Append a b ab | a b -> ab where-  tappend :: a -> b -> ab-instance Append Nil b b where-  tappend Nil b = b-instance Append b c bc => Append (Cons a b) c (Cons a bc) where-  tappend (a :-: b) c = a :-: tappend b c+unintp :: Monad m => String -> m (Maybe ReError)+unintp = return . Just . Unint 200 --- | Typeclass for use input masks (either single modules or lists of modules)+-- | Typeclass for input masks (either single modules or lists of modules) class CallMask cm l | cm -> l where-  usemask :: (MonadRoom m,MonadPlayer m) => cm -> StateT [(String,Token)] m (Maybe l)+  usemask :: (MonadRoom m,MonadPlayer m) => cm -> StateT [(String,Token)] m (Either ReError l)+  verbosemask :: cm -> String  -- | Ensures that the end of the input is reached data EnsureLineEnd = EnsureLineEnd@@ -81,75 +81,137 @@ data Remaining = Remaining -- | Catches an available, carried or seen object data CatchObj = AvailableObject | SeenObject | CarriedObject+-- | Provide multiple alternatives and catch the first matching one as well as its result+data Which a = Which [a]+-- | Provide an optional mask part+data Optional a = Optional a+-- | Ignore a token or result+data Ignore = Ignore+-- | Pass-through a result+data Pass = Pass +firstSeq :: Monad m => (a -> m (Either ReError b)) -> [a] -> m (Either ReError (a,b))+firstSeq _ [] = return $ Left $ Unint (-1) "You'll never see this error."+firstSeq f (p:ps) = f p >>= \case+  Left (Unint i s) -> firstSeq f ps >>= \case+    Left (Unint i2 s2)+      | i2 < i -> return $ Left $ Unint i s+      | otherwise -> return $ Left $ Unint i2 s2+  Left (Forward s) -> return $ Left $ Forward s+  Right k -> return $ Right (p,k)++instance (CallMask a ar, IntoMaybe ar am,Append am Nil am) => CallMask (Optional a) am where+  usemask (Optional a) = do+    usemask a >>= \case+      Left _ -> return $ Right $ tnothing (undefined :: ar)+      Right k -> return $ Right $ tjust k+  verbosemask (Optional a) = "optionally [" ++ verbosemask a ++ "]"++instance (CallMask a r,Append (Cons a Nil) r ar) => CallMask (Which a) ar where+  usemask (Which []) = do+    ss <- get+    case ss of+      [] -> unint "Couldn't match empty choice (Which []) with end of input. This is the dungeon writer's fault, you should blame him."+      (s,_):_ -> unint ("Couldn't match empty choice (Which []) with word \""++s++"\". This is the dungeon writer's fault, you should blame him.")+  usemask (Which ps) = do+    ss <- get+    if null ss then unint ("End of input reached, but one of the following expected: " ++ concat (intersperse " or " $ map verbosemask ps))+               else let (s:_) = ss in do+      firstSeq usemask ps >>= \case+        Left e -> return $ Left e+        Right (k,r) -> return $ Right (tappend (k :-: Nil) r)+  verbosemask (Which []) = "empty choice (you should blame the dungeon writer)"+  verbosemask (Which ps) = concat $ intersperse "or" $ map verbosemask ps+ instance CallMask Token Nil where   usemask t = do     ss <- get-    if null ss then return Nothing-               else let (s:_) = ss in do-      modify tail-      return $ if snd s == t then Just Nil else Nothing+    if null ss then unint ("End of input reached, but token \""++show t++"\" expected.")+               else let (s:_) = ss in+      if snd s == t then modify tail >> return (Right Nil) else unint ("Token \""++show (snd s)++"\" found, but token \""++show t++"\" expected.")+  verbosemask = show+ +instance CallMask Ignore Nil where+  usemask t = do+    ss <- get+    if null ss then unint "End of input reached, but any token expected."+      else modify tail >> return (Right Nil)+  verbosemask _ = "any token"  instance CallMask String Nil where   usemask t = do     ss <- get-    if null ss then return Nothing-               else let (s:_) =ss in do-      modify tail-      return $ if fst s == t then Just Nil else Nothing+    if null ss then unint ("End of input reached, but token \""++t++"\" expected.")+               else let (s:_) =ss in+      if fst s == t then modify tail >> return (Right Nil)+      else unint ("Token \""++show (snd s)++"\" found, but \""++t++"\" expected.")+  verbosemask = show        instance CallMask EnsureLineEnd Nil where   usemask EnsureLineEnd = do     s <- get-    return $ if null s then Just Nil else Nothing+    if null s then return (Right Nil) else unint ("End of input expected, but token \""++show (snd $ head s)++"\" found.")+  verbosemask _ = "end of input"      instance CallMask CatchByType (Cons String Nil) where   usemask ct = do     ss <- get-    if null ss then return Nothing+    if null ss then unint ("End of input reached, but \""++verbosemask ct++"\" expected.")                else let (s:_) = ss in do            modify tail       return $ case (ct,snd s) of-        (CatchVerb, Verb t) -> Just (t :-: Nil)-        (CatchAny, Verb t) -> Just (t :-: Nil)-        (CatchPrep, Prep t) -> Just (t :-: Nil)-        (CatchAny, Prep t) -> Just (t :-: Nil)-        (CatchNoun, Noun t) -> Just (t :-: Nil)-        (CatchAny, Noun t) -> Just (t :-: Nil)-        (CatchAdj, Adj t) -> Just (t :-: Nil)-        (CatchAny, Adj t) -> Just (t :-: Nil)-        (CatchOrdn i, Ordn j t) -> if i == j then Just (t :-: Nil) else Nothing-        (CatchAny, Ordn _ t) -> Just (t :-: Nil)-        (CatchFixe, Fixe t) -> Just (t :-: Nil)-        (CatchAny, Fixe t) -> Just (t :-: Nil)-        (CatchSkilln, Skilln t) -> Just (t :-: Nil)-        (CatchAny, Skilln t) -> Just (t :-: Nil)-        (CatchUnint, Unintellegible t) -> Just (t :-: Nil)-        (CatchAny, Unintellegible t) -> Just (t :-: Nil)-        _ -> Nothing+        (CatchVerb, Verb t) -> Right (t :-: Nil)+        (CatchAny, Verb t) -> Right (t :-: Nil)+        (CatchPrep, Prep t) -> Right (t :-: Nil)+        (CatchAny, Prep t) -> Right (t :-: Nil)+        (CatchNoun, Noun t) -> Right (t :-: Nil)+        (CatchAny, Noun t) -> Right (t :-: Nil)+        (CatchAdj, Adj t) -> Right (t :-: Nil)+        (CatchAny, Adj t) -> Right (t :-: Nil)+        (CatchOrdn i, Ordn j t) -> if i == j then Right (t :-: Nil) else Left $ Unint 0 ("Ordinal #"++show j++" found, but ordinal #"++show i++" expected.")+        (CatchAny, Ordn _ t) -> Right (t :-: Nil)+        (CatchFixe, Fixe t) -> Right (t :-: Nil)+        (CatchAny, Fixe t) -> Right (t :-: Nil)+        (CatchSkilln, Skilln t) -> Right (t :-: Nil)+        (CatchAny, Skilln t) -> Right (t :-: Nil)+        (CatchUnint, Unintellegible t) -> Right (t :-: Nil)+        (CatchAny, Unintellegible t) -> Right (t :-: Nil)+        (ct,t) -> Left $ Unint 0 ("Token \""++show t++"\" found, but "++verbosemask ct++" expected.")+  verbosemask CatchVerb = "verb"+  verbosemask CatchPrep = "preposition"+  verbosemask CatchNoun = "simple noun"+  verbosemask CatchAdj = "adjective"+  verbosemask (CatchOrdn i) = "token expressing ordinal #"++show i+  verbosemask CatchFixe = "fix expression"+  verbosemask CatchSkilln = "skill name"+  verbosemask CatchUnint = "unclassified token (blame the dungeon's author!)"+  verbosemask CatchAny = "token"          instance CallMask CatchOrd (Cons Int Nil) where   usemask CatchOrd = do     ss <- get-    if null ss then return Nothing+    if null ss then unint "End of input reached, but ordinal number expected."                else let (s:_) = ss in do            modify tail       case snd s of-        Ordn i _ -> return $ Just (i :-: Nil)-        _ -> return Nothing+        Ordn i _ -> return $ Right (i :-: Nil)+        t -> unint ("Token \""++show t++"\" found, but ordinal number expected.")+  verbosemask CatchOrd = "ordinal number"  instance CallMask CatchToken (Cons Token Nil) where   usemask CatchToken = do     ss <- get-    if null ss then return Nothing-               else modify tail >> return (Just (snd (head ss) :-: Nil))+    if null ss then unint "End of line reached, but token expected."+               else modify tail >> return (Right (snd (head ss) :-: Nil))   usemask CatchNounc = do     ss <- get     case mergeNoun ss of-      Nothing -> return Nothing-      Just (t,xs) -> do put xs; return $ Just (t :-: Nil)+      Left e -> return $ Left e+      Right (t,xs) -> do put xs; return $ Right (t :-: Nil)+  verbosemask CatchToken = "token"+  verbosemask CatchNounc = "noun" -instance CallMask CatchObj (Cons ObjectState Nil) where+instance CallMask CatchObj (Cons (Titled ObjectState) Nil) where   usemask k = do     ss <- get     as <- lift $ case k of@@ -157,86 +219,63 @@       SeenObject -> seenObjects       CarriedObject -> carriedObjects     case mergeNoun ss of-      Nothing -> return Nothing-      Just (t,xs) -> do+      Left e -> return $ Left e+      Right (t,xs) -> do         put xs         case getObject' as t of-          Found x -> return $ Just (x :-: Nil)-          _ -> return Nothing+          Found x -> return $ Right (Titled (show t) x :-: Nil)+          TooMany -> return $ Left $ Unint 100 (show t++" matches on multiple objects. Please be more precise or add an ordinal number.")+          NoneFound -> return $ Left $ Unint 100 $ case k of+            AvailableObject -> "I neither carry nor see any "++show t+            SeenObject -> "I can't see any "++show t+            CarriedObject -> "I don't carry any "++show t+  verbosemask AvailableObject = "available object"+  verbosemask SeenObject = "seen object"+  verbosemask CarriedObject = "carried object"  instance CallMask Remaining (Cons [String] Nil) where   usemask Remaining = do     ss <- get     put []-    return $ Just (map fst ss :-: Nil)+    return $ Right (map fst ss :-: Nil)+  verbosemask _ = "anything"  instance CallMask Nil Nil where-  usemask Nil = return $ Just Nil+  usemask Nil = return $ Right Nil+  verbosemask _ = "end of mask"    instance (CallMask x r,CallMask xs rs,Append r rs rx) => CallMask (Cons x xs) rx where   usemask (x :-: xs) = do     l1 <- usemask x     case l1 of-      Nothing -> return Nothing-      Just l1 -> do+      Left e -> return $ Left e+      Right l1 -> do         l2 <- usemask xs         case l2 of-          Nothing -> return Nothing-          Just l2 -> return $ Just $ tappend l1 l2---- | Typeclass for everything that may be converted to a tuple-class Tuplify l t | l -> t where-  tuplify :: l -> t--instance Tuplify Nil () where-  tuplify Nil = ()--instance Tuplify (Cons a Nil) a where-  tuplify (a :-: Nil) = a--instance Tuplify (Cons a (Cons b Nil)) (a,b) where-  tuplify (a :-: b :-: Nil) = (a,b)--instance Tuplify (Cons a (Cons b (Cons c Nil))) (a,b,c) where-  tuplify (a :-: b :-: c :-: Nil) = (a,b,c)--instance Tuplify (Cons a (Cons b (Cons c (Cons d Nil)))) (a,b,c,d) where-  tuplify (a :-: b :-: c :-: d :-: Nil) = (a,b,c,d)--instance Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e Nil))))) (a,b,c,d,e) where-  tuplify (a :-: b :-: c :-: d :-: e :-: Nil) = (a,b,c,d,e)--instance Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e (Cons f Nil)))))) (a,b,c,d,e,f) where-  tuplify (a :-: b :-: c :-: d :-: e :-: f :-: Nil) = (a,b,c,d,e,f)--instance Tuplify ObjectState ObjectState where-  tuplify = id--instance Tuplify Int Int where-  tuplify = id--instance Tuplify String String where-  tuplify = id+          Left (Unint x s) -> return $ Left $ Unint (x+1) s+          Left e -> return $ Left e+          Right l2 -> return $ Right $ tappend l1 l2+  verbosemask (x :-: xs) = verbosemask x ++ ", then " ++ verbosemask xs  -- | Use a mask on a list of tokens-processMask' :: CallMask m r => m -> [(String,Token)] -> DungeonM (Maybe r)+processMask' :: CallMask m r => m -> [(String,Token)] -> DungeonM (Either ReError r) processMask' m s = evalStateT (usemask m) s  -- | Use a mask on a list of tokens and tuplify the result. Dispatch errors to the underlying monad.-processMask :: (CallMask m r, Append r Nil r, Tuplify r t) => m -> [String] -> DungeonM t+processMask :: (Append m (Cons EnsureLineEnd Nil) s,CallMask s r, Append r Nil r, Tuplify r t) => m -> [String] -> DungeonM t processMask m s = do   ss <- mapM lookupVocab s-  mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss+  mr <- processMask' (tappend m (EnsureLineEnd :-: Nil)) $ zip s ss   case mr of-    Nothing -> throwError UnintellegibleError-    Just r -> return $ tuplify r+    Left _ -> throwError UnintellegibleError+    Right r -> return $ tuplify r --- | Try to use a mask on a list of tokens. Only return whether it succeeded.-tryMask :: (Append r Nil r, CallMask m r) => m -> [String] -> DungeonM Bool+-- | Try to use a mask on a list of tokens. +tryMask :: (Append m (Cons EnsureLineEnd Nil) s,Append r Nil r, CallMask s r) => m -> [String] -> DungeonM (Either ReError r) tryMask m s = do   ss <- mapM lookupVocab s-  mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss-  return $ isJust mr+  mr <- processMask' (tappend m (EnsureLineEnd :-: Nil)) $ zip s ss+  return mr  -- | Token is adjective? isAdj (Adj _) = True@@ -247,20 +286,20 @@ isNoun _ = False  -- | Merge nouns and adjectives to a complex noun-mergeNoun :: [(String,Token)] -> Maybe (Token,[(String,Token)])-mergeNoun [] = Nothing+mergeNoun :: [(String,Token)] -> Either ReError (Token,[(String,Token)])+mergeNoun [] = Left $ Unint 5 "End of input reached, but noun expected." mergeNoun ts@((_,Noun s):_) =   let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts-  in Just (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts)+  in Right (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts) mergeNoun ts@((_,Adj s):_) =   let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts-  in Just (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts)+  in Right (Nounc (map fst $ init as) Nothing (fst $ last as), drop (length as) ts) mergeNoun (o@(_,Ordn i _):ts) =   let as = takeWhile (\(_,t) -> isAdj t || isNoun t) ts   in case as of-    [] -> Nothing-    _ ->  Just (Nounc (map fst $ init as) (Just i) (fst $ last as), drop (length as) ts)-mergeNoun _ = Nothing+    [] -> Left $ Unint 0 "Sole ordinal number found, but noun expected."+    _ ->  Right (Nounc (map fst $ init as) (Just i) (fst $ last as), drop (length as) ts)+mergeNoun (o:_) = Left $ Unint 0 ("Token \""++show (snd o)++"\" found, but noun expected.")  getObject' :: [ObjectState] -> Token -> GetterResponse getObject' os (Nounc as i n) =@@ -286,3 +325,106 @@  seenObjects :: MonadRoom m => m [ObjectState] seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState++-- | Typeclass for evaluation result predicate masks+class PredMask rm im where+  usepmask :: rm -> im -> ChattyDungeonM (Maybe ReError)++instance PredMask Nil Nil where+  usepmask Nil Nil = return Nothing++instance (PredMask r i,PredMask rs is) => PredMask (Cons r rs) (Cons i is) where+  usepmask (r :-: rs) (i :-: is) = do+    usepmask r i >>= \case+      Nothing -> usepmask rs is+      Just (Unint i s) -> return $ Just $ Unint (i+1) s++instance PredMask (x -> Bool, String) x where+  usepmask (r,fs) i = case r i of+    True -> return Nothing+    False -> unintp fs++instance PredMask (x -> Maybe ReError) x where+  usepmask f i = return $ f i++instance PredMask (x -> PrerequisiteBox, String) x where+  usepmask (p,fs) i = runPrerequisite (p i) >>= \case+    True -> return Nothing+    False -> unintp fs++instance PredMask String String where+  usepmask s i = case s == i of+    True -> return Nothing+    False -> unintp ("Token \""++i++"\" expected, but \""++s++"\" found.")++instance PredMask Ignore a where+  usepmask Ignore _ = return Nothing++instance PredMask Feature (Titled ObjectState) where+  usepmask f (Titled n i) = case elem f $ avlInorder $ objectFeaturesOf i of+    True -> return Nothing+    False -> unintp $  case f of+      Damagable -> n++" may not be damaged."+      Acquirable -> n++" may not be acquired."+      Usable -> "You don't know how to use "++n+      Drinkable -> "You can't drink "++n+      Eatable -> "You can't eat "++n+      Mobile -> n++" may not move."+      _ -> n++" does not possess the required feature."++-- | Typeclass for evaluation result post-processing masks+class PostMask pm im rm | pm im -> rm where+  usepost :: pm -> im -> ChattyDungeonM rm++instance PostMask Nil Nil Nil where+  usepost Nil Nil = return Nil++instance (PostMask m i r, PostMask ms is rs, Append r rs rx) => PostMask (Cons m ms) (Cons i is) rx where+  usepost (m :-: ms) (i :-: is) = do+    b <- usepost m i+    bs <- usepost ms is+    return $ tappend b bs++instance PostMask Ignore a Nil where+  usepost Ignore a = return Nil++instance PostMask (a -> b) a (Cons b Nil) where+  usepost f a = return (f a :-: Nil)++instance PostMask (a -> b) (Titled a) (Cons b Nil) where+  usepost f (Titled _ a) = return (f a :-: Nil)++instance PostMask Pass a (Cons a Nil) where+  usepost _ a = return (a :-: Nil)++-- | Typeclass for evaluation result combi masks+class CombiMask cm rm pm pom | cm rm -> pm pom where+  ctopred :: cm -> rm -> pm+  ctopost :: cm -> rm -> pom++instance CombiMask Nil Nil Nil Nil where+  ctopred Nil _ = Nil+  ctopost Nil _ = Nil++instance (CombiMask m i p po, CombiMask ms is ps pos) => CombiMask (Cons m ms) (Cons i is) (Cons p ps) (Cons po pos) where+  ctopred (m :-: ms) _ = ctopred m (undefined :: i) :-: ctopred ms (undefined :: is)+  ctopost (m :-: ms) _ = ctopost m (undefined :: i) :-: ctopost ms (undefined :: is)++instance CombiMask Ignore a Ignore Ignore where+  ctopred Ignore _ = Ignore+  ctopost Ignore _ = Ignore++instance CombiMask (a -> Maybe b, String) a (a -> Bool,String) (a -> b) where+  ctopred (f,s) _ = (isJust . f,s)+  ctopost (f,_) _ = unJust . f where unJust (Just j) = j++instance CombiMask (a -> Either ReError b) a (a -> Maybe ReError) (a -> b) where+  ctopred f _ = (eitherToMaybe . f)+    where eitherToMaybe (Right _) = Nothing+          eitherToMaybe (Left e) = Just e+  ctopost f _ = unRight . f+    where unRight (Right x) = x++instance CombiMask Pass a Ignore Pass where+  ctopred _ _ = Ignore+  ctopost _ _ = Pass

@@ -41,7 +41,15 @@             | CantAcquireThatError       -- ^ "I can't take that."             | WontHitThatError           -- ^ "I won't hit that."             | WrongMethodError           -- ^ "Wrong method for creating that."+            | ReError ReError            -- ^ To embed ReErrors             deriving Show++-- | Antisplice new errors+data ReError = Unint Int String+             | Uncon String+             | Forward String+             | Bye+             deriving (Eq,Ord,Show)  -- | Alias for 'FailT' 'SplErr' type SplErrT m = FailT SplErr m

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, RankNTypes, LambdaCase #-}  {-   This module is part of Antisplice.@@ -34,12 +34,15 @@ import Game.Antisplice.Monad.Vocab import Game.Antisplice.Utils.Graph import Game.Antisplice.Utils.AVL+import Game.Antisplice.Utils.BST import Game.Antisplice.Utils.TST import Game.Antisplice.Utils.None import Game.Antisplice.Utils.ListBuilder+import Game.Antisplice.Utils.Hetero import Game.Antisplice.Rooms import Game.Antisplice.Stats import Game.Antisplice.Skills+import Game.Antisplice.MaskedSkills import Game.Antisplice.Call import Game.Antisplice.Action import Control.Arrow@@ -51,76 +54,78 @@  aliases :: [(String,String)] 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"+  "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"+  "eq" >-< "list equipment"+  "'" >-< "echo"  defVocab :: TST Token defVocab = foldr (\(k,v) -> tstInsert k (v k)) none $ strictBuild $ do-  lit "quit" 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 "on" Prep-  lit "for" Prep-  lit "of" 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+  "quit" >-< Verb+  "acquire" >-< Verb+  "drop" >-< Verb+  "idiot" >-< Noun+  "first" >-< Ordn 1+  "next" >-< Ordn 1+  "primary" >-< Ordn 1+  "second" >-< Ordn 2+  "third" >-< Ordn 3+  "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+  "on" >-< Prep+  "for" >-< Prep+  "of" >-< Prep+  "enter" >-< Verb+  "list" >-< Verb+  "exits" >-< Fixe+  "inventory" >-< Fixe+  "score" >-< Fixe+  "main" >-< Fixe+  "hand" >-< Fixe+  "off" >-< Fixe+  "chest" >-< Fixe+  "feet" >-< Fixe+  "wrists" >-< Fixe+  "waist" >-< Fixe+  "head" >-< Fixe+  "legs" >-< Fixe+  "back" >-< Fixe+  "hands" >-< Fixe+  "neck" >-< Fixe+  "finger" >-< Fixe+  "left" >-< Fixe+  "right" >-< Fixe+  "equipment" >-< Fixe+  "equip" >-< Verb+  "echo" >-< Verb  replaceAliases :: [String] -> [String] replaceAliases [] = []@@ -148,24 +153,27 @@  react :: Consumer react = Nil #->> noneM-  #|| Verb "quit" #->> throwError QuitError+  #|| Verb "quit" :-: Nil #->> throwError QuitError+  #|| Verb "echo" :-: Remaining :-: Nil #- unwords :-: Nil &-> (\s -> mprintLn =<< expand ("$user -> $user: \"%{V2;"++s++"}\""))   #|| Verb "commit" :-: Noun "suicide" :-: Nil #->> (do     eprintLn (Vivid Red) "You stab yourself in the chest, finally dying."     throwError QuitError)   #|| Verb "enter" :-: AvailableObject :-: Nil #-> objectTriggerOnEnterOf-  #|| Verb "ascend" #->> changeRoom Up-  #|| Verb "descend" #->> changeRoom Down-  #|| Verb "go" :-: CatchFixe :-: Nil #-> (\d -> changeRoom $ case d of-                                       "north" -> North-                                       "south" -> South-                                       "east" -> East-                                       "west" -> West-                                       "northeast" -> NorthEast-                                       "northwest" -> NorthWest-                                       "southeast" -> SouthEast-                                       "southwest" -> SouthWest-                                       "up" -> Up-                                       "down" -> Down)+  #|| Verb "ascend" :-: Nil #->> changeRoom Up+  #|| Verb "descend" :-: Nil #->> changeRoom Down+  #|| Verb "go" :-: CatchFixe :-: Nil+              #- (\case+                    "north" -> Right North+                    "south" -> Right South+                    "east" -> Right East+                    "west" -> Right West+                    "northeast" -> Right NorthEast+                    "northwest" -> Right NorthWest+                    "southeast" -> Right SouthEast+                    "southwest" -> Right SouthWest+                    "up" -> Right Up+                    "down" -> Right Down+                    s -> Left $ Unint 0 ("\""++s++"\" is not a direction.")) :-: Nil &?-> changeRoom   #|| Verb "list" :-: Fixe "exits" :-: Nil #->> (do                                            s <- getDungeonState                                            let (Just r) = currentRoomOf s@@ -187,28 +195,28 @@                                             mprintLn $ printf "Stamina:      %5i   Armor:   %5i" sta arm                                             mprintLn $ printf "Attack power: %5i   Haste:   %5i" akp hst                                             mprintLn $ printf "Global cooldown:  %5i" gcd)-  #|| Verb "equip" :-: CarriedObject :-: Nil #-> (equipObject >=> \o -> case o of+  #|| Verb "equip" :-: CarriedObject :-: Nil #-> (equipObject >=> \case                                              Nothing -> noneM                                              Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s})-  #|| Verb "equip" :-: CarriedObject :-: Prep "at" :-: Remaining :-: Nil #-> (\(o,ps) -> do-                                                                                 k <- case ps of-                                                                                   ["main","hand"] -> return MainHand-                                                                                   ["off","hand"] -> return OffHand-                                                                                   ["chest"] -> return Chest-                                                                                   ["feet"] -> return Feet-                                                                                   ["wrists"] -> return Wrists-                                                                                   ["waist"] -> return Waist-                                                                                   ["head"] -> return Head-                                                                                   ["legs"] -> return Legs-                                                                                   ["back"] -> return Back-                                                                                   ["hands"] -> return Hands-                                                                                   ["neck"] -> return Neck-                                                                                   ["right","finger"] -> return Finger1-                                                                                   ["left","finger"] -> return Finger2-                                                                                   _ -> throwError UnintellegibleError-                                                                                 equipObjectAt k o >>= \o -> case o of-                                                                                   Nothing -> noneM-                                                                                   Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s})+  #|| Verb "equip" :-: CarriedObject :-: Prep "at" :-: Remaining :-: Nil #-+                Pass :-: (\case+                           ["main","hand"] -> Right MainHand+                           ["off","hand"] -> Right OffHand+                           ["chest"] -> Right Chest+                           ["feet"] -> Right Feet+                           ["wrists"] -> Right Wrists+                           ["waist"] -> Right Waist+                           ["head"] -> Right Head+                           ["legs"] -> Right Legs+                           ["back"] -> Right Back+                           ["hands"] -> Right Hands+                           ["neck"] -> Right Neck+                           ["right","finger"] -> Right Finger1+                           ["left","finger"] -> Right Finger2+                           ss -> Left $ Unint 0 ("\""++unwords ss++"\" is not a valid equipment slot")) :-: Nil+                 &?-> (\(o,k) -> equipObjectAt k o >>= \case+                                                        Nothing -> noneM+                                                        Just o -> modifyPlayerState $ \s -> s{playerInventoryOf=avlInsert o $ playerInventoryOf s})   #|| Verb "list" :-: Fixe "equipment" :-: Nil #->> (     let pr (Just k) s = mprintLn $ printf "%-15s%s" s $ unpack $ objectTitleOf k         pr Nothing _ = noneM@@ -227,5 +235,5 @@       lit Neck "Neck:"       lit Finger1 "Right finger:"       lit Finger2 "Left finger:")-  #|| Verb "acquire" :-: SeenObject :-: Nil #-> acquireObject . objectIdOf-  #|| Verb "drop" :-: CarriedObject :-: Nil #-> dropObject . objectIdOf+  #|| Verb "acquire" :-: SeenObject :-: Nil #- objectIdOf :-: Nil &-> acquireObject +? Acquirable :-: Nil+  #|| Verb "drop" :-: CarriedObject :-: Nil #- objectIdOf :-: Nil &-> dropObject

@@ -0,0 +1,75 @@+{-# LANGUAGE ExistentialQuantification, RankNTypes, FlexibleContexts, ScopedTypeVariables #-}++{-+  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 operators for composing masked consumers+module Game.Antisplice.MaskedSkills where++import Data.Monoid+import Game.Antisplice.Call+import Game.Antisplice.Monad.Dungeon+import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.Hetero++-- | A special consumer whose conditions and actions rely on evaluation result masks+data MaskedConsumer r = MasCon [PredMaskCond r] [PostMaskHandler r]++-- | A special handler that relies on an evaluation result post-processing mask+data PostMaskHandler r = forall po pr pt. (PostMask po r pr,Tuplify pr pt) => PMHandler po (pt -> Handler)++-- | A special condition that relies on an evaluation result predicate mask+data PredMaskCond r = forall p. PredMask p r => PMCond p++instance Monoid (MaskedConsumer r) where+  mempty = MasCon [] []+  (MasCon c1 h1) `mappend` (MasCon c2 h2) = MasCon (c1 ++ c2) (h1 ++ h2)++instance None (MaskedConsumer r) where+  none = mempty++infix 8 &->+-- | Composes a masked consumer from an evaluation result post-processing mask and a handler that relies on its result+(&->) :: (PostMask po r pr, Tuplify pr pt) => po -> (pt -> Handler) -> MaskedConsumer r+po &-> h = MasCon [] [PMHandler po h]++infix 8 -&?->+-- | Composes a masked consumer from an evaluation result combi mask and a handler that relies on its possible result. Takes a third parameter for the correct type. In most cases you'll want '&?->' instead.+(-&?->) :: (CombiMask cm r pm pom, PredMask pm r, PostMask pom r por, Tuplify por pot) => cm -> (pot -> Handler) -> r -> MaskedConsumer r+c -&?-> h = \r -> MasCon [PMCond $ ctopred c r] [PMHandler (ctopost c r) h]++infix 8 &?->+-- | Composes a masked consumer from an evaluation result combi mask and a handler that relies on its possible result.+(&?->) :: (CombiMask cm r pm pom, PredMask pm r, PostMask pom r por, Tuplify por pot) => cm -> (pot -> Handler) -> MaskedConsumer r+c &?-> h = (c -&?-> h) undefined++{-handle :: (Tuplify pr pt, PostMask (a -> a) r pr) => (pt -> Handler) -> MaskedConsumer r+handle h = id &-> h-}++infixl 7 +?+-- | Adds an evaluation result predicate mask to a masked consumer.+(+?) :: PredMask p r => MaskedConsumer r -> p -> MaskedConsumer r+mc +? p = mc <> MasCon [PMCond p] []++infixl 7 +&+-- | Concatenates two masked consumers.+(+&) :: MaskedConsumer r -> MaskedConsumer r -> MaskedConsumer r+m1 +& m2 = m1 <> m2

@@ -30,6 +30,8 @@     HandlerBox (..),     Prerequisite,     PrerequisiteBox (..),+    Predicate,+    PredicateBox (..),     -- * Utilities     IsText (..),     Direction (..),@@ -93,6 +95,7 @@ import Game.Antisplice.Utils.Counter import Game.Antisplice.Utils.None import Game.Antisplice.Utils.Focus+import Game.Antisplice.Utils.Hetero import Game.Antisplice.Monad.Vocab import Control.Arrow import Control.Monad.Error@@ -115,11 +118,17 @@ type Prerequisite = ChattyDungeonM Bool -- | A boxed 'Prerequisite' to avoid ImpredicativeTypes newtype PrerequisiteBox = Prerequisite { runPrerequisite :: Prerequisite }+-- | The common type for all predicates.+type Predicate = ChattyDungeonM (Maybe ReError)+-- | A boxed 'Predicate' to avoid ImpredicativeTypes+newtype PredicateBox = Predicate { runPredicate :: ChattyDungeonM (Maybe ReError) }  instance None HandlerBox where   none = Handler $ return () instance None PrerequisiteBox where   none = Prerequisite $ return True+instance None PredicateBox where+  none = Predicate $ return Nothing  -- | Key for item or player statistics data StatKey = Strength@@ -132,9 +141,16 @@              | CooldownDuration              | AttackPower              deriving (Ord,Eq)++instance Tuplify StatKey StatKey where+  tuplify = id+ -- | Key for equipment slot data EquipKey = MainHand | OffHand | Chest | Feet | Wrists | Waist | Head | Legs | Back | Hands | Neck | Finger1 | Finger2 deriving (Ord,Eq) +instance Tuplify EquipKey EquipKey where+  tuplify = id+ instance Indexable EquipKey EquipKey EquipKey where   type ValueOf EquipKey = EquipKey   type IndexOf EquipKey = EquipKey@@ -152,6 +168,9 @@     roomTriggerOnAnnounceOf :: Handler   } +instance Tuplify RoomState RoomState where+  tuplify = id+ -- | The room monad. Used to create or modify room data. newtype RoomT m a = Room { runRoomT :: RoomState -> m (a,RoomState) } @@ -196,11 +215,21 @@     factionTriggerOnFriendlyOf :: Handler,     factionTriggerOnExaltedOf :: Handler   }++instance Tuplify Faction Faction where+  tuplify = id+                data Attitude = Hostile | Friendly | Exalted deriving (Eq,Ord) +instance Tuplify Attitude Attitude where+  tuplify = id+ -- | Relation between the player and the object. data Relation = Near | Carried | Worn deriving (Ord,Eq) +instance Tuplify Relation Relation where+  tuplify = id+ -- | Object features. data Feature = Damagable  -- ^ May take damage.              | Acquirable -- ^ May be acquired.@@ -217,6 +246,9 @@              | Described (Atom String) -- ^ Implies an additional particle for the room description              deriving (Ord,Eq) +instance Tuplify Feature Feature where+  tuplify = id+ instance Indexable Feature Feature Feature where   type IndexOf Feature = Feature   type ValueOf Feature = Feature@@ -226,9 +258,15 @@ -- | Phantom ID type for objects. data ObjectId = ObjectId Int | FalseObject deriving (Eq,Ord) +instance Tuplify ObjectId ObjectId where+  tuplify = id+ -- | Phantom ID type for object kinds. data KindId = KindId Int | FalseKind deriving (Eq,Ord) +instance Tuplify KindId KindId where+  tuplify = id+ instance None ObjectId where   none = FalseObject instance None KindId where@@ -278,6 +316,9 @@     objectTriggerOnDrinkOf :: Handler   } deriving Typeable +instance Tuplify ObjectState ObjectState where+  tuplify = id+ instance Indexable ObjectState ObjectId ObjectState where   type IndexOf ObjectState = ObjectId   type ValueOf ObjectState = ObjectState@@ -312,7 +353,7 @@ type Invokable = [String] -> HandlerBox  -- | Some prerequisite that may be invoked by the user-type InvokableP = [String] -> PrerequisiteBox+type InvokableP = [String] -> PredicateBox  -- | A player stereotype data PlayerStereo = PlayerStereo {@@ -323,6 +364,10 @@  -- | Phantom ID type for players newtype PlayerId = PlayerId Int deriving (Eq,Ord)++instance Tuplify PlayerId PlayerId where+  tuplify = id+ -- | Phantom ID type for cooldowns data CooldownId = GlobalCooldown | CooldownId Int deriving (Eq,Ord) -- | Phantom ID type for currencies@@ -432,6 +477,9 @@    -- | 10 directions to go data Direction = North | NorthEast | East | SouthEast | South | SouthWest | West | NorthWest | Up | Down deriving (Eq,Show)++instance Tuplify Direction Direction where+  tuplify = id  -- | State type for DungeonT data DungeonState = DungeonState {

@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses #-}+ {-   This module is part of Antisplice.   Copyleft (c) 2014 Marvin Cohrs@@ -28,6 +30,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Game.Antisplice.Utils.TST+import Game.Antisplice.Utils.Hetero  -- | Algebraic type for primitive and complex tokens. data Token = Unintellegible String@@ -40,7 +43,24 @@            | Skilln String            | Nounc [String] (Maybe Int) String              -- ^ Complex noun, with attributes and maybe ordinal index.-             deriving (Eq,Show)+             deriving Eq++instance Show Token where+  show (Unintellegible s) = "[?] " ++ s+  show (Verb s) = "[verb] " ++ s+  show (Prep s) = "[prep] " ++ s+  show (Noun s) = "[noun] " ++ s+  show (Adj s) = "[adj] " ++ s+  show (Ordn i s) = "[#" ++ show i ++ "] " ++ s+  show (Fixe s) = "[fix] " ++ s+  show (Skilln s) = "[skill] " ++ s+  show (Nounc [] Nothing s) = "[noun+] "++s+  show (Nounc as Nothing s) = "[noun+] "++unwords as++" "++s+  show (Nounc [] (Just i) s) = "[noun #"++show i++"] "++s+  show (Nounc as (Just i) s) = "[noun #"++show i++"] "++unwords as++" "++s++instance Tuplify Token Token where+  tuplify = id  -- | The vocab monad. Carries the currently noun vocab as its state. newtype VocabT m a = Vocab { runVocabT :: TST Token -> m (a,TST Token) }

@@ -24,6 +24,8 @@ -- | Some utility functions for constructing paths between rooms. module Game.Antisplice.Paths where +import Control.Monad+import Data.Maybe import Data.Monoid import Game.Antisplice.Action import Game.Antisplice.Monad.Dungeon@@ -97,10 +99,10 @@   toGate g = Gate g  instance Gatifiable ActionBefore where-  toGate (ActionBefore g) = Gate $ PathState (askAction g) (runAction g) noneM+  toGate (ActionBefore g) = Gate $ PathState (liftM isNothing $ askAction g) (runAction g) noneM  instance Gatifiable ActionAfter where-  toGate (ActionAfter g) = Gate $ PathState (askAction g) noneM (runAction g)+  toGate (ActionAfter g) = Gate $ PathState (liftM isNothing $ askAction g) noneM (runAction g)  gatedPath :: (Gatifiable g,MonadDungeon m) => NodeId -> NodeId -> Direction -> g -> m () gatedPath f t d g = establishWay f t d (runGate $ toGate g)

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances, RecordWildCards #-}+{-# LANGUAGE RankNTypes, FlexibleContexts, FlexibleInstances, RecordWildCards, LambdaCase #-}  {-   This module is part of Antisplice.@@ -37,6 +37,7 @@   recipe,   validConsumer,   validCondition,+  (#-),   (#->),   (#->>),   -- * Sample consumers@@ -54,6 +55,7 @@ import Control.Monad.Identity import Control.Monad.Error.Class import Data.Monoid+import Data.Maybe import Game.Antisplice.Action import Game.Antisplice.Call import Game.Antisplice.Errors@@ -64,33 +66,54 @@ import Game.Antisplice.Utils.None import Game.Antisplice.Utils.Counter import Game.Antisplice.Utils.Atoms+import Game.Antisplice.Utils.Hetero+import Game.Antisplice.MaskedSkills  -- | A wrapper type for skill execution preconditions. newtype Condition = Condition { runCondition' :: InvokableP }-runCondition :: Condition -> [String] -> ChattyDungeonM Bool-runCondition c ps = runPrerequisite $ runCondition' c ps+runCondition :: Condition -> [String] -> ChattyDungeonM (Maybe ReError)+runCondition c ps = runPredicate $ runCondition' c ps  instance Monoid Condition where-  mempty = Condition $ \_ -> Prerequisite $ return True-  a `mappend` b = Condition $ \ps -> Prerequisite $ do+  mempty = Condition $ \_ -> Predicate $ return Nothing+  a `mappend` b = Condition $ \ps -> Predicate $ do     a' <- runCondition a ps     b' <- runCondition b ps-    return (a' && b')+    return $ case a' of+      Nothing ->  b'+      Just (Unint i s) -> case b' of+        Nothing -> Just (Unint i s)+        Just (Unint j t)+          | i >= j -> Just (Unint i s)+          | otherwise -> Just (Unint j s)+        e -> e+      e -> e  instance IsAction Condition where-  p #&& q = Condition $ \ps -> Prerequisite $ do-    a <- runCondition p ps-    if a then runCondition q ps-         else return False-  p #|| q = Condition $ \ps -> Prerequisite $ do-    a <- runCondition p ps-    if a then return True-         else runCondition q ps+  p #&& q = Condition $ \ps -> Predicate $ do+    runCondition p ps >>= \case+      Nothing -> runCondition q ps+      Just (Unint i s) -> runCondition q ps >>= \case+        Nothing -> return $ Just $ Unint i s+        Just (Unint j _) | i >= j -> return $ Just $ Unint i s+        e -> return e+      e -> return e+  p #|| q = Condition $ \ps -> Predicate $ do+    runCondition p ps >>= \case+      Nothing -> return Nothing+      Just (Unint i s) -> runCondition q ps >>= \case+        Just (Unint j _) | i >= j -> return $ Just $ Unint i s+        e -> return e+      Just (Uncon s) -> return $ Just (Uncon s)+      e -> runCondition q ps   p !&& q = p <> q-  p !|| q = Condition $ \ps -> Prerequisite $ do+  p !|| q = Condition $ \ps -> Predicate $ do     a <- runCondition p ps     b <- runCondition q ps-    return (a || b)+    return $ case a of+      Nothing -> Nothing+      Just (Unint i s) | Just (Unint j _) <- b, i >= j -> Just $ Unint i s+      _ -> b                instance None Condition where   none = mempty@@ -119,34 +142,24 @@  instance IsAction Consumer where   (Consumer c1 a1) #&& (Consumer c2 a2) = Consumer (c1 #&& c2) (\ps -> Handler (runHandler (a1 ps) >> runHandler (a2 ps)))-  (Consumer c1 a1) #|| (Consumer c2 a2) = Consumer (c1 #|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> if q then runHandler (a1 ps) else runHandler (a2 ps)))+  (Consumer c1 a1) #|| (Consumer c2 a2) = Consumer (c1 #|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> if isNothing q then runHandler (a1 ps) else runHandler (a2 ps)))   p !&& q = p <> q-  (Consumer c1 a1) !|| (Consumer c2 a2) = Consumer (c1 !|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> runCondition c2 ps >> if q then runHandler (a1 ps) else runHandler (a2 ps)))+  (Consumer c1 a1) !|| (Consumer c2 a2) = Consumer (c1 !|| c2) (\ps -> Handler (runCondition c1 ps >>= \q -> runCondition c2 ps >> if isNothing q then runHandler (a1 ps) else runHandler (a2 ps)))  instance None Consumer where   none = mempty  -- | Focus direct object focusDirectC :: Consumer-{-focusDirectC = bareAction (\p -> case p of-                                   SkillParam Getters{..} (Just o) _ _ _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o-                                   _ -> throwError UnintellegibleError)-}-focusDirectC = validConsumer SeenObject $ \o -> focusOpponent $ objectIdOf o+focusDirectC = SeenObject :-: Nil #-> \o -> focusOpponent $ objectIdOf o  -- | Optionally ocus direct object (obligatory if none is focused yet) optionallyFocusDirectC :: Consumer-{-optionallyFocusDirectC = bareAction (\p -> case p of-                                        SkillParam Getters{..} (Just o) _ _ _ _ -> focusOpponent =<< return.objectIdOf =<< dispget getSeenObject o-                                        SkillParam _ Nothing _ _ _ _ -> do-                                          o <- liftM playerOpponentOf getPlayerState-                                          case o of-                                            FalseObject -> throwError UnintellegibleError-                                            _ -> noneM)-}-optionallyFocusDirectC = focusDirectC #|| validConsumer Nil (\_ ->  do-                                                                o <- liftM playerOpponentOf getPlayerState-                                                                case o of-                                                                  FalseObject -> throwError UnintellegibleError-                                                                  _ -> noneM)+optionallyFocusDirectC = focusDirectC #|| Nil #->> (do+                                                      o <- liftM playerOpponentOf getPlayerState+                                                      case o of+                                                         FalseObject -> throwError UnintellegibleError+                                                         _ -> noneM)  -- | Typeclass for everything that may act as a consumer. class ToConsumer c where@@ -167,15 +180,15 @@ instance ToConsumer Condition where   toConsumer c = Consumer c (\_ -> Handler $ return none) -instance ToConsumer PrerequisiteBox where+instance ToConsumer PredicateBox where   toConsumer p = Consumer (Condition $ \_ -> p) (\_ -> Handler $ return none)  instance ToConsumer Action where-  toConsumer a = Consumer (Condition $ \_ -> Prerequisite $ askAction a) (\_ -> Handler $ runAction a)+  toConsumer a = Consumer (Condition $ \_ -> Predicate $ askAction a) (\_ -> Handler $ runAction a)  -- | Typeclass for everything that may be extended by consumers using !+ class Extensible e where-  infixl 5 !++  infixl 4 !+   -- | Add a consumer to the skill.   (!+) :: ToConsumer c => e -> c -> e @@ -190,21 +203,21 @@ instance Extensible Consumer where   s !+ c = s <> toConsumer c -infixl 5 >!++infixl 4 >!+ -- | Add a consumer to the monadic extensible (>!+) :: (ToConsumer c,Monad m,Extensible e) => m e -> c -> m e m >!+ c = do   s <- m   return (s !+ c) -infixl 5 !+>+infixl 4 !+> -- | Add a monadic consumer to the extensible (!+>) :: (ToConsumer c,Monad m,Extensible e) => e -> m c -> m e s !+> m = do   c <- m   return (s !+ c) -infixl 5 >!+>+infixl 4 >!+> -- | Add a monadic consumer to the monadic extensible (>!+>) :: (ToConsumer c,Monad m,Extensible e) => m e -> m c -> m e ms >!+> mc = do@@ -213,28 +226,47 @@   return (s !+ c)  -- | Build a consumer using new-style input validation-validConsumer :: (Append r Nil r,CallMask m r,Tuplify r t) => m -> (t -> Handler) -> Consumer-validConsumer m h = Consumer-  (Condition $ \ps -> Prerequisite $ tryMask m ps)+validConsumer :: (Append m (Cons EnsureLineEnd Nil) s,Append r Nil r,CallMask s r,Tuplify r t) => m -> (t -> Handler) -> Consumer+validConsumer m h =+  let eitherToMaybe (Right x) = Nothing+      eitherToMaybe (Left e) = Just e+  in Consumer+  (Condition $ \ps -> Predicate $ liftM eitherToMaybe $ tryMask m ps)   (\ps -> Handler $ do       t <- processMask m ps       h t) -infixr 7 #->+infixr 6 #-+-- | Map a masked consumer to a call mask+(#-) :: (Append m (Cons EnsureLineEnd Nil) s,Append r Nil r, CallMask s r) => m -> MaskedConsumer r -> Consumer+m #- (MasCon ps hs) = Consumer+  (Condition $ \ss -> Predicate $ do+      tryMask m ss >>= \case+        Right r -> liftM andl $ mapM (\(PMCond c) -> usepmask c r) ps+        Left e -> return $ Just e)+  (\ps -> Handler $ do+      tryMask m ps >>= \case+        Right r -> mapM_ (\(PMHandler po h) -> h =<< liftM tuplify (usepost po r)) hs+        Left e -> throwError $ ReError e)++infixr 6 #-> -- | Infix version of validConsumer-(#->) :: (Append r Nil r, CallMask m r, Tuplify r t) => m -> (t -> Handler) -> Consumer+(#->) :: (Append m (Cons EnsureLineEnd Nil) s,Append r Nil r, CallMask s r, Tuplify r t) => m -> (t -> Handler) -> Consumer (#->) = validConsumer -infixr 7 #->>+infixr 6 #->> -- | Infix version of validConsumer, swallowing the empty handler parameter-(#->>) :: CallMask m Nil => m -> Handler -> Consumer+(#->>) :: (Append m (Cons EnsureLineEnd Nil) s,CallMask s Nil) => m -> Handler -> Consumer m #->> h = m #-> const h  -- | Build a condition using new-style input validation-validCondition :: (Append r Nil r, CallMask m r, Tuplify r t) => m -> (t -> Prerequisite) -> Condition+validCondition :: (Append m (Cons EnsureLineEnd Nil) s,Append r Nil r, CallMask s r, Tuplify r t) => m -> (t -> Predicate) -> Condition validCondition m p =-  Condition (\ps -> Prerequisite $ tryMask m ps) <>-  Condition (\ps -> Prerequisite $ do t <- processMask m ps; p t)+  let eitherToMaybe (Right x) = Nothing+      eitherToMaybe (Left e) = Just e+  in+    Condition (\ps -> Predicate $ liftM eitherToMaybe $ tryMask m ps) <>+    Condition (\ps -> Predicate $ do t <- processMask m ps; p t)  -- | Dispatch the remaining part of the line as a recipe call callRecipe :: RecipeMethod -> Consumer@@ -280,5 +312,6 @@   where runConsumer' :: Consumer -> Invokable         runConsumer' (Consumer c a) = \ps -> Handler $ do           b <- runCondition c ps-          unless b $ throwError CantCastThatNowError-          runHandler $ a ps+          case b of+            Nothing -> runHandler $ a ps+            Just e -> throwError $ ReError e

@@ -58,11 +58,13 @@ import Game.Antisplice.Monad.Dungeon import Game.Antisplice.Monad.Vocab import Game.Antisplice.Rooms+import Game.Antisplice.MaskedSkills import Game.Antisplice.Skills import Game.Antisplice.Stats import Game.Antisplice.Templates import Game.Antisplice.Utils.Atoms import Game.Antisplice.Utils.None+import Game.Antisplice.Utils.Hetero import Text.Chatty.Interactor.Templates import System.IO @@ -168,14 +170,14 @@       AttackPower -> get Strength * 2       CooldownDuration -> (get CooldownDuration ^ 2) `div` (get CooldownDuration + get Haste) - get CooldownDuration       _ -> 0-  mergeSkill $ skill "use" !+ validConsumer AvailableObject objectTriggerOnUseOf+  mergeSkill $ skill "use" !+ AvailableObject :-: Nil #-> objectTriggerOnUseOf  visualStereo :: MonadVocab m => m PlayerStereo visualStereo = liftM snd $ flip runStereoBuilderT none $ do-  mergeSkill $ skill "look" !+-    validConsumer Nil (\_ -> roomTriggerOnLookOf =<< getRoomState) #||-    validConsumer (Prep "at" :-: AvailableObject :-: Nil) objectTriggerOnLookAtOf-  mergeSkill $ skill "read" !+ validConsumer AvailableObject objectTriggerOnReadOf+  mergeSkill (skill "look" !++    Nil #->> (roomTriggerOnLookOf =<< getRoomState)+    #|| Prep "at" :-: AvailableObject :-: Nil #-> objectTriggerOnLookAtOf)+  mergeSkill (skill "read" !+ AvailableObject :-: Nil #-> objectTriggerOnReadOf)  manualStereo :: MonadVocab m => m PlayerStereo manualStereo = liftM snd $ flip runStereoBuilderT none $ do@@ -183,5 +185,5 @@  consumeStereo :: MonadVocab m => m PlayerStereo consumeStereo = liftM snd $ flip runStereoBuilderT none $ do-  mergeSkill $ skill "drink" !+ validConsumer AvailableObject objectTriggerOnDrinkOf-  mergeSkill $ skill "eat" !+ validConsumer AvailableObject objectTriggerOnEatOf+  mergeSkill $ skill "drink" !+ AvailableObject :-: Nil #- Pass &-> objectTriggerOnDrinkOf +? Drinkable :-: Nil+  mergeSkill $ skill "eat" !+ AvailableObject :-: Nil #- Pass &-> objectTriggerOnEatOf +? Eatable :-: Nil

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ImpredicativeTypes #-}+{-# LANGUAGE FlexibleContexts #-}  {-   This module is part of Antisplice.@@ -73,20 +73,23 @@           l' <- expand l           mputh l'           e <- runFailT (act l')+          let erprintLn = eprintLn $ Vivid Red           case e of             Right _ -> return ()-            Left VerbMustFirstError -> mprintLn "Please start with a verb."-            Left UnintellegibleError -> mprintLn "I don't understand that."-            Left CantWalkThereError -> mprintLn "I can't walk there."-            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 CantCastThatNowError -> mprintLn "Sorry, I can't cast that now. Check your health, mana and cooldowns."-            Left WontHitThatError -> mprintLn "I won't hit that."-            Left CantAcquireThatError -> mprintLn "I can't take that."+            Left VerbMustFirstError -> erprintLn "Please start with a verb."+            Left UnintellegibleError -> erprintLn "I don't understand that."+            Left CantWalkThereError -> erprintLn "I can't walk there."+            Left WhichOneError -> erprintLn "Which one do you mean?"+            Left CantSeeOneError -> erprintLn "I can't see one here."+            Left DontCarryOneError -> erprintLn "You don't carry one."+            Left CantEquipThatError -> erprintLn "I can't equip that."+            Left CantEquipThatThereError -> erprintLn "I can't wear that there. You might want to try some other place?"+            Left WhereToEquipError -> erprintLn "Where?"+            Left CantCastThatNowError -> erprintLn "Sorry, I can't cast that now. Check your health, mana and cooldowns."+            Left WontHitThatError -> erprintLn "I won't hit that."+            Left CantAcquireThatError -> erprintLn "I can't take that."+            Left (ReError (Unint i e)) -> erprintLn e+            Left (ReError (Uncon e)) -> erprintLn e             Left e -> throwError e           throwError DoneError         Just Nothing -> liftIO (killThread thr) >> mprintLn "quit" >> throwError QuitError

@@ -25,11 +25,13 @@ module Game.Antisplice.Utils.Fail where  import Control.Monad+import Control.Monad.Identity import Control.Monad.Error.Class import Control.Monad.Trans.Class  -- | The error handling monad. newtype FailT e m a = Fail { runFailT :: m (Either e a) }+type Fail e = FailT e Identity  instance Monad m => Functor (FailT e m) where   fmap f a = Fail $ do

@@ -0,0 +1,91 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, RankNTypes, FlexibleContexts, LambdaCase, ScopedTypeVariables #-}++{-+  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.Utils.Hetero where++infixr 9 :-:+-- | The Cons type for a heterogenous list+data Cons a b = (:-:) a b+-- | The empty list+data Nil = Nil++-- | Typeclass for appending one heterogenous list to another one+class Append a b ab | a b -> ab where+  tappend :: a -> b -> ab+instance Append Nil b b where+  tappend Nil b = b+instance Append b c bc => Append (Cons a b) c (Cons a bc) where+  tappend (a :-: b) c = a :-: tappend b c++-- | Typeclass for wrapping a heterogenous list into a Maybe on demand+class IntoMaybe a ar  where+  tjust :: a -> ar+  tnothing :: a -> ar+instance IntoMaybe Nil Nil where+  tjust Nil = Nil+  tnothing a = Nil+instance IntoMaybe (Cons a as) (Cons (Maybe (Cons a as)) Nil) where+  tjust a = Just a :-: Nil+  tnothing a = Nothing :-: Nil++-- | Typeclass for everything that may be converted to a tuple+class Tuplify l t | l -> t where+  tuplify :: l -> t++instance Tuplify Nil () where+  tuplify Nil = ()++instance Tuplify a ar => Tuplify (Cons a Nil) ar where+  tuplify (a :-: Nil) = tuplify a++instance (Tuplify a ar, Tuplify b br) => Tuplify (Cons a (Cons b Nil)) (ar,br) where+  tuplify (a :-: b :-: Nil) = (tuplify a, tuplify b)++instance (Tuplify a ar, Tuplify b br, Tuplify c cr) => Tuplify (Cons a (Cons b (Cons c Nil))) (ar,br,cr) where+  tuplify (a :-: b :-: c :-: Nil) = (tuplify a, tuplify b, tuplify c)++instance (Tuplify a ar, Tuplify b br, Tuplify c cr, Tuplify d dr) => Tuplify (Cons a (Cons b (Cons c (Cons d Nil)))) (ar,br,cr,dr) where+  tuplify (a :-: b :-: c :-: d :-: Nil) = (tuplify a, tuplify b,tuplify c,tuplify d)++instance (Tuplify a ar, Tuplify b br, Tuplify c cr, Tuplify d dr, Tuplify e er) => Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e Nil))))) (ar,br,cr,dr,er) where+  tuplify (a :-: b :-: c :-: d :-: e :-: Nil) = (tuplify a,tuplify b,tuplify c,tuplify d,tuplify e)++instance (Tuplify a ar, Tuplify b br, Tuplify c cr, Tuplify d dr, Tuplify e er, Tuplify f fr) => Tuplify (Cons a (Cons b (Cons c (Cons d (Cons e (Cons f Nil)))))) (ar,br,cr,dr,er,fr) where+  tuplify (a :-: b :-: c :-: d :-: e :-: f :-: Nil) = (tuplify a,tuplify b,tuplify c,tuplify d,tuplify e,tuplify f)++instance Tuplify Int Int where+  tuplify = id++instance Tuplify Char Char where+  tuplify = id++instance Tuplify a ar => Tuplify [a] [ar] where+  tuplify = map tuplify++instance Tuplify a ar => Tuplify (Maybe a) (Maybe ar) where+  tuplify = fmap tuplify++data Titled a = Titled String a++instance Tuplify a ar => Tuplify (Titled a) ar where+  tuplify (Titled _ a) = tuplify a

@@ -55,3 +55,6 @@  lit :: ListBuilder l (a,b) => a -> b -> l () lit a b = li (a,b)++(>-<) :: ListBuilder l (a,b) => a -> b -> l ()+(>-<) = lit