module Task.TheatreRate.Recognizer (theatreRate) where
import Control.Arrow
import Control.Applicative (many,empty)
import Control.Monad (guard, msum)
import Data.Maybe
import Util.List
import Util.Monad
import Recognize.Data.Approach
import Recognize.Data.Math
import Recognize.Data.MathParserOptions
import Recognize.Data.MathParserOutput
import Recognize.Data.MathStoryProblem
import Recognize.Data.Diagnosis
import Recognize.Data.StringLexer
import Recognize.Expr.Functions
import Recognize.Parsing.Derived
import Recognize.Parsing.Parse
import Recognize.Recognizer
import Recognize.Strategy.Applications
import Recognize.SubExpr.Recognizer
import Recognize.SubExpr.SEParser
import Recognize.SubExpr.Symbols
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Ideas.Common.Id
import Ideas.Utils.Uniplate (transform)
import Ideas.Utils.Prelude
import Task.TheatreRate.Assess
import Task.Network.TheatreRate
import Bayes.Evidence ( evidenceOfAbsence )
theatreRate :: MathStoryProblem
theatreRate = mathStoryProblem
{ problemId = newId "theatrerate"
, processInputs = filter ((== newId "07b") . getId)
, analyzers = [(newId "07b", ana)]
, inputFile = Just "input/theatrerate.csv"
, networkFile = Just "networks/TheatreRate.xdsl"
, singleNetwork = network
}
where
ana = analyzer
{ parser = mathParser mathParserOptions {multByConcatenation = False} . stringLexerOutput
, recognizer = seRecognizer pDiagnosis . mathParserOutput . modifyInput
, collector = evidenceOfAbsence ans2 False . assess'
}
modifyInput :: MathParserOutput -> MathParserOutput
modifyInput (MathParserOutput mpo che) = MathParserOutput (map math mpo) che
where
math (M t ethe) = M t $ fmap (transform exprDiv . transform expr) ethe
expr e = case e of
(Var "r" :*: 1) -> Var "r1"
(Var "r" :*: 2) -> Var "r2"
(Var "R" :*: 1) -> Var "R1"
(Var "R" :*: 2) -> Var "R2"
(Var "T" :*: 1) -> Var "T1"
(Var "T" :*: 2) -> Var "T2"
(Var "t" :*: 1) -> Var "t1"
(Var "t" :*: 2) -> Var "t2"
_ -> e
exprDiv e = case e of
(Var "R1" :/: e') -> e'
(Var "r1" :/: e') -> e'
(Var "R2" :/: e') -> e'
(Var "r2" :/: e') -> e'
(Var "T1" :/: e') -> e'
(Var "t1" :/: e') -> e'
(Var "T2" :/: e') -> e'
(Var "t2" :/: e') -> e'
_ -> e
pDiagnosis :: SEParser Diagnosis
pDiagnosis = do
(appr, st) <- pSteps
let sd = newDiagnosis appr st
return sd
pSteps :: SEParser (Approach, [Step])
pSteps = do
(ap,e,st,sk) <- choice
[
(\(e,st,sk) -> (Numerical,e,st,sk)) <$> withGuard (not . null . snd3) pStepsNumerical
, (\(e,st,sk) -> (Algebraic,e,st,sk)) <$> withGuard (not . null . snd3) pStepsAlgebraic
]
fa_st <- pFinalAnswer sk e
let ss = st ++ maybeToList fa_st
guard (length ss >= 1)
return (ap,ss)
r1_def :: Expr -> Expr
r1_def s = 4*s + 30 <!> 30*s + 4 <!> 30*s
r2_def :: Expr -> Expr
r2_def s = 8*s <!> newMagicNat*s
r12_def :: Expr
r12_def = lt "s" newMagicVar $ \s -> lbl "R1" (r1_def s) <?> lbl "R2" (r2_def s)
r12_equation :: Expr
r12_equation = lbl "setup equation" $ lt "s" newMagicVar $ \s -> r1_def s <&> r2_def s
r12_inequation :: Expr
r12_inequation = lbl "setup inequation" $ lt "s" newMagicVar $ \s -> r1_def s <&> r2_def s
pStepsAlgebraic :: SEParser (Expr,[Step],[Math])
pStepsAlgebraic =
pInOrder
[ \_ -> do
modify $ \st -> st { inputType = Just [Expr, Definition] }
pMatchSubSteps r12_def
, \mres -> case mres of
Nothing -> empty
Just (e1,st1) -> do
(e2,st2) <- resetAfter $ pMatchSubSteps r12_def
guard (e1 /= e2)
return (e2,st1++st2)
, \_ -> do
modify $ \st -> st { inputType = Just [LinearWithType EqualTo] }
res <- resetAfter (pMatchSubSteps r12_equation)
pLog ("test: " ++ show res)
return res
, \_ -> do
modify $ \st -> st { inputType = Just [LinearWithType LessThan, LinearWithType GreaterThan] }
res <- resetAfter (pMatchSubSteps r12_inequation)
pLog ("test: " ++ show res)
return res
,
\mres -> do
pLog ("equation succeeded: " ++ show mres)
mrel <- case mres of
Just (e,st) -> do
(e1,e2) <- getBinary e
let rel = e1 .==. e2
math <- maybeToParse $ safeLast $ getMaths st
return $ Just (rel,math)
Nothing -> return Nothing
pLog $ "found rel: " ++ show mrel
res <- pSolveLinear mrel
guard (length (snd res) >= 2)
return $ first rightHandSide res
]
pStepsNumerical :: SEParser (Expr, [Step],[Math])
pStepsNumerical = do
pLog "Numerical"
res <- many1 (pSkipUntil $ pMatchSubSteps nexpr)
let sts = concatMap (snd . fst) res
let sk = concatMap snd res
let e = fst $ fst $ head res
return (e, sts, sk)
where
nexpr = lt "r" newMagicNat $ \r -> lblE "Try" r ((30 + 4*r <!> 30*r + 4 <!> 30*r) <&> 8*r)
pFinalAnswer :: [Math] -> Expr -> SEParser (Maybe Step)
pFinalAnswer skipped e = do
pLog "pFinalAnswer"
rest <- many skip
let answers = mapMaybe mAnswer (skipped ++ rest)
let me = closestInList (filter (\n -> isNat n && n >= 6 && n <= 10) $ e : answers) 8
case me of
Nothing -> pLog "empty" >> return Nothing
Just fe -> return $ Just $ makeFAStep fe
mAnswer :: Math -> Maybe Expr
mAnswer m =
msum
[ do
(x :==: y) <- getEq m
guard (isVar x && isNat y)
return y
, do
n <- getExpr m
guard (isNat n)
return n
]