{-# LANGUAGE FlexibleInstances #-}
module Recognize.Model.Assess
(
generateEvidence, answerCorrect, stringNode
, failOnInvalidEquationAny, failOnInvalidEquation, failOnIncorrectDistribution, failOnCommonMistake
, failOnUnequalRelationAny, failOnUnequalRelation, failOnAtomMixedUpAny, failOnAnyMistake
, withoutFailure
, giveNodeAndCollect, giveNodeAndCollectAll, giveNodeAndCollectAllKnown, giveNodeAndCollectDefault
) where
import Control.Monad.Identity
import Control.Monad.State
import Data.Either
import Data.Maybe
import Data.Monoid
import Data.List
import Domain.Math.Expr
import Domain.Math.Data.Relation
import Ideas.Utils.Uniplate
import Recognize.Model.Constraint
import Recognize.Model.EvidenceBuilder
import Recognize.Model.Result
import Bayes.Evidence
import Recognize.Data.Approach
import Recognize.Data.Attribute
import Recognize.Model.Connectives
import Recognize.Expr.Normalform
import Recognize.Expr.Symbols
import Recognize.Expr.Functions
import Bayes.Network
import Util.List
generateEvidence :: (Approach -> EvBuilder ())
-> Approach
-> [[Attribute]]
-> Evidence
generateEvidence feb appr = buildEvidence (feb appr)
answerCorrect :: Expr -> [[Attribute]] -> Node Bool -> Evidence
answerCorrect ans attrs aC = mconcat (catMaybes [ verifyConstraintI (answerConstraint ans aC) (concat attrs)])
stringNode :: Maybe String -> Node String -> Evidence
stringNode (Just s) n = n .== s
stringNode Nothing _ = mempty
answerConstraint :: Expr -> Node Bool -> NodeConstraint Bool Identity [Attribute]
answerConstraint fa aC =
makeNodeConstraint aC $ \xs -> return $
case xs of
_ | FinalAnswer fa `elem` xs -> Success
| hasFA xs -> Failure
| otherwise -> Unknown
where
hasFA xs = isJust $ find (\attr -> case attr of
FinalAnswer _ -> True
_ -> False) xs
failOnInvalidEquationAny :: Constraint EvBuilder [Attribute]
failOnInvalidEquationAny = negateConstraint (exists1 $ InvalidEquation wildcard wildcard)
failOnInvalidEquation :: Expr -> Expr -> Constraint EvBuilder [Attribute]
failOnInvalidEquation e1 e2 = negateConstraint (exists1 $ InvalidEquation e1 e2)
failOnIncorrectDistribution :: Constraint EvBuilder [Attribute]
failOnIncorrectDistribution = negateConstraint (exists1 IncorrectDistribution <||> exists1 NonMatchingParentheses)
failOnCommonMistake :: Constraint EvBuilder [Attribute]
failOnCommonMistake = negateConstraint (exists1 CommonMistake)
failOnUnequalRelation :: Relation Expr -> Relation Expr -> Constraint EvBuilder [Attribute]
failOnUnequalRelation rel1 rel2 = negateConstraint (exists1 $ UnequalRelations rel1 rel2)
failOnUnequalRelationAny :: Constraint EvBuilder [Attribute]
failOnUnequalRelationAny = failOnUnequalRelation wildcardRelation wildcardRelation
failOnAtomMixedUpAny :: Constraint EvBuilder [Attribute]
failOnAtomMixedUpAny = negateConstraint (exists1 $ AtomMixedUp wildcard wildcard)
failOnAnyMistake :: Constraint EvBuilder [Attribute]
failOnAnyMistake = failOnCommonMistake <> failOnInvalidEquationAny <> failOnUnequalRelationAny <> failOnAtomMixedUpAny <> failOnIncorrectDistribution
withoutFailure :: Constraint EvBuilder [Attribute] -> Constraint EvBuilder [Attribute]
withoutFailure c = c ==> (failOnAnyMistake <?>> mempty)
collect :: Verifiable b => NodeConstraint b EvBuilder [Attribute] -> EvBuilder ()
collect c = verifyConstraint c >>= storeEvidenceMaybe
collectDefault :: Verifiable b => NodeConstraint b EvBuilder [Attribute] -> Expr -> Expr -> EvBuilder ()
collectDefault c var new = do
mev <- verifyConstraint c
val <- (nfComAssoc . normalizeIfNF) <$> transformM getValueOf new
replaceWhenUnknown mev var val
storeEvidenceMaybe mev
replaceWhenUnknown :: Maybe a -> Expr -> Expr -> EvBuilder ()
replaceWhenUnknown Nothing var new = setValueOf var new
replaceWhenUnknown _ _ _ = return ()
giveNodeAndCollect :: Verifiable b => Node b -> Constraint EvBuilder [Attribute] -> EvBuilder ()
giveNodeAndCollect n c = do
let nodeconstraint = giveNode n c
collect nodeconstraint
giveNodeAndCollectAll :: Verifiable b => Node b -> [Constraint EvBuilder [Attribute]] -> EvBuilder ()
giveNodeAndCollectAll n cs = do
evs <- mapM (verifyConstraint . giveNode n) cs
let knownEvs = lefts (map snd (concatMap fromEvidence (catMaybes evs)))
let nodeconstraint | 1 `elem` knownEvs = giveNode n failure
| any isNothing evs = giveNode n unknown
| otherwise = giveNode n success
storeEvidenceMaybe (verifyConstraintI nodeconstraint [])
giveNodeAndCollectAllKnown :: Verifiable b => Node b -> [Constraint EvBuilder [Attribute]] -> EvBuilder ()
giveNodeAndCollectAllKnown n cs = do
evs <- mapM (verifyConstraint . giveNode n) cs
let knownEvs = lefts (map snd (concatMap fromEvidence (catMaybes evs)))
let nodeconstraint | null knownEvs = giveNode n unknown
| 1 `elem` knownEvs = giveNode n failure
| otherwise = giveNode n success
storeEvidenceMaybe (verifyConstraintI nodeconstraint [])
giveNodeAndCollectDefault :: Verifiable b => Node b -> Constraint EvBuilder [Attribute] -> Expr -> Expr -> EvBuilder ()
giveNodeAndCollectDefault n c var new = do
let nodeconstraint = giveNode n c
collectDefault nodeconstraint var new
class Verifiable b where
verifyConstraint :: NodeConstraint b EvBuilder [Attribute] -> EvBuilder (Maybe Evidence)
verifyConstraintI :: NodeConstraint b Identity [a] -> [a]-> Maybe Evidence
instance Verifiable Bool where
verifyConstraint c = do
attrs <- getAttributesPerStep
mi <- returnOnJustM (\a -> do
st <- get
res <- getResult (getConstraint c) a
when (isUnknown res) $ put st
return $ resultToBool res) attrs
case mi of
Nothing -> do
r <- getResult (getConstraint c) []
return (resultToBool r >>= \i -> return $ getNode c .== i)
Just (i,attrs') -> do
putAttributes attrs'
return $ Just $ getNode c .== i
verifyConstraintI c attrs =
case resultToBool $ runIdentity $ getResult (getConstraint c) attrs of
Nothing -> Nothing
Just i -> Just $ getNode c .== i
instance Verifiable (Maybe Bool) where
verifyConstraint c = do
attrs <- getAttributesPerStep
mi <- returnOnJustM (\a -> do
st <- get
res <- getResult (getConstraint c) a
when (isUnknown res) $ put st
return $ resultToBool res) attrs
case mi of
Nothing -> do
r <- getResult (getConstraint c) []
return (resultToBool r >>= \i -> return $ getNode c .== (Just i))
Just (i,attrs') -> do
putAttributes attrs'
return $ Just $ getNode c .== (Just i)
verifyConstraintI c attrs =
case resultToBool $ runIdentity $ getResult (getConstraint c) attrs of
Nothing -> Nothing
Just i -> Just $ getNode c .== (Just i)