module Task.MagicTrick.Assess where
import Data.Monoid
import qualified Data.List.NonEmpty as N
import qualified Data.Semigroup as SG
import Domain.Math.Expr
import Ideas.Common.Id hiding ((<>))
import Recognize.Data.Approach
import Recognize.Data.Attribute
import Bayes.Evidence
import Recognize.Data.Op
import Recognize.Data.RuleId
import Recognize.Data.Diagnosis as S
import Recognize.Data.Step
import Recognize.Model.Assess
import Recognize.Model.Connectives
import Recognize.Model.Constraint
import Recognize.Model.EvidenceBuilder
import Recognize.Expr.Symbols
import Task.Network.MagicTrick
import Bayes.Network
assess' :: Diagnosis -> Evidence
assess' sd =
generateEvidence (`buildStepsEvidence` me) appr attrs
where
attrs = map (snd . getValue) $ steps sd
me = payload sd
appr = approach sd
buildStepsEvidence :: Approach -> Maybe Expr -> EvBuilder ()
buildStepsEvidence Algebraic (Just me) = stepsA1Builder me SG.<> stepsA2Builder me
buildStepsEvidence Numerical (Just me) = stepsN1Builder me SG.<> stepsN2Builder me
buildStepsEvidence _ Nothing = return ()
add8C :: Constraint EvBuilder [Attribute]
add8C = exists1 (Expand $ Add 8)
mul3C :: Constraint EvBuilder [Attribute]
mul3C = exists1 (Expand $ Mul 3)
sub4C :: Constraint EvBuilder [Attribute]
sub4C = exists1 (Expand $ Sub 4)
addXC :: Expr -> Constraint EvBuilder [Attribute]
addXC x = exists1 (Expand $ Add x)
div4C :: Constraint EvBuilder [Attribute]
div4C = exists1 (Expand $ Div 4)
add2C :: Constraint EvBuilder [Attribute]
add2C = exists1 (Expand $ Add 2)
subXC :: Expr -> Constraint EvBuilder [Attribute]
subXC x = exists1 (Expand $ Sub x)
fullyExpanded :: Expr -> Constraint EvBuilder [Attribute]
fullyExpanded x = mconcat [add8C, mul3C, sub4C, addXC x, div4C, add2C, subXC x]
stepsA1Builder :: Expr -> EvBuilder ()
stepsA1Builder me = do
let fullC = fullyExpanded me
giveNodeAndCollect ans1Strat1Step2 (fullC <> (fullC ==> failOnAnyMistake))
a1_2 <- newVar "a1_2"
giveNodeAndCollect ans1Strat1Step3 (fullC ==> implication
[ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + a1_2)
]
[ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + 24) ])
a1_3 <- newVar "a1_3"
giveNodeAndCollect ans1Strat1Step4 (fullC ==> implication
[ ARule Collect_Num (a1_2 N.:| [-4]) a1_3
, ARule Collect_Var (3*me N.:| [me]) (4*me)
]
[ ARule Collect_Num (a1_2 N.:| [-4]) (normalform $ a1_2 - 4)
, ARule Collect_Var (3*me N.:| [me]) (4*me) ])
a1_4 <- newVar "a1_4"
giveNodeAndCollect ans1Strat1Step5 $ fullC ==> implication
[ ARule Distr_Division (((4*me + a1_3) / 4) N.:| []) ((4*me)/4 + a1_3/4)
, ARule Division (4*me/4 N.:| []) me
, ARule Division (a1_3/4 N.:| []) a1_4
]
[ ARule Distr_Division (((4*me + a1_3) / 4) N.:| []) ((4*me)/4 + a1_3/4)
, ARule Division (4*me/4 N.:| []) me
, ARule Division (a1_3/4 N.:| []) (normalform $ a1_3 / 4)]
giveNodeAndCollect ans1Strat1Step6 $ fullC ==> implication
[ ARule Collect_Var (me N.:| [- me]) 0
, ARule Collect_Num (a1_4 N.:| [2]) (normalform $ a1_4 + 2)
]
[]
giveNodeAndCollect ans1 $ fullC ==> implication
[ ARule Collect_Var (me N.:| [- me]) 0
, ARule Collect_Num (a1_4 N.:| [2]) (normalform $ a1_4 + 2)
]
[]
stepsA2Builder :: Expr -> EvBuilder ()
stepsA2Builder me = do
giveNodeAndCollect ans1Strat2Step1 add8C
a2_2 <- newVar "a2_2"
giveNodeAndCollectDefault ans1Strat2Step2 (add8C ==> mul3C ==> (implication
[ ARule Distr_Times ((me + 8)*3 N.:| []) (3*me + a2_2) ]
[ ARule Distr_Times ((me + 8)*3 N.:| []) (3*me + 24)
]
<?>> failOnAnyMistake))
a2_2 24
a2_3 <- newVar "a2_3"
giveNodeAndCollectDefault ans1Strat2Step3 (sub4C ==> (implication
[ ARule Collect_Num (a2_2 N.:| [-4]) a2_3 ]
[ ARule Collect_Num (a2_2 N.:| [-4]) (normalform $ a2_2 - 4) ]
<?>> failOnAnyMistake))
a2_3 (normalform $ a2_2 - 4)
giveNodeAndCollect ans1Strat2Step4 $ addXC me ==> (implication
[ ARule Collect_Var (3*me N.:| [me]) (4*me)]
[ ARule Collect_Var (3*me N.:| [me]) (4*me) ]
<?>> failOnAnyMistake)
a2_5 <- newVar "a2_5"
giveNodeAndCollectDefault ans1Strat2Step5 (div4C ==> (implication
[ ARule Distr_Division (((4*me + a2_3) / 4) N.:| []) ((4*me)/4 + a2_3/4)
, ARule Division (4*me/4 N.:| []) me
, ARule Division (a2_3/4 N.:| []) a2_5
]
[ ARule Distr_Division (((4*me + a2_3) / 4) N.:| []) ((4*me)/4 + a2_3/4)
, ARule Division (4*me/4 N.:| []) me
, ARule Division (a2_3/4 N.:| []) (normalform $ a2_3 / 4)]
<?>> failOnAnyMistake))
a2_5 (normalform $ a2_3 / 4)
a2_6 <- newVar "a2_6"
giveNodeAndCollectDefault ans1Strat2Step6 (add2C ==> (implication
[ ARule Collect_Num (a2_5 N.:| [2]) a2_6 ]
[ ARule Collect_Num (a2_5 N.:| [2]) (normalform $ a2_5 + 2) ]
<?>> failOnAnyMistake))
a2_6 (normalform $ a2_5 + 2)
a2_7 <- newVar "a2_7"
giveNodeAndCollect ans1Strat2Step7 $ subXC me ==> (implication
[ ARule Collect_Var (me N.:| [-me]) 0 ]
[]
<?>> failOnAnyMistake)
giveNodeAndCollect ans1 $ subXC me ==> (implication
[ ARule Collect_Var (me N.:| [-me]) 0 ]
[]
<?>> failOnAnyMistake)
stepsN1Builder :: Expr -> EvBuilder ()
stepsN1Builder me = do
let fullC = fullyExpanded me
giveNodeAndCollect ans1Strat3Step1 $ fullC ==> failOnAnyMistake
let empty = Node "empty" "" [("Correct", True),("Incorrect", False)] [] (CPT [0.5, 0.5])
n1_2 <- newVar "n1_2"
giveNodeAndCollect empty $ fullC ==> (implication
[ ARule Collect_Num (me N.:| [8]) n1_2 ]
[ ARule Collect_Num (me N.:| [8]) (normalform $ me + 8) ]
<?>> failOnAnyMistake)
n1_3 <- newVar "n1_3"
giveNodeAndCollect empty $ fullC ==> (implication
[ ARule Times (n1_2 N.:| [3]) n1_3 ]
[ ARule Times (n1_2 N.:| [3]) (normalform $ n1_2 * 3) ]
<?>> failOnAnyMistake)
n1_4 <- newVar "n1_4"
giveNodeAndCollect empty $ fullC ==> (implication
[ ARule Collect_Num (n1_3 N.:| [-4, me]) n1_4 ]
[ ARule Collect_Num (n1_3 N.:| [-4, me]) (normalform $ n1_3 - 4 + me) ]
<?>> failOnAnyMistake)
n1_5 <- newVar "n1_5"
giveNodeAndCollect empty $ fullC ==> (implication
[ ARule Division (n1_4 N.:| [4]) n1_5 ]
[ ARule Division (n1_4 N.:| [4]) (normalform $ n1_4 / 4) ]
<?>> failOnAnyMistake)
n1_6 <- newVar "n1_6"
giveNodeAndCollect ans1Strat3Step2 $ fullC ==> (implication
[ ARule Collect_Num (n1_5 N.:| [2, me]) n1_6 ]
[ ARule Collect_Num (n1_5 N.:| [2, me]) (normalform $ n1_5 + 2 - me) ]
<?>> failOnAnyMistake)
giveNodeAndCollect ans1 $ fullC ==> (implication
[ ARule Collect_Num (n1_5 N.:| [2, me]) n1_6 ]
[ ARule Collect_Num (n1_5 N.:| [2, me]) (normalform $ n1_5 + 2 - me) ]
<?>> failOnAnyMistake)
stepsN2Builder :: Expr -> EvBuilder ()
stepsN2Builder me = do
n2_1 <- newVar "n2_1"
let cn2_1a = add8C
cn2_1b = implication
[ ARule Collect_Num (me N.:| [8]) n2_1 ]
[ ARule Collect_Num (me N.:| [8]) (normalform $ me + 8) ]
<?>> failOnAnyMistake
if me == 0
then setValueOf n2_1 8 >> giveNodeAndCollect ans1Strat4Step1 cn2_1a
else giveNodeAndCollectDefault ans1Strat4Step1 (add8C ==> cn2_1b) n2_1 (normalform $ me + 8)
n2_2 <- newVar "n2_2"
giveNodeAndCollectDefault ans1Strat4Step2 (mul3C ==> (implication
[ ARule Times (n2_1 * 3 N.:| []) n2_2 ]
[ ARule Times (n2_1 * 3 N.:| []) (normalform $ n2_1 * 3) ]
<?>> failOnAnyMistake))
n2_2 (normalform $ n2_1 * 3)
n2_3 <- newVar "n2_3"
giveNodeAndCollectDefault ans1Strat4Step3 (sub4C ==> (implication
[ ARule Collect_Num (n2_2 N.:| [-4]) n2_3 ]
[ ARule Collect_Num (n2_2 N.:| [-4]) (normalform $ n2_2 - 4) ]
<?>> failOnAnyMistake))
n2_3 (normalform $ n2_2 - 4)
n2_4 <- newVar "n2_4"
giveNodeAndCollectDefault ans1Strat4Step4 (addXC me ==> (implication
[ ARule Collect_Num (n2_3 N.:| [me]) n2_4 ]
[ ARule Collect_Num (n2_3 N.:| [me]) (normalform $ n2_3 + me) ]
<?>> failOnAnyMistake))
n2_4 (normalform $ n2_3 + me)
n2_5 <- newVar "n2_5"
giveNodeAndCollectDefault ans1Strat4Step5 (div4C ==> (implication
[ ARule Division (n2_4 / 4 N.:| []) n2_5 ]
[ ARule Division (n2_4 / 4 N.:| []) (normalform $ n2_4 / 4) ]
<?>> failOnAnyMistake))
n2_5 (normalform $ n2_4 / 4)
n2_6 <- newVar "n2_6"
giveNodeAndCollectDefault ans1Strat4Step6 (add2C ==> (implication
[ ARule Collect_Num (n2_5 N.:| [2]) n2_6 ]
[ ARule Collect_Num (n2_5 N.:| [2]) (normalform $ n2_5 + 2) ]
<?>> failOnAnyMistake))
n2_6 (normalform $ n2_5 + 2)
n2_7 <- newVar "n2_7"
giveNodeAndCollect ans1Strat4Step7 $ subXC me ==> (implication
[ ARule Collect_Num (n2_6 N.:| [-me]) n2_7
]
[ ARule Collect_Num (n2_6 N.:| [-me]) (normalform $ n2_6 - me) ]
<?>> failOnAnyMistake)
giveNodeAndCollect ans1 $ subXC me ==> (implication
[ ARule Collect_Num (n2_6 N.:| [-me]) n2_7
]
[ ARule Collect_Num (n2_6 N.:| [-me]) (normalform $ n2_6 - me) ]
<?>> failOnAnyMistake)