module Recognize.SubExpr.Recognizer
( pMatchSubSteps
) where
import Control.Applicative (empty, (<|>))
import Control.Arrow
import Control.Monad
import Data.Maybe
import qualified Data.Map as M
import Domain.Math.Data.Relation
import Domain.Math.Expr
import Ideas.Common.Id (newId)
import Ideas.Common.Rewriting
import Ideas.Common.View (from)
import Ideas.Utils.Prelude
import Recognize.Parsing.Parse
import Recognize.Data.Math
import Recognize.Parsing.Derived
import Recognize.SubExpr.SEParser
import Recognize.Expr.Functions as F
import Recognize.Expr.Normalform
import Recognize.SubExpr.Compare
import Recognize.SubExpr.Symbols
import Recognize.SubExpr.Functions as SF
import Recognize.Data.Attribute
import Recognize.Data.Diagnosis
import Recognize.Data.Step
import Util.List
import Util.Monad
pMatchSubSteps :: Expr -> SEParser (Expr, [Step])
pMatchSubSteps m = do
pLog $ "pMatchSubSteps: " ++ show m
b_iter <- gets optIterate
stop_pred <- gets matchPredicate
(e,st) <- pFoldAlt b_iter (\(m2,steps) -> do
pLog ("Iteration: " ++ show m2 ++ " " ++ show steps)
math <- peek
pLog ("Math: " ++ show math)
when (isMatched m2) $ pLog "stopping" >> guard (stop_pred m2)
choice' [successStep (m2,steps) math, failStep (m2,steps)]
) (m,[])
pLog ("Can we exit pMatchSubSteps? " ++ show e ++ " | " ++ show (isMatched e))
unless (isMatched e) empty
e2 <- pSubstituteVars e
e3 <- maybeToParse $ getMatched e2
let e4 = cleanExpr e3
pLog ("Exit pMatchSubSteps: " ++ show (e4, st))
return (e4, st)
where
successStep (m2,steps) math = do
(m3, attr2) <- gets inputType >>= pMatchSubInputType m2 math
_ <- skip
return (m3, steps ++ [Step (newId "subexpr") (math, attr2) []])
failStep mst = do
guardBy optSkipOnce
modify $ \st -> st { optSkipOnce = False }
_ <- skip
pLog "Skip an expression"
math <- peek
successStep mst math
pMatchSubInputType :: Expr -> Math -> Maybe [InputType] -> SEParser (Expr, [Attribute])
pMatchSubInputType m math Nothing = do
e <- getExpr math
pLog ("pMatchSubInputType: " ++ show e ++ " : " ++ show (determineInputType e))
pMatchSubInputType' m math (determineInputType e)
pMatchSubInputType m math (Just its) = do
e <- getExpr math
pLog ("pMatchSubInputType: " ++ show e ++ " : " ++ show (determineInputType e) ++ " " ++ show its)
let e_inputType = determineInputType e
guard $ any (doesTypeConform e e_inputType) its
pMatchSubInputType' m math e_inputType
where
doesTypeConform e Linear lwt@(LinearWithType t) = e `conformsTo` lwt
doesTypeConform _ eit it = eit == it
pMatchSubInputType' :: Expr -> Math -> InputType -> SEParser (Expr, [Attribute])
pMatchSubInputType' m math Expr = getExpr math >>= pMatchSubExpr m
pMatchSubInputType' m math Definition = getEq math >>= pMatchSubDef m
pMatchSubInputType' m math Equation = do
che <- gets chainedEquations
rel <- getRelation math
pMatchSubEq che m (leftHandSide rel :==: rightHandSide rel)
pMatchSubInputType' m math Linear = do
rel <- getRelation math
pMatchSubLin m rel
pMatchSubInputType' m math (LinearWithType _) = pMatchSubInputType' m math Linear
pMatchSubExpr :: Expr -> Expr -> SEParser (Expr, [Attribute])
pMatchSubExpr m e = do
pLog ("pMatchSubExpr: " ++ show m ++ " | " ++ show e)
res <- pMatchSubInput (\x -> addMatching x >> return (matchExpr x)) m e
pLog ("MatchedExpr: " ++ show m ++ " " ++ show e ++ " " ++ show res)
return res
pMatchSubEq :: Bool -> Expr -> Equation Expr -> SEParser (Expr, [Attribute])
pMatchSubEq _ m (x :==: y) = do
pLog ("pMatchSubEq: " ++ show m ++ " | " ++ show x ++ " .==. " ++ show y)
us <- resetSEState
mxy <- option $ choice' [ (\(a,b) -> (a,b,y)) <$> pMatchSubInput return x y
]
put us
let attr1 = maybe [InvalidEquation x y] (\t -> MatchedBy x y : snd3 t) mxy
when (isJust mxy) $ pLog ("Found Valid equation match: " ++ show mxy)
when (isNothing mxy) $ pLog "Found Invalid equation"
(m2,attr2) <- pMatchSubInput (\_ -> addMatching y >> return (matchExpr $ maybe y thd3 mxy)) m x
pLog ("Matched: " ++ show m ++ " | " ++ show (x .==. y) ++ " | " ++ show m2 ++ " | " ++ show mxy)
return (m2, filter (\a -> isLabelAttr a || isCommonMistake a) attr2 ++ attr1)
pMatchSubDef :: Expr -> Equation Expr -> SEParser (Expr, [Attribute])
pMatchSubDef m e@(x :==: y) = do
pLog ("pMatchSubDef: " ++ show m ++ " | " ++ show e)
(m2,rw) <- pMatchSubInput (\_ -> addMatching x >> addMatching y >> matchExpr <$> (return y <|> return x)) m y
pLog ("MatchedDef: " ++ show m ++ " " ++ show e ++ " " ++ show m2)
return (m2, rw)
pMatchSubLin :: Expr -> Relation Expr -> SEParser (Expr, [Attribute])
pMatchSubLin m rel = do
let x = leftHandSide rel
let y = rightHandSide rel
pLog ("pMatchSubLin: " ++ show m ++ " | " ++ show x ++ " .==. " ++ show y)
(m2,attrx) <- pMatchSubInput (\_ -> addMatching x >> matchExpr <$> return x) m x
(m3,attry) <- pMatchSubInput (\_ -> addMatching y >> matchExpr <$> return y) m2 y
return (m3,attrx++attry)
pMatchSubInput :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])
pMatchSubInput c m e =
choice'
[ pFindSubExpr c m e
, do
guardBy optGrow
guard (not $ hasMatch m)
f <- gets growF
applyFirstM c $ pMatchSubGrow f (\x -> addMatching x >> return (matchExpr x)) m e
]
pMatchSubGrow :: (Expr -> Expr) -> (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])
pMatchSubGrow f c m e = do
pLog ("pMatchSubGrow " ++ show e ++ " " ++ show m)
let alts = alternativesExpr m
let findAlts = map (\(m2,rw) -> pFindSubExpr c e m2 >>= \(e2,_) -> return (e2,rw,m2)) alts
(e2,rw,m2) <- choice' findAlts
pLog $ "Matching in Grow: " ++ show e2 ++ " | " ++ show m2
if isMatch e2
then (\x -> (x,rw)) <$> c e
else second (rw++) <$> pMatchSubGrow f c e2 (f (matchExpr m2))
pFindSubExpr :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubExpr c m e = do
pLog ("pFindSubExpr: " ++ show m ++ " " ++ show e)
mres <- option pFindSubExpr'
maybeToParse mres
where
pFindSubExpr' =
case getFunction m of
Nothing -> pFindSubNullary c m e
Just (s,[])
| isMagicNumberSymbol s -> pFindSubMagicNumber c e
| isMagicNatSymbol s -> pFindSubMagicNat c e
| isMagicVarSymbol s -> pFindSubMagicVar c e
Just (s,[x])
| isStopSymbol s -> empty
| isMatchSymbol s -> pFindSubMatch c s x e
| isSimSymbol s -> pFindSubSim c s x e
| isNoSimSymbol s -> pFindSubNoSim c s x e
| isSubSymbol s -> pFindSubSub c s x e
| isVarSymbol s -> pFindSubVar c x e
| otherwise -> pFindSubUnary c s x e
Just (s,[x,y])
| isBuggySymbol s -> pFindSubBuggy c x y e
| isOrSymbol s -> pFindSubOr c s x y e
| isAndSymbol s -> pFindSubAnd c s x y e
| isLabelSymbol s -> pFindSubLabel c s x y e
| timesSymbol == s -> pFindSubAssoc c s (snd $ from productView m) e
| plusSymbol == s -> pFindSubAssoc c s (from sumView m) e
| divideSymbol == s -> pFindSubDivision c s x y e
| otherwise -> pFindSubBinary c s x y e
Just (s,[x,y,z])
| isLtSymbol s -> pFindSubLt c x y z e
_ -> pLog ("Empty in pFindSubExpr: " ++ show m ++ " " ++ show e) >> empty
pFindSubMagicNumber :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])
pFindSubMagicNumber c e = do
guard (isNumber e)
(\x -> (x,[])) <$> c e
pFindSubMagicNat :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])
pFindSubMagicNat c e = do
guard (isNat e)
(\x -> (x,[])) <$> c e
pFindSubMagicVar :: (Expr -> SEParser Expr) -> Expr -> SEParser (Expr, [Attribute])
pFindSubMagicVar c e = do
guard (F.isVar e)
(\x -> (x,[])) <$> c e
pFindSubNullary :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubNullary c e1 e2 = do
pLog ("pFindSubNullary: " ++ show e1 ++ " " ++ show e2)
precision <- gets precision
b <- pCompare (roundNumber precision e1) (roundNumber precision e2)
guard b
(\x -> (x,[])) <$> c e1
pFindSubMatch :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubMatch c s m e = do
(e,attrs) <- pMatchAlts (function s [m]) e
let mattr = MatchedBy m e
e' <- c e
return (e',mattr : attrs)
pFindSubSim :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubSim c s m e = do
b <- gets optTraverse
dic <- gets usedVariables
modify $ \st -> st { optTraverse = False }
m' <- maybeToParse $ substituteAllIf SF.isVar dic m
(m2, attrs) <- pFindSubExpr c (nf $ cleanExpr m') e
modify $ \st -> st { optTraverse = b }
pLog $ "pFindSubSim " ++ show m' ++ " | " ++ show m2 ++ " | " ++ show e
if isMatched m2 && isSimplified m2
then return (m2, attrs)
else return (function s [m2], attrs)
pFindSubNoSim :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubNoSim c s m e = do
pLog $ "pFindSubNoSim: " ++ show m ++ " " ++ show e
modify $ \st -> st { optSimplify = False }
(m2, attrs) <- pFindSubExpr c m e
modify $ \st -> st { optSimplify = True }
return (function s [m2], attrs)
pFindSubSub :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubSub c s m e = do
pLog ("pFindSubSub: " ++ show m ++ " " ++ show e)
guardBy optTraverse
if isMatched m
then do
(m2,attrs) <- pFindSubExpr c m e
if nfComAssoc m2 == nf m2
then return (m2,attrs)
else return (function s [m2],attrs)
else do
guard (hasSub m || not (isAtom e))
sim <- gets optSimplify
modify $ \st -> st { optSimplify = False }
(m2, attrs) <- pFindSubExpr c m e
modify $ \st -> st { optSimplify = sim }
pLog ("pFindSubSub: " ++ show m2)
if isMatched m2 && nfComAssoc m2 == nf m2
then return (m2, attrs)
else return (function s [m2], attrs)
pFindSubVar :: (Expr -> SEParser Expr) -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubVar c (Var v) e = do
pLog ("pFindSubVar: " ++ show v ++ " " ++ show e)
vars <- gets usedVariables
let mx = M.lookup v vars
x <- maybeToParse mx
(x2, attrs) <- applyFirstM c $ pMatchAlts x e
modify $ \st -> st { usedVariables = M.insert v x2 vars }
pLog ("End of pFindSubVar: " ++ show x2)
return (x2,attrs)
pFindSubVar _ _ _ = empty
pFindSubUnary :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubUnary c s m e =
choice [ do
guardBy optTraverse
(m2,rw) <- pFindSubExpr c m e
return (function s [m2], rw)
,
applyFirstM c $ pMatchAlts (function s [m]) e
]
pFindSubBuggy :: (Expr -> SEParser Expr) -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubBuggy c x y e = do
pLog ("pFindSubBuggy: " ++ show x ++ " " ++ show y ++ " " ++ show e)
choice
[ do
pLog "Go in Left"
pFindSubExpr c x e
, do
pLog "Go in Right"
second (CommonMistake:) <$> pFindSubExpr c y e
]
pFindSubOr :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubOr c s x y e = do
pLog ("pFindSubOr: " ++ show x ++ " " ++ show y ++ " " ++ show e)
(eth, attr) <- choice
[ first Left <$> pFindSubExpr c x e
, first Right <$> pFindSubExpr c y e
]
case eth of
Left x' -> return (function s [x',y], attr)
Right y' -> return (function s [x,y'],attr)
pFindSubAnd :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubAnd c s x y e = do
pLog ("pFindSubAnd: " ++ show x ++ " " ++ show y ++ " " ++ show e)
(eth, attr) <- choice
[ first Left <$> pFindSubExpr c x e
, first Right <$> pFindSubExpr c y e
]
case eth of
Left x' -> return (function s [x',y], attr)
Right y' -> return (function s [x,y'],attr)
pFindSubLabel :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubLabel c s lbl@(Var l) x e = do
pLog ("pFindSubLabel: " ++ show lbl ++ " " ++ show x ++ " " ++ show e)
(m,attr) <- pFindSubExpr c x e
return $
if isMatched m
then (m, Label l : attr)
else (function s [lbl, m], attr)
pFindSubLabel _ _ _ _ _ = empty
pFindSubDivision :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubDivision c s x y e = do
pLog ("pFindSubDivision: " ++ show s ++ " " ++ show x ++ " " ++ show y ++ " " ++ show e)
choice [ do
guardBy optTraverse
(x2,rw) <- pFindSubExpr c x e
return (function s [x2,y], rw)
, do
guardBy optTraverse
(y2, rw) <- pFindSubExpr c y e
return (function s [x,y2], rw)
, do
(opS, xs) <- choice'
[ succeedIf (\xs -> length xs > 1) (plusSymbol, from sumView x)
, succeedIf (\xs -> length xs > 1) (timesSymbol, snd $ from productView x)
]
choice [ do
guardBy optTraverse
((z,rw),zs) <- choiceFor' (selections xs) $ \(x,xs) -> pFindSubExpr c (x/y) e >>= \res -> return (res,xs)
return (function s (z:zs), rw)
, do
(x2,attr) <- pFindSubAssoc c opS xs (e*y)
return (function s [x2,y], attr)
] ,
applyFirstM c $ pMatchAlts (function s [x,y]) e
]
pFindSubBinary :: (Expr -> SEParser Expr) -> Symbol -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubBinary c s x y e = do
pLog ("pFindSubBinary:" ++ show s ++ " " ++ show x ++ " " ++ show y ++ " " ++ show e)
choice
[ do
guardBy optTraverse
(x2,rw) <- pFindSubExpr c x e
return (function s [x2,y], rw)
, do
guardBy optTraverse
(y2, rw) <- pFindSubExpr c y e
return (function s [x,y2], rw)
, applyFirstM c $ pMatchAlts (function s [x,y]) e
]
pFindSubAssoc :: (Expr -> SEParser Expr) -> Symbol -> [Expr] -> Expr -> SEParser (Expr, [Attribute])
pFindSubAssoc c s xs e = do
pLog ("pFindSubAssoc : " ++ show s ++ " " ++ show xs ++ " | " ++ show e)
let subCombsCartProd = concatMap (uncurry cartProd . first (: []) . second subExprsCombs) $ selections xs
pLog $ "Assoc tempts: " ++ show subCombsCartProd
choice
[ choiceFor subCombsCartProd $ \(y,(ys,attr)) -> do
pLog ("Assoc attempt: " ++ show y ++ " " ++ show ys ++ " | " ++ show e)
(ys',attr2) <- pFindSubExpr c (function s ys) e
return (function s [y,ys'],attr ++ attr2)
, do
(e,attr) <- pMatchAlts (function s xs) e
e' <- c e
return (e',attr)
]
pFindSubLt :: (Expr -> SEParser Expr) -> Expr -> Expr -> Expr -> Expr -> SEParser (Expr, [Attribute])
pFindSubLt c (Var v) x y e = do
pLog ("pFindSubLt: " ++ show v ++ " " ++ show x ++ " " ++ show y ++ " " ++ show e)
modify $ \st -> st { usedVariables = M.insert v x (usedVariables st) }
pFindSubExpr c y e
pFindSubLt _ _ _ _ _ = empty
pMatchAlts :: Expr -> Expr -> SEParser (Expr, [Attribute])
pMatchAlts m e = do
pLog $ "pMatchAlts: " ++ show m ++ " | " ++ show e
pLog $ "pMatch alts: " ++ show alts
choiceFor alts $ \(m1,attrs) -> do
pLog ("pMatchAlt: " ++ show m1 ++ " | " ++ show e)
choice'
[ do
guardBy optSimplify
guard (not $ hasSub m1)
(_, _, z) <- pCompareBySimplify m1 e
pLog "Simplified equal"
attrs' <- pGatherLabels m1
return (e, attrs' ++ attrs ++ z)
, do
pLog "Compare normalized"
(_, y) <- pCompareByNormalize m1 e
pLog "Normalized equal"
attrs' <- pGatherLabels m1
return (e, attrs' ++ attrs ++ y)
]
where
alts = alternativesExpr m
pGatherLabels :: Expr -> SEParser [Attribute]
pGatherLabels m = case getFunction m of
Nothing -> return []
Just (s,[Var l,y])
| isLabelSymbol s -> (Label l:) <$> pGatherLabels y
Just (s,[Var l, e,y])
| isLabelSymbol s -> do
e' <- pSubstituteVars e
(LabelE l e':) <$> pGatherLabels y
Just (_,xs) -> concat <$> mapM pGatherLabels xs