{-# 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.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 (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 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" ] , 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 (‘#’)" 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 (‘#’)" | otherwise = do let nameTemplate' = templateSafe $ Text.pack nameTemplate case nameTemplate' of Left _ -> shellPutErrLn "Invalid template – ‘$n’ gets replaced by [1..], ‘$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 $ maybe (return ()) ((>>) <$> outputResult <*> applyEffect) <=< enactTest' 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 (test, view rResult -> (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 effect) lift . outputLogged focusId $ test ++ " effects: " ++ effectDesc enactTest' :: FormulaM Stats Test -> Sh GameState (Maybe (String, TestResult)) enactTest' test = runMaybeT $ do focusName <- MaybeT (use gFocus) >>= lift . toName let evalF = MaybeT . focusState (gFocus' . eStats) . evalFormula' [focusName] test' <- evalF test result <- evalF $ enactTest 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 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: %.2f" maxLength (CI.original str) (fromRational avg :: Double) Nothing -> return () mapM_ printAvg $ Map.toList sheet