more pretty

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 (‘#<n>’)"
 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 _ = "<archetype>"
-  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 _ = "<test>"
-  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))