rudimentary state

3 files changed, 223 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)
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
new file mode 100644
index 0000000..afe1060
--- /dev/null
+++ b/src/Sequence/Types.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, ViewPatterns, OverloadedStrings, TemplateHaskell, GeneralizedNewtypeDeriving #-}
+
+module Sequence.Types
+  ( GameState(..), gEntities, gEntityNames
+  , Faction, faction, faction'
+  , SeqVal(..), seqVal
+  , Entity(..), eFaction, eSeqVal
+  , EntityName(..), entityName
+  , EntityIdentifier(..), entityId
+  , inhabitedFactions, priorityQueue
+  ) where
+
+import Control.Lens
+
+import System.Console.Shell
+
+import Data.Default
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+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.Maybe
+import Data.Tuple
+import Data.Ord
+  
+
+newtype Faction = Faction { _lFaction :: Maybe (CI String) }
+  deriving (Show, Eq, Ord)
+makeLenses ''Faction
+
+instance Default Faction where
+  def = Faction Nothing
+
+unaligned :: CI String
+unaligned = "Unaligned"
+
+faction :: Getter Faction (Maybe (CI String))
+faction = lFaction
+
+faction' :: Lens' Faction String
+faction' = lens (CI.original . fromMaybe unaligned . view faction) (\s a -> s { _lFaction = parseFaction a })
+  where
+    parseFaction str@(CI.mk -> str')
+      | str' == unaligned = Nothing
+      | null str          = Nothing
+      | otherwise         = Just str'
+
+
+newtype SeqVal = SeqVal { _seqVal :: Integer }
+  deriving (Show, Ord, Eq, Num, Integral, Enum, Real)
+makeLenses ''SeqVal
+  
+
+data Entity = Entity
+              { _eFaction :: Faction
+              , _eSeqVal :: Maybe SeqVal
+              }
+  deriving (Show)
+makeLenses ''Entity
+
+instance Default Entity where
+  def = Entity
+        { _eFaction = def
+        , _eSeqVal = def
+        }
+
+newtype EntityName = EntityName { _entityName :: CI String }
+  deriving (Show, Eq, Ord)
+makeLenses ''EntityName
+
+newtype EntityIdentifier = EntityIdentifier { _entityId :: Integer }
+  deriving (Show, Eq, Ord)
+makeLenses ''EntityIdentifier
+
+data GameState = GameState
+                 { _gEntities    :: Map EntityIdentifier Entity
+                 , _gEntityNames :: Bimap EntityIdentifier EntityName
+                 }
+makeLenses ''GameState
+
+instance Default GameState where
+  def = GameState
+        { _gEntities = def
+        , _gEntityNames = Bimap.empty
+        }
+
+inhabitedFactions :: Getter GameState [Faction]
+inhabitedFactions = to $ nub . sort . Map.elems . fmap (view eFaction) . view gEntities
+
+priorityQueue :: Getter GameState [(SeqVal, EntityIdentifier)]
+priorityQueue = to priorityQueue'
+  where
+    priorityQueue' (Map.toAscList . view gEntities -> entities) = sortBy (comparing $ Down . snd) . concat . map filter . map (over _1 $ view eSeqVal) . map swap $ entities
+    filter (Nothing, _) = mempty
+    filter (Just val, id) = pure (val, id)
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
new file mode 100644
index 0000000..7d28b83
--- /dev/null
+++ b/src/Sequence/Utils.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE ViewPatterns, FlexibleContexts, MultiParamTypeClasses #-}
+
+module Sequence.Utils
+  ( toName, fromName
+  ) where
+
+import Sequence.Types
+
+import Control.Monad.State.Strict
+
+import Control.Lens
+
+import Data.Bimap (Bimap)
+import qualified Data.Bimap as Bimap
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import Data.Function
+import Data.Default
+import Data.Maybe
+import Text.Read
+
+import Data.List
+
+import System.Console.Shell
+
+unaligned = view faction' def
+  
+toName :: MonadState GameState m => EntityIdentifier -> m String
+toName id = fromMaybe (show $ id ^. entityId) . fmap (CI.original . view entityName) . Bimap.lookup id <$> use gEntityNames
+
+fromName :: MonadState GameState m => String -> m (Maybe EntityIdentifier)
+fromName (readMaybe -> n@(Just _)) = return $ EntityIdentifier <$> n
+fromName (EntityName . CI.mk -> name) = Bimap.lookupR name <$> use gEntityNames
+
+instance Completion EntityIdentifier GameState where
+  completableLabel _ = "<entity>"
+  complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities
+
+instance Completion Faction GameState where
+  completableLabel _ = "<faction>"
+  complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions)