module Task.AreaAndExpression (areaAndExpression) where
import Control.Monad
import Data.Maybe
import Data.Semigroup
import Domain.LinearAlgebra.Matrix
import Domain.Math.Data.MultivariatePolynomial
import Domain.Math.Expr
import Domain.Math.Numeric.Views
import Ideas.Common.Library hiding (Recognizable, steps, parser, recognizer)
import Recognize.Data.Approach (Approach (Algebraic))
import Bayes.Evidence
import Recognize.Data.Attribute
import Recognize.Data.Math
import Recognize.Data.MathStoryProblem
import Recognize.Data.MathParserOutput
import Recognize.Data.Solution
import Recognize.Data.Step
import Recognize.Data.Diagnosis
import Recognize.Data.StringLexer
import Recognize.Parsing.Derived
import Recognize.Parsing.Interpretation
import Recognize.Recognizer
import Data.List
import Util.String
import qualified Data.Map as M
import Task.Network.AreaAndExpression
areaAndExpression :: MathStoryProblem
areaAndExpression = mathStoryProblem
{ problemId = newId "areaandexpression"
, processInputs = return . mergeInputs
, analyzers = [(mergedId, ana)]
, inputFile = Just "input/areaandexpression.csv"
, networkFile = Just "networks/AreaAndExpression.xdsl"
, singleNetwork = network
}
where
ana = analyzer
{ parser = mathParser mempty . stringLexerOutput
, recognizer = defaultRecognizer pDiagnosis . mathParserOutput
, collector = evidenceOfAbsence ans1 False . mconcat . map assessSteps . steps
}
mergedId :: Id
mergedId = newId "areaandexpression.concatenated"
mergeInputs :: [Input] -> Input
mergeInputs is = Input mergedId $ map strBool $ concat
[ searchFor (newId "08a")
, searchFor (newId "08b")
, [Right "0"]
, searchFor (newId "08c")
, searchFor (newId "08d")
, searchFor (newId "08e")
, searchFor (newId "08f")
, searchFor (newId "08g")
, [Right "0"]
]
where
strBool (Right s) | strToLower s == "true" = Right "1"
strBool (Right s) | strToLower s == "false" = Right "0"
strBool s = s
searchFor k =
maybe [Right ""] getInput (find ((== k) . getInputId) is)
assessSteps :: Step -> Evidence
assessSteps s | getId s == newId "s1" = ans1 .== stepCorrect
| getId s == newId "s2" = ans1 .== stepCorrect
| otherwise = ans1 .== False
where stepCorrect = (any correctAttribute . snd . getValue) s
correctAttribute (Other s) | s == "S1" = True
| s == "S2" = True
| otherwise = False
correctAttribute _ = False
correct1 :: Matrix Expr
correct1 = makeMatrix
[ [0, 0, 0]
, [1 , 1 , 1]
, [0, 1 , 0]
]
correct2 :: Matrix Expr
correct2 = makeMatrix
[ [0, 1, 0]
, [0, 1 , 1]
, [0, 1 , 0]
]
termMatrix :: Matrix Expr
termMatrix = makeMatrix
[ [ x :*: y
| y <- [Var "y", Var "x", 1]
]
| x <- [Var "y", Var "x", Var "x"]
]
solution :: Matrix Expr
solution = mapMul correct1 termMatrix
mapMul :: Num a => Matrix a -> Matrix a -> Matrix a
mapMul a b = makeMatrix $ zipWith (zipWith (*)) (rows a) (rows b)
matrixToExpr :: Matrix Expr -> Expr
matrixToExpr = simplify (multivariatePolynomialViewWith rationalView) . to sumView . concat . rows
pDiagnosis :: InterpretationParser Diagnosis
pDiagnosis = (newDiagnosis Algebraic . singleton) <$>
toStep (newId "S1")
(do x <- pReplicate 3 (pReplicate 3 pAnyExpr)
guard (all (\y -> y == 0 || y == 1) (concat x))
f (makeMatrix x))
where
f :: Matrix Expr -> InterpretationParser [Attribute]
f x | x == correct1 = return [ Other "S1" ]
| x == correct2 = return [ Other "S2" ]
| otherwise = return $ fromMaybe [] $ do
xp <- (toMultivariatePolynomial . matrixToExpr) (mapMul termMatrix x)
yp <- (toMultivariatePolynomial . matrixToExpr) solution
yss <- (mapM (\(fs,c) -> ((,) fs <$> match naturalView c) ) . M.toAscList . multivariatePolynomialToMap) yp
xss <- (mapM (\(fs,c) -> ((,) fs <$> match naturalView c) ) . M.toAscList . multivariatePolynomialToMap) xp
return (g xss yss)
g :: [(Factors,Integer)]
-> [(Factors,Integer)]
-> [Attribute]
g ((xf,xc) : xs) [] = Other (show (Nat xc :*: fromFactors xf) ++ " is incorrect") : g xs []
g [] ((yf,yc) : ys) = Other (show (Nat yc :*: fromFactors yf) ++ " is missing") : g [] ys
g xss@((xf,xc):xs) yss@((yf,yc):ys)
| yf == xf , yc == xc = g xs ys
| yf == xf , yc > xc = Other ("Missing "++ show (yc - xc) ++ " of " ++ show yf) : g xs ys
| yf == xf , yc < xc = Other (show (xc - yc) ++ " too much of "++ show yf) : g xs ys
| yf > xf = Other (show (Nat xc :*: fromFactors xf) ++ " is incorrect") : g xs yss
| yf < xf = Other (show (Nat yc :*: fromFactors yf) ++ " is missing") : g xss ys
g _ _ = []