From 1b7f21ba636e4034f76495deafd0ac6ca9758a4e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 2 Jun 2016 23:29:36 +0200 Subject: rudimentary state --- src/Main.hs | 77 +++++++++++++++++++++++++++++++++++++- src/Sequence/Types.hs | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/Sequence/Utils.hs | 46 +++++++++++++++++++++++ 3 files changed, 223 insertions(+), 1 deletion(-) create mode 100644 src/Sequence/Types.hs create mode 100644 src/Sequence/Utils.hs (limited to 'src') 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 _ = "" + complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . map ((evalState ?? st) . toName) . Map.keys $ st ^. gEntities + +instance Completion Faction GameState where + completableLabel _ = "" + complete _ st prefix = return . filter ((isPrefixOf `on` CI.foldCase) prefix) . nub . sort $ unaligned : map (view faction') (st ^. inhabitedFactions) -- cgit v1.2.3