probibilistic computations

6 files changed, 54 insertions, 6 deletions

diff --git a/sequence.cabal b/sequence.cabal
index ada1546..c7c58e4 100644
--- a/sequence.cabal
+++ b/sequence.cabal
@@ -34,5 +34,6 @@ executable sequence
                      , table-layout
                      , game-probability
                      , readline
+                     , either
   hs-source-dirs:      src
   default-language:    Haskell2010
\ No newline at end of file
diff --git a/sequence.nix b/sequence.nix
index ff36401..a272486 100644
--- a/sequence.nix
+++ b/sequence.nix
@@ -1,6 +1,6 @@
 { mkDerivation, base, bimap, case-insensitive, containers
-, data-default, directory, filepath, game-probability, lens, mtl
-, readline, Shellac, Shellac-haskeline, stdenv, table-layout
+, data-default, directory, either, filepath, game-probability, lens
+, mtl, readline, Shellac, Shellac-haskeline, stdenv, table-layout
 , xdg-basedir
 }:
 mkDerivation {
@@ -11,7 +11,7 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [
     base bimap case-insensitive containers data-default directory
-    filepath game-probability lens mtl readline Shellac
+    either filepath game-probability lens mtl readline Shellac
     Shellac-haskeline table-layout xdg-basedir
   ];
   license = stdenv.lib.licenses.mit;
diff --git a/src/Main.hs b/src/Main.hs
index 96e3fef..8f955bb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -33,6 +33,7 @@ import Control.Monad.State.Strict
 
 import Sequence.Types
 import Sequence.Utils
+import Sequence.Formula
 
 import Text.Layout.Table
 
diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
new file mode 100644
index 0000000..7a6e689
--- /dev/null
+++ b/src/Sequence/Formula.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances #-}
+
+module Sequence.Formula
+  ( FormulaM
+  , evalFormula
+  , val
+  ) where
+
+import Control.Lens
+
+import Control.Monad.Trans.Either
+import Control.Monad.Reader
+import Numeric.Probability.Game.Event
+
+import Sequence.Utils
+
+import Text.Read (readMaybe)
+
+type FormulaM input a = ReaderT input (EitherT (Question input) EventM) a
+
+data Question input = Question
+                      { answer :: Lens' input (Maybe Int)
+                      , prompt :: String
+                      }
+
+instance Integral a => Num (FormulaM input a) where
+  (+) x y = (+) <$> x <*> y
+  (-) x y = (-) <$> x <*> y
+  negate = fmap negate
+  abs = fmap abs
+  signum = fmap signum
+  (*) x y = sum <$> (flip replicateM y =<< fromIntegral <$> x)
+  fromInteger = return . fromInteger
+
+askQuestion :: MonadIO m => input -> (Question input) -> m input
+askQuestion input q@(Question{..}) = flip (set answer) input <$> askQ prompt (join . fmap readMaybe)
+
+evalFormula :: MonadIO m => input -> FormulaM input a -> m a
+evalFormula input formula = do
+  result <- liftIO . enact . runEitherT . (runReaderT ?? input) $ formula
+  case result of
+    Left q -> askQuestion input q >>= flip evalFormula formula
+    Right result -> return result
+
+val :: Integral a => Lens' input (Maybe Int) -> String -> FormulaM input Int
+val answer prompt = view answer >>= maybe (lift . left $ Question{..}) return
diff --git a/src/Sequence/Types.hs b/src/Sequence/Types.hs
index 8895569..55c9013 100644
--- a/src/Sequence/Types.hs
+++ b/src/Sequence/Types.hs
@@ -52,7 +52,7 @@ faction' = lens (CI.original . fromMaybe unaligned . view faction) (\s a -> s {
       | otherwise         = Just str'
 
 
-newtype SeqVal = SeqVal { _seqVal :: Integer }
+newtype SeqVal = SeqVal { _seqVal :: Int }
   deriving (Show, Ord, Eq, Num, Integral, Enum, Real)
 makeLenses ''SeqVal
   
diff --git a/src/Sequence/Utils.hs b/src/Sequence/Utils.hs
index 32f8239..f0a8849 100644
--- a/src/Sequence/Utils.hs
+++ b/src/Sequence/Utils.hs
@@ -49,7 +49,7 @@ withFocus f = use gFocus >>= \focus -> case focus of
   Nothing -> shellPutErrLn $ "Currently not focusing any entity"
   Just id -> f id
 
-askBool :: String -> Bool -> Sh st Bool
+askBool :: MonadIO m => String -> Bool -> m Bool
 askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . CI.mk)
   where
     eval "yes" = Just True
@@ -58,7 +58,7 @@ askBool prompt initial = askQ prompt $ fromMaybe initial . join . fmap (eval . C
     eval "n" = Just False
     eval _ = Nothing
 
-askQ :: String -> (Maybe String -> a) -> Sh st a
+askQ :: MonadIO m => String -> (Maybe String -> a) -> m a
 askQ prompt eval = eval <$> liftIO (readline $ prompt ++ " ")
   
 unaligned = view faction' def