{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, OverloadedStrings, OverloadedLists, RankNTypes #-}

module Sequence.Utils
  ( TimerLength(..), TimerOrigin(..)
  , withArg, (<~>), withFocus, withFocus'
  , focusState
  , toName, toDesc
  , outputLogged
  , scaleTimer
  , statAccessors
  , Argument(..)
  , Completion(..)
  , module Sequence.Utils.Ask
  ) where

import Sequence.Types

import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe

import Control.Applicative
import Control.Monad
import Control.Lens

import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Function
import Data.Default
import Data.Maybe
import Text.Read (readMaybe)

import Data.List
import Data.Bool
import Data.Char

import System.Console.Shell
import System.Console.Shell.ShellMonad
import System.Console.Shell.Backend.Haskeline

import Sequence.Utils.Ask
import Sequence.Contact.Types
import Sequence.Formula

import Text.Regex (mkRegex, subRegex)

data TimerLength = TimerLength TimerOrigin Int

data TimerOrigin = Absolute | Now

class Argument a st | a -> st where
  arg :: String -> Sh st (Maybe a)

withArg :: Argument a st => (a -> Sh st ()) -> (Completable a -> Sh st ())
withArg f (Completable str) = arg str >>= \a -> case a of
  Nothing -> shellPutErrLn $ "Could not parse ‘" ++ str ++ "’"
  Just a  -> f a

infixr 0 <~>
(<~>) :: Argument a st => Completable a -> (a -> Sh st ()) -> Sh st ()
(<~>) = flip withArg

withFocus :: (EntityIdentifier -> Sh GameState ()) -> Sh GameState ()
withFocus f = use gFocus >>= maybe (shellPutErrLn $ "Currently not focusing any entity") f

withFocus' :: (Entity -> Sh GameState a) -> Sh GameState (Maybe a)
withFocus' f = preuse gFocus' >>= maybe (Nothing <$ shellPutErrLn "Currently not focusing any entity") (fmap Just . f)

focusState :: MonadState s m => Traversal' s a -> StateT a (MaybeT m) b -> m (Maybe b)
focusState lens action = runMaybeT $ uncurry (<$) . over _2 (lens .=) =<< runStateT action =<< MaybeT (preuse lens)

unaligned = view faction' def

toName :: MonadState GameState m => EntityIdentifier -> m String
toName ident = do
  let number = review entityId' ident
  isShadowed <- uses gEntityNames . Bimap.memberR $ view entityName number
  let number' = bool id ('#':) isShadowed $ number
  fromMaybe number' . fmap (review entityName) . Bimap.lookup ident <$> use gEntityNames

toDesc :: (MonadState GameState m, MonadIO m) => EntityIdentifier -> m String
toDesc ident = do
  name <- toName ident
  health <- runMaybeT $ do
    maxVit <- MaybeT . focusState (gEntities . ix ident) . evalFormula' [name] =<< (MaybeT . preuse $ gEntities . ix ident . eStats . sMaxVitality)
    hDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sTotalDamage
    fDamage <- MaybeT . preuse $ gEntities . ix ident . eStats . sFatigue
    return $ (maxVit - hDamage, maxVit - fDamage)
  case health of
    Just dmg -> return $ name ++ " " ++ show dmg
    Nothing -> return name

outputLogged :: EntityIdentifier -> String -> Sh GameState ()
outputLogged id str = gLog <>= pure (id, clean str) >> shellPutStrLn str
  where
    clean str = subRegex (mkRegex "(\x9B|\x1B\\[)[0-?]*[ -/]*[@-~]") str "" -- remove ANSI escapes

scaleTimer :: Int -> Rational -> Timer -> Timer
scaleTimer _ _ t@(Constant _) = t
scaleTimer (fromIntegral -> now) factor (Scaled r) = Scaled $ ((max 0 $ r - now) * factor) + now

instance Completion TimerLength GameState where
  completableLabel _ = "<timer offset>"
  complete _ st prefix = return []

instance Argument TimerLength GameState where
  arg str
    | ('+':cs) <- str
    , (Just n) <- readMaybe cs
    , n >= 0 = return . Just $ TimerLength Now n
    | (Just n) <- readMaybe str
    , n >= 0 = return . Just $ TimerLength Absolute n
    | otherwise = return Nothing

instance Completion EntityIdentifier GameState where
  completableLabel _ = "<entity>"
  complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities

instance Argument EntityIdentifier GameState where
  arg = \str -> do
    fromForcedIdR <- fromForcedId str
    fromNameR <- fromName str
    fromIdR <- fromId str
    return $ fromForcedIdR <|> fromNameR <|> fromIdR
    where
      fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames
      fromId (preview entityId' -> Just n) = (n <$) . guard . Map.member n <$> use gEntities
      fromId _ = return Nothing
      fromForcedId ('#':str) = fromId str
      fromForcedId _ = return Nothing

instance Completion Faction GameState where
  completableLabel _ = "<faction>"
  complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions)

instance Argument Faction GameState where
  arg = return . Just . flip (set faction') def

instance Completion (Set Hitzone) GameState where
  completableLabel _ = "<hitzones>"
  complete _ st (over each reverse . span (/= ',') . reverse -> (wPrefix, lPrefix))
    | not $ null wPrefix
    , all (== '*') wPrefix = return . pure . join $ hitzones
    | otherwise = return . map (lPrefix ++) . filter ((isPrefixOf `on` CI.foldCase) wPrefix) $ hitzones
    where
      hitzones = sort . map (review hitzone) $ fromMaybe [] (Map.keys <$> preview (gFocus' . eStats . sHitzones) st)
      join [] = ""
      join [x] = x
      join (x:xs) = x ++ "," ++ join xs

instance Argument (Set Hitzone) GameState where
  arg protoWs = runMaybeT $ do
    let
      trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
      split = foldr (\c l@(w:ws) -> if c == ',' then "" : l else (c : w) : ws) [""]
      ws = Set.fromList . map CI.mk . filter (not . null) . map trim . split $ protoWs
      hasGlob = Set.member "*" ws
    hitzones <- Set.map (view _Hitzone) . Map.keysSet <$> MaybeT (preuse $ gFocus' . eStats . sHitzones)
    guard (hasGlob || ws `Set.isSubsetOf` hitzones)
    return . Set.map (review _Hitzone) $ if hasGlob then hitzones else ws

instance Completion DamageType GameState where
  completableLabel _ = "<damageType>"
  complete _ _ prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) $ map show ([minBound .. maxBound] :: [DamageType])

instance Argument DamageType GameState where
  arg (CI.mk -> word) = return $ Map.lookup word types
    where
      types = Map.fromList [(CI.mk $ show dType, dType) | dType <- [minBound .. maxBound]]

instance Completion (Formula Stats) GameState where
  completableLabel _ = "<value>"
  complete _ st (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys $ Map.filter (isJust . (\a -> preview (gFocus' . eStats . folding a) st)) statAccessors

instance Argument (Formula Stats) GameState where
  arg (CI.mk -> name) = runMaybeT $ fromAccessor `mplus` fromNumber
    where
      fromAccessor = do
        accessor <- MaybeT . return $ Map.lookup name statAccessors
        MaybeT . preuse $ gFocus' . eStats . folding accessor
      fromNumber = MaybeT . return . fmap fromInteger . (readMaybe :: String -> Maybe Integer) $ CI.original name

statAccessors :: Map (CI String) (Stats -> Maybe (Formula Stats))
statAccessors = [ ("Stärke", preview sAStrength)
                , ("Ausdauer", preview sAEndurance)
                , ("Masse", preview sAMass)
                , ("Reflexe", preview sAReflexes)
                , ("Beweglichkeit", preview sAMobility)
                , ("Geschicklichkeit", preview sADexterity)
                , ("Intelligenz", preview sAIntelligence)
                , ("Charisma", preview sACharisma)
                , ("Wahrnehmung", preview sAPerception)
                , ("Entschlossenheit", preview sAWillpower)
                
                , ("Archaische Distanzwaffen", preview sSArchaicRanged)
                , ("Handfeuerwaffen", preview sSFirearms)
                , ("Schwere Waffen", preview sSHeavyWeapons)
                , ("Energiewaffen", preview sSEnergyWeapons)
                , ("Waffenloser Nahkampf", preview sSUnarmedMelee)
                , ("Bewaffneter Nahkampf", preview sSArmedMelee)
                , ("Wurfwaffen", preview sSThrownWeapons)
                , ("Tarnung & Schleichen", preview sSStealth)
                , ("Diebeshandwerk & Betrügerei", preview sSThievery)
                , ("Schlösser Knacken", preview sSLockpicking)
                , ("Fallen Stellen & Entschärfen", preview sSTrapping)
                , ("Naturwissenschaften", preview sSSciences)
                , ("Erste Hilfe", preview sSFirstAid)
                , ("Medizinische Praktik", preview sSMedicine)
                , ("Geisteswissenschaften", preview sSHumanities)
                , ("Ingenieurwesen & Reperatur", preview sSEngineering)
                , ("Handwerkskunst", preview sSCraft)
                , ("Interface", preview sSInterface)
                , ("Redekunst", preview sSSpeech)
                , ("Führung", preview sSLeadership)
                , ("Hauswirtschaft", preview sSHomeEconomics)
                , ("Überlebenskunst", preview sSSurvival)
                , ("Motorrad", preview sSMotorcycle)
                , ("Radfahrzeug", preview sSWheeled)
                , ("Schwebefahrzeug", preview sSHovercraft)
                , ("Tragflächenmaschine", preview sSAircraft)
                , ("Raumfahrzeug", preview sSSpacecraft)
                , ("Wasserfahrzeug", preview sSWatercraft)
                , ("Kettenfahrzeug", preview sSTracked)
                , ("Exoskelett", preview sSExoskeleton)

                , ("Beißen", preview sSBiting)
                , ("Aufspüren", preview sSSearching)
                , ("Betragen", preview sSDemeanour)

                , ("Rammen", preview sSRamming)
                , ("Zielerfassung", preview sSTargeting)
                , ("Verständnis", preview sSComprehension)

                , ("Zerfleischen", preview sSMauling)
                , ("Ätzende Ausscheidung", preview sSExcreting)

                , ("Grotesker Angriff", preview sSGrotesqueAssault)
                
                , ("Maximale Vitalität", preview sMaxVitality)
                , ("Sequenzwert", preview sSeqVal)
                , ("Schmerztoleranz", preview sPainTolerance)
                , ("Erschöpfungstoleranz", preview sFatigueTolerance)

                , ("Vitalität", liftM2 (-) <$> preview sMaxVitality <*> preview (sTotalDamage . to return))
                , ("Erschöpfung", preview $ sFatigue . to return)
                ]