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
|
{-# LANGUAGE ViewPatterns #-}
import Control.Monad
import Control.Lens
import System.Console.Shell
import System.Console.Shell.ShellMonad
import System.Console.Shell.Backend.Haskeline
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.Utils
import Text.Layout.Table
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 tip 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"
]
}
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 <~ use tip
blur = gFocus .= Nothing
-- Manual focus
setFocus :: Completable EntityIdentifier -> Sh GameState ()
setFocus = withArg $ \ident -> gFocus .= Just 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
|
