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