{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Recognize.Model.EvidenceBuilder
( EvBuilder
, putAttributes, updateVar, getValueOf
, setValueOf, storeEvidenceMaybe, buildEvidence, newVar
, getAttributesPerStep, getVariables, putVariables
) where
import Control.Monad.State
import Data.Semigroup
import qualified Data.Map as M
import Domain.Math.Expr
import Recognize.Data.Attribute
import Bayes.Evidence
import Recognize.Expr.Symbols
newtype EvBuilder a = EvBuilder (State EvState a)
data EvState = EvState
{ evidence :: Evidence
, attributes :: [[Attribute]]
, variables :: M.Map String Expr
}
instance Functor EvBuilder where
fmap f m = pure f <*> m
instance Applicative EvBuilder where
pure = return
(<*>) = ap
instance Semigroup (EvBuilder a) where
EvBuilder ev1 <> EvBuilder ev2 = EvBuilder $ do
st <- get
if null $ fromEvidence $ evidence $ execState ev1 st
then ev2
else ev1
instance Monad EvBuilder where
return = EvBuilder . return
EvBuilder m >>= f = EvBuilder $ do
a <- m
let EvBuilder x = f a
x
instance MonadState EvState EvBuilder where
get = EvBuilder get
put s = EvBuilder $ put s
newVar :: String -> EvBuilder Expr
newVar s = do
let mn = namedWildcard s
updateVar s mn
return mn
updateVar :: String -> Expr -> EvBuilder ()
updateVar s v = EvBuilder $ modify $ \st ->
st { variables = M.insert s v $ variables st }
getValueOf :: Expr -> EvBuilder Expr
getValueOf e@(Sym s [Var n]) = EvBuilder $ do
m <- gets variables
case (isNamedWildcardSymbol s,M.lookup n m) of
(True,Just e') -> return e'
_ -> return e
getValueOf e = return e
setValueOf :: Expr -> Expr -> EvBuilder ()
setValueOf (Sym _ [Var n]) v = updateVar n v
setValueOf _ _ = return ()
buildEvidence :: EvBuilder () -> [[Attribute]] -> Evidence
buildEvidence (EvBuilder m) attrs =
evidence $ execState m $ EvState mempty attrs M.empty
storeEvidence :: Evidence -> EvBuilder ()
storeEvidence ev = EvBuilder $ modify $ \st ->
st { evidence = evidence st <> ev }
storeEvidenceMaybe :: Maybe Evidence -> EvBuilder ()
storeEvidenceMaybe = maybe (return ()) storeEvidence
putAttributes :: [[Attribute]] -> EvBuilder ()
putAttributes attrs = EvBuilder $ modify $ \st -> st { attributes = attrs }
getAttributesPerStep :: EvBuilder [[Attribute]]
getAttributesPerStep = EvBuilder $ gets attributes
getVariables :: EvBuilder (M.Map String Expr)
getVariables = EvBuilder $ gets variables
putVariables :: M.Map String Expr -> EvBuilder ()
putVariables vs = EvBuilder $ modify $ \st -> st { variables = vs }