rudimentary state

2 files changed, 147 insertions, 0 deletions

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)