From bf7b92a4daff86e3853b1005dcd18c94d14ac362 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 5 Jun 2016 01:35:13 +0200
Subject: Prevent infinite recursion (crudely)

---
 src/Sequence/Formula.hs | 23 +++++++++++++++--------
 1 file changed, 15 insertions(+), 8 deletions(-)

(limited to 'src/Sequence')

diff --git a/src/Sequence/Formula.hs b/src/Sequence/Formula.hs
index c3e9e33..7fb4ccb 100644
--- a/src/Sequence/Formula.hs
+++ b/src/Sequence/Formula.hs
@@ -13,6 +13,8 @@ import Data.Data.Lens
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Base
 import Numeric.Probability.Game.Event
 import qualified Numeric.Probability.Game.Dice as D
 
@@ -25,13 +27,17 @@ import Data.List
 import Data.Maybe
 import Data.Either
 
-import Debug.Trace
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 
-type FormulaM input a = ReaderT input (ExceptT (Question input) EventM) a
+type FormulaM input a = StateT (Set String) (ReaderT input (ExceptT (Question input) EventM)) a
 
 type Formula input = FormulaM input Int
 
+instance MonadBase EventM EventM where
+  liftBase = id
+
 data Question input = Question
                       { answer :: Traversal' input (Formula input)
                       , prompt :: String
@@ -66,15 +72,16 @@ askQuestion input q@(Question{..}) = flip (set answer) input . maybe (throwError
 evalFormula :: (MonadIO m, Ord a, Show a) => input -> FormulaM input a -> m (input, a)
 evalFormula = evalFormula' []
   where
-    evalFormula' finalChanges input formula = trace "evalFormula'" $ do
-      result <- liftIO . enact . traceShowId . runExceptT . (runReaderT ?? input) $ formula
-      liftIO . traceIO $ show (isLeft result, isRight result)
+    evalFormula' finalChanges input formula = do
+      result <- liftIO . enact . runExceptT . (runReaderT ?? input) . (evalStateT ?? Set.empty) $ formula
       case result of
         Left q@(Question{..}) -> askQuestion input q >>= flip (evalFormula' $ bool (pure . set answer $ throwError q) mempty keepResult ++ finalChanges) formula
         Right result -> return (foldr ($) input finalChanges, result)
 
 val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
-val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}) id . trace "val"
+val answer prompt keepResult = do
+  gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (throwError Question{..})
+  preview answer >>= maybe (throwError Question{..}) id
 
 -- viewL :: Lens' lInput sInput -> Prism' (FormulaM sInput a) (FormulaM lInput a)
 -- viewL lTrav = iso asL asS
@@ -87,5 +94,5 @@ val answer prompt keepResult = preview answer >>= maybe (throwError Question{..}
 -- val' lTrav sTrav prompt keepResult = preview (lTrav . sTrav . viewL lTrav) >>= maybe (throwError Question{ answer = lTrav . sTrav . viewL lTrav, ..}) id
 
 d, z :: Integral a => Int -> FormulaM input a
-d n = lift . lift . fmap fromIntegral $ D.d n
-z n = lift . lift . fmap fromIntegral $ D.z n
+d n = liftBase . fmap fromIntegral $ D.d n
+z n = liftBase . fmap fromIntegral $ D.z n
-- 
cgit v1.2.3