From e66d94505776ec13259bedde4e5342985322a482 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 8 May 2016 02:09:04 +0200 Subject: Feature completion --- src/Command.hs | 7 +++++-- src/Main.hs | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---- src/Types.hs | 4 +++- src/Utils.hs | 20 +++++-------------- 4 files changed, 71 insertions(+), 22 deletions(-) diff --git a/src/Command.hs b/src/Command.hs index 659d14d..127e986 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -19,6 +19,9 @@ import qualified Data.Text as Text import Data.Maybe (fromMaybe) +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + import Types data Cmd = PerformAlt Alteration Comment @@ -85,7 +88,7 @@ parseCmd' args = do cmdParser :: Maybe Entity -> Parser Cmd cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDesc "Exit gracefully" - , command "dump" $ pure Dump `info` progDesc "Print all internal state in a format not necessarily human readable" + , command "list" $ pure Dump `info` progDesc "Print a list of tracked entities" , command "history" $ parseHistory `info` progDesc "Print an excerpt of combat history" , command "who" $ pure ShowTip `info` progDesc "Who’s turn is it?" , command "set" $ parseOverride `info` progDesc "Set an entities sequence value" @@ -116,7 +119,7 @@ cmdParser tip = hsubparser $ mconcat [ command "quit" $ pure Quit `info` progDes entity | (Just tip') <- tip = fromMaybe tip' <$> optional entity' | otherwise = entity' - entity' = Entity <$> (Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (argument positive $ help "Number of the target entity" <> metavar "NUMBER") + entity' = Entity <$> (CI.mk . Text.pack <$> strArgument (help "Name of the target entity" <> metavar "NAME")) <*> optional (option positive $ long "number" <> short 'n' <> help "Number of the target entity" <> metavar "NUMBER") sequenceValue = argument auto (help "Sequence value adjustment" <> metavar "SEQUENCE") sequenceValue' = argument auto (help "Sequence value" <> metavar "SEQUENCE") diff --git a/src/Main.hs b/src/Main.hs index 86c8771..4429853 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts, ViewPatterns, OverloadedStrings, TupleSections #-} import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as MaxPQueue @@ -9,8 +9,11 @@ import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text +import Data.Set (Set) +import qualified Data.Set as Set + import Data.Default.Class -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing, fromJust) import System.Environment.XDG.BaseDir (getUserCacheFile) import System.Environment (getProgName) @@ -54,7 +57,7 @@ runCli = do Quit -> liftIO exitSuccess - Dump -> get >>= outputStrLn . show + Dump -> gets ctxSequence >>= mapM_ (outputStrLn . showAssoc) . MaxPQueue.toDescList ShowTip -> do tip <- fmap snd <$> gets (MaxPQueue.getMax . ctxSequence) case tip of @@ -63,6 +66,57 @@ runCli = do ShowHistory ns -> do let sel = maybe id takeR ns mapM_ (outputStrLn . show) =<< sel <$> gets ctxHistory - PerformAlt alt comment -> apply' alt comment + PerformAlt alt comment -> apply alt comment _ -> undefined runCli + +showAssoc :: (SequenceValue, Entity) -> String +showAssoc (val, entity) = show val <> "\t" <> (Text.unpack $ showEntity entity) + + +apply :: SequenceM m => Alteration -> Comment -> InputT m () +apply alteration comment = alter alteration >> modify (\ctx -> ctx { ctxHistory = ctxHistory ctx |> (alteration, comment) }) + +alter :: SequenceM m => Alteration -> InputT m () +alter (Modify entity ((+) -> mod)) = alterMatching entity mod +alter (Override entity (const -> mod)) = alterMatching entity mod +alter (Rename old new) = do + [(k, _)] <- filter (\(_, v) -> v == old) <$> gets (MaxPQueue.assocsU . ctxSequence) + alter (Drop old) + alter (Insert new k) +alter (Drop entity) = do + (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence + modify $ \ctx -> ctx { ctxSequence = notMatching } + when (MaxPQueue.null matching) warnEmpty +alter (Insert entity val) = do + modify $ \ctx -> ctx { ctxSequence = MaxPQueue.insert val entity $ ctxSequence ctx } + introduceNumbering entity + + +alterMatching :: SequenceM m => Entity -> (SequenceValue -> SequenceValue) -> InputT m () +alterMatching entity mod = do + (matching, notMatching) <- MaxPQueue.partition (== entity) <$> gets ctxSequence + modify $ \ctx -> ctx { ctxSequence = notMatching `MaxPQueue.union` MaxPQueue.mapKeys mod matching } + when (MaxPQueue.null matching) warnEmpty + +introduceNumbering :: SequenceM m => Entity -> InputT m () +introduceNumbering entity = do + let + matches (Entity name _) (Entity name' _) = name == name' + (matching, notMatching) <- MaxPQueue.partition (matches entity) <$> gets ctxSequence + if MaxPQueue.size matching <= 1 + then return () + else do + let + (matching', notMatching') = MaxPQueue.partition (\(Entity _ n) -> isNothing n) matching + maxN = MaxPQueue.foldrU (\(Entity _ n) -> max n) (Just 0) notMatching' + modify $ \ctx -> ctx { ctxSequence = snd $ MaxPQueue.foldrWithKey accum (fromJust maxN, MaxPQueue.union notMatching notMatching') matching' } + if MaxPQueue.null notMatching' + then outputStrLn $ "Had to introduce a numbering scheme to differentiate multiple entities called »" <> (Text.unpack $ showEntity entity) <> "«" + else outputStrLn $ "Inserted new entity called »" <> (Text.unpack $ showEntity entity) <> "« into existing numbering scheme" + where + accum key (Entity val _) (n, queue) = (succ n, MaxPQueue.insert key (Entity val $ Just (succ n)) queue) + +warnEmpty :: MonadIO m => InputT m () +warnEmpty = outputStrLn "Selection did not match any entities" + diff --git a/src/Types.hs b/src/Types.hs index a90e5fe..031d2d5 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -22,6 +22,8 @@ import Data.Text (Text) import Data.Default.Class +import Data.CaseInsensitive (CI) + import Control.Monad.State.Strict (MonadState(..), MonadTrans(..)) import Control.Monad.Writer.Strict (MonadWriter, MonadTrans(..)) @@ -30,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO) import System.Console.Haskeline (InputT) -data Entity = Entity Text (Maybe Integer) +data Entity = Entity (CI Text) (Maybe Integer) deriving (Eq, Ord, Show) type SequenceValue = Integer diff --git a/src/Utils.hs b/src/Utils.hs index cac88ac..b98359a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -2,8 +2,6 @@ module Utils ( showEntity - , apply, apply' - , entities , takeR ) where @@ -24,23 +22,15 @@ import qualified Data.Set as Set import Data.Sequence (Seq, ViewR(..), (|>)) import qualified Data.Sequence as Seq +import Data.CaseInsensitive ( CI ) +import qualified Data.CaseInsensitive as CI + import Types showEntity :: Entity -> Text showEntity (Entity name number) - | (Just (show -> n)) <- number = name <> " № " <> Text.pack n - | otherwise = name - -apply' :: MonadState Context m => Alteration -> Comment -> m () -apply' alteration comment = modify $ onCtx (apply alteration comment) - where - onCtx f ctx = let (sequence', history') = f $ ctxSequence ctx in ctx { ctxSequence = sequence', ctxHistory = ctxHistory ctx <> history' } - -apply :: Alteration -> Comment -> Sequence -> (Sequence, History) -apply alteration comment seq = undefined - -entities :: MonadState Sequence m => m (Set Entity) -entities = Set.fromList . MaxPQueue.elems <$> get + | (Just (show -> n)) <- number = CI.original name <> " № " <> Text.pack n + | otherwise = CI.original name takeR :: Integer -> Seq a -> Seq a takeR _ (Seq.viewr -> EmptyR) = Seq.empty -- cgit v1.2.3