src/formula.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
  20 (*
  21
  22 (** Implementation of hashconsed Boolean formulae *)
  23
  24 *)
  25 module type ATOM =
  26 sig
  27   type t
  28   val neg : t -> t
  29   include Hcons.Abstract with type t := t
  30   include Common_sig.Printable with type t := t
  31 end
  32
  33 type ('formula,'atom) expr =
  34   | False
  35   | True
  36   | Or of 'formula * 'formula
  37   | And of 'formula * 'formula
  38   | Atom of 'atom
  39
  40 module Make (P: ATOM) =
  41 struct
  42
  43
  44   type 'hcons node = {
  45     pos : ('hcons,P.t) expr;
  46     mutable neg : 'hcons;
  47   }
  48
  49   external hash_const_variant : [> ] -> int = "%identity"
  50   external vb : bool -> int = "%identity"
  51
  52   module rec Node : Hcons.S
  53     with type data = Data.t = Hcons.Make (Data)
  54     and Data : Common_sig.HashedType  with type t = Node.t node =
  55   struct
  56     type t =  Node.t node
  57     let equal x y =
  58       match x.pos, y.pos with
  59       | a,b when a == b -> true
  60       | Or(xf1, xf2), Or(yf1, yf2)
  61       | And(xf1, xf2), And(yf1,yf2)  -> xf1 == yf1 && xf2 == yf2
  62       | Atom(p1), Atom(p2) -> p1 == p2
  63       | _ -> false
  64
  65     let hash f =
  66       match f.pos with
  67       | False -> 0
  68       | True -> 1
  69       | Or (f1, f2) ->
  70           HASHINT3 (PRIME1, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  71       | And (f1, f2) ->
  72           HASHINT3(PRIME3, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  73       | Atom(p) -> HASHINT2(PRIME5, Uid.to_int (P.uid p))
  74   end
  75
  76     type t = Node.t
  77     let hash x = x.Node.hash
  78     let uid x = x.Node.id
  79     let equal = Node.equal
  80     let expr f = f.Node.node.pos
  81
  82     let compare f1 f2 = compare f1.Node.id  f2.Node.id
  83     let prio f =
  84       match expr f with
  85       | True | False -> 10
  86       | Atom _ -> 8
  87       | And _ -> 6
  88       | Or _ -> 1
  89
  90     let rec print ?(parent=false) ppf f =
  91       if parent then fprintf ppf "(";
  92       let _ = match expr f with
  93       | True -> fprintf ppf "%s" Pretty.top
  94       | False -> fprintf ppf "%s" Pretty.bottom
  95       | And(f1,f2) ->
  96           print ~parent:(prio f > prio f1) ppf f1;
  97           fprintf ppf " %s "  Pretty.wedge;
  98           print ~parent:(prio f > prio f2) ppf f2;
  99       | Or(f1,f2) ->
 100           (print ppf f1);
 101           fprintf ppf " %s " Pretty.vee;
 102           (print ppf f2);
 103       | Atom(p) -> fprintf ppf "%a" P.print p
 104 (*          let _ = flush_str_formatter() in
 105           let fmt = str_formatter in
 106           let a_str, d_str =
 107           match  dir with
 108           | `Left ->  Pretty.down_arrow, Pretty.subscript 1
 109           | `Right -> Pretty.down_arrow, Pretty.subscript 2
 110           | `Epsilon -> Pretty.epsilon, ""
 111           | `Up1 -> Pretty.up_arrow, Pretty.subscript 1
 112           | `Up2 -> Pretty.up_arrow, Pretty.subscript 2
 113         in
 114         fprintf fmt "%s%s" a_str d_str;
 115         State.print fmt s;
 116         let str = flush_str_formatter() in
 117         if b then fprintf ppf "%s" str
 118         else Pretty.pp_overline ppf str *)
 119   in
 120     if parent then fprintf ppf ")"
 121
 122 let print ppf f =  print ~parent:false ppf f
 123
 124 let is_true f = (expr f) == True
 125 let is_false f = (expr f) == False
 126
 127
 128 let cons pos neg =
 129   let nnode = Node.make { pos = neg; neg = Obj.magic 0 } in
 130   let pnode = Node.make { pos = pos; neg = nnode } in
 131     (Node.node nnode).neg <- pnode; (* works because the neg field isn't taken into
 132                                        account for hashing ! *)
 133     pnode,nnode
 134
 135
 136 let true_,false_ = cons True False
 137
 138 let atom_ p = fst (cons (Atom(p)) (Atom(P.neg p)))
 139
 140 let not_ f = f.Node.node.neg
 141
 142 let order f1 f2 = if uid f1 < uid f2 then f2,f1 else f1,f2
 143
 144 let or_ f1 f2 =
 145   (* Tautologies: x|x, x|not(x) *)
 146
 147   if equal f1 f2 then f1
 148   else if equal f1 (not_ f2) then true_
 149
 150   (* simplification *)
 151   else if is_true f1 || is_true f2 then true_
 152   else if is_false f1 && is_false f2 then false_
 153   else if is_false f1 then f2
 154   else if is_false f2 then f1
 155
 156   (* commutativity of | *)
 157   else
 158     let f1, f2 = order f1 f2 in
 159       fst (cons (Or(f1,f2)) (And(not_ f1, not_ f2)))
 160
 161
 162 let and_ f1 f2 =
 163   not_ (or_ (not_ f1) (not_ f2))
 164
 165
 166 let of_bool = function true -> true_ | false -> false_
 167
 168 let fold f phi acc =
 169   let rec loop phi acc =
 170     match expr phi with
 171     | And (phi1, phi2) | Or(phi1, phi2)  ->
 172         loop phi2 (loop phi1 (f phi acc))
 173     | _ -> f phi acc
 174   in
 175   loop phi acc
 176
 177 end