rudimentary state

6 files changed, 302 insertions, 6 deletions

diff --git a/default.nix b/default.nix
index ac19354..c96e43f 100644
--- a/default.nix
+++ b/default.nix
@@ -3,6 +3,60 @@
 }:
 
 rec {
-  haskellPackages = pkgs.haskell.packages."${compilerName}";
+  haskellPackages = pkgs.haskell.packages."${compilerName}".override {
+    overrides = self: super: {
+      Shellac = pkgs.haskell.lib.appendPatch super.Shellac (pkgs.writeText "build.patch" ''
+        From 29c78ed6549525fefb04ae6f7cab8316ac59f3c4 Mon Sep 17 00:00:00 2001
+        From: Gregor Kleen <gkleen@yggdrasil.li>
+        Date: Thu, 2 Jun 2016 17:14:15 +0200
+        Subject: [PATCH 1/2] Hiding <$> provided by newer versions of Prelude
+        
+        ---
+         src/System/Console/Shell/PPrint.hs | 1 +
+         1 file changed, 1 insertion(+)
+        
+        diff --git a/src/System/Console/Shell/PPrint.hs b/src/System/Console/Shell/PPrint.hs
+        index e8ec520..8d271e1 100644
+        --- a/src/System/Console/Shell/PPrint.hs
+        +++ b/src/System/Console/Shell/PPrint.hs
+        @@ -48,6 +48,7 @@ module System.Console.Shell.PPrint
+                 ) where
+         
+         import System.IO      (Handle,hPutStr,hPutChar,stdout)
+        +import Prelude hiding ((<$>))
+         
+         infixr 5 </>,<//>,<$>,<$$>
+         infixr 6 <>,<+>
+        -- 
+        2.8.0
+        
+        
+        From 74cb07ccfa92fdcdd6eb3c5871289796ea4981d5 Mon Sep 17 00:00:00 2001
+        From: Gregor Kleen <gkleen@yggdrasil.li>
+        Date: Thu, 2 Jun 2016 17:28:17 +0200
+        Subject: [PATCH 2/2] Applicative instance for Sh
+        
+        ---
+         src/System/Console/Shell/Types.hs | 2 +-
+         1 file changed, 1 insertion(+), 1 deletion(-)
+        
+        diff --git a/src/System/Console/Shell/Types.hs b/src/System/Console/Shell/Types.hs
+        index 4ec47a9..9efe4b4 100644
+        --- a/src/System/Console/Shell/Types.hs
+        +++ b/src/System/Console/Shell/Types.hs
+        @@ -74,7 +74,7 @@ type OutputCommand = BackendOutput -> IO ()
+         --   The type parameter @st@ allows the monad to carry around a package of
+         --   user-defined state.
+         newtype Sh st a = Sh { unSh :: StateT (CommandResult st) (ReaderT OutputCommand IO) a }
+        -   deriving (Monad, MonadIO, MonadFix, Functor)
+        +   deriving (Monad, MonadIO, MonadFix, Functor, Applicative)
+         
+         ------------------------------------------------------------------------
+         -- The shell description and utility functions
+        -- 
+        2.8.0
+      '');
+    };
+  };
   sequence = haskellPackages.callPackage ./sequence.nix {};
 }
diff --git a/sequence.cabal b/sequence.cabal
index 0cea160..3d9e66f 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -17,8 +17,21 @@ cabal-version:       >=1.10
 
 executable sequence
   main-is:             Main.hs
-  -- other-modules:       
+  other-modules:       Sequence.Types
   -- other-extensions:    
-  build-depends:       base >=4.8 && <4.9
+  build-depends:       base >=4.8 && <5
+                     , Shellac
+                     , Shellac-haskeline
+                     , data-default
+                     , xdg-basedir
+                     , filepath
+                     , directory
+                     , containers
+                     , case-insensitive
+                     , lens
+                     , bimap
+                     , mtl
+                     , table-layout
+                     , game-probability
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index 612eb30..4533ad2 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,10 +1,17 @@
-{ mkDerivation, base, stdenv }:
+{ mkDerivation, base, bimap, case-insensitive, containers
+, data-default, directory, filepath, game-probability, lens, mtl
+, Shellac, Shellac-haskeline, stdenv, table-layout, xdg-basedir
+}:
 mkDerivation {
   pname = "sequence";
   version = "0.0.0";
   src = ./.;
   isLibrary = false;
   isExecutable = true;
-  executableHaskellDepends = [ base ];
+  executableHaskellDepends = [
+    base bimap case-insensitive containers data-default directory
+    filepath game-probability lens mtl Shellac Shellac-haskeline
+    table-layout xdg-basedir
+  ];
   license = stdenv.lib.licenses.mit;
 }
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)