Call.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, 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/>.
-}

-- | 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
  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 :-:
-- | 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 use 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)

-- | Ensures that the end of the input is reached
data EnsureLineEnd = EnsureLineEnd
-- | Catches the string of a token matching the given token type
data CatchByType = CatchVerb | CatchPrep | CatchNoun | CatchAdj | CatchOrdn Int | CatchFixe | CatchSkilln | CatchUnint | CatchAny
-- | Catches an entire token
data CatchToken = CatchToken | CatchNounc
-- | Catches the number of an Ordn token
data CatchOrd = CatchOrd
-- | Catches the remaining part of the line
data Remaining = Remaining
-- | Catches an available, carried or seen object
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

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

-- | Use a mask on a list of tokens
processMask' :: CallMask m r => m -> [(String,Token)] -> DungeonM (Maybe 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 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

-- | 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
tryMask m s = do
  ss <- mapM lookupVocab s
  mr <- processMask' (m :-: EnsureLineEnd :-: Nil) $ zip s ss
  return $ isJust mr

-- | Token is adjective?
isAdj (Adj _) = True
isAdj _ = False

-- | Token is noun?
isNoun (Noun _) = True
isNoun _ = False

-- | Merge nouns and adjectives to a complex noun
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 !! (idx-1))
                                          
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