ghc/tests/specialise/clausify001/PreludeClausify.hs

   1 -- CLAUSIFY: Reducing Propositions to Clausal Form
   2 -- Colin Runciman, University of York, 10/90
   3 --
   4 -- An excellent benchmark is: (a = a = a) = (a = a = a) = (a = a = a)
   5 --
   6 -- Optimised version: based on Runciman & Wakeling [1993]
   7 -- Patrick Sansom, University of Glasgow, 2/94
   8 --
   9 -- Char# specialisation test with prelude stuff explicit
  10 -- Patrick Sansom, University of Glasgow, 12/94
  11
  12 module PreludeClausify( clausify, AList(..) ) where
  13
  14 -- convert lines of propostions input to clausal forms
  15 clausify input = scc "clausify"
  16                  concat
  17                  (interleave (repeat "prop> ")
  18                              (map clausifyline (lines input)))
  19
  20 clausifyline = scc "CAF:clausifyline"
  21                concat . map disp . clauses . parse
  22
  23 -- the main pipeline from propositional formulae to printed clauses
  24 clauses = scc "CAF:clauses" unicl . split . disin . negin . elim
  25
  26 -- clauses = (scc "unicl" unicl) . (scc "split" split) .
  27 --           (scc "disin" disin) . (scc "negin" negin) .
  28 --           (scc "elim"  elim)
  29
  30 -- clauses = (\x -> scc "unicl" unicl x) .
  31 --           (\x -> scc "split" split x) .
  32 --           (\x -> scc "disin" disin x) .
  33 --           (\x -> scc "negin" negin x) .
  34 --           (\x -> scc "elim"  elim x)
  35
  36 data StackFrame = Ast Formula | Lex Char
  37
  38 data Formula =
  39   Sym Char# |                   -- ***
  40   Not Formula |
  41   Dis Formula Formula |
  42   Con Formula Formula |
  43   Imp Formula Formula |
  44   Eqv Formula Formula
  45
  46 -- separate positive and negative literals, eliminating duplicates
  47 clause p = scc "clause"
  48            let
  49            clause' (Dis p q)       x   = clause' p (clause' q x)
  50            clause' (Sym s)       (c,a) = (insert s c , a)
  51            clause' (Not (Sym s)) (c,a) = (c , insert s a)
  52            in
  53            clause' p (ANil , ANil)
  54
  55 conjunct p = scc "conjunct"
  56              case p of
  57              (Con p q) -> True
  58              p         -> False
  59
  60 -- shift disjunction within conjunction
  61 disin p = scc "disin"
  62           case p of
  63           (Con p q) -> Con (disin p) (disin q)
  64           (Dis p q) -> disin' (disin p) (disin q)
  65           p         -> p
  66
  67 -- auxilary definition encoding (disin . Dis)
  68 disin' p r = scc "disin'"
  69              case p of
  70              (Con p q) -> Con (disin' p r) (disin' q r)
  71              p         -> case r of
  72                           (Con q r) -> Con (disin' p q) (disin' p r)
  73                           q         -> Dis p q
  74
  75 -- format pair of lists of propositional symbols as clausal axiom
  76 disp p = scc "disp"
  77          case p of
  78          (l,r) -> interleave (foldrA ((:) `o` C#) [] l) spaces ++ "<="
  79                   ++ interleave spaces (foldrA ((:) `o` C#) [] r) ++ "\n"
  80
  81 -- eliminate connectives other than not, disjunction and conjunction
  82 elim f = scc "elim"
  83          case f of
  84          (Sym s)    -> Sym s
  85          (Not p)    -> Not (elim p)
  86          (Dis p q)  -> Dis (elim p) (elim q)
  87          (Con p q)  -> Con (elim p) (elim q)
  88          (Imp p q)  -> Dis (Not (elim p)) (elim q)
  89          (Eqv f f') -> Con (elim (Imp f f')) (elim (Imp f' f))
  90
  91 -- remove duplicates and any elements satisfying p
  92 filterset p s = scc "filterset"
  93                 filterset' [] p s
  94
  95 filterset' res p l = scc "filterset'"
  96                      case l of
  97                      []     -> []
  98                      (x:xs) -> if (notElem x res) && (p x) then
  99                                    x : filterset' (x:res) p xs
 100                                else
 101                                    filterset' res p xs
 102
 103 -- insertion of an item into an ordered list
 104 insert x l = scc "insert"
 105              case l of
 106              ANil    -> x :! ANil
 107              (y:!ys) -> if x < y then x:!(y:!ys)
 108                        else if x > y then y :! insert x ys
 109                        else y:!ys
 110
 111 interleave xs ys = scc "interleave"
 112                    case xs of
 113                    (x:xs) -> x : interleave ys xs
 114                    []     -> []
 115
 116 -- shift negation to innermost positions
 117 negin f = scc "negin"
 118           case f of
 119           (Not (Not p))   -> negin p
 120           (Not (Con p q)) -> Dis (negin (Not p)) (negin (Not q))
 121           (Not (Dis p q)) -> Con (negin (Not p)) (negin (Not q))
 122           (Dis p q)       -> Dis (negin p) (negin q)
 123           (Con p q)       -> Con (negin p) (negin q)
 124           p               -> p
 125
 126 -- the priorities of symbols during parsing
 127 opri c = scc "opri"
 128          case c of
 129          '(' -> 0
 130          '=' -> 1
 131          '>' -> 2
 132          '|' -> 3
 133          '&' -> 4
 134          '~' -> 5
 135
 136 -- parsing a propositional formula
 137 parse t = scc "parse"
 138           let [Ast f] = parse' t []
 139           in f
 140
 141 parse' cs s = scc "parse'"
 142               case cs of
 143               []      -> redstar s
 144               (' ':t) -> parse' t s
 145               ('(':t) -> parse' t (Lex '(' : s)
 146               (')':t) -> let (x : Lex '(' : s') = redstar s
 147                          in  parse' t (x:s')
 148               (c:t)   -> if inRange ('a','z') c then
 149                             parse' t (Ast (Sym (case c of C# c# -> c#)) : s) -- ***
 150                          else if spri s > opri c then parse' (c:t) (red s)
 151                          else parse' t (Lex c : s)
 152
 153 -- reduction of the parse stack
 154 red l = scc "red"
 155         case l of
 156         (Ast p : Lex '=' : Ast q : s) -> Ast (Eqv q p) : s
 157         (Ast p : Lex '>' : Ast q : s) -> Ast (Imp q p) : s
 158         (Ast p : Lex '|' : Ast q : s) -> Ast (Dis q p) : s
 159         (Ast p : Lex '&' : Ast q : s) -> Ast (Con q p) : s
 160         (Ast p : Lex '~' : s)         -> Ast (Not p) : s
 161
 162 -- iterative reduction of the parse stack
 163 redstar = scc "CAF:redstar"
 164           while ((/=) 0 . spri) red
 165
 166 spaces = scc "CAF:spaces"
 167          repeat ' '
 168
 169 -- split conjunctive proposition into a list of conjuncts
 170 split p = scc "split"
 171           let
 172           split' (Con p q) a = split' p (split' q a)
 173           split' p a = p : a
 174           in
 175           split' p []
 176
 177 -- priority of the parse stack
 178 spri s = scc "spri"
 179          case s of
 180          (Ast x : Lex c : s) -> opri c
 181          s -> 0
 182
 183 -- does any symbol appear in both consequent and antecedant of clause
 184 tautclause p = scc "tautclause"
 185                case p of
 186                (c,a) -> -- [x | x <- c, x `elem` a] /= []
 187                         anyA (\x -> x `elemA` a) c
 188
 189 -- form unique clausal axioms excluding tautologies
 190 unicl = scc "CAF:unicl"
 191         filterset (not . tautclause) . map clause
 192
 193 -- functional while loop
 194 while p f x = scc "while"
 195               if p x then while p f (f x) else x
 196
 197 {- STUFF FROM PRELUDE -}
 198
 199 data AList a = ANil | a :! (AList a)
 200      deriving (Eq)
 201
 202 elemA x ANil    = False
 203 elemA x (y:!ys) = x==y || elemA x ys
 204
 205 anyA p ANil     = False
 206 anyA p (x:!xs)  = p x || anyA p xs
 207
 208 foldrA f z ANil   =  z
 209 foldrA f z (x:!xs)=  f x (foldrA f z xs)
 210
 211 o f g x = f (g x)
 212
 213
 214 instance Eq Char# where
 215     x == y = eqChar# x y
 216     x /= y = neChar# x y
 217
 218 instance Ord Char# where
 219     (<=) x y = leChar# x y
 220     (<)  x y = ltChar# x y
 221     (>=) x y = geChar# x y
 222     (>)  x y = gtChar# x y
 223
 224     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
 225     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
 226
 227     _tagCmp a b
 228       = if      (eqChar# a b) then _EQ
 229         else if (ltChar# a b) then _LT else _GT
 230