module Game.Antisplice.Call (
Cons (..),
Nil (..),
Append (..),
Tuplify (..),
processMask,
tryMask,
CallMask (..),
EnsureLineEnd (..),
CatchByType (..),
CatchToken (..),
CatchOrd (..),
Remaining (..),
CatchObj (..),
) where
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Error.Class
import Data.Maybe
import Game.Antisplice.Errors
import Game.Antisplice.Monad.Dungeon
import Game.Antisplice.Monad.Vocab
import Game.Antisplice.Utils.AVL
infixr 8 :-:
data Cons a b = (:-:) a b
data Nil = Nil
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
class CallMask cm l | cm -> l where
usemask :: (MonadRoom m,MonadPlayer m) => cm -> StateT [(String,Token)] m (Maybe l)
data EnsureLineEnd = EnsureLineEnd
data CatchByType = CatchVerb | CatchPrep | CatchNoun | CatchAdj | CatchOrdn Int | CatchFixe | CatchSkilln | CatchUnint | CatchAny
data CatchToken = CatchToken | CatchNounc
data CatchOrd = CatchOrd
data Remaining = Remaining
data CatchObj = AvailableObject | SeenObject | CarriedObject
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
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
instance CallMask EnsureLineEnd Nil where
usemask EnsureLineEnd = do
s <- get
return $ if null s then Just Nil else Nothing
instance CallMask CatchByType (Cons String Nil) where
usemask ct = do
ss <- get
if null ss then return Nothing
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
instance CallMask CatchOrd (Cons Int Nil) where
usemask CatchOrd = do
ss <- get
if null ss then return Nothing
else let (s:_) = ss in do
modify tail
case snd s of
Ordn i _ -> return $ Just (i :-: Nil)
_ -> return Nothing
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))
usemask CatchNounc = do
ss <- get
case mergeNoun ss of
Nothing -> return Nothing
Just (t,xs) -> do put xs; return $ Just (t :-: Nil)
instance CallMask CatchObj (Cons ObjectState Nil) where
usemask k = do
ss <- get
as <- lift $ case k of
AvailableObject -> availableObjects
SeenObject -> seenObjects
CarriedObject -> carriedObjects
case mergeNoun ss of
Nothing -> return Nothing
Just (t,xs) -> do
put xs
case getObject' as t of
Found x -> return $ Just (x :-: Nil)
_ -> return Nothing
instance CallMask Remaining (Cons [String] Nil) where
usemask Remaining = do
ss <- get
put []
return $ Just (map fst ss :-: Nil)
instance CallMask Nil Nil where
usemask Nil = return $ Just Nil
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
l2 <- usemask xs
case l2 of
Nothing -> return Nothing
Just l2 -> return $ Just $ tappend l1 l2
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
processMask' :: CallMask m r => m -> [(String,Token)] -> DungeonM (Maybe r)
processMask' m s = evalStateT (usemask m) s
processMask :: (CallMask m 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
case mr of
Nothing -> throwError UnintellegibleError
Just r -> return $ tuplify r
tryMask :: (Append r Nil r, CallMask m r) => m -> [String] -> DungeonM Bool
tryMask m s = do
ss <- mapM lookupVocab s
mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss
return $ isJust mr
isAdj (Adj _) = True
isAdj _ = False
isNoun (Noun _) = True
isNoun _ = False
mergeNoun :: [(String,Token)] -> Maybe (Token,[(String,Token)])
mergeNoun [] = Nothing
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)
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)
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
getObject' :: [ObjectState] -> Token -> GetterResponse
getObject' os (Nounc as i n) =
let ns1 = filter (elem n . objectNamesOf) os
ns2 = foldr (\a ns -> filter (elem a . objectAttributesOf) ns) ns1 as
in case ns2 of
[] -> NoneFound
xs -> case i of
Nothing -> case xs of
[x] -> Found x
_ -> TooMany
Just idx -> if idx > length xs then NoneFound
else Found (xs !! (idx1))
availableObjects :: (MonadRoom m,MonadPlayer m) => m [ObjectState]
availableObjects = do
rs <- getRoomState
ps <- getPlayerState
return (avlInorder (roomObjectsOf rs) ++ avlInorder (playerInventoryOf ps))
carriedObjects :: MonadPlayer m => m [ObjectState]
carriedObjects = liftM (avlInorder.playerInventoryOf) getPlayerState
seenObjects :: MonadRoom m => m [ObjectState]
seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState