diff --git a/Data/BoolExpr.hs b/Data/BoolExpr.hs new file mode 100644 --- /dev/null +++ b/Data/BoolExpr.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-------------------------------------------------------------------- +-- | +-- Module : Data.BoolExpr +-- Copyright : (c) Nicolas Pouillard 2008,2009 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-- Boolean expressions and various representations. +-------------------------------------------------------------------- + +module Data.BoolExpr + (-- * A boolean class + Boolean(..) + -- * Boolean trees + ,BoolExpr(..) + ,reduceBoolExpr + ,evalBoolExpr + -- * Signed constants + ,Signed(..) + ,constants + -- * Conjunctive Normal Form + ,CNF(..),Conj(..) + ,boolTreeToCNF + ,reduceCNF + -- * Disjunctive Normal Form + ,Disj(..),DNF(..) + ,boolTreeToDNF + ,reduceDNF + -- * Other transformations + ,dualize + ,pushNotInwards + ) + where + +-- import Test.QuickCheck hiding (Positive) +import Control.Applicative +import Data.Monoid (Monoid(..)) +import Data.Foldable (Foldable(..)) +import Data.Traversable + +infix /\ +infix \/ + +-- | A boolean type class. +class Boolean f where + ( /\ ) :: f a -> f a -> f a + ( \/ ) :: f a -> f a -> f a + bNot :: f a -> f a + bTrue :: f a + bFalse :: f a + bConst :: a -> f a + +-- | Syntax of boolean expressions parameterized over a +-- set of leaves, named constants. +data BoolExpr a = BAnd (BoolExpr a) (BoolExpr a) + | BOr (BoolExpr a) (BoolExpr a) + | BNot (BoolExpr a) + | BTrue + | BFalse + | BConst 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) + +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 + +instance Foldable BoolExpr where + foldMap = foldMapDefault + +instance Boolean BoolExpr where + ( /\ ) = BAnd + ( \/ ) = BOr + bNot = BNot + bTrue = BTrue + bFalse = BFalse + bConst = BConst + +-- | 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 (BConst c) = bConst c + +--- | Disjunction of atoms ('a') +newtype Disj a = Disj { unDisj :: [a] } + deriving (Show, Functor, Monoid) + +--- | Conjunction of atoms ('a') +newtype Conj a = Conj { unConj :: [a] } + deriving (Show, Functor, Monoid) + +--- | Conjunctive Normal Form +newtype CNF a = CNF { unCNF :: Conj (Disj a) } + deriving (Show, Monoid) + +--- | Disjunctive Normal Form +newtype DNF a = DNF { unDNF :: Disj (Conj a) } + deriving (Show, Monoid) + +instance Functor CNF where + fmap f (CNF x) = CNF (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[]] + bConst x = CNF $ Conj[Disj[x]] + +instance Functor DNF where + fmap f (DNF x) = DNF (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[] + 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 + +-- Given a evaluation function of constants, returns an evaluation +-- function over boolean trees. +-- +-- Note that since 'BoolExpr' is a functor, one can simply use +-- 'reduceBoolExpr': +-- +-- @ +-- evalBoolExpr f = reduceBoolExpr . fmap (f$) +-- @ +evalBoolExpr :: (a -> Bool) -> (BoolExpr a -> Bool) +evalBoolExpr f = reduceBoolExpr . fmap (f$) + +-- | Returns constants used in a given boolean tree, these +-- constants are returned signed depending one how many +-- negations stands over a given constant. +constants :: BoolExpr a -> [Signed a] +constants = go True + 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] + +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 + +-- | 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 + +-- | Convert a boolean tree to a conjunctive normal form. +boolTreeToCNF :: NegateConstant a -> BoolExpr a -> CNF a +boolTreeToCNF neg = fromBoolExpr . pushNotInwards neg + +-- | 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 + +-- | Reduce a boolean expression in disjunctive normal form to a single +-- boolean. +reduceDNF :: DNF Bool -> Bool +reduceDNF = any (and . unConj) . unDisj . unDNF + +{- +prop_reduceBoolExpr_EQ_reduceCNF neg t = reduceBoolExpr t == reduceCNF (boolTreeToCNF neg 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_Bool = prop_reduceBoolExpr_EQ_reduceDNF (BConst . not) + +{-* Generated by DrIFT : Look, but Don't Touch. *-} +instance (Arbitrary a) => Arbitrary (BoolExpr a) where + arbitrary = do x <- choose (1::Int,6) -- :: Int inserted manually + case x of + 1 -> do v1 <- arbitrary + v2 <- arbitrary + return (BAnd v1 v2) + 2 -> do v1 <- arbitrary + v2 <- arbitrary + return (BOr v1 v2) + 3 -> do v1 <- arbitrary + return (BNot v1) + 4 -> do return (BTrue ) + 5 -> do return (BFalse ) + 6 -> do v1 <- arbitrary + return (BConst v1) + --coarbitrary = error "coarbitrary not yet supported" -- quickcheck2 +-} diff --git a/Data/BoolExpr/Parser.hs b/Data/BoolExpr/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/BoolExpr/Parser.hs @@ -0,0 +1,82 @@ +module Data.BoolExpr.Parser + (-- * Parsing function + parseBoolExpr + -- * Language definition and components + ,languageDef + ,lexer + ,identifier + ,whiteSpace + ,symbol + ) +where + +import Control.Monad +import Control.Applicative hiding ((<|>)) +import Data.BoolExpr +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P + +{- | Parse a search query as a boolean tree using the following grammar. + Note that this parser is parameterized over the parser of query simple + terms (const). + +@ + bt ::= bt AND bt + | bt bt -- same as AND + | bt OR bt + | - bt + | ( bt ) + | const + const ::= \ +@ +-} +parseBoolExpr :: CharParser st a -> CharParser st (BoolExpr a) +parseBoolExpr parseConst = disj + where disj = conj `chainl1` orOp + conj = factor `chainl1` andOp + factor = parens disj <|> + (((symbol "-" >> return BNot) <|> return id) `ap` (BConst `fmap` parseConst)) + + andOp = BAnd <$ option "" (symbol "AND") + orOp = BOr <$ symbol "OR" + +-- | Underlying lexer of 'languageDef' +lexer :: P.TokenParser st +lexer = P.makeTokenParser languageDef + +-- | Shorthand for 'P.parens lexer'. +parens :: CharParser st a -> CharParser st a +parens = P.parens lexer + +-- | Shorthand for 'P.symbol' 'lexer'. +symbol :: String -> CharParser st String +symbol = P.symbol lexer + +-- | Shorthand for 'P.whiteSpace' 'lexer'. +whiteSpace :: CharParser st () +whiteSpace = P.whiteSpace lexer + +-- | Shorthand for 'P.identifier' 'lexer'. +identifier :: CharParser st String +identifier = P.identifier lexer + +wordLetter :: CharParser st Char +wordLetter = alphaNum <|> oneOf "_:;`,~@.!#$%^&*=+?|\\{}[]<>" + +-- | Basic language definition for search queries. +-- Reserved names are @\"AND\"@ @\"OR\"@ and @\"-\"@. +-- Identifiers accepts almost every ASCII sequences without blanks nor @\'-\'@. +languageDef :: P.LanguageDef st +languageDef = P.LanguageDef + { P.commentStart = "" + , P.commentEnd = "" + , P.commentLine = "" + , P.nestedComments = True + , P.identStart = wordLetter + , P.identLetter = wordLetter <|> char '-' + , P.opStart = mzero + , P.opLetter = mzero + , P.reservedOpNames= [] + , P.reservedNames = ["AND", "OR", "-"] + , P.caseSensitive = True + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008, 2009, Nicolas Pouillard +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/boolexpr.cabal b/boolexpr.cabal new file mode 100644 --- /dev/null +++ b/boolexpr.cabal @@ -0,0 +1,23 @@ +name: boolexpr +cabal-Version: >=1.6 +version: 0.1 +license: BSD3 +license-File: LICENSE +copyright: (c) Nicolas Pouillard +author: Nicolas Pouillard +maintainer: Nicolas Pouillard +category: Search, Data Structures, Parsing +synopsis: Boolean expressions with various representations and search queries. +description: Boolean expressions with various representations and search queries. +stability: Provisional +build-type: Simple + +library + build-depends: base>=3.0&&<5, parsec + exposed-modules: Data.BoolExpr + Data.BoolExpr.Parser + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/np/boolexpr.git