path: root/src/Main.hs

{-# LANGUAGE ViewPatterns, RecordWildCards, OverloadedStrings, FlexibleContexts, RankNTypes #-}

import Control.Monad

import Control.Lens hiding (Context(..))

import System.Console.Shell
import System.Console.Shell.ShellMonad
import System.Console.Shell.Backend.Haskeline
import System.Console.ANSI (setSGRCode, SGR(..), ConsoleLayer(..), ConsoleIntensity(..), ColorIntensity(..), Color(..))

import System.Environment.XDG.BaseDir
import System.FilePath
import System.Directory

import Data.Default
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.Bimap (Bimap)
import qualified Data.Bimap as Bimap

import Data.List

import Data.List
import Data.Maybe
import Data.Bool

import Data.Function

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

import Sequence.Types
import Sequence.Contact.Types
import Sequence.Contact.Archetypes
import Sequence.Contact.Tests
import Sequence.Utils
import Sequence.Formula

import Text.Layout.Table

import Text.Read (readMaybe)

import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text.Lazy as Lazy.Text
import Data.Text.Template

import Debug.Trace

main :: IO ()
main = do
  historyFile <- getUserCacheFile "sequence" "history"
  createDirectoryIfMissing True $ takeDirectory historyFile
  let
    description = initialShellDescription
                  { historyFile = Just historyFile
                  , prompt = \st -> return $ maybe "" (++ " ") ((evalState ?? st) . toName <$> view gFocus st) ++ "→ "
                  , beforePrompt = do
                      { stateMaintenance
                      ; stateOutline >>= (\str -> if null str then return () else shellPutStr str)
                      ; gets focusNotes >>= (\str -> if null str then return () else shellPutStr str)
                      }
                  , commandStyle = OnlyCommands
                  , shellCommands = [ exitCommand "exit"
                                    , helpCommand "help"
                                    , cmd "entities" listEntities "List all entities"
                                    , cmd "tip" focusTip "Focus the entity at the top of the queue"
                                    , cmd "focus" setFocus "Focus a specific entity"
                                    , cmd "blur" blur "Focus no entity"
                                    , cmd "remove" remove "Remove the focused entity from the queue"
                                    , cmd "factions" listFactions "List all inhabited factions"
                                    , cmd "name'" renameFaction "Rename a faction – merge if new name is taken"
                                    , cmd "members" listFaction "List all members of a faction"
                                    , cmd "align" alignEntity "Align the focused entity to a faction – creating it, if necessary"
                                    , cmd "name" nameEntity "Name the current entity overriding previous name assignments"
                                    , cmd "spawn" spawnEntity "Create a new entity from an archetype focusing on it"
                                    , cmd "spawn'" spawnFaction "Create a new faction and spawn multiple copies of an archetype in it"
                                    , cmd "test" rollTest "Roll a test using the stats of the currently focused entity"
                                    , cmd "combat" entitySeqVal "Roll sequence value for the current focus and enter combat"
                                    , cmd "combat'" factionSeqVal "Roll sequence values for all members of a faction and have them enter combat"
                                    , cmd "spend" spendSeq "Spend some of the current focus´ AP"
                                    , cmd "delay" delay "Spend AP until the current focus´ sequence is no higher than the next highest"
                                    , cmd "note" addNote "Add a note to the current focus"
                                    , cmd "hit" takeHit "Damage the focused entity"
                                    , cmd "fatigue" takeFatigue "Inflict fatigue damage upon the focused entity"
                                    ]
                  , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '*']
                  }
  void $ runShell description haskelineBackend (def :: GameState)

stateOutline :: Sh GameState String
stateOutline = do
  st <- get
  case st of
    st | null (st ^. priorityQueue) -> return ""
       | otherwise                  -> unlines <$> mapM table (st ^. gRounds')
  where
    table :: Int -> Sh GameState String
    table round = do
      factions <- map (view faction') <$> use inhabitedFactions
      st <- get
      let
        roundStr 0 = "Current Round"
        roundStr 1 = "Next Round"
        roundStr n = show n ++ " Rounds later"

        pQueue = filter (\(v, _) -> round == v ^. seqRound . _Wrapped) $ st ^. priorityQueue
        protoRows = groupBy ((==) `on` fst) pQueue
        faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities)

        rowGs :: Sh GameState [RowGroup]
        rowGs = runListT $ do
          rowGroup'@((seq, _):_) <- ListT $ return protoRows
          let
            rowGroup = map snd rowGroup'
            factionColumn i = runListT $ do
              x <- ListT $ return rowGroup
              guard $ factionIndex x == i
              toDesc x
            factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions
          colsAllG top . ([maybe "" show $ view seqVal seq] :) <$> mapM factionColumn [0..(length factions - 1)]
      layoutTableToString <$> rowGs <*> pure (Just (roundStr round : factions, repeat def)) <*> pure (repeat def) <*> pure unicodeBoldHeaderS

focusNotes :: GameState -> String
focusNotes = maybe "" (unlines . map dotted) . preview (gFocus' . eNotes)
  where
    dotted "" = " • "
    dotted str
      | fstL : [] <- lines str = " • " ++ fstL
      | fstL : tailL <- lines str = " • " ++ fstL ++ "\n" ++ unlines (map ("   " ++ ) tailL)
      | otherwise = ""

stateMaintenance :: Sh GameState ()
stateMaintenance = do
  void . runMaybeT $ do
    focusId <- MaybeT $ use gFocus
    name <- lift $ toName focusId
    let
      lStats :: Traversal' GameState Stats
      lStats = gEntities . ix focusId . eStats
      evalF formula = do
        stats <- MaybeT $ preuse lStats
        (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula
        lStats .= nStats
        return x
    isDead <- evalF =<< MaybeT (preuse $ lStats . sDead)
    isUnconscious <- evalF =<< MaybeT (preuse $ lStats . sUnconscious)
    guard $ isDead || isUnconscious
    when isDead . lift . shellPutStrLn $ name ++ " died"
    when isUnconscious . lift . shellPutStrLn $ name ++ " is unconscious"
    gFocus' . eSeqVal .= Nothing
    gFocus .= Nothing

-- Query state
listFactions, listEntities :: Sh GameState ()
listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction')
listEntities = use (gEntities . to Map.keys) >>= mapM_ (shellPutStrLn <=< toName)

-- Automatic focus
focusTip, blur :: Sh GameState ()
focusTip = gFocus <~ preuse tip
blur     = gFocus .= Nothing

-- Manual focus
setFocus :: Completable EntityIdentifier -> Sh GameState ()
setFocus = withArg $ \ident -> gFocus ?= ident
 
-- Drop information
remove :: Sh GameState ()
remove = withFocus $ \ident -> do
  name <- toName ident
  confirmation <- askBool ("Are you sure you want to remove ‘" ++ name ++ "’?") False
  when confirmation $ do
    gEntities %= Map.delete ident
    gEntityNames %= Bimap.delete ident
    blur

-- Manage Entity
spawnEntity :: Completable Entity -> Sh GameState ()
spawnEntity = withArg $ \entity -> do
  identifier <- use gNextId'
  modify $ insertEntity entity
  gFocus ?= identifier

nameEntity :: String -> Sh GameState ()
nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#<n>’)"
nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName)

-- Manage faction
listFaction, alignEntity :: Completable Faction -> Sh GameState ()
listFaction = withArg $ \qFaction -> use gEntities >>= mapM_ (shellPutStrLn <=< toName) . Map.keys . Map.filter ((==) qFaction . view eFaction)
alignEntity = withArg $ \nFaction -> withFocus $ \ident -> gEntities %= Map.adjust (set eFaction nFaction) ident

renameFaction :: Completable Faction -> Completable Faction -> Sh GameState ()
renameFaction f1' f2' = withArg (\f1 -> withArg (\f2 -> renameFaction' f1 f2) f2') f1'
  where
    renameFaction' f1 f2 = modifying (gEntities . each . eFaction) (\cF -> bool cF f2 $ cF == f1)

spawnFaction :: Completable Faction -> Integer -> Completable Entity -> String -> Sh GameState ()
spawnFaction cFaction num cEntity nameTemplate
  | ('#':_) <- nameTemplate = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#<n>’)"
  | otherwise = do
      let nameTemplate' = templateSafe $ Text.pack nameTemplate
      case nameTemplate' of
        Left _ -> shellPutErrLn "Invalid template – ‘$n’ gets replaced by [1..<n>], ‘$faction’ gets replaced by name of faction, and ‘$i’ gets replaced by a numerical identifier – quote ‘$’ as ‘$$’"
        Right nameTemplate -> withArg (\faction -> withArg (\entity -> mapM_ (spawnFaction' faction entity nameTemplate) [1..num]) cEntity) cFaction
  where
    spawnFaction' faction entity nameTemplate num = do
      identifier <- use gNextId'
      let name = Lazy.Text.unpack <$> renderA nameTemplate (context num)
          context num "i" = Just . Text.pack $ review entityId' identifier
          context num "n" = Just . Text.pack $ show num
          context num "faction" = Just . Text.pack $ faction ^. faction'
          context num _ = Nothing
      modify $ insertEntity entity
      maybe (return ()) (nameEntity identifier) name
      gEntities %= Map.adjust (set eFaction faction) identifier
    nameEntity identifier name = modifying gEntityNames $ Bimap.insert identifier (name ^. entityName)

-- Dice rolls
rollTest :: Completable (FormulaM Stats Test) -> Sh GameState ()
rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . ppResult)
  where
    ppResult result = pad 3 (show $ result^.rWith) ++ ": " ++ setSGRCode (colour result) ++ name result ++ setSGRCode [] ++ " by " ++ pad 2 (show $ result^.rBy) ++ "pp"
    colour CritSuccess{..} = [SetColor Foreground Vivid Green, SetConsoleIntensity BoldIntensity]
    colour Success{..} = [SetColor Foreground Dull Green]
    colour Failure{..} = [SetColor Foreground Dull Red]
    colour CritFailure{..} = [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity]
    name CritSuccess{..} = "Critical Success"
    name Success{..} = "Success"
    name Failure{..} = "Failure"
    name CritFailure{..} = "Critical Failure"
    pad n str
      | length str >= n = str
      | otherwise = ' ' : pad (n - 1) str

enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult)
enactTest' test = withFocus' $ \focus -> do
  focusName <- use gFocus >>= toName . fromJust
  (newFocus, result) <- evalFormula focusName focus (enactTest =<< test)
  gFocus' .= newFocus
  return result
      
entitySeqVal :: Sh GameState ()
entitySeqVal = withFocus entitySeqVal'

factionSeqVal :: Completable Faction -> Sh GameState ()
factionSeqVal = withArg $ \qFaction -> use gEntities >>= mapM_ (entitySeqVal') . Map.keys . Map.filter ((==) qFaction . view eFaction)

entitySeqVal' :: EntityIdentifier -> Sh GameState ()
entitySeqVal' ident = void . runMaybeT $ do
  entity <- MaybeT $ preuse (gEntities . ix ident)
  sVal <- MaybeT . return $ preview (eStats . sSeqVal) entity
  name <- toName ident
  round <- use gRound
  (newEntity, sNum) <- evalFormula name entity sVal
  let val = Just $ def
            & set (seqRound . _Wrapped) round
            & set seqVal (Just sNum)
            & set seqEpsilon (entity ^. eStats . sSeqEpsilon)
  gEntities . at ident .= Just (newEntity & set eSeqVal val)

spendSeq :: Int -> Sh GameState ()
spendSeq n = withFocus $ \focusId -> do
  gEntities . ix focusId . eStats . sSequence . _Just . seqVal . _Just -= n

delay :: Sh GameState ()
delay = withFocus $ \focusId -> () <$ runMaybeT (delay' focusId)
  where
    delay' focusId = do
      tipId <- MaybeT $ preuse tip
      tipSeq <- MaybeT . preuse $ gEntities . ix tipId . eStats . sSequence . _Just . seqVal . _Just
      focusSeq <- MaybeT . preuse $ gEntities . ix focusId . eStats . sSequence . _Just . seqVal . _Just
      guard $ focusSeq > tipSeq
      lift . spendSeq $ focusSeq - tipSeq

addNote :: String -> Sh GameState ()
addNote note = withFocus $ \focusId -> gEntities . ix focusId . eNotes %= (note :)

doShock :: Int -> Traversal' Stats ShockEffect -> Sh GameState ()
doShock dmg efLens = withFocus $ \focusId -> do
  let
    lStats :: Traversal' GameState Stats
    lStats = gEntities . ix focusId . eStats
  name <- toName focusId
  void . runMaybeT $ do
    cripple <- MaybeT . preuse $ lStats . efLens
    let -- evalF formula = do
        --   stats <- MaybeT $ preuse lStats
        --   (nStats, x) <- (evalFormula name :: Stats -> FormulaM Stats a -> MaybeT (Sh GameState) (Stats, a)) stats formula
        --   lStats .= nStats
        --   return x
        evalF = MaybeT . focusState lStats . evalFormula' name
        cVar cLens = evalF =<< MaybeT (preuse $ lStats . (cripple ^. cLens))
    bar <- cVar seBar
    val <- cVar seVal
    reBar <- cVar seReBar
    if cripple ^. seApplied
      then guard $ dmg >= reBar
      else guard $ val >= bar
    lStats . efLens . seApplied .= True
    (CI.original -> effectName, effect) <- view _Effect <$> (evalF . table $ cripple ^. seEffect)
    lStats <~ (MaybeT . fmap join . runMaybeT $ evalF effect)
    lift $ shellPutStrLn effectName
    lift . addNote $ "Effect: " ++ effectName

takeHit :: Int -> Completable (Set Hitzone) -> Completable DamageType -> Sh GameState ()
takeHit dmg a1 a2 = flip withArg a1 $ \zones -> flip withArg a2 $ \dType -> withFocus $ \focusId -> forM_ zones $ \zone -> void . runMaybeT $ do
  let
    lStats :: Traversal' GameState Stats
    lStats = gEntities . ix focusId . eStats
  name <- toName focusId
  armor <- MaybeT . preuse $ lStats . sArmor . ix zone
  dmg' <- MaybeT . focusState lStats . evalFormula' name $ absorb armor dType dmg
  forM_ (Map.toList dmg') $ \(dType, dmg) -> lift . runMaybeT $ do
    guard $ dmg > 0
    lift $ shellPutStrLn $ name ++ " took " ++ show dmg ++ " " ++ show dType
    case dType of
      Fatigue -> lStats . sFatigue += dmg
      _       -> lStats . sDamage . ix zone += dmg
    case dType of
      Fatigue -> lift $ doShock dmg sFatigueShock
      _       -> lift $ do
        doShock dmg (sCripple . ix zone)
        doShock dmg sPainShock
    
takeFatigue :: Int -> Sh GameState ()
takeFatigue dmg = withFocus $ \focusId -> do
  gEntities . ix focusId . eStats . sFatigue += dmg
  doShock dmg sFatigueShock