Constraint.hs

{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- This module defines the constraint data types.
-- We differentiate between two constraint types:
-- 
-- * Node constraint
-- * regular constraint
-- 
-- The regular constraint consists of a set of identifiers
-- and a function that consumes some type @a@ and produces a `Result`.
-- The set of identifiers come from combining constraints using the connectives
-- defined in "Connectives".
-- 
-- A Node constraint is simply a product of a Node Bool (the node) and a regular constraint.
-- The constraint then corresponds to a node in one of the networks.
--
-----------------------------------------------------------------------------

module Recognize.Model.Constraint where

import Data.Monoid
import qualified Data.Semigroup as SG
import Recognize.Model.EvidenceBuilder
import Recognize.Model.Result
import Bayes.Network (Node)

-- | Wraps over a constraint by giving it a specific node
data NodeConstraint b m a = NodeConstraint
  { getNode :: Node b -- ^ The node of a constraint
  , getConstraint :: Constraint m a -- ^ The underlying constraint
  }

-- | Models constraints that have an identifier and describe predicates that produce a result
data Constraint m a = Constraint
  {
    getResult :: a -> m Result -- ^ Predicates that produces a `Result` given an @a@
  }

-- | Couple a constraint to a specific Node
giveNode :: Node b -> Constraint m a -> NodeConstraint b m a
giveNode = NodeConstraint

-- | Makes a nodeconstraint:
makeNodeConstraint :: Node b -> (a -> m Result) -> NodeConstraint b m a
makeNodeConstraint node = NodeConstraint node . Constraint

instance SG.Semigroup (Constraint EvBuilder a) where
   (Constraint mr1) <> (Constraint mr2) = Constraint (combinePredicates mr1 mr2)

instance Monoid (Constraint EvBuilder a) where
  mempty = Constraint (\_ -> return Success)
  mappend = (SG.<>)

-- | Combines two predicates into one
combinePredicates :: (a -> EvBuilder Result) -> (a -> EvBuilder Result) -> a -> EvBuilder Result
combinePredicates rm1 rm2 a = do
  r1 <- rm1 a
  r2 <- rm2 a
  return (r1 <> r2)