module DataTypes
where
 
import Prelude hiding (and, or)
 
data RoseTree a
    = RT a [RoseTree a]
    deriving (Eq, Ord, Show, Read)
 
data BoolOp
    = F
    | T
    | V Name
    | NOT
    | AND
    | OR
    | IMPL
    | EQUIV
    | XOR
    | NAND
    | NOR
    deriving (Eq, Ord)
 
instance Show BoolOp
    where
    show = showOp
 
type BoolExpr = RoseTree BoolOp
 
type Name = String
 
type Env = [(Name, Bool)]
 
type Names = [Name]
 
 
 
foldRT  :: (a -> [b] -> b) -> RoseTree a -> b
foldRT f (RT op al)
    = f op (map (foldRT f) al)
 
 
mapRT   :: (a -> b) -> (RoseTree a -> RoseTree b)
mapRT f (RT e al)
    = RT (f e) (map (mapRT f) al)
 
 
 
invBoolEx :: BoolExpr -> Bool
invBoolEx (RT op al)
    | op `elem` [F, T]
        = null al
invBoolEx (RT (V _) al)
    = null al
invBoolEx (RT NOT al)
    = length al == 1
invBoolEx (RT IMPL al)
    = length al == 2
invBoolEx (RT op al)
    | op `elem` [AND, OR, EQUIV, XOR, NAND, NOR]
        = length al >= 2
 
 
opr     :: BoolExpr -> BoolOp
opr (RT op _) = op
 
args    :: BoolExpr -> [BoolExpr]
args (RT _ al) = al
 
 
 
true    :: BoolExpr
true
    = RT T []
 
false   :: BoolExpr
false
    = RT F []
 
var     :: Name -> BoolExpr
var n
    = RT (V n) []
 
 
 
boolEx  :: BoolOp -> [BoolExpr] -> BoolExpr
boolEx op []
    | op `elem` [AND, EQUIV, NOR]
        = true
    | op `elem` [OR, XOR, NAND]
        = false
 
boolEx op [e1]
    | op `elem` [AND, OR, EQUIV]
        = e1
    | op `elem` [XOR, NAND, NOR]
        = boolEx NOT [e1]
 
boolEx op al
    | op `elem` [F,T]
      &&
      not (null al)
        = error ( "boolEx: Illegal constant expression "
                  ++ show (RT op al)
                )
boolEx (V n) al
    | not (null al)
        = error ( "boolEx: Illegal variable expression "
                  ++ show (RT (V n) al)
                )
boolEx NOT al
    | length al /= 1
        = error ( "boolEx: Illegal NOT expression "
                  ++ show (RT NOT al)
                )
boolEx IMPL al
    | length al /= 2
        = error ( "boolEx: Illegal IMPL expression "
                  ++ show (RT IMPL al)
                )
 
boolEx op al
    = RT op al
 
 
 
neg     :: BoolExpr -> BoolExpr
neg e
    = boolEx NOT [e]
 
impl    :: BoolExpr -> BoolExpr -> BoolExpr
a `impl` b
    = boolEx IMPL [a, b]
 
and     :: BoolExpr -> BoolExpr -> BoolExpr
a `and` b
    = boolEx AND [a, b]
 
or      :: BoolExpr -> BoolExpr -> BoolExpr
a `or` b
    = boolEx OR [a, b]
 
equiv   :: BoolExpr -> BoolExpr -> BoolExpr
a `equiv` b
    = boolEx EQUIV [a, b]
 
xor     :: BoolExpr -> BoolExpr -> BoolExpr
a `xor` b
    = boolEx XOR [a, b]
 
nand    :: BoolExpr -> BoolExpr -> BoolExpr
a `nand` b
    = boolEx NAND [a, b]
 
nor     :: BoolExpr -> BoolExpr -> BoolExpr
a `nor` b
    = boolEx NOR [a, b]
 
 
 
prio :: BoolOp -> Int
prio NOT   = 1
prio AND   = 3
prio NAND  = 3
prio OR    = 3
prio XOR   = 3
prio NOR   = 3
prio IMPL  = 4
prio EQUIV = 5
prio _     = 0
 
showOp F        = "false"
showOp T        = "true"
showOp (V n)    = n
showOp NOT      = "not"
showOp AND      = "and"
showOp OR       = "or"
showOp IMPL     = "=>"
showOp EQUIV    = "<=>"
showOp XOR      = "xor"
showOp NAND     = "nand"
showOp NOR      = "nor"
 
 
showEx :: BoolExpr -> String
showEx = showEx' 10
 
showEx' :: Int -> BoolExpr -> String
showEx' p (RT op al)
    | p <= pop
        = "(" ++ str ++ ")"
    | otherwise
        = str
    where
    pop = prio op
 
    str = show' op al
 
    show' op al
        | op `elem` [AND,OR,IMPL,EQUIV,XOR,NAND,NOR]
            = foldl1 (\ x y -> x ++ " " ++ show op ++ " " ++ y)
              .
              map (showEx' pop) $ al
        | op == NOT
            = show op ++ " " ++ showEx' pop (head al)
        | otherwise
            = show op