From a98cd5d87a0c7959146a8ca35aa40f42fc146ad8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 3 Jun 2016 13:53:38 +0200
Subject: probibilistic computations

---
 src/Sequence/Formula.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 src/Sequence/Types.hs   |  2 +-
 src/Sequence/Utils.hs   |  4 ++--
 3 files changed, 49 insertions(+), 3 deletions(-)
 create mode 100644 src/Sequence/Formula.hs

(limited to 'src/Sequence')

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
-- 
cgit v1.2.3