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
|
{-# 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.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 "factions" listFactions "List all inhabited factions"
, cmd "members" listFaction "List all members of a faction"
, cmd "entities" listEntities "List all entities"
, cmd "align" alignEntity "Align an 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)]
listFaction :: Completable Faction -> Sh GameState ()
listFaction = withArg $ \qFaction -> use gEntities >>= mapM_ (shellPutStrLn <=< toName) . Map.keys . Map.filter ((==) qFaction . view eFaction)
listFactions :: Sh GameState ()
listFactions = use inhabitedFactions >>= mapM_ (shellPutStrLn . view faction')
listEntities :: Sh GameState ()
listEntities = use (gEntities . to Map.keys) >>= mapM_ (shellPutStrLn <=< toName)
alignEntity :: Completable EntityIdentifier -> Completable Faction -> Sh GameState ()
alignEntity ident' nFaction' = flip withArg nFaction' $ \nFaction -> flip withArg ident' $ \ident -> do
gEntities %= Map.adjust (set eFaction nFaction) ident
|
