boolexpr 0.1 → 0.2

raw patch · 4 files changed

+240/−84 lines, 4 filesdep +extraPVP ok

version bump matches the API change (PVP)

Dependencies added: extra

API changes (from Hackage documentation)

Files

• Data/BoolExpr.hs +169/−73
• Data/BoolExpr/Parser.hs +14/−5
• Data/BoolExpr/Printer.hs +49/−0
• boolexpr.cabal +8/−6

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} -------------------------------------------------------------------- -- | -- Module    : Data.BoolExpr@@ -15,33 +15,71 @@ module Data.BoolExpr   (-- * A boolean class    Boolean(..)+   -- * Generic functions derived from Boolean+  ,bAnd+  ,bAll+  ,bOr+  ,bAny    -- * Boolean trees   ,BoolExpr(..)   ,reduceBoolExpr   ,evalBoolExpr+   -- * Boolean evaluation semantic+  ,Eval(..)+  ,runEvalId    -- * Signed constants   ,Signed(..)+  ,negateSigned+  ,evalSigned+  ,reduceSigned   ,constants+  ,negateConstant    -- * Conjunctive Normal Form   ,CNF(..),Conj(..)+  ,fromCNF   ,boolTreeToCNF   ,reduceCNF    -- * Disjunctive Normal Form   ,Disj(..),DNF(..)+  ,fromDNF   ,boolTreeToDNF   ,reduceDNF    -- * Other transformations   ,dualize+  ,fromBoolExpr   ,pushNotInwards   )   where  -- import Test.QuickCheck hiding (Positive)-import Control.Applicative-import Data.Monoid (Monoid(..))-import Data.Foldable (Foldable(..))+-- import Control.Applicative+import Control.Monad (ap) import Data.Traversable ++-- | Signed values are either positive or negative.+data Signed a = Positive a | Negative a+  deriving (Eq, Ord, Show, Read)++instance Functor Signed where+  fmap f (Positive x) = Positive (f x)+  fmap f (Negative x) = Negative (f x)++instance Traversable Signed where+  traverse f (Positive x) = Positive <$> f x+  traverse f (Negative x) = Negative <$> f x++instance Foldable Signed where+  foldMap = foldMapDefault++instance Applicative Signed where+  pure  = Positive+  (<*>) = ap++instance Monad Signed where+  Positive x >>= f = f x+  Negative x >>= f = negateSigned $ f x+ infix /\ infix \/ @@ -52,8 +90,24 @@   bNot   :: f a -> f a   bTrue  :: f a   bFalse :: f a-  bConst :: a -> f a+  bConst :: Signed a -> f a +-- | Generalized 'Data.Foldable.and'.+bAnd :: (Foldable t, Boolean f) => t (f b) -> f b+bAnd = foldr (/\) bTrue++-- | Generalized 'Data.Foldable.all'.+bAll :: (Foldable t, Boolean f) => (a -> f b) -> t a -> f b+bAll f = foldr (\x y -> f x /\ y) bTrue++-- | Generalized 'Data.Foldable.or'.+bOr :: (Foldable t, Boolean f) => t (f b) -> f b+bOr = foldr (\/) bFalse++-- | Generalized 'Data.Foldable.any'.+bAny :: (Foldable t, Boolean f) => (a -> f b) -> t a -> f b+bAny f = foldr (\x y -> f x \/ y) bFalse+ -- | Syntax of boolean expressions parameterized over a -- set of leaves, named constants. data BoolExpr a = BAnd (BoolExpr a) (BoolExpr a)@@ -61,28 +115,24 @@                 | BNot (BoolExpr a)                 | BTrue                 | BFalse-                | BConst a+                | BConst (Signed a)   deriving (Eq, Ord, Show) {-! derive : Arbitrary !-} --- | Signed values are either positive of negative.-data Signed a = Positive a | Negative a-  deriving (Eq, Ord, Show, Read)- instance Functor BoolExpr where   fmap f (BAnd a b) = BAnd (fmap f a) (fmap f b)-  fmap f (BOr a b)  = BOr (fmap f a) (fmap f b)-  fmap f (BNot t)   = BNot (fmap f t)-  fmap _ BTrue      = BTrue-  fmap _ BFalse     = BFalse-  fmap f (BConst x) = BConst (f x)+  fmap f (BOr  a b) = BOr  (fmap f a) (fmap f b)+  fmap f (BNot t  ) = BNot (fmap f t)+  fmap _  BTrue     = BTrue+  fmap _  BFalse    = BFalse+  fmap f (BConst x) = BConst (fmap f x)  instance Traversable BoolExpr where   traverse f (BAnd a b) = BAnd <$> traverse f a <*> traverse f b-  traverse f (BOr a b)  = BOr  <$> traverse f a <*> traverse f b-  traverse f (BNot t)   = BNot <$> traverse f t-  traverse _ BTrue      = pure BTrue-  traverse _ BFalse     = pure BFalse-  traverse f (BConst x) = BConst <$> f x+  traverse f (BOr  a b) = BOr  <$> traverse f a <*> traverse f b+  traverse f (BNot t  ) = BNot <$> traverse f t+  traverse _  BTrue     = pure BTrue+  traverse _  BFalse    = pure BFalse+  traverse f (BConst x) = BConst <$> traverse f x  instance Foldable BoolExpr where   foldMap = foldMapDefault@@ -95,63 +145,79 @@   bFalse = BFalse   bConst = BConst +newtype Eval b a = Eval { runEval :: (a -> b) -> b }++runEvalId :: Eval a a -> a+runEvalId e = runEval e id++instance b ~ Bool => Boolean (Eval b) where+  ( /\ ) = liftE2 (&&)+  ( \/ ) = liftE2 (||)+  bNot   = liftE  not+  bTrue  = Eval $ const True+  bFalse = Eval $ const False+  bConst = Eval . flip evalSigned++liftE :: (b -> b) -> Eval b a -> Eval b a+liftE f (Eval x) = Eval (f . x)++liftE2 :: (b -> b -> b) -> Eval b a -> Eval b a -> Eval b a+liftE2 f (Eval x) (Eval y) = Eval (\e -> f (x e) (y e))++ -- | Turns a boolean tree into any boolean type. fromBoolExpr :: Boolean f => BoolExpr a -> f a fromBoolExpr (BAnd l r) = fromBoolExpr l /\ fromBoolExpr r-fromBoolExpr (BOr l r)  = fromBoolExpr l \/ fromBoolExpr r-fromBoolExpr (BNot t)   = bNot $ fromBoolExpr t-fromBoolExpr BTrue      = bTrue-fromBoolExpr BFalse     = bFalse+fromBoolExpr (BOr  l r) = fromBoolExpr l \/ fromBoolExpr r+fromBoolExpr (BNot t  ) = bNot $ fromBoolExpr t+fromBoolExpr  BTrue     = bTrue+fromBoolExpr  BFalse    = bFalse fromBoolExpr (BConst c) = bConst c  --- | Disjunction of atoms ('a') newtype Disj a = Disj { unDisj :: [a] }-  deriving (Show, Functor, Monoid)+  deriving (Show, Functor, Semigroup, Monoid)  --- | Conjunction of atoms ('a') newtype Conj a = Conj { unConj :: [a] }-  deriving (Show, Functor, Monoid)+  deriving (Show, Functor, Semigroup, Monoid)  --- | Conjunctive Normal Form-newtype CNF a = CNF { unCNF :: Conj (Disj a) }-  deriving (Show, Monoid)+newtype CNF a = CNF { unCNF :: Conj (Disj (Signed a)) }+  deriving (Show, Semigroup, Monoid)  --- | Disjunctive Normal Form-newtype DNF a = DNF { unDNF :: Disj (Conj a) }-  deriving (Show, Monoid)+newtype DNF a = DNF { unDNF :: Disj (Conj (Signed a)) }+  deriving (Show, Semigroup, Monoid)  instance Functor CNF where-  fmap f (CNF x) = CNF (fmap (fmap f) x)+  fmap f (CNF x) = CNF (fmap (fmap (fmap f)) x)  instance Boolean CNF where   l /\ r = l `mappend` r   l \/ r = CNF $ Conj [ x `mappend` y | x <- unConj $ unCNF l                                       , y <- unConj $ unCNF r ]-  bNot = error "bNot on CNF"-  bTrue = CNF $ Conj[]-  bFalse = CNF $ Conj[Disj[]]+  bNot     = error "bNot on CNF"+  bTrue    = CNF $ Conj[]+  bFalse   = CNF $ Conj[Disj[]]   bConst x = CNF $ Conj[Disj[x]] + instance Functor DNF where-  fmap f (DNF x) = DNF (fmap (fmap f) x)+  fmap f (DNF x) = DNF (fmap (fmap (fmap f)) x)  instance Boolean DNF where   l /\ r = DNF $ Disj [ x `mappend` y | x <- unDisj $ unDNF l                                       , y <- unDisj $ unDNF r ]   l \/ r = l `mappend` r-  bNot = error "bNot on CNF"-  bTrue = DNF $ Disj[Conj[]]-  bFalse = DNF $ Disj[]+  bNot     = error "bNot on CNF"+  bTrue    = DNF $ Disj[Conj[]]+  bFalse   = DNF $ Disj[]   bConst x = DNF $ Disj[Conj[x]]  -- | Reduce a boolean tree annotated by booleans to a single boolean. reduceBoolExpr :: BoolExpr Bool -> Bool-reduceBoolExpr (BAnd a b) = reduceBoolExpr a && reduceBoolExpr b-reduceBoolExpr (BOr  a b) = reduceBoolExpr a || reduceBoolExpr b-reduceBoolExpr (BNot a)   = not $ reduceBoolExpr a-reduceBoolExpr BTrue      = True-reduceBoolExpr BFalse     = False-reduceBoolExpr (BConst c) = c+reduceBoolExpr = evalBoolExpr id  -- Given a evaluation function of constants, returns an evaluation -- function over boolean trees.@@ -163,7 +229,7 @@ -- evalBoolExpr f = reduceBoolExpr . fmap (f$) -- @ evalBoolExpr :: (a -> Bool) -> (BoolExpr a -> Bool)-evalBoolExpr f = reduceBoolExpr . fmap (f$)+evalBoolExpr env expr = runEval (fromBoolExpr expr) env  -- | Returns constants used in a given boolean tree, these -- constants are returned signed depending one how many@@ -173,54 +239,84 @@   where go sign (BAnd a b) = go sign a ++ go sign b         go sign (BOr  a b) = go sign a ++ go sign b         go sign (BNot t)   = go (not sign) t-        go _    BTrue      = []-        go _    BFalse     = []-        go sign (BConst x) = [if sign then Positive x else Negative x]+        go _     BTrue     = []+        go _     BFalse    = []+        go sign (BConst x) = [if sign then x else negateSigned x] -dualize :: NegateConstant a -> BoolExpr a -> BoolExpr a-dualize neg (BAnd l r) = BOr  (dualize neg l) (dualize neg r)-dualize neg (BOr  l r) = BAnd (dualize neg l) (dualize neg r)-dualize _   BTrue      = BFalse-dualize _   BFalse     = BTrue-dualize neg (BConst c) = neg c-dualize _   (BNot _)   = error "dualize: impossible" -type NegateConstant a = a -> BoolExpr a+dualize :: Boolean f => BoolExpr a -> f a+dualize (BAnd l r) = dualize l \/ dualize r+dualize (BOr  l r) = dualize l /\ dualize r+dualize  BTrue     = bFalse+dualize  BFalse    = bTrue+dualize (BConst c) = negateConstant c+dualize (BNot e)   = fromBoolExpr e+-- When dualize is used by pushNotInwards not BNot remain,+-- hence it makes sense to assert that dualize does not+-- have to work on BNot. However `dualize` can be freely+-- used as a fancy `bNot`.+-- dualize (BNot _)   = error "dualize: impossible" + -- | Push the negations inwards as much as possible. -- The resulting boolean tree no longer use negations.-pushNotInwards :: NegateConstant a -> BoolExpr a -> BoolExpr a-pushNotInwards neg (BAnd l r)   = BAnd (pushNotInwards neg l) (pushNotInwards neg r)-pushNotInwards neg (BOr  l r)   = BOr  (pushNotInwards neg l) (pushNotInwards neg r)-pushNotInwards neg (BNot t)     = dualize neg $ pushNotInwards neg t-pushNotInwards _   BTrue        = BTrue-pushNotInwards _   BFalse       = BFalse-pushNotInwards _   b@(BConst _) = b +pushNotInwards :: Boolean f => BoolExpr a -> f a+pushNotInwards (BAnd l r)   = pushNotInwards l /\ pushNotInwards r+pushNotInwards (BOr  l r)   = pushNotInwards l \/ pushNotInwards r+pushNotInwards (BNot t  )   = dualize $ pushNotInwards t+pushNotInwards  BTrue       = bTrue+pushNotInwards  BFalse      = bFalse+pushNotInwards (BConst c)   = bConst c++-- | Convert a 'CNF' (a boolean expression in conjunctive normal form)+-- to any other form supported by 'Boolean'.+fromCNF :: Boolean f => CNF a -> f a+fromCNF = bAll (bAny bConst . unDisj) . unConj . unCNF++-- | Convert a 'DNF' (a boolean expression in disjunctive normal form)+-- to any other form supported by 'Boolean'.+fromDNF :: Boolean f => DNF a -> f a+fromDNF = bAny (bAll bConst . unConj) . unDisj . unDNF+ -- | Convert a boolean tree to a conjunctive normal form.-boolTreeToCNF :: NegateConstant a -> BoolExpr a -> CNF a-boolTreeToCNF neg = fromBoolExpr . pushNotInwards neg+boolTreeToCNF :: BoolExpr a -> CNF a+boolTreeToCNF = pushNotInwards +-- | Convert a boolean tree to a disjunctive normal form.+boolTreeToDNF :: BoolExpr a -> DNF a+boolTreeToDNF = pushNotInwards+ -- | Reduce a boolean expression in conjunctive normal form to a single -- boolean. reduceCNF :: CNF Bool -> Bool-reduceCNF = all (or . unDisj) . unConj . unCNF---- | Convert a boolean tree to a disjunctive normal form.-boolTreeToDNF :: (a -> BoolExpr a) -> BoolExpr a -> DNF a-boolTreeToDNF neg = fromBoolExpr . pushNotInwards neg+reduceCNF = runEvalId . fromCNF  -- | Reduce a boolean expression in disjunctive normal form to a single -- boolean. reduceDNF :: DNF Bool -> Bool-reduceDNF = any (and . unConj) . unDisj . unDNF+reduceDNF = runEvalId . fromDNF +evalSigned :: (a -> Bool) -> Signed a -> Bool+evalSigned f (Positive x) = f x+evalSigned f (Negative x) = not $ f x++reduceSigned :: Signed Bool -> Bool+reduceSigned = evalSigned id++negateSigned :: Signed a -> Signed a+negateSigned (Positive x) = Negative x+negateSigned (Negative x) = Positive x++negateConstant :: Boolean f => Signed a -> f a+negateConstant = bConst . negateSigned+ {--prop_reduceBoolExpr_EQ_reduceCNF neg t = reduceBoolExpr t == reduceCNF (boolTreeToCNF neg t)+prop_reduceBoolExpr_EQ_reduceCNF t = reduceBoolExpr t == reduceCNF (boolTreeToCNF t)  prop_reduceBoolExpr_EQ_reduceCNF_Bool = prop_reduceBoolExpr_EQ_reduceCNF (BConst . not) -prop_reduceBoolExpr_EQ_reduceDNF neg t = reduceBoolExpr t == reduceDNF (boolTreeToDNF neg t)+prop_reduceBoolExpr_EQ_reduceDNF t = reduceBoolExpr t == reduceDNF (boolTreeToDNF t)  prop_reduceBoolExpr_EQ_reduceDNF_Bool = prop_reduceBoolExpr_EQ_reduceDNF (BConst . not) 

@@ -1,6 +1,7 @@+{-# LANGUAGE FlexibleContexts #-} module Data.BoolExpr.Parser   (-- * Parsing function-   parseBoolExpr+  parseBoolExpr    -- * Language definition and components   ,languageDef   ,lexer@@ -11,7 +12,6 @@ where  import Control.Monad-import Control.Applicative hiding ((<|>)) import Data.BoolExpr import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P@@ -25,6 +25,7 @@         | bt bt -- same as AND         | bt OR bt         | - bt+        | NOT bt         | ( bt )         | const    const ::= \<given as argument\>@@ -34,8 +35,14 @@ parseBoolExpr parseConst = disj    where disj   = conj   `chainl1` orOp          conj   = factor `chainl1` andOp-         factor = parens disj <|>-                  (((symbol "-" >> return BNot) <|> return id) `ap` (BConst `fmap` parseConst))+         factor =     (  (symbol "-"   >> return BNot)+                     <|> (symbol "NOT" >> return BNot)+                     <|> (return id                  )+                      ) +                      `ap` +                         (  parens disj +                        <|> BConst `fmap` (Positive `fmap` parseConst)+                         )           andOp = BAnd <$ option "" (symbol "AND")          orOp  = BOr <$ symbol "OR"@@ -58,7 +65,9 @@  -- | Shorthand for 'P.identifier' 'lexer'. identifier :: CharParser st String-identifier = P.identifier lexer+identifier = do+    str <- P.identifier lexer+    pure str  wordLetter :: CharParser st Char wordLetter = alphaNum <|> oneOf "_:;`,~@.!#$%^&*=+?|\\{}[]<>"

@@ -0,0 +1,49 @@+module Data.BoolExpr.Printer+  (-- * Printers+    boolExprPrinter+  , signedPrinter+  , disjPrinter+  , conjPrinter+  , cnfPrinter+  , dnfPrinter+  )+where++import Data.BoolExpr++-- | Printer+boolExprPrinter :: (a -> ShowS) -> BoolExpr a -> ShowS+boolExprPrinter f = go+  where+    go (BAnd a b) = paren $ go a . text " AND " . go b+    go (BOr  a b) = paren $ go a . text " OR "  . go b+    go (BNot a)   = text "-" . paren (go a)+    go  BTrue     = text "TRUE" -- not in the parser+    go  BFalse    = text "FALSE" -- not in the parser+    go (BConst c) = signedPrinter f c++sep :: String -> String -> (a -> ShowS) -> [a] -> ShowS+sep empty _ _ [] = text empty+sep _     s f xs = foldr1 (\x y -> x . text s . y) (f <$> xs)++signedPrinter :: (a -> ShowS) -> Signed a -> ShowS+signedPrinter f (Positive c) = f c+signedPrinter f (Negative c) = text "-" . f c++disjPrinter :: (a -> ShowS) -> Disj a -> ShowS+disjPrinter f = sep "FALSE" " OR " (paren . f) . unDisj++conjPrinter :: (a -> ShowS) -> Conj a -> ShowS+conjPrinter f = sep "TRUE" " AND " (paren . f) . unConj++cnfPrinter :: (a -> ShowS) -> CNF a -> ShowS+cnfPrinter f = conjPrinter (disjPrinter (signedPrinter f)) . unCNF++dnfPrinter :: (a -> ShowS) -> DNF a -> ShowS+dnfPrinter f = disjPrinter (conjPrinter (signedPrinter f)) . unDNF++paren :: ShowS -> ShowS+paren = showParen True++text :: String -> ShowS+text  = showString

@@ -1,6 +1,6 @@ name:            boolexpr-cabal-Version:   >=1.6-version:         0.1+cabal-Version:   >=1.10+version:         0.2 license:         BSD3 license-File:    LICENSE copyright:       (c) Nicolas Pouillard@@ -13,11 +13,13 @@ build-type:      Simple  library-  build-depends:   base>=3.0&&<5, parsec-  exposed-modules: Data.BoolExpr-                   Data.BoolExpr.Parser+  build-depends:   base>=3.0&&<5, parsec, extra+  exposed-modules: Data.BoolExpr,+                   Data.BoolExpr.Parser,+                   Data.BoolExpr.Printer   ghc-options:     -Wall+  default-language: Haskell98  source-repository head   type:     git-  location: https://github.com/np/boolexpr.git+  location: https://github.com/boolexpr/boolexpr.git