From f434263fcce697f29c668a1c9ac2f05a1de1012c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 5 Jun 2016 02:11:43 +0200 Subject: more pretty --- sequence.cabal | 1 + sequence.nix | 12 ++++++------ src/Main.hs | 19 +++++++++++++++++-- src/Sequence/Contact/Archetypes.hs | 2 +- src/Sequence/Contact/Tests.hs | 14 +++++++++----- 5 files changed, 34 insertions(+), 14 deletions(-) diff --git a/sequence.cabal b/sequence.cabal index 11e3273..b721848 100644 --- a/sequence.cabal +++ b/sequence.cabal @@ -36,5 +36,6 @@ executable sequence , readline , transformers , transformers-base + , ansi-terminal hs-source-dirs: src default-language: Haskell2010 \ No newline at end of file diff --git a/sequence.nix b/sequence.nix index 7b46a9d..5e8a130 100644 --- a/sequence.nix +++ b/sequence.nix @@ -1,7 +1,7 @@ -{ mkDerivation, base, bimap, case-insensitive, containers -, data-default, directory, filepath, game-probability, lens, mtl -, readline, Shellac, Shellac-haskeline, stdenv, table-layout -, transformers, transformers-base, xdg-basedir +{ mkDerivation, ansi-terminal, base, bimap, case-insensitive +, containers, data-default, directory, filepath, game-probability +, lens, mtl, readline, Shellac, Shellac-haskeline, stdenv +, table-layout, transformers, transformers-base, xdg-basedir }: mkDerivation { pname = "sequence"; @@ -10,8 +10,8 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base bimap case-insensitive containers data-default directory - filepath game-probability lens mtl readline Shellac + ansi-terminal base bimap case-insensitive containers data-default + directory filepath game-probability lens mtl readline Shellac Shellac-haskeline table-layout transformers transformers-base xdg-basedir ]; diff --git a/src/Main.hs b/src/Main.hs index c6eee62..06cc6ed 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns, RecordWildCards #-} import Control.Monad @@ -7,6 +7,7 @@ import Control.Lens import System.Console.Shell import System.Console.Shell.ShellMonad import System.Console.Shell.Backend.Haskeline +import System.Console.ANSI (setSGRCode, SGR(..), ConsoleLayer(..), ConsoleIntensity(..), ColorIntensity(..), Color(..)) import System.Environment.XDG.BaseDir import System.FilePath @@ -126,8 +127,22 @@ nameEntity :: String -> Sh GameState () nameEntity ('#':_) = shellPutErrLn "We do not allow names that might shadow explicit access to entities via their number (‘#’)" nameEntity name = withFocus $ \ident -> modifying gEntityNames $ Bimap.insert ident (name ^. entityName) +-- Dice rolls rollTest :: Completable (FormulaM Stats Test) -> Sh GameState () -rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . show) +rollTest = withArg $ enactTest' >=> maybe (return ()) (shellPutStrLn . ppResult) + where + ppResult result = pad 3 (show $ result^.rWith) ++ ": " ++ setSGRCode (colour result) ++ name result ++ setSGRCode [] ++ " by " ++ pad 2 (show $ result^.rBy) ++ "pp" + colour CritSuccess{..} = [SetColor Foreground Vivid Green, SetConsoleIntensity BoldIntensity] + colour Success{..} = [SetColor Foreground Dull Green] + colour Failure{..} = [SetColor Foreground Dull Red] + colour CritFailure{..} = [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] + name CritSuccess{..} = "Critical Success" + name Success{..} = "Success" + name Failure{..} = "Failure" + name CritFailure{..} = "Critical Failure" + pad n str + | length str >= n = str + | otherwise = ' ' : pad (n - 1) str enactTest' :: (FormulaM Stats Test) -> Sh GameState (Maybe TestResult) enactTest' test = withFocus' $ \focus -> do diff --git a/src/Sequence/Contact/Archetypes.hs b/src/Sequence/Contact/Archetypes.hs index 3b014e4..8eb9dd7 100644 --- a/src/Sequence/Contact/Archetypes.hs +++ b/src/Sequence/Contact/Archetypes.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI instance Completion Entity GameState where completableLabel _ = "" - complete _ _ (CI.foldCase -> prefix) = return . filter (prefix `isPrefixOf`) . map CI.foldedCase $ Map.keys archetypes + complete _ _ (CI.foldCase -> prefix) = return . map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) $ Map.keys archetypes instance Argument Entity GameState where arg = return . fmap (flip (set eStats) def) . flip Map.lookup archetypes . CI.mk diff --git a/src/Sequence/Contact/Tests.hs b/src/Sequence/Contact/Tests.hs index 86f72b5..8aa072a 100644 --- a/src/Sequence/Contact/Tests.hs +++ b/src/Sequence/Contact/Tests.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TemplateHaskell, OverloadedStrings, OverloadedLists, ViewPatterns, MultiParamTypeClasses, FlexibleContexts, RankNTypes, TypeSynonymInstances, FlexibleInstances, ImpredicativeTypes #-} module Sequence.Contact.Tests - ( TestResult(..) - , Test + ( TestResult(..), rWith, rBy + , Test, tCritSuccessMod, tCritFailureMod, tBaseDifficulty, tMod , enactTest ) where @@ -55,12 +55,16 @@ instance Default Test where } tests :: MonadReader Stats m => m (Map (CI String) (FormulaM Stats Test)) -tests = mconcat <$> sequence [ test "Stärke" (sAStrength . attributeTest) +tests = mconcat <$> sequence [ test "Stärke" $ sAStrength . attributeTest + + , test "Archaische Distanzwaffen" $ sSArchaicRanged . skillTest + + , test "Beißen" $ sSBiting . skillTest ] where test k v = maybe mempty (Map.singleton k) <$> preview v - -- skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) + skillTest = to (\x -> flip (set tBaseDifficulty) def <$> x) attributeTest = to (\x -> flip (set tBaseDifficulty) def . (* 10) <$> x) @@ -71,7 +75,7 @@ getTest (CI.mk -> str) = folding tests' instance Completion (FormulaM Stats Test) GameState where completableLabel _ = "" - complete _ st (CI.foldCase -> prefix) = return . fromMaybe [] . fmap (filter (prefix `isPrefixOf`) . map CI.foldedCase . Map.keys) $ previews (gFocus' . eStats) tests st + complete _ st (CI.foldCase -> prefix) = return . fromMaybe [] . fmap (map CI.original . filter ((prefix `isPrefixOf`) . CI.foldedCase) . Map.keys) $ previews (gFocus' . eStats) tests st instance Argument (FormulaM Stats Test) GameState where arg str = join <$> preuses (gFocus' . eStats) (preview (getTest str)) -- cgit v1.2.3