{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Domain.Algebra.Boolean
(
BoolValue(..), Boolean(..)
, ands, ors, implies, equivalent
, CoBoolean(..), conjunctions, disjunctions
, DualMonoid(..), And(..), Or(..)
) where
import Control.Applicative
import Domain.Algebra.Group
import Ideas.Common.Classes
import Test.QuickCheck
import qualified Data.Semigroup as Sem
class BoolValue a => CoBoolean a where
isAnd :: a -> Maybe (a, a)
isOr :: a -> Maybe (a, a)
isComplement :: a -> Maybe a
instance CoBoolean a => CoMonoid (And a) where
isEmpty = isTrue . fromAnd
isAppend = fmap (mapBoth And) . isAnd . fromAnd
instance CoBoolean a => CoMonoidZero (And a) where
isMonoidZero = isFalse . fromAnd
instance CoBoolean a => CoMonoid (Or a) where
isEmpty = isFalse . fromOr
isAppend = fmap (mapBoth Or) . isOr . fromOr
instance CoBoolean a => CoMonoidZero (Or a) where
isMonoidZero = isTrue . fromOr
conjunctions :: CoBoolean a => a -> [a]
conjunctions = map fromAnd . associativeList . And
disjunctions :: CoBoolean a => a -> [a]
disjunctions = map fromOr . associativeList . Or
class MonoidZero a => DualMonoid a where
(><) :: a -> a -> a
dualCompl :: a -> a
newtype And a = And {fromAnd :: a}
deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
instance Functor And where
fmap f = And . f . fromAnd
instance Applicative And where
pure = And
And f <*> And a = And (f a)
instance Boolean a => Sem.Semigroup (And a) where
(<>) = liftA2 (<&&>)
instance Boolean a => Monoid (And a) where
mempty = pure true
mappend = (Sem.<>)
instance Boolean a => MonoidZero (And a) where
mzero = pure false
instance Boolean a => DualMonoid (And a) where
(><) = liftA2 (<||>)
dualCompl = liftA complement
newtype Or a = Or {fromOr :: a}
deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
instance Functor Or where
fmap f = Or . f . fromOr
instance Applicative Or where
pure = Or
Or f <*> Or a = Or (f a)
instance Boolean a => Sem.Semigroup (Or a) where
(<>) = liftA2 (<||>)
instance Boolean a => Monoid (Or a) where
mempty = pure false
mappend = (Sem.<>)
instance Boolean a => MonoidZero (Or a) where
mzero = pure true
instance Boolean a => DualMonoid (Or a) where
(><) = liftA2 (<&&>)
dualCompl = liftA complement