{-# 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.Monoid         (All (..), Any (..), (<>))
import           Data.Traversable    (Traversable)
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 (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
$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
/= :: Logic a -> Logic a -> Bool
Eq, (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
$cfrom :: forall a x. Logic a -> Rep (Logic a) x
from :: forall x. Logic a -> Rep (Logic a) x
$cto :: forall a x. Rep (Logic a) x -> Logic a
to :: forall x. Rep (Logic a) x -> Logic a
Generic, 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
$ccompare :: forall a. Ord a => Logic a -> Logic a -> Ordering
compare :: Logic a -> Logic a -> Ordering
$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
>= :: Logic a -> Logic a -> Bool
$cmax :: forall a. Ord a => Logic a -> Logic a -> Logic a
max :: Logic a -> Logic a -> Logic a
$cmin :: forall a. Ord a => Logic a -> Logic a -> Logic a
min :: Logic a -> Logic a -> Logic a
Ord, 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
$cshowsPrec :: forall a. Show a => Int -> Logic a -> ShowS
showsPrec :: Int -> Logic a -> ShowS
$cshow :: forall a. Show a => Logic a -> String
show :: Logic a -> String
$cshowList :: forall a. Show a => [Logic a] -> ShowS
showList :: [Logic a] -> ShowS
Show)

instance Functor Logic where
  fmap :: forall a b. (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 a b. (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 a b. (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 a b. (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 a b. (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 a b. (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 :: forall a. a -> Logic a
pure a
a = a -> Logic a
forall a. a -> Logic a
Leaf a
a
  Logic (a -> b)
fl <*> :: forall a b. 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 a b. (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 a b. 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 a b. 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 a b. 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 a b. 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 a b. 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 :: forall a. a -> Logic a
return = a -> Logic a
forall a. a -> Logic a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Logic a
l >>= :: forall a b. 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 a b. 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 a b. 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 a b. 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 a b. 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 a b. 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 :: forall m a. Monoid m => (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 m a. Monoid m => (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 m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
forall m a. Monoid m => (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 m a. Monoid m => (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 m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
forall m a. Monoid m => (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 m a. Monoid m => (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 :: forall (f :: * -> *) a b.
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic b)
traverse a -> f b
f Logic a
ll f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall a b. f (a -> b) -> f a -> f 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic b)
traverse a -> f b
f Logic a
ll f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall a b. f (a -> b) -> f a -> f 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic 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