1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
{-# LANGUAGE RecordWildCards, RankNTypes, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, ViewPatterns, TypeFamilies, GADTs, TypeOperators, ExistentialQuantification, FlexibleContexts #-}
module Sequence.Formula
( FormulaM, Formula, quot'
, (:<:)(..), Context(..), ctx
, evalFormula, evalFormula'
, val
, d, z
, Table, table
) where
import Control.Lens hiding (Context(..))
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
import Sequence.Utils.Ask
import Text.Read (readMaybe)
import Data.Bool
import Data.List
import Data.Maybe
import Data.Either
import Data.Tuple
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
class (:<:) small large where
ctx' :: Traversal' large small
instance a :<: a where
ctx' = simple
instance a :<: (a, a) where
ctx' = both
instance a :<: (a, b) where
ctx' = _1
instance a :<: (b, a) where
ctx' = _2
instance () :<: a where
ctx' = united
data Context small = forall large. (small :<: large) => Context large
ctx :: Traversal' (Context input) input
ctx modifySmall (Context large) = Context <$> ctx' modifySmall large
type FormulaM input a = StateT (Set String) (ReaderT (Context 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
, keepResult :: Bool
}
instance Eq (Question a) where
(==) _ _ = True
instance Ord (Question a) where
(<=) _ _ = True
instance Show (Question a) where
show Question{..} = show prompt
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 = do n <- x
sum <$> replicateM (fromIntegral n) y
fromInteger = return . fromInteger
quot' :: Integral a => FormulaM input a -> FormulaM input a -> FormulaM input a
quot' = liftM2 quot
askQuestion :: (MonadIO m, sInput :<: lInput) => String -> lInput -> Question sInput -> m lInput
askQuestion promptPref input q@(Question{..}) = flip (set $ ctx' . answer) input . maybe (throwError q) return <$> askQ (promptPref' ++ prompt) (join . fmap readMaybe)
where
promptPref'
| null promptPref = ""
| otherwise = promptPref ++ " » "
evalFormula :: (MonadIO m, sInput :<: lInput) => String -> lInput -> FormulaM sInput a -> m (lInput, a)
evalFormula = evalFormula' []
where
evalFormula' finalChanges promptPref input formula = do
result <- liftIO . enact . runExceptT . (runReaderT ?? (Context input)) . (evalStateT ?? Set.empty) $ formula
case result of
Left q@(Question{..}) -> askQuestion promptPref input q >>= flip (flip evalFormula' promptPref $ bool (pure . set (ctx' . answer) $ throwError q) mempty keepResult ++ finalChanges) formula
Right result -> return (foldr ($) input finalChanges, result)
evalFormula' :: (MonadIO m, sInput :<: lInput, MonadState lInput m) => String -> FormulaM sInput a -> m a
evalFormula' promptPref formula = uncurry (<$) . over _2 put . swap =<< flip (evalFormula promptPref) formula =<< get
val :: Integral a => Traversal' input (Formula input) -> String -> Bool -> Formula input
val answer prompt keepResult = do
gets (Set.member prompt) >>= bool (modify $ Set.insert prompt) (modify (Set.delete prompt) >> throwError Question{..})
preview (ctx . answer) >>= maybe (throwError Question{..}) id
d, z :: Integral a => Int -> FormulaM input a
d n = liftBase . fmap fromIntegral $ D.d n
z n = liftBase . fmap fromIntegral $ D.z n
type Table a = Map a Rational
table :: Ord a => Table a -> FormulaM input a
table = liftBase . makeEventProb . Map.assocs
|
