{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
module ToySolver.Data.OrdRel
(
RelOp (..)
, flipOp
, negOp
, showOp
, evalOp
, OrdRel (..)
, fromOrdRel
, IsEqRel (..)
, IsOrdRel (..)
) where
import qualified Data.IntSet as IS
import ToySolver.Data.Boolean
import ToySolver.Data.IntVar
infix 4 .<., .<=., .>=., .>., .==., ./=.
data RelOp = Lt | Le | Ge | Gt | Eql | NEq
deriving (Show, Eq, Ord)
flipOp :: RelOp -> RelOp
flipOp Le = Ge
flipOp Ge = Le
flipOp Lt = Gt
flipOp Gt = Lt
flipOp Eql = Eql
flipOp NEq = NEq
negOp :: RelOp -> RelOp
negOp Lt = Ge
negOp Le = Gt
negOp Ge = Lt
negOp Gt = Le
negOp Eql = NEq
negOp NEq = Eql
showOp :: RelOp -> String
showOp Lt = "<"
showOp Le = "<="
showOp Ge = ">="
showOp Gt = ">"
showOp Eql = "="
showOp NEq = "/="
evalOp :: Ord a => RelOp -> a -> a -> Bool
evalOp Lt = (<)
evalOp Le = (<=)
evalOp Ge = (>=)
evalOp Gt = (>)
evalOp Eql = (==)
evalOp NEq = (/=)
class IsEqRel e r | r -> e where
(.==.) :: e -> e -> r
(./=.) :: e -> e -> r
class IsEqRel e r => IsOrdRel e r | r -> e where
(.<.), (.<=.), (.>.), (.>=.) :: e -> e -> r
ordRel :: RelOp -> e -> e -> r
a .<. b = ordRel Lt a b
a .<=. b = ordRel Le a b
a .>. b = ordRel Gt a b
a .>=. b = ordRel Ge a b
ordRel Lt a b = a .<. b
ordRel Gt a b = a .>. b
ordRel Le a b = a .<=. b
ordRel Ge a b = a .>=. b
ordRel Eql a b = a .==. b
ordRel NEq a b = a ./=. b
{-# MINIMAL ((.<.), (.<=.), (.>.), (.>=.)) | ordRel #-}
data OrdRel e = OrdRel e RelOp e
deriving (Show, Eq, Ord)
instance Complement (OrdRel c) where
notB (OrdRel lhs op rhs) = OrdRel lhs (negOp op) rhs
instance IsEqRel e (OrdRel e) where
(.==.) = ordRel Eql
(./=.) = ordRel NEq
instance IsOrdRel e (OrdRel e) where
ordRel op a b = OrdRel a op b
instance Variables e => Variables (OrdRel e) where
vars (OrdRel a _ b) = vars a `IS.union` vars b
instance Functor OrdRel where
fmap f (OrdRel a op b) = OrdRel (f a) op (f b)
fromOrdRel :: IsOrdRel e r => OrdRel e -> r
fromOrdRel (OrdRel a op b) = ordRel op a b
instance (Eval m e a, Ord a) => Eval m (OrdRel e) Bool where
eval m (OrdRel lhs op rhs) = evalOp op (eval m lhs) (eval m rhs)