src/boolean.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2013 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 INCLUDE "utils.ml"
  17
  18 open Format
  19 open Misc
  20
  21 (*
  22
  23 (** Implementation of hashconsed Boolean formulae *)
  24
  25 *)
  26 module type ATOM =
  27 sig
  28   include Hcons.S
  29   include Common_sig.Printable with type t := t
  30 end
  31
  32 type ('formula,'atom) expr =
  33   | False
  34   | True
  35   | Or of 'formula * 'formula
  36   | And of 'formula * 'formula
  37   | Atom of 'atom * bool
  38
  39 module Make (A: ATOM) =
  40 struct
  41
  42
  43   type 'hcons node = {
  44     pos : ('hcons,A.t) expr;
  45     mutable neg : 'hcons;
  46   }
  47
  48   external hash_const_variant : [> ] -> int = "%identity"
  49   external vb : bool -> int = "%identity"
  50
  51   module rec Node : Hcons.S
  52     with type data = Data.t = Hcons.Make (Data)
  53     and Data : Common_sig.HashedType  with type t = Node.t node =
  54   struct
  55     type t =  Node.t node
  56     let equal x y =
  57       match x.pos, y.pos with
  58       | a,b when a == b -> true
  59       | Or(xf1, xf2), Or(yf1, yf2)
  60       | And(xf1, xf2), And(yf1,yf2)  -> xf1 == yf1 && xf2 == yf2
  61       | Atom(p1, b1), Atom(p2, b2) -> p1 == p2 && b1 == b2
  62       | _ -> false
  63
  64     let hash f =
  65       match f.pos with
  66       | False -> 0
  67       | True -> 1
  68       | Or (f1, f2) ->
  69           HASHINT3 (PRIME1, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  70       | And (f1, f2) ->
  71           HASHINT3(PRIME3, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  72       | Atom(p, b) -> HASHINT3(PRIME5, Uid.to_int (A.uid p), int_of_bool b)
  73   end
  74
  75     type t = Node.t
  76     let hash x = x.Node.hash
  77     let uid x = x.Node.id
  78     let equal = Node.equal
  79     let expr f = f.Node.node.pos
  80
  81     let compare f1 f2 = compare f1.Node.id  f2.Node.id
  82     let prio f =
  83       match expr f with
  84       | True | False -> 10
  85       | Atom _ -> 8
  86       | And _ -> 6
  87       | Or _ -> 1
  88
  89     let rec print ?(parent=false) ppf f =
  90       if parent then fprintf ppf "(";
  91       let _ = match expr f with
  92       | True -> fprintf ppf "%s" Pretty.top
  93       | False -> fprintf ppf "%s" Pretty.bottom
  94       | And(f1,f2) ->
  95           print ~parent:(prio f > prio f1) ppf f1;
  96           fprintf ppf " %s "  Pretty.wedge;
  97           print ~parent:(prio f > prio f2) ppf f2;
  98       | Or(f1,f2) ->
  99           print ppf f1;
 100           fprintf ppf " %s " Pretty.vee;
 101           print ppf f2
 102       | Atom(p,b) ->
 103         fprintf ppf "%s%a" (if b then "" else Pretty.lnot) A.print p
 104   in
 105     if parent then fprintf ppf ")"
 106
 107 let print ppf f =  print ~parent:false ppf f
 108
 109 let is_true f = (expr f) == True
 110 let is_false f = (expr f) == False
 111
 112 let cons pos neg =
 113   let nnode = Node.make { pos = neg; neg = Obj.magic 0 } in
 114   let pnode = Node.make { pos = pos; neg = nnode } in
 115   (Node.node nnode).neg <- pnode; (* works because the neg field isn't
 116                                     taken into account for hashing ! *)
 117   pnode, nnode
 118
 119
 120 let true_,false_ = cons True False
 121
 122 let atom_ p =
 123   let a, _ = cons (Atom(p, true)) (Atom(p, false)) in a
 124
 125 let not_ f = f.Node.node.neg
 126
 127 let order f1 f2 = if uid f1 < uid f2 then f2,f1 else f1,f2
 128
 129 let or_ f1 f2 =
 130   (* Tautologies: x|x, x|not(x) *)
 131
 132   if equal f1 f2 then f1
 133   else if equal f1 (not_ f2) then true_
 134
 135   (* simplification *)
 136   else if is_true f1 || is_true f2 then true_
 137   else if is_false f1 && is_false f2 then false_
 138   else if is_false f1 then f2
 139   else if is_false f2 then f1
 140
 141   (* commutativity of | *)
 142   else
 143     let f1, f2 = order f1 f2 in
 144       fst (cons (Or(f1,f2)) (And(not_ f1, not_ f2)))
 145
 146
 147 let and_ f1 f2 =
 148   not_ (or_ (not_ f1) (not_ f2))
 149
 150
 151 let of_bool = function true -> true_ | false -> false_
 152
 153 let fold f phi acc =
 154   let rec loop phi acc =
 155     match expr phi with
 156     | And (phi1, phi2) | Or(phi1, phi2)  ->
 157         loop phi2 (loop phi1 (f phi acc))
 158     | _ -> f phi acc
 159   in
 160   loop phi acc
 161
 162 let iter f phi = fold (fun phi () -> f phi) phi ()
 163 end