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