Zhegalkin polynomials and conversion to algebraic normal form

Polynomial.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}

import qualified Data.Set as S
import Data.List (intercalate, sort)

data UnaryOp
  = Not
  deriving (Show)

data BinaryOp
  = And
  | Or
  | Xor
  deriving (Show)

data Term a
  = F
  | T
  | Var a
  deriving (Show, Eq, Ord)

newtype Monomial a = Monomial (S.Set (Term a))
  deriving (Show, Eq)

instance Ord a => Ord (Monomial a) where
  compare (Monomial m) (Monomial n) = case compare (S.size m) (S.size n) of
                                        EQ -> compareMonomials m n
                                        x  -> x  

compareMonomials :: Ord a => S.Set a -> S.Set a -> Ordering
compareMonomials s t | S.null s  = EQ
                     | otherwise = case compare (S.findMin s) (S.findMin t) of
                                       EQ -> compareMonomials (S.deleteMin s) (S.deleteMin t)
                                       x  -> x

newtype Polynomial a = Polynomial (S.Set (Monomial a))
  deriving (Show)

instance Ord a => Num (Polynomial a) where
  (Polynomial p) + (Polynomial q) = Polynomial $ S.difference (S.union p q) (S.intersection p q)
  (Polynomial p) * (Polynomial q) = Polynomial $ S.fromList [ Monomial (S.union x y) | Monomial x <- S.toList p, Monomial y <- S.toList q ]

  negate x    = 1 + x
  fromInteger x = case x of
    0 -> Polynomial $ S.singleton $ Monomial $ S.singleton F
    n -> Polynomial $ S.singleton $ Monomial $ S.singleton T

  abs         = error "not implemented"
  signum      = error "not implemented"

term :: Term a -> Polynomial a
term = Polynomial . S.singleton . Monomial . S.singleton

newtype V = V Char
  deriving (Eq, Ord)

instance Show V where
  show (V c) = [c]

data Expr a
  = Te (Term a)
  | UOp UnaryOp (Expr a)
  | BOp BinaryOp (Expr a) (Expr a)
  deriving (Show)

var :: Char -> Expr V
var = Te . Var . V

lnot :: Expr a -> Expr a
lnot = UOp Not

land :: Expr a -> Expr a -> Expr a
land = BOp And

lor :: Expr a -> Expr a -> Expr a
lor = BOp Or

anf :: Ord a => Expr a -> Polynomial a
anf (Te t)        = term t
anf (UOp Not e)   = negate $ anf e
anf (BOp And l r) = anf l * anf r
anf (BOp Or l r)  = let l' = anf l; r' = anf r in l' + r' + l' * r'
anf (BOp Xor l r) = anf l + anf r

pprint :: (Show a, Ord a) => Polynomial a -> String
pprint (Polynomial p) = intercalate " + " $ map pprintMonomial $ sort $ S.toList p

pprintMonomial :: (Show a, Ord a) => Monomial a -> String
pprintMonomial (Monomial m) | S.size m == 1 = pprintTerm $ S.findMin m
                            | otherwise     = intercalate "" $ map pprintTerm $ filter (/= T) $ S.toList m

pprintTerm :: Show a => Term a -> String
pprintTerm F       = "0"
pprintTerm T       = "1"
pprintTerm (Var v) = show v