{-# LANGUAGE FlexibleContexts, RankNTypes #-}

{-
  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 all methods for language intellection.
module Game.Antisplice.Lang (act,defVocab) where

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
import Game.Antisplice.Monad.Vocab
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.Arrow
import Control.Monad.Error
import Text.Printf
import Data.Text (unpack)
import Data.Maybe
import Data.Char

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"

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 "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 [] = []
replaceAliases (s:ss) = words (aliasOf s) ++ replaceAliases ss
  where aliasOf x = case filter ((==x).fst) aliases of
          [] -> x
          (a:_) -> snd a

isIntellegible :: Token -> Bool
isIntellegible (Unintellegible _) = False
isIntellegible _ = True

isNoun :: Token -> Bool
isNoun (Noun _) = True
isNoun _ = False

isAdj :: Token -> Bool
isAdj (Adj _) = True
isAdj _ = False

mergeNouns :: [Token] -> [Token]
mergeNouns [] = []
mergeNouns (Noun s:ts) = Nounc [] Nothing s : mergeNouns ts
mergeNouns ts@(Adj _:_) =
  let as = takeWhile isAdj ts
      ns = dropWhile isAdj ts
  in case ns of
    (n:nx) -> Nounc (map (\(Adj a) -> a) as) Nothing ((\(Noun n) -> n) n) : mergeNouns nx
    _ -> as
mergeNouns (o@(Ordn i _):ts) =
  let as = takeWhile isAdj ts
      ns = dropWhile isAdj ts
  in case ns of
    (n:nx) -> Nounc (map (\(Adj a) -> a) as) (Just i) ((\(Noun n) -> n) n) : mergeNouns nx
    _ -> o:as
mergeNouns (t:ts) = t : mergeNouns ts

-- | Run a given input line.
act :: String -> ChattyDungeonM ()
act s = do
  ts <- mapM lookupVocab $ replaceAliases $ words $ map toLower s
  let ss = mergeNouns ts
  unless (all isIntellegible ss) $ throwError UnintellegibleError
  case ss of
    [] -> return ()
    (Verb v:_) -> act' ss
    (Skilln n:ps) -> do
      ste <- totalStereo
      case stereoSkillBonus ste n of
        Nothing -> throwError CantCastThatNowError
        Just t -> runHandler . t =<< do
          gao <- liftM getObject' availableObjects
          gco <- liftM getObject' carriedObjects
          gso <- liftM getObject' seenObjects
          let getters = Getters gao gco gso
              tmplt = none{paramGettersOf=getters}
          case ps of
            [] -> return tmplt
            [n@Nounc{}] -> return tmplt{paramDirectOf=Just n}
            [Prep "at",n@Nounc{}] -> return tmplt{paramAtOf=Just n}
            [n1@Nounc{},Prep "at",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramAtOf=Just n2}
            [Prep "on",n@Nounc{}] -> return tmplt{paramOnOf=Just n}
            [n1@Nounc{},Prep "on",n2@Nounc{}] -> return tmplt{paramDirectOf=Just n1,paramOnOf=Just n2}
            _ -> throwError UnintellegibleError
    _ -> throwError VerbMustFirstError
  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 "enter":n@Nounc{}:[]) = getAvailableObject_ n >>= objectTriggerOnEnterOf
act' (Verb "ascend":[]) = changeRoom Up
act' (Verb "descend":[]) = changeRoom Down
act' (Verb "go":Fixe 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
act' (Verb "list":Fixe "exits":[]) = do
  s <- getDungeonState
  let (Just r) = currentRoomOf s
  forM_ (listEdges r $ roomsOf s) $ \(l,c,n) -> do
    b <- pathPrerequisiteOf c
    mprint "  " >> mprint (show l) >> mprint " -> "
    mprint =<< withRoom n getRoomTitle
    if not b then mprintLn " (locked)"
             else mprintLn ""
act' (Verb "list":Fixe "inventory":[]) = do
  ps <- getPlayerState
  mprintLn "Your inventory:"
  forM_ (avlInorder $ playerInventoryOf ps) $ \os -> mprintLn $ printf "  %s" $ unpack $ objectTitleOf os
act' (Verb "list":Fixe "score":[]) = do
  [str, agi, sta, int, spi, arm, akp] <- mapM calcStat [Strength, Agility, Stamina, Intelligence, Spirit, Armor, AttackPower]
  [hst, gcd] <- mapM calcStat [Haste, CooldownDuration]
  mprintLn $ printf "Strength:     %5i   Agility: %5i" str agi
  mprintLn $ printf "Intelligence: %5i   Spirit:  %5i" int spi
  mprintLn $ printf "Stamina:      %5i   Armor:   %5i" sta arm
  mprintLn $ printf "Attack power: %5i   Haste:   %5i" akp hst
  mprintLn $ printf "Global cooldown:  %5i" gcd
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 "list":Fixe "equipment":[]) = 
  let pr (Just k) s = mprintLn $ printf "%-15s%s" s $ unpack $ objectTitleOf k
      pr Nothing _ = noneM
      firstM = runKleisli . first . Kleisli
  in mapM_ (firstM getEquipment >=> uncurry pr) $ lazyBuild $ do
    lit MainHand "Main hand:"
    lit OffHand "Off hand:"
    lit Chest "Chest:"
    lit Feet "Feet:"
    lit Wrists "Wrists:"
    lit Waist "Waist:"
    lit Head "Head:"
    lit Legs "Legs:"
    lit Back "Back:"
    lit Hands "Hands:"
    lit Neck "Neck:"
    lit Finger1 "Right finger:"
    lit Finger2 "Left finger:"
act' (Verb "acquire":n@Nounc{}:[]) = getSeenObject_ n >>= (acquireObject . objectIdOf)
act' (Verb "drop":n@Nounc{}:[]) = getCarriedObject_ n >>= (dropObject . objectIdOf)
act' _ = throwError UnintellegibleError

getObject :: (MonadError SplErr m) => Token -> [ObjectState] -> SplErr -> m ObjectState
getObject n os err =
  case getObject' os n of
    NoneFound -> throwError err
    TooMany -> throwError WhichOneError
    Found x -> return x

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))
    
getAvailableObject_ :: (MonadRoom m, MonadError SplErr m, MonadPlayer m) => Token -> m ObjectState
getAvailableObject_ n = do
  os <- availableObjects
  getObject n os CantSeeOneError

carriedObjects :: MonadPlayer m => m [ObjectState]
carriedObjects = liftM (avlInorder.playerInventoryOf) getPlayerState

getCarriedObject_ :: (MonadPlayer m, MonadError SplErr m) => Token -> m ObjectState
getCarriedObject_ n = do
  os <- carriedObjects
  getObject n os DontCarryOneError

seenObjects :: MonadRoom m => m [ObjectState]
seenObjects = liftM (avlInorder.roomObjectsOf) getRoomState

getSeenObject_ :: (MonadRoom m, MonadError SplErr m) => Token -> m ObjectState
getSeenObject_ n = do
  os <- seenObjects
  getObject n os CantSeeOneError