src/Main.hs


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

{-# 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 . snd <$> (listToMaybe $ view priorityQueue 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"
                                    ]
                  }
  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 (Completable (flip (set faction') def -> 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)