{-# LANGUAGE TupleSections #-}
module Task.MagicTrick.Recognizer where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.List
import qualified Data.List.NonEmpty as N
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Math.Expr hiding (pExpr, fromDouble)
import Ideas.Common.Id
import Ideas.Utils.Uniplate
import Recognize.Data.Approach
import Recognize.Data.Attribute
import Recognize.Data.Math
import Recognize.Data.Op
import Recognize.Data.Diagnosis
import Recognize.Data.Step
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Recognize.Parsing.Parse
import Recognize.Parsing.Derived
import Recognize.Parsing.MathParser (parseMath)
import Recognize.Data.MathParserOptions
import Recognize.Strategy.Applications
import Recognize.SubExpr.SEParser
import Util.List
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOutput
import Recognize.Recognizer
import Task.MagicTrick.Assess
import Task.Network.MagicTrick
import Bayes.Probability ( fromDouble, Probability )
import Bayes.Network ( Node(..) )
import Bayes.Evidence ( Evidence, evidenceOfAbsence, nodeNotSet, nodeIsSet, nodeSetTo, (.=~) )
magicTrick :: MathStoryProblem
magicTrick = mathStoryProblem
{ problemId = newId "magictrick"
, analyzers = [(newId "05", ana)]
, inputFile = Just "input/magictrick.csv"
, networkFile = Just "networks/MagicTrick.xdsl"
, singleNetwork = network
}
where
ana = analyzer
{ recognizer = myrecognize
, collector = fillInMissedSteps . evidenceOfAbsence ans1 False . whereDidWeGoWrong . assess'
}
myrecognize po = seRecognizer pDiagnosis $ mathParserOutput po
probHigh, probMediumLow, probLow :: [Probability]
probHigh = [fromDouble 0.8, fromDouble 0.2, fromDouble 0]
probMediumLow = [fromDouble 0.4, fromDouble 0.6, fromDouble 0]
probLow = [fromDouble 0.2, fromDouble 0.8, fromDouble 0]
whereDidWeGoWrong :: Evidence -> Evidence
whereDidWeGoWrong ev =
if nodeIsSet ans1 ev
then ev
else mappend ev . additionalEvidence . flip map [strat1,strat2,strat3,strat4] $ \strat ->
if studentTried strat ev
then whereDidItGoWrong strat
else Nothing
where
additionalEvidence nodes = mconcat $ case catMaybes nodes of
[] -> map (.=~ probMediumLow) [ans1Strat1Step1, ans1Strat2Step1, ans1Strat3Step1, ans1Strat4Step1]
other -> map (.=~ probLow) other
studentTried :: [Node a] -> Evidence -> Bool
studentTried strat ev' = any (flip nodeIsSet ev') strat
whereDidItGoWrong :: [Node a] -> Maybe (Node a)
whereDidItGoWrong strat = listToMaybe . reverse . takeWhile (flip nodeNotSet ev) . reverse $ strat
strat1 = [ans1Strat1Step1, ans1Strat1Step2, ans1Strat1Step3, ans1Strat1Step4, ans1Strat1Step5, ans1Strat1Step6]
strat2 = [ans1Strat2Step1, ans1Strat2Step2, ans1Strat2Step3, ans1Strat2Step4, ans1Strat2Step5, ans1Strat2Step6, ans1Strat2Step7]
strat3 = [ans1Strat3Step1, ans1Strat3Step2]
strat4 = [ans1Strat4Step1, ans1Strat4Step2, ans1Strat4Step3, ans1Strat4Step4, ans1Strat4Step5, ans1Strat4Step6, ans1Strat4Step7]
fillInMissedSteps :: Evidence -> Evidence
fillInMissedSteps = applyTransformations
[
( nodeSetTo ans1Strat1Step6 (Just True)
, ans1Strat1Step5 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step5 (Just True)
, ans1Strat1Step4 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step4 (Just True)
, ans1Strat1Step3 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step3 (Just True)
, ans1Strat1Step2 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step2 (Just True)
, ans1Strat1Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step7 (Just True)
, ans1Strat2Step6 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step6 (Just True)
, ans1Strat2Step5 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step5 (Just True)
, ans1Strat2Step4 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step4 (Just True)
, ans1Strat2Step3 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step3 (Just True)
, ans1Strat2Step2 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step2 (Just True)
, ans1Strat2Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat3Step2 (Just True)
, ans1Strat3Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step3 (Just True)
, ans1Strat1Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat1Step4 (Just True)
, ans1Strat1Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step3 (Just True)
, ans1Strat2Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step5 (Just True)
, ans1Strat2Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step6 (Just True)
, ans1Strat2Step1 .=~ probHigh )
, ( nodeSetTo ans1Strat2Step7 (Just True)
, ans1Strat2Step1 .=~ probHigh )
]
where
applyTransformations :: [(Evidence -> Bool, Evidence)] -> Evidence -> Evidence
applyTransformations = flip $ foldl (flip applyTransformation)
applyTransformation :: (Evidence -> Bool, Evidence) -> Evidence -> Evidence
applyTransformation (ante, post) ev =
case ante ev of
True -> ev `mappend` post
False -> ev
pDiagnosis :: SEParser Diagnosis
pDiagnosis = do
sds <- pAttempts1
return $ head sds
oTryManyBuggyPars :: Bool
oTryManyBuggyPars = True
oSkipExpressions :: Bool
oSkipExpressions = True
pAttempts1 :: SEParser [Diagnosis]
pAttempts1 = do
xs <- pAttempts
when (null xs) empty
return xs
pAttempts :: SEParser [Diagnosis]
pAttempts
| oSkipExpressions = catMaybes <$> many (Just <$> pStdDiagnosis <|> Nothing <$ skip)
| otherwise = many1 pStdDiagnosis
guessMagicExpr :: [Expr] -> [Expr]
guessMagicExpr [] = []
guessMagicExpr es@(e:_) = filter (matches es) z
where
z = nub $ [ x | Nat 8 :+: x <- universe e]
++ [ x | x :+: Nat 8 <- universe e ]
++ concatMap f (universe e)
++ [Nat 0]
f v@(Nat _) = [v]
f v@(Var _) = [v]
f v@(Negate (Nat _)) = [v]
f v@(Number _) = [v]
f _ = []
matches es' m = all (all (\e' -> case e' of
Nat 8 :+: x -> m == x
x :+: Nat 8 -> m == x
_ -> True) . universe) (take 3 es')
pMagicExpr :: SEParser Expr
pMagicExpr = withInputList (guessMagicExpr . mapMaybe getExpr)
pVars :: SEParser [String]
pVars = withInput (nub . concatMap vars . mapMaybe getExpr)
pAnnounce :: [String] -> Expr -> SEParser ()
pAnnounce vs x = () <$ many (() <$ pExpr x
<|> choice [ pEq $ Var v :==: x | v <- vs ] )
pConclude :: [String] -> [Expr] -> Expr -> SEParser Expr
pConclude vs cs r =
maybe r fst . uncons <$>
many (choice ((7 <$ pExpr 7) : [ c <$ pEq (Var v :==: c) | v <- vs, c <- cs ]))
pStdDiagnosis :: SEParser Diagnosis
pStdDiagnosis = do
x <- pMagicExpr
vs <- pVars
(a,st) <- pStepsFor x x (if x == 0 then taskIfZero else task x)
res <- pConclude vs (nub [x,a]) a
let attrs = map getAttributes st
return Diagnosis
{ category = case x of { (Var _) -> Algebraic ; _ -> Numerical }
, correctResult = res == 7
, resultIsSimplified = nf res == res
, parenthesisMismatch = any (elem NonMatchingParentheses) attrs
, payload = Just x
, steps = st
, result = Just res
}
task :: Expr -> [Op]
task me = [Add 8, Mul 3, Sub 4, Add me, Div 4, Add 2, Sub me]
taskIfZero :: [Op]
taskIfZero = [Add 8, Mul 3, Sub 4, Div 4, Add 2]
expandOps :: [Op] -> [Attribute]
expandOps = map Expand
taskExpand :: Expr -> [Attribute]
taskExpand = map Expand . task
taskForget :: Expr -> [Attribute]
taskForget = map Forget . task
pStepsFor :: Expr ->
Expr ->
[Op] ->
SEParser (Expr, [Step])
pStepsFor x a ops = do
pLog $ "pStepsFor: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops
option $ satisfyWith (getExpr >=> (\e -> guard (a == e)))
eth <- pStepsPhase1 x a ops
case eth of
Left (e, st, ops') -> do
pLog $ "Fail after phase1 " ++ show x ++ " " ++ show st ++ " " ++ show e ++ " " ++ show ops'
ms <- pStepsPhase2 x e
case ms of
Just (e', st') -> do
pLog $ "success after phase2 " ++ show x ++ " " ++ show st' ++ " " ++ show e'
second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops'
Nothing -> do
pLog "Fail after phase 2"
ma <- pStepsPhase3 x e ops'
case ma of
Just (e', st', ops'') -> do
pLog $ "success after phase3 " ++ show x ++ " " ++ show st' ++ " " ++ show e' ++ " " ++ show ops''
second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' ops''
Nothing -> do
pLog $ "Failed phase3: " ++ show st ++ " " ++ show e ++ " " ++ show ops'
(e', st', ops'') <- pStepsPhase4 x e ops' st
pLog $ "success after phase4 " ++ show x ++ " " ++ show st' ++ " " ++ show e' ++ " " ++ show ops'
second (\st'' -> st' ++ st'') <$> pStepsFor x e' ops''
Right (e, st, _) -> do
pLog $ "Success after phase1: " ++ show st ++ " | " ++ show e
ms <- pStepsPhase2 x e
case ms of
Just (e', st') -> do
pLog $ "success after phase2 " ++ show x ++ " " ++ show st' ++ " " ++ show e'
second (\st'' -> st ++ [st'] ++ st'') <$> pStepsFor x e' []
Nothing -> do
pLog "done in StepsFor"
return (e, st)
pStepsPhase1 :: Expr -> Expr -> [Op] -> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))
pStepsPhase1 = pTask pStepOperators
pStepsPhase2 :: Expr -> Expr -> SEParser (Maybe (Expr, Step))
pStepsPhase2 = pTaskSimplify
pStepsPhase3 :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))
pStepsPhase3 = pTaskErr
pStepsPhase4 :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])
pStepsPhase4 = pTaskForget
pTask :: (Expr -> Expr -> [Op] -> SEParser (Expr, Step))
-> Expr
-> Expr
-> [Op]
-> SEParser (Either (Expr, [Step], [Op]) (Expr, [Step], [Op]))
pTask _ _ a [] = return $ Right (a, [], [])
pTask strat x a xs = do
pLog $ "pTask: " ++ show x ++ " | " ++ show a ++ " | " ++ show xs
pTask'
where
pTask' =
choice'
[ do
(b, as) <- strat x a ops
eth <- pTask strat x b ys
case eth of
Left (c, cs, zs) -> return $ Left (c, as : cs, zs)
Right (c, cs, zs) -> return $ Right (c, as : cs, zs)
| (ops, ys) <- splits xs, length ops > 0
]
|> pIf (null xs) (succeed $ Right (a, [], xs))
|> succeed (Left (a, [], xs))
pTaskSimplify :: Expr -> Expr -> SEParser (Maybe (Expr, Step))
pTaskSimplify x a = do
pLog $ "pTaskSimplify: " ++ show x ++ " | " ++ show a
m <- withInput head
if fst (simplify a) == a then return Nothing
else do
ma <- option $ pStepSimplify x a
return $ ma >>= \(e, as) -> Just (e, smallStep (newId "simplify") (m,as))
pTaskForget :: Expr -> Expr -> [Op] -> [Step] -> SEParser (Expr, [Step], [Op])
pTaskForget x a [Sub ope] stps
| x == ope || (isVar x && isVar ope) = return (a, modifyAt (length stps - 1) (addAttribute (Forget $ Sub x)) stps, [])
| otherwise = empty
pTaskForget x a (op:op2:xs) stps = do
(e,st) <- pStepForget x a op op2
return (e, stps++[st], xs)
pTaskForget _ _ _ _ = empty
pTaskErr :: Expr -> Expr -> [Op] -> SEParser (Maybe (Expr, Step, [Op]))
pTaskErr _ _ [] = empty
pTaskErr x a (op:xs) = option $ (\(e,st) -> (e,st,xs)) <$> pStepError x a [op]
pStepOperators :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, Step)
pStepOperators x a ops = do
m <- withInput head
(e,as) <- pStep x a ops
let as' = map Expand ops ++ as
return (e, smallStep (newId "") (m,as'))
pStepError :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, Step)
pStepError x a ops = do
m <- withInput head
(e,as) <- pStepErr x a ops
return (e, smallStep (newId "") (m,as))
pStepForget :: Expr
-> Expr
-> Op
-> Op
-> SEParser (Expr, Step)
pStepForget x a op1 op2 = do
m <- withInput head
(e,as) <- pStep x a [op2]
return (e, smallStep (newId "") (m,Forget op1 :as))
pStep :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, [Attribute])
pStep x a ops =
choice'
[ do
m <- peek
guard $ isJust $ getEq m
pStepEquation x a ops
, do
m <- peek
guard $ isNothing $ getEq m
pStepExpr x a ops
, pBuggyStep x a ops
]
pStepErr :: Expr -> Expr -> [Op] -> SEParser (Expr, [Attribute])
pStepErr x a ops =
pFixEqCom (b :==: b)
|> choice [pFixEqCom (b :==: norm b) | norm <- [nfCom . nf]]
|> pFixExprCom b
|> choice [pFixExprCom (norm b) | norm <- [nfCom . nf]]
where
b = formExpr x a ops
pBuggyStep :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, [Attribute])
pBuggyStep x a ops =
pIf (length ops >= 2) (
((,[IncorrectDistribution, Recovery]) . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b)
|> ((,[IncorrectDistribution] ) . rightHandSide) <$> fst <$> pEqWith2 (\e -> (nfCom e,[])) (\e -> (nfCom $ nf e,[])) (b' :==: b')
|> (,[IncorrectDistribution]) <$> fst <$> pExprWith (\e -> (nfCom e,[])) b'
)
|> pIf (not $ null ops) (pNextStepBuggyPars a b)
where
b' = foldl (flip fromOp') a (map (substOp x) ops)
b = formExpr x a ops
pStepSimplify :: Expr
-> Expr
-> SEParser (Expr, [Attribute])
pStepSimplify x a = do
pLog $ "pStepSimplify: " ++ show x ++ " | " ++ show a
choice'
[ do
m <- peek
guard $ isJust $ getEq m
(attr,e) <- pExplicitSimplifyEq x a
return (attr,e)
, do
m <- peek
guard $ isNothing $ getEq m
(attr,e) <- pExplicitSimplifyExpr a
return (attr,e)
]
pExplicitSimplifyEq :: Expr
-> Expr
-> SEParser (Expr, [Attribute])
pExplicitSimplifyEq x a = do
pLog $ "pExplicitSimplifyEq: " ++ show x ++ " | " ++ show a
choice
[ first rightHandSide <$> pEqWith simplify (a :==: a)
, pEqWithL simplify a
]
pExplicitSimplifyExpr :: Expr
-> SEParser (Expr, [Attribute])
pExplicitSimplifyExpr = pExprWith simplify
pStepEquation :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, [Attribute])
pStepEquation x a ops = do
pLog $ "pStepEquation: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops
choice
[ first rightHandSide <$> pEqWith simplify (b :==: b)
, pEqWithL simplify b
]
|> pIf (length ops <= 3)
(pFixEqCom (b :==: nfCom (nf b)))
where
b = formExpr x a ops
pStepExpr :: Expr
-> Expr
-> [Op]
-> SEParser (Expr, [Attribute])
pStepExpr x a ops = do
pLog $ "In pStepExpr: " ++ show x ++ " | " ++ show a ++ " | " ++ show ops ++ " | " ++ show b
pExprWith (\e -> (nfCom e, [])) b
|> pIf (length ops < 4) (second (\attr -> (Implicit <$> ops)++attr) <$> pExprWith simplify b)
where
b = formExpr x a ops
pNextStepBuggyPars :: Expr -> Expr -> SEParser (Expr, [Attribute])
pNextStepBuggyPars _ b = let np = noPars b in choice'
[ (lhs', [NonMatchingParentheses]) <$ pEqCom (lhs' :==: nf b)
|> (lhs', [NonMatchingParentheses]) <$ pExprCom lhs'
| lhs' <- np
]
splits :: [a] -> [([a], [a])]
splits xs = zip (inits xs) (tails xs)
pIf :: Alternative f => Bool -> f a -> f a
pIf b p = if b then p else empty
noPars :: Expr -> [Expr]
noPars e = (if oTryManyBuggyPars then id else take 1) $
mapMaybe f (dropParensString (show e))
where
f s = case myparseExpr s of
Just new | new /= e -> Just new
_ -> Nothing
myparseExpr s =
case mapMaybe getExpr (snd $ parseMath mathParserOptions s) of
[m] -> Just m
_ -> Nothing
dropParensString :: String -> [String]
dropParensString = rec []
where
rec ps [] = [ "" | null ps ]
rec ps (x:xs)
| x == '(' = rec (False:ps) xs ++ map (x:) (rec (True:ps) xs)
| x == ')' = if null ps
then []
else if head ps
then map (x:) (rec (drop 1 ps) xs)
else rec (drop 1 ps) xs
| otherwise = map (x:) (rec ps xs)
pFixEqCom :: Equation Expr
-> SEParser (Expr, [Attribute])
pFixEqCom e = peekEq >>= \eq -> pLog ("pFixEqCom: " ++ show e ++ " | " ++ show eq) >> pMatchEq e eq
pMatchEq :: Equation Expr
-> Equation Expr
-> SEParser (Expr, [Attribute])
pMatchEq (a :==: b) (x :==: y) =
pIf (not (a === x) && any (=== x) (changeOp a) && y === x)
(pRewrite (y, [OperatorMixedUp plusSymbol plusSymbol]))
<|> pIf (a /= x) (pMatchExpr a x)
<|> pIf (not (a === x) && b === y) (second (Recovery:) <$> pMatchExpr (nfCom a) (nfCom x))
<|> pIf (not (a === x) && b == y) (pRewrite (y, [InvalidEquation x y, Recovery]))
<|> pIf (a === x && (b /= y)) (pRewrite (y, [InvalidEquation x y]))
pFixExprCom :: Expr -> SEParser (Expr, [Attribute])
pFixExprCom e = peekExpr >>= pMatchExpr e
pMatchExpr :: Expr
-> Expr
-> SEParser (Expr, [Attribute])
pMatchExpr e p = choice
[ do
el <- maybeToParse $ getLeft e
pl <- maybeToParse $ getLeft p
let e' = replaceLeft pl e
guard (e' == p)
pRewrite (p, [AtomMixedUp pl el])
, do
er <- maybeToParse $ getRight e
pr <- maybeToParse $ getRight p
let e' = replaceRight pr e
guard (e' == p)
pRewrite (p, [AtomMixedUp pr er])
, pIf (equivalentStructure e p
&& filter isAtom (universe e) == filter isAtom (universe p)
&& not (isAtom e)
)
(pRewrite (p, [OperatorMixedUp plusSymbol plusSymbol]))
, pIf ((not.isAtom) e
&& equivalentStructure e p
&& length (changeSet e p) == 1
)
(pRewrite (p, [AtomMixedUp p e]))
]
pEqWith :: (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])
pEqWith f x = do
m <- satisfyWith Just
pLog $ "pEqWith: " ++ show x ++ " | " ++ show m
case getEq m of
Just y -> do
let xl = leftHandSide x
yl = leftHandSide y
(fxl,axl) = f xl
(fxr,_) = f (rightHandSide x)
(fyl,ayl) = f yl
(fyr,ayr) = f (rightHandSide y)
guard (
if xl == yl then fyl == fyr
else fxl == fyl && fyl == fyr && hasCommonality axl ayl && (hasCommonality ayl ayr || null ayr))
pLog $ "pEqWith success: " ++ show fxl ++ " " ++ show fxr ++ " | " ++ show fyl ++ " " ++ show fyr
return (y, ayl \\ ayr)
Nothing -> empty
pEqWith2 :: (Expr -> (Expr, [Attribute])) -> (Expr -> (Expr, [Attribute])) -> Equation Expr -> SEParser (Equation Expr, [Attribute])
pEqWith2 f g x = do
m <- satisfyWith Just
pLog $ "pEqWith2: " ++ show x ++ " | " ++ show m
case getEq m of
Just y -> do
let (fx,_) = f (leftHandSide x)
(gx,_) = g (rightHandSide x)
(fy,aly) = f (leftHandSide y)
(gy,ary) = g (rightHandSide y)
guard (fx == fy && gx == gy)
pLog $ "pEqWith2 success: " ++ show fx ++ " " ++ show fy ++ " | " ++ show gx ++ " " ++ show gy
return (y, aly \\ ary)
Nothing -> empty
pEqWithL :: (Expr -> (Expr, [Attribute])) -> Expr -> SEParser (Expr, [Attribute])
pEqWithL f x = do
m <- satisfyWith Just
pLog $ "pEqWithL: " ++ show x ++ " | " ++ show m
case getEq m of
Just y -> do
let (fx,ax) = f x
(fyl,ayl) = f (leftHandSide y)
(fyr,_) = f (rightHandSide y)
guard (fx == fyl && fyl == fyr && (hasCommonality ax ayl || null ayl))
pLog $ "pEqWith success: " ++ show fx ++ " " ++ show fyl ++ " " ++ show fyr
return (leftHandSide y, ax \\ ayl)
Nothing -> empty
hasCommonality :: [Attribute] -> [Attribute] -> Bool
hasCommonality xs ys =
let xs' = map nfa xs
ys' = map nfa ys
in any (`elem` xs') ys'
where
nfa (ARule i a b) = ARule i (N.map nfComAssoc a) (nfComAssoc b)
nfa r = r