module Task.VPattern.Recognizer (vPattern) where
import Control.Applicative (many)
import Control.Arrow (second)
import Control.Monad (guard, msum)
import Util.List
import Util.Monad
import Recognize.Data.Approach
import Recognize.Data.Attribute hiding (Other)
import Recognize.Data.Math
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOptions
import Recognize.Data.MathParserOutput
import Recognize.Data.Diagnosis
import Recognize.Data.Step
import Recognize.Data.StringLexer
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Recognize.Parsing.Derived
import Recognize.Parsing.Parse
import Recognize.SubExpr.SEParser
import Recognize.Recognizer
import Recognize.SubExpr.Recognizer
import Recognize.SubExpr.Symbols
import Task.VPattern.Assess
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Ideas.Common.Id
import Task.Network.VPattern
import Bayes.Evidence ( evidenceOfAbsence )
vPattern :: MathStoryProblem
vPattern = mathStoryProblem
{ problemId = newId "vpattern"
, analyzers = [(newId "10", ana)]
, inputFile = Just "input/vpattern.csv"
, networkFile = Just "networks/VPattern.xdsl"
, singleNetwork = network
}
where
ana = analyzer
{ parser = mathParser mathParserOptions { functionCallWhitelist = "nN" } . stringLexerOutput
, recognizer = seRecognizer pDiagnosis . mathParserOutput
, collector = evidenceOfAbsence ans1 False . assess'
}
pDiagnosis :: SEParser Diagnosis
pDiagnosis = do
(appr, e, st) <- pSteps
let sd = newDiagnosis appr st
return $ sd { result = Just e }
pSteps :: SEParser (Approach, Expr, [Step])
pSteps = do
(app,e,st) <- choice'
[
(\(e,st) -> (Algebraic,e,st)) <$> withGuard (not . null . snd) pStepsA1
, (\(e,st) -> (Other "Algebraic2",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA2
, (\(e,st) -> (Other "Algebraic3",e,st)) <$> withGuard (not . null . snd) pStepsA3
, (\(e,st) -> (Other "Algebraic4",e,st)) <$> withGuard ((>=2) . length . snd) pStepsA4
]
_ <- many skip
return (app,e,st)
stepS :: SEParser (Expr, [Step])
stepS = do
(e,st) <- pMatchSubSteps sexpr
return (e, appLast (addAttribute (FinalAnswer e)) st)
where
sexpr = lbl "S" $ lt "n" newMagicVar $ \x -> noSim $ 1 + 2 * x <!> 2 * x - 1 <!> newMagicNat * x <!> x + x + x
pStepsS :: SEParser (Expr, [Step])
pStepsS = (\(x, y, _) -> (x, y)) <$> pInOrder [const stepS]
pStepsA1 :: SEParser (Expr, [Step])
pStepsA1 = (\(x, y, _) -> (x, y)) <$> pInOrder
[ const $ pMatchSubSteps aexpr
, const stepS
]
where
aexpr = lbl "A1" $ lt "n" newMagicVar $ \x -> noSim $ x + x + 1 <!> x + x - 1
pStepsA2 :: SEParser (Expr, [Step])
pStepsA2 = (\(x, y, _) -> (x, y)) <$> pInOrder
[ const $ pMatchSubSteps aexpr
, const stepS
]
where
aexpr = lbl "A2" $ lt "n" newMagicVar $ \x -> noSim $ x + (x + 1) <!> x + (x - 1)
pStepsA3 :: SEParser (Expr, [Step])
pStepsA3 = (\(x, y, _) -> (x, y)) <$> pInOrder
[ const $ pMatchSubSteps a1expr
, const $ pMatchSubSteps a2expr
, const stepS
]
where
a1expr = lbl "A3_1" $ lt "n" newMagicVar $ \x -> noSim $ 2*(x - 1 <!> x)
a2expr = lbl "A3_2" $ lt "n" newMagicVar $ \x -> noSim $ 3 + 2*(x - 1 <!> x) <!> 2 + 3*(x-1 <!> x)
pStepsA4 :: SEParser (Expr, [Step])
pStepsA4 = (\(x, y, _) -> (x, y)) <$> pInOrder
[ const $ second (maybe [] ((:[]) . addAttribute (Label "2")) . mergeSteps) <$> withGuard (\t -> length (snd t) >= 2) (pNumSteps 3)
, const stepS
]
pNumSteps :: Expr -> SEParser (Expr, [Step])
pNumSteps e =
choice'
[ do
(e',ss) <- pNumStep e
pLog ("successfully parsed a num and value: " ++ show e' ++ " " ++ show ss)
second (ss:) <$> pNumSteps e'
, return (e,[])
]
where
pNumStep ex = do
(_,b,math) <- choice'
[ do
meq <- skip
(r :==: a) <- getEq meq
meq2 <- skip
(n :==: b) <- getEq meq2
guard (isNat a && isNat b)
choice'
[ do
guard ((n == Var "N" || n == Var "n") && (r == Var "R" || r == Var "r"))
return (a,b,meq2)
, do
guard ((r == Var "N" || r == Var "n") && (n == Var "R" || n == Var "r"))
return (b,a,meq)
]
, do
meq <- skip
(n :==: b) <- getEq meq
guard (n == Var "N" || n == Var "n")
return (n,b,meq)
]
(b',attr) <- isVal ex b
return (b', Step (newId "") (math,attr) [])
isVal :: Expr -> Expr -> SEParser (Expr, [Attribute])
isVal e1 e2 =
maybeToParse $ msum
[ do
guard $ isNat $ nf $ (e2-e1)/2
return (e2,[])
, do
guard $ isNat $ nf $ (e2-e1)/3
return (e2,[CommonMistake])
, do
guard $ isNat $ nf $ (e2-e1)/1
return (e2,[CommonMistake])
]