Advise-me-0.1: src/Task/MagicTrick/Assess.hs
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- Assessment for the magictrick exercise
--
-----------------------------------------------------------------------------
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 =
--stringNode (apprtostring appr) ans1Strat <> --check which approach has been used
generateEvidence (`buildStepsEvidence` me) appr attrs
where
-- sd = firstDiagnosis md
attrs = map (snd . getValue) $ steps sd
me = payload sd --Get the magic expression
appr = approach sd
-- Unnecessary to verify arithmetic strategy constraints when the category is algebraic and vice versa.
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
-- For all steps in the general strategy the formula must first be fully expanded
let fullC = fullyExpanded me
giveNodeAndCollect ans1Strat1Step2 (fullC <> (fullC ==> failOnAnyMistake))
-- We introduce a variable that will match to anything
a1_2 <- newVar "a1_2"
giveNodeAndCollect ans1Strat1Step3 (fullC ==> implication
-- The only difference between the hypothesis and the conclusion is @a1_2@ and @24@. Since @a1_2@ will match to anything
-- if it matches to something that is not @24@ then a failure is generated. Otherwise, either we get a success or unknown.
[ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + a1_2) -- must be nat
]
[ ARule Distr_Times (3 * (me + 8) N.:| []) (3*me + 24) ])
a1_3 <- newVar "a1_3"
giveNodeAndCollect ans1Strat1Step4 (fullC ==> implication
-- By now we should have an actual value for @a1_2@, but we repeat the same process that we used in the above constraint
[ ARule Collect_Num (a1_2 N.:| [-4]) a1_3
, ARule Collect_Var (3*me N.:| [me]) (4*me)
]
-- normalform will simplify @a1_2 - 4@ within the comparison function
[ 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"
-- For stepwise strategies we only require expansion of the formula up to a certain point
-- If we could not verify constraint a2_2 then it must mean @a2_2@ still refers to some wildcard. With collectDefault @a2_2@ will be a2_signed 24
-- if the result of constraint @a2_2@ is unknown
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
-- With collectDefault @a2_3@ will be assigned @a2_2 - 4@ if the result of constraint @a2_3@ is unknown.
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)
-- With collectDefault @a2_5@ will be assigned @a2_3 / 4@ if the result of constraint @a2_5@ is unknown.
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
--Create an empty node to hold the intermediate steps
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)