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 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 46 insertions(+)
 create mode 100644 src/Sequence/Formula.hs

(limited to 'src/Sequence/Formula.hs')

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