Allure-0.4.1: src/Grammar.hs

module Grammar where

import Data.Char
import Data.Set as S
import Data.List as L
import qualified Data.IntMap as IM

import Item
import Movable
import MovableKind
import State
import ItemKind
import Effect


suffixS :: String -> String
suffixS word = case last word of
                'y' -> init word ++ "ies"
                's' -> word ++ "es"
                'x' -> word ++ "es"
                _   -> word ++ "s"

capitalize :: String -> String
capitalize [] = []
capitalize (c : cs) = toUpper c : cs

-- | How to refer to a movable in object position of a sentence.
objectMovable :: MovableKind -> String
objectMovable mk = nname mk

-- | How to refer to a movable in subject position of a sentence.
subjectMovable :: MovableKind -> String
subjectMovable x = capitalize $ objectMovable x

verbMovable :: MovableKind -> String -> String
verbMovable mk v = if nname mk == "you" then v else suffixS v

-- | Sentences such like "The dog barks".
subjectMovableVerb :: MovableKind -> String -> String
subjectMovableVerb x v = subjectMovable x ++ " " ++ verbMovable x v

compoundVerbMovable :: MovableKind -> String -> String -> String
compoundVerbMovable m v p = verbMovable m v ++ " " ++ p

subjectVerbIObject :: State -> Movable -> String -> Item -> String -> String
subjectVerbIObject state m v o add =
  subjectMovable (mkind m) ++ " " ++
  verbMovable (mkind m) v ++ " " ++
  objectItem state o ++ add ++ "."

subjectVerbMObject :: Movable -> String -> Movable -> String -> String
subjectVerbMObject m v o add =
  subjectMovable (mkind m) ++ " " ++
  verbMovable (mkind m) v ++ " " ++
  objectMovable (mkind o) ++ add ++ "."

subjCompoundVerbIObj :: State -> Movable -> String -> String ->
                        Item -> String -> String
subjCompoundVerbIObj state m v p o add =
  subjectMovable (mkind m) ++ " " ++
  compoundVerbMovable (mkind m) v p ++ " " ++
  objectItem state o ++ add ++ "."

makeObject :: Int -> (String -> String) -> String -> String
makeObject 1 adj obj = let b = adj obj
                       in  case b of
                             (c:_) | c `elem` "aeio" -> "an " ++ b
                             _                       -> "a " ++ b
makeObject n adj obj = show n ++ " " ++ adj (suffixS obj)

objectItem :: State -> Item -> String
objectItem state o =
  let ik = ikind o
      kind = ItemKind.getIK ik
      identified = L.length (jflavour kind) == 1 ||
                   ik `S.member` sdiscoveries state
      addSpace s = if s == "" then "" else " " ++ s
      eff = effectToName (jeffect kind)
      pwr = if ipower o == 0 then "" else "(+" ++ show (ipower o) ++ ")"
      adj name = if identified
                 then name ++ addSpace eff ++ addSpace pwr
                 else let flavour = getFlavour (sassocs state) ik
                      in  flavourToName flavour ++ " " ++ name
  in  makeObject (icount o) adj (jname kind)