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.Map as Lazy (Map)
import qualified Data.Map as Lazy.Map

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

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

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

import Data.List

import Data.List
import Data.Maybe
import Data.Bool
import Data.Monoid (Monoid(..), (<>), All(..))
import Data.Ord
import Data.Ratio

import Data.Foldable (toList)

import Data.Function

import Control.Monad.State.Strict
import Control.Monad.Reader
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 Numeric.Probability.Game.Event (EventM, makeEventProb, enact)

import Text.Layout.Table

import Text.Read (readMaybe)
import Text.Printf

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 "pTip" pFocusTip "Focus a random entity"
                                    , 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 "replace" replaceEntity "Replace the focused entity with a different one carrying over some values"
                                    , 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 "timer" entityTimer "Set a timer associated with the current entity"
                                    , cmd "pTimer" pEntityTimer "Set a timer associated with the current entity. Scale remaining time dynamically with the number of combatants"
                                    , cmd "untimer" clearEntityTimer "Remove the timer associated with the current entity"
                                    , cmd "uncombat" clearEntitySeqVal "Drop the focused entity out of combat"
                                    , cmd "uncombat'" clearFactionSeqVal "Drop all members of a faction out of 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 and focus that one"
                                    , cmd "note" addNote "Add a note to the current focus"
                                    , cmd "unnote" delNote "Remove a note from the current focus"
                                    , cmd "hit" takeHit "Damage the focused entity"
                                    , cmd "heal" healDmg "Heal the focused entity"
                                    , cmd "heal'" healFatigue "Heal the focused entity of fatigue"
                                    , cmd "log" dumpLog "Print the combat log"
                                    , cmd "val" printVal "Find the distribution of a specific value of the current entities"
                                    , cmd "summary" printVals "Find the averages of applicable all values"
                                    , cmd "burstfire" burstfire "Roll an automatic burst of <n> shots against given skill compensating for recoil with the given attribute"
                                    ]
                  , wordBreakChars = wordBreakChars initialShellDescription \\ [',', '\'']
                  }
  void $ runShell description haskelineBackend (def :: GameState)

stateOutline :: Sh GameState String
stateOutline = do
  st <- get
  time <- use gTimer

  unlines <$> sequence ( ( if not (null $ st ^. timers) || not (null $ st ^. gRounds')
                           then [ return $ "Round timer: " ++ show time ]
                           else []
                         )
                         ++ ( if not (null $ st ^. timers) then [ tTable ] else [] )
                         ++ ( if not (null $ st ^. gRounds') then map table (st ^. gRounds') else [] )
                       )
  where
    table :: Int -> Sh GameState String
    table round = do
      factions <- map (view faction') <$> use combatFactions
      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
      tableString <$> pure (repeat def) <*> pure unicodeBoldHeaderS <*> pure (titlesH $ roundStr round : factions) <*> rowGs
    tTable :: Sh GameState String
    tTable = do
      factions <- map (view faction') <$> use combatFactions'
      st <- get
      let
        time = st ^. gTimer
        protoRows = groupBy ((==) `on` fst) $ st ^. timers
        faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities)

        rowGs :: Sh GameState [RowGroup]
        rowGs = runListT $ do
          rowGroup'@((t, _):_) <- 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 . ([show . round $ t ^. absTime - fromIntegral time] :) <$> mapM factionColumn [0..(length factions - 1)]
      tableString <$> pure (repeat def) <*> pure unicodeBoldHeaderS <*> pure (titlesH $ ("Time left") : factions) <*> rowGs

focusNotes :: GameState -> String
focusNotes st
  | (Just notes) <- preview (gFocus' . eNotes) st = let notes'  = zip ([1..] :: [Int]) notes
                                                        dotted' = dotted . maximum $ map (length . show . fst) notes'
                                                    in unlines $ map dotted' notes'
  | otherwise = ""
  where
    prefix :: Int -> Int -> String
    prefix pad n = printf (" %*d) " :: String) pad n
    prefix' :: Int -> String
    prefix' pad = printf (" %*s) " :: String) pad ("" :: String)
    dotted :: Int -> (Int, String) -> String
    dotted pad (n, "") = prefix pad n
    dotted pad (n, str)
      | fstL : [] <- lines str = prefix pad n ++ fstL
      | fstL : tailL <- lines str = prefix pad n ++ fstL ++ "\n" ++ unlines (map (prefix' pad ++ ) 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
      safe a = lift $ fromMaybe False <$> runMaybeT a
    isDead <- safe $ evalF =<< MaybeT (preuse $ lStats . sDead)
    isUnconscious <- safe $ evalF =<< MaybeT (preuse $ lStats . sUnconscious)
    isDestroyed <- safe $ evalF =<< MaybeT (preuse $ lStats . sDestroyed)
    guard $ isDead || isUnconscious || isDestroyed
    case (isDead, isUnconscious, isDestroyed) of
      (True, _, _) -> lift . shellPutStrLn $ name ++ " is dead"
      (_, True, _) -> lift . shellPutStrLn $ name ++ " is unconscious"
      (_, _, True) -> lift . shellPutStrLn $ name ++ " is destroyed"
    gFocus' . eSeqVal .= Nothing
    -- gFocus .= Nothing
  void $ do
    newCount <- fromIntegral . length <$> use priorityQueue
    lastCount <- fromIntegral <$> use gLastCount
    time <- use gTimer
    when (newCount /= lastCount) $ do
      let
        scale :: Entity -> Sh GameState Entity
        scale entity = (execStateT ?? entity) $ do
          eTimer . _Just %= scaleTimer time (newCount % (max 1 lastCount))
      gEntities <~ (mapM scale =<< use gEntities)
  gLastCount <~ length <$> use priorityQueue
  void $ do
    round <- use gRound
    let
      finished sVal = fromMaybe False (previews (seqVal . _Just) (<= 0) sVal) || view (seqRound . _Wrapped) sVal /= round
    allFinished <- getAll . foldMapOf (gEntities . each . eSeqVal . _Just) (All . finished) <$> get
    when allFinished $ do
      let
        advanceRound' :: EntityIdentifier -> Entity -> Sh GameState Entity
        advanceRound' ident entity = fmap (fromMaybe entity . (\(m, s) -> s <$ m)) . (runStateT ?? entity) . runMaybeT $ do
          cRound <- MaybeT . preuse $ eSeqVal . _Just . seqRound . _Wrapped
          guard $ cRound < 0
          cVal <- MaybeT . preuse $ eSeqVal . _Just . seqVal . _Just
          name <- lift . lift $ toName ident
          (newEntity, nVal) <- lift . lift $ rollSeqVal entity name
          put $ set eSeqVal nVal newEntity 
          when (cVal < 0) $ -- Carry over negative values from previous rounds
            eSeqVal . _Just . seqVal . _Just += cVal
          eSeqVal . _Just . seqRound . _Wrapped += 1
        advanceTimer :: Entity -> Sh GameState Entity
        advanceTimer entity = (execStateT ?? entity) $ do
          rTime <- lift $ use gTimer
          eTimer . _Just . absTime -= fromIntegral rTime
      gRounds -= 1
      gEntities <~ (mapM advanceTimer =<< imapM advanceRound' =<< use gEntities)
      gTimer .= 0

rollSeqVal :: Entity -> String -> Sh GameState (Entity, Maybe SeqVal)
rollSeqVal entity name = do
  let sVal = fromMaybe (val ignored ["Sequenzwert"] False) $ preview (eStats . sSeqVal) entity
  (newEntity, sNum) <- evalFormula [name] entity sVal
  round <- use gRound
  let val = Just $ def
            & set (seqRound . _Wrapped) round
            & set seqVal (Just sNum)
            & set seqEpsilon (entity ^. eStats . sSeqEpsilon)
  return (newEntity, val)

-- 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, pFocusTip :: Sh GameState ()
focusTip = gFocus <~ preuse tip
blur     = gFocus .= Nothing
pFocusTip = do
  nextTimer <- preuse $ timers . folding listToMaybe
  time <- fromIntegral <$> use gTimer
  round <- use gRound
  let
    eWeight :: Maybe SeqVal -> Int
    eWeight sVal
      | preview (_Just . seqRound . _Wrapped) sVal == Just round
      , (preview (_Just . seqVal . _Just) -> Just n) <- sVal = max 0 n
      | otherwise = 0
  entities <- map (over _2 . view $ eSeqVal . to eWeight) . Map.toList <$> use gEntities
  case nextTimer of
    nextTimer
      | Just timer <- nextTimer
      , fst $ over _1 (\t -> t ^. absTime <= time) timer
                      -> gFocus .= Just (snd timer)
      | null entities -> gFocus .= Nothing
      | otherwise     -> gFocus <~ Just <$> liftIO (enact $ makeEventProb entities)

entityTimer, pEntityTimer :: Completable TimerLength -> Sh GameState ()
entityTimer = entityTimer' Constant
pEntityTimer = entityTimer' Scaled
entityTimer' toTimer = withArg $ \(TimerLength origin n) -> do
  time <- use gTimer
  entities <- length <$> use priorityQueue
  let
    timer = case origin of
      Absolute -> n
      Now -> time + n
  gFocus' . eTimer .= Just (scaleTimer time (max 1 $ fromIntegral entities) . toTimer $ fromIntegral timer)

clearEntityTimer :: Sh GameState ()
clearEntityTimer = gFocus' . eTimer .= 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
    blur

-- Manage Entity
spawnEntity, replaceEntity :: Completable Entity -> Sh GameState ()
spawnEntity = withArg $ \entity -> do
  identifier <- use gNextId'
  modify $ insertEntity entity
  gFocus ?= identifier
replaceEntity = withArg $ \entity -> void . withFocus' $ \old -> do
  let oldStats = old ^. eStats
  modifying (gFocus' . eStats) . execState $ do
    put $ entity ^. eStats
    let
      copy :: st -> Traversal' st a -> State st ()
      copy from lens = do
        case preview lens from of
          Just a  -> lens .= a
          Nothing -> return ()
    copy oldStats sSeqVal
    copy oldStats sTimer
    copy oldStats sModifiers
    copy oldStats sEquipment

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

rollTest' :: FormulaM Stats Test -> Sh GameState ()
rollTest' = rollTest'' Nothing

rollTest'' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState ()
rollTest'' testMod = maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' testMod
  where
    outputResult :: (String, TestResult) -> Sh GameState ()
    outputResult (test, view (rRoll . to ppResult) -> result) = do
      focusId <- use gFocus
      case focusId of
        Nothing -> shellPutStrLn result
        Just id -> outputLogged id $ test ++ ": " ++ result
    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


    applyEffect :: (String, TestResult) -> Sh GameState ()
    applyEffect (_, view rResult -> Nothing) = return ()
    applyEffect (test, view rResult -> Just (Effect (CI.original -> effectDesc) effect)) = void . runMaybeT $ do
      focusId <- MaybeT $ use gFocus
      name <- toName focusId
      let
        lStats :: Traversal' GameState Stats
        lStats = gEntities . ix focusId . eStats
        evalF = MaybeT . focusState lStats . evalFormula' [name]
      guard =<< askBool ("Apply effects (" ++ effectDesc ++ ")?") True
      lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect)
      lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc

enactTest' :: Maybe (Formula Stats) -> FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult))
enactTest' testMod test = runMaybeT $ do
  focusName <- MaybeT (use gFocus) >>= lift . toName
  let evalF = MaybeT . focusState (gFocus' . eStats) . evalFormula' [focusName]
  test' <- evalF test
  result <- evalF $ (maybe enactTest (flip enactTestMod) testMod) test'
  return (view (tName . to CI.original) test', 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)

clearEntitySeqVal :: Sh GameState ()
clearEntitySeqVal = withFocus clearEntitySeqVal'

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

entitySeqVal', clearEntitySeqVal' :: EntityIdentifier -> Sh GameState ()
entitySeqVal' ident = void . runMaybeT $ do
  entity <- MaybeT $ preuse (gEntities . ix ident)
  name <- toName ident
  (newEntity, val) <- lift $ rollSeqVal entity name
  gEntities . at ident .= Just (newEntity & set eSeqVal val)
  gLog <>= pure (ident, "Sequence: " ++ show (fromJust $ view seqVal =<< val))
clearEntitySeqVal' ident = gEntities . ix ident . eSeqVal .= Nothing

spendSeq :: Int -> String -> Sh GameState ()
spendSeq n logStr = withFocus $ \focusId -> do
  gFocus' . eSeqVal . _Just . seqVal . _Just -= n
  hasSeq <- isJust <$> preuse (gFocus' . eSeqVal . _Just . seqVal . _Just)
  when hasSeq $
    gTimer += n
  gLog <>= pure (focusId, logStr)

delay :: Sh GameState ()
delay = withFocus $ fmap (\_ -> ()) . runMaybeT . delay'
  where
    delay' focusId = do
      tipId <- MaybeT . preuse $ priorityQueue . folding (fmap snd . listToMaybe . filter (\(_, i) -> i /= focusId))
      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
      tipName <- toName tipId
      lift $ spendSeq (focusSeq - tipSeq) ("Wait for " ++ tipName)
      gFocus ?= tipId

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

delNote :: Int -> Sh GameState ()
delNote ((\n -> n - 1) -> index) = withFocus $ \focusId -> gEntities . ix focusId . eNotes %= strike index
  where
    strike :: Int -> [a] -> [a]
    strike _ [] = []
    strike 0 (_:xs) = xs
    strike n (x:xs) = x : strike (n - 1) xs

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
    Effect (CI.original -> effectName) effect <- evalF . table $ cripple ^. seEffect
    lStats <~ (MaybeT . fmap join . runMaybeT . evalF $ runMaybeT effect)
    lift . outputLogged focusId $ "Effect: " ++ 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 -> do
  name <- toName focusId
  let zones' = map (review hitzone) $ toList zones
  gLog <>= pure (focusId, "Hit for " ++ show dmg ++ " " ++ show dType ++ " to " ++ show zones')
  forM_ zones $ \zone -> void . runMaybeT $ do
    let
      lStats :: Traversal' GameState Stats
      lStats = gEntities . ix focusId . eStats
    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 . outputLogged focusId $ show dmg ++ " " ++ show dType ++ " to " ++ show (review hitzone zone)
      case dType of
        Electric -> do
          lStats . sFatigue += dmg
          lift $ doShock dmg sFatigueShock
          mass <- (MaybeT . focusState lStats . evalFormula' [name]) =<< MaybeT (preuse $ lStats . sAMass)
          willpower <- (MaybeT . focusState lStats . evalFormula' [name]) =<< MaybeT (preuse $ lStats . sAWillpower)
          let loss = max 0 $ dmg - mass - willpower
          lStats . sSequence . _Just . seqVal . _Just -= loss
          guard $ loss > willpower
          lift $ addNote "prone"
        Fatigue  -> do
          lStats . sFatigue += dmg
          lift $ doShock dmg sFatigueShock
        _        -> do
          lStats . sDamage . ix zone += dmg
          lift $ doShock dmg (sCripple . ix zone)
          lift $ doShock dmg sPainShock

healDmg :: Int -> Completable (Set Hitzone) -> Sh GameState ()
healDmg n = withArg $ \zones -> withFocus $ \focusId -> do
  gLog <>= pure (focusId, "Heal " ++ show (map (review hitzone) $ toList zones) ++ " for " ++ show n ++ " each")
  forM_ zones $ \zone -> do
    gEntities . ix focusId . eStats . sDamage . ix zone -= n

healFatigue :: Int -> Sh GameState ()
healFatigue n = withFocus $ \focusId -> do
  gLog <>= pure (focusId, "Heal for " ++ show n ++ " Fatigue")
  gEntities . ix focusId . eStats . sFatigue -= n

dumpLog :: Sh GameState ()
dumpLog = use gLog >>= mapMOf (each . _1) toName >>= shellPutStrLn . toTable
  where
    toTable :: Seq (String, String) -> String
    -- toTable (map (rowG . toListOf both) . toList -> table) = layoutTableToString table (Just (["Entity", "String"], [def, def])) [def, def] unicodeBoldHeaderS
    toTable (map (rowG . toListOf both) . toList -> table) = tableString [def, def] unicodeBoldHeaderS (titlesH ["Entity", "String"]) table

printVal :: Completable (Formula Stats) -> Sh GameState ()
printVal = withArg $ \formula -> withFocus $ \focusId -> do
  name <- toName focusId
  outline =<< focusState (gEntities . ix focusId . eStats) (findDistribution' [name] formula)
  where
    outline Nothing = shellPutErrLn "No such value"
    outline (Just (Map.toList -> [(v, _)])) = shellPutStrLn $ show v
    outline (Just (sortBy (comparing fst) . Map.toList -> vals)) = mapM_ (shellPutStrLn . outline') vals
      where
        barLength = 100
        outline' (v, prob) = printf "%*s: %.2f [%-*s]"
          (maximum lengths) (show v)
          (fromRational prob :: Double)
          barLength (replicate (round $ fromInteger barLength * normalize prob) '#')
        lengths = map (length . show . fst) vals
        -- normalize p = p / maximum (map snd vals)
        normalize = id

printVals :: Sh GameState ()
printVals = withFocus $ \focusId -> do
  name <- toName focusId
  sheet <- Map.mapMaybe id <$> mapM (\l -> preuse $ gFocus' . eStats . to l . _Just) statAccessors
  let
    maxLength = maximum . map (length . CI.original) $ Map.keys sheet
    printAvg (str, formula) = do
      result <- focusState (gFocus' . eStats) (findAverage [name] formula)
      case result of
        Just avg -> shellPutStrLn $ printf "%*s: %5.1f" maxLength (CI.original str) (fromRational avg :: Double)
        Nothing  -> return ()
  mapM_ printAvg $ Map.toList sheet

burstfire :: Int -> Completable (Formula Stats) -> Completable (Formula Stats) -> Sh GameState ()
burstfire nShots skill' attr' = skill' <~> \skill -> attr' <~> \attr -> withFocus (burstfire' skill attr)
  where
    burstfire' skill attr focusId = void . runMaybeT $ do
      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
      skillVal <- evalF skill
      attrVal <- evalF attr
      minStrRaw <- evalF $ val ignored ["Mindeststärke der Waffe"] False
      minStrMod <- evalF $ val ignored ["Mindeststärke der Waffe", "Modifikator"] False
      mod <- evalF $ val ignored ["Modifikator"] False
      let
        recoilMod = max 0 $ 10 + (minStr - attrVal) 
        minStr = minStrRaw + minStrMod
      lift . forM_ [1..nShots] $ \n -> do
        rollTest'' (Just $ fromIntegral mod) . return $ def
          & tName . iso CI.original CI.mk .~ printf "Schuss %2d" n
          & tBaseDifficulty .~ skillVal
          & tMod .~ (n - 1) * (-recoilMod)
          & tEffect .~ MaybeT . table . critTables "Fernkampfangriffe"