Boolean.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Ideas 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)
--
-----------------------------------------------------------------------------

module Domain.Algebra.Boolean
   ( -- * Boolean algebra (re-exported)
     BoolValue(..), Boolean(..)
   , ands, ors, implies, equivalent
     -- * CoBoolean (matching)
   , CoBoolean(..), conjunctions, disjunctions
     -- * Monoids monoid
   , DualMonoid(..), And(..), Or(..)
   ) where

import Control.Applicative
import Domain.Algebra.Group
import Ideas.Common.Classes
import Test.QuickCheck
import qualified Data.Semigroup as Sem

--------------------------------------------------------
-- CoBoolean (matching)

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

--------------------------------------------------------
-- Dual monoid for a monoid (and for or, and vice versa)

class MonoidZero a => DualMonoid a where
   (><)      :: a -> a -> a
   dualCompl :: a -> a

--------------------------------------------------------
-- And monoid

newtype And a = And {fromAnd :: a}
   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)

instance Functor And where -- could be derived
   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

--------------------------------------------------------
-- Or monoid

newtype Or a  = Or {fromOr :: a}
   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)

instance Functor Or where -- could be derived
   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