probibilistic computations

4 files changed, 50 insertions, 3 deletions

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