1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
{-# LANGUAGE ViewPatterns, RecordWildCards #-}
import Control.Monad
import Control.Lens
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
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Bimap (Bimap)
import qualified Data.Bimap as Bimap
import Data.List
import Data.List
import Data.Maybe
import Data.Function
import Control.Monad.State.Strict
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)
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 = gets stateOutline >>= (\str -> if null str then return () else shellPutStrLn 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 "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 "roll" rollTest "Roll a test using the stats of the currently focused entity"
]
}
void $ runShell description haskelineBackend (def :: GameState)
stateOutline :: GameState -> String
stateOutline st
| null pQueue = ""
| otherwise = layoutTableToString rowGs (Just ("" : factions, repeat def)) (repeat def) unicodeBoldHeaderS
where
factions = map (view faction') $ st ^. inhabitedFactions
pQueue = st ^. priorityQueue
protoRows = groupBy ((==) `on` fst) pQueue
faction id = fromJust $ view eFaction <$> Map.lookup id (st ^. gEntities)
factionIndex id = fromJust $ elemIndex (view faction' $ faction id) factions
rowGs = do
rowGroup'@((seqVal', _):_) <- protoRows
let
rowGroup = map snd rowGroup'
factionColumn i = [evalState ?? st $ toName x | x <- rowGroup, factionIndex x == i ]
return . colsAllG top $ [show (seqVal' ^. seqVal)] : map factionColumn [0..(length factions - 1)]
-- Query state
listFactions, listEntities :: Sh GameState ()
listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction')
listEntities = use (gEntities . to Map.keys) >>= mapM_ (shellPutStrLn <=< toName)
-- 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
-- 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)
-- 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
(newStats, result) <- evalFormula (view eStats focus) (enactTest =<< test)
gFocus'.eStats .= newStats
return result
|
