{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module: Data.Greskell.Logic
-- Description: Logic tree data structure
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- Developer note: This module defines 'Logic', a data structure for
-- logic operation tree. There are already similar packages to this
-- module, but, none of them satisfy our requirements.
--
-- Boolean/logic tree data structures
--
-- - https://hackage.haskell.org/package/boolean-normal-forms
-- - https://hackage.haskell.org/package/logic-classes
-- - https://hackage.haskell.org/package/PropLogic
-- - https://hackage.haskell.org/package/Logic
-- - https://hackage.haskell.org/package/boolean-like
--
-- Typeclasses about boolean/logic operations
--
-- - https://hackage.haskell.org/package/Boolean
-- - https://hackage.haskell.org/package/cond
--
-- Trees that contain heterogeneous values
--
-- - http://hackage.haskell.org/package/dual-tree
-- - http://hackage.haskell.org/package/fingertree
--
-- @since 1.2.0.0 
module Data.Greskell.Logic
  ( Logic(..),
    runBool
  ) where

import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Control.Monad (Monad(return,(>>=)))
import Data.Foldable (Foldable(foldMap, toList))
import Data.Traversable (Traversable)
import Data.Monoid ((<>), All(..), Any(..))
import GHC.Generics (Generic)

-- | A general-purpose logic tree structure. Only the leaf nodes have
-- values of type @a@. The tree is lazy both in value and spine (structure).
data Logic a =
    Leaf a -- ^ Leaf node with value
  | And (Logic a) [Logic a] -- ^ \"and\" logic operator
  | Or  (Logic a) [Logic a] -- ^ \"or\" logic operator
  | Not (Logic a) -- ^ \"not\" logic operator
  deriving (Int -> Logic a -> ShowS
[Logic a] -> ShowS
Logic a -> String
(Int -> Logic a -> ShowS)
-> (Logic a -> String) -> ([Logic a] -> ShowS) -> Show (Logic a)
forall a. Show a => Int -> Logic a -> ShowS
forall a. Show a => [Logic a] -> ShowS
forall a. Show a => Logic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Logic a] -> ShowS
$cshowList :: forall a. Show a => [Logic a] -> ShowS
show :: Logic a -> String
$cshow :: forall a. Show a => Logic a -> String
showsPrec :: Int -> Logic a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Logic a -> ShowS
Show,Logic a -> Logic a -> Bool
(Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool) -> Eq (Logic a)
forall a. Eq a => Logic a -> Logic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Logic a -> Logic a -> Bool
$c/= :: forall a. Eq a => Logic a -> Logic a -> Bool
== :: Logic a -> Logic a -> Bool
$c== :: forall a. Eq a => Logic a -> Logic a -> Bool
Eq,Eq (Logic a)
Eq (Logic a)
-> (Logic a -> Logic a -> Ordering)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Logic a)
-> (Logic a -> Logic a -> Logic a)
-> Ord (Logic a)
Logic a -> Logic a -> Bool
Logic a -> Logic a -> Ordering
Logic a -> Logic a -> Logic a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Logic a)
forall a. Ord a => Logic a -> Logic a -> Bool
forall a. Ord a => Logic a -> Logic a -> Ordering
forall a. Ord a => Logic a -> Logic a -> Logic a
min :: Logic a -> Logic a -> Logic a
$cmin :: forall a. Ord a => Logic a -> Logic a -> Logic a
max :: Logic a -> Logic a -> Logic a
$cmax :: forall a. Ord a => Logic a -> Logic a -> Logic a
>= :: Logic a -> Logic a -> Bool
$c>= :: forall a. Ord a => Logic a -> Logic a -> Bool
> :: Logic a -> Logic a -> Bool
$c> :: forall a. Ord a => Logic a -> Logic a -> Bool
<= :: Logic a -> Logic a -> Bool
$c<= :: forall a. Ord a => Logic a -> Logic a -> Bool
< :: Logic a -> Logic a -> Bool
$c< :: forall a. Ord a => Logic a -> Logic a -> Bool
compare :: Logic a -> Logic a -> Ordering
$ccompare :: forall a. Ord a => Logic a -> Logic a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Logic a)
Ord,(forall x. Logic a -> Rep (Logic a) x)
-> (forall x. Rep (Logic a) x -> Logic a) -> Generic (Logic a)
forall x. Rep (Logic a) x -> Logic a
forall x. Logic a -> Rep (Logic a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Logic a) x -> Logic a
forall a x. Logic a -> Rep (Logic a) x
$cto :: forall a x. Rep (Logic a) x -> Logic a
$cfrom :: forall a x. Logic a -> Rep (Logic a) x
Generic)

instance Functor Logic where
  fmap :: (a -> b) -> Logic a -> Logic b
fmap a -> b
f Logic a
l =
    case Logic a
l of
      Leaf a
a -> b -> Logic b
forall a. a -> Logic a
Leaf (a -> b
f a
a)
      And Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Logic a]
rls)
      Or Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Logic a]
rls)
      Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
nl)

-- | 'pure' is 'Leaf'. @fl@ '<*>' @rl@ appends the @rl@ to the leaves
-- of @fl@.
instance Applicative Logic where
  pure :: a -> Logic a
pure a
a = a -> Logic a
forall a. a -> Logic a
Leaf a
a
  Logic (a -> b)
fl <*> :: Logic (a -> b) -> Logic a -> Logic b
<*> Logic a
rl =
    case Logic (a -> b)
fl of
      Leaf a -> b
f -> (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
rl
      And Logic (a -> b)
lfl [Logic (a -> b)]
rfls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic (a -> b)
lfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) ((Logic (a -> b) -> Logic b) -> [Logic (a -> b)] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) [Logic (a -> b)]
rfls)
      Or Logic (a -> b)
lfl [Logic (a -> b)]
rfls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic (a -> b)
lfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) ((Logic (a -> b) -> Logic b) -> [Logic (a -> b)] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) [Logic (a -> b)]
rfls)
      Not Logic (a -> b)
nfl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic (a -> b)
nfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl)

instance Monad Logic where
  return :: a -> Logic a
return = a -> Logic a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Logic a
l >>= :: Logic a -> (a -> Logic b) -> Logic b
>>= a -> Logic b
f =
    case Logic a
l of
      Leaf a
a -> a -> Logic b
f a
a
      And Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic a
ll Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) [Logic a]
rls)
      Or Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic a
ll Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) [Logic a]
rls)
      Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic a
nl Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f)

instance Foldable Logic where
  foldMap :: (a -> m) -> Logic a -> m
foldMap a -> m
f Logic a
l =
    case Logic a
l of
      Leaf a
a -> a -> m
f a
a
      And Logic a
ll [Logic a]
rls -> (a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Logic a -> m) -> [Logic a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Logic a]
rls
      Or Logic a
ll [Logic a]
rls -> (a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Logic a -> m) -> [Logic a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Logic a]
rls
      Not Logic a
nl -> (a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
nl

instance Traversable Logic where
  traverse :: (a -> f b) -> Logic a -> f (Logic b)
traverse a -> f b
f Logic a
l =
    case Logic a
l of
      Leaf a
a -> b -> Logic b
forall a. a -> Logic a
Leaf (b -> Logic b) -> f b -> f (Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
      And Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic b -> [Logic b] -> Logic b)
-> f (Logic b) -> f ([Logic b] -> Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
ll f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Logic a -> f (Logic b)) -> [Logic a] -> f [Logic b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> Logic a -> f (Logic b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [Logic a]
rls
      Or Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic b -> [Logic b] -> Logic b)
-> f (Logic b) -> f ([Logic b] -> Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
ll f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Logic a -> f (Logic b)) -> [Logic a] -> f [Logic b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> Logic a -> f (Logic b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [Logic a]
rls
      Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic b -> Logic b) -> f (Logic b) -> f (Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
nl

-- | Run the logic tree of 'Bool' values to get the result.
runBool :: Logic Bool -> Bool
runBool :: Logic Bool -> Bool
runBool Logic Bool
l =
  case Logic Bool
l of
    Leaf Bool
b -> Bool
b
    And Logic Bool
ll [Logic Bool]
rls -> All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ [All] -> All
forall a. Monoid a => [a] -> a
mconcat ([All] -> All) -> [All] -> All
forall a b. (a -> b) -> a -> b
$ (Bool -> All
All (Bool -> All) -> Bool -> All
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) All -> [All] -> [All]
forall a. a -> [a] -> [a]
: (Logic Bool -> All) -> [Logic Bool] -> [All]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All (Bool -> All) -> (Logic Bool -> Bool) -> Logic Bool -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logic Bool -> Bool
runBool) [Logic Bool]
rls
    Or Logic Bool
ll [Logic Bool]
rls  -> Any -> Bool
getAny (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ [Any] -> Any
forall a. Monoid a => [a] -> a
mconcat ([Any] -> Any) -> [Any] -> Any
forall a b. (a -> b) -> a -> b
$ (Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) Any -> [Any] -> [Any]
forall a. a -> [a] -> [a]
: (Logic Bool -> Any) -> [Logic Bool] -> [Any]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Any
Any (Bool -> Any) -> (Logic Bool -> Bool) -> Logic Bool -> Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logic Bool -> Bool
runBool) [Logic Bool]
rls
    Not Logic Bool
nl -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
nl