rudimentary state

1 files changed, 76 insertions, 1 deletions

diff --git a/src/Main.hs b/src/Main.hs
index e9e1deb..639673c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,2 +1,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 = undefined
+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)