src/formula.ml

   1 INCLUDE "utils.ml"
   2 open Format
   3
   4
   5 type 'hcons expr =
   6   | False | True
   7   | Or of 'hcons * 'hcons
   8   | And of 'hcons * 'hcons
   9   | Atom of ([ `Left | `Right | `Epsilon ] * bool * State.t)
  10   | Pred of Tree.Predicate.t
  11
  12 type 'hcons node = {
  13   pos : 'hcons expr;
  14   mutable neg : 'hcons;
  15   st : (StateSet.t*StateSet.t*StateSet.t)*(StateSet.t*StateSet.t*StateSet.t);
  16   size: int; (* Todo check if this is needed *)
  17 }
  18
  19 external hash_const_variant : [> ] -> int = "%identity"
  20
  21 module rec Node : Hcons.S
  22   with type data = Data.t = Hcons.Make (Data)
  23   and Data : Hashtbl.HashedType  with type t = Node.t node =
  24   struct
  25     type t =  Node.t node
  26     let equal x y = x.size == y.size &&
  27       match x.pos, y.pos with
  28         | a,b when a == b -> true
  29         | Or(xf1, xf2), Or(yf1, yf2)
  30         | And(xf1, xf2), And(yf1,yf2)  -> (xf1 == yf1) && (xf2 == yf2)
  31         | Atom(d1, p1, s1), Atom(d2 ,p2 ,s2) -> d1 == d2 && p1 == p2 && s1 == s2
  32         | Pred(p1), Pred(p2) -> p1 == p2
  33         | _ -> false
  34
  35     let hash f =
  36       match f.pos with
  37         | False -> 0
  38         | True -> 1
  39         | Or (f1, f2) -> HASHINT3(PRIME2, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  40         | And (f1, f2) -> HASHINT3(PRIME3, Uid.to_int f1.Node.id, Uid.to_int f2.Node.id)
  41         | Atom(d, p, s) -> HASHINT4(PRIME4, hash_const_variant d,vb p,s)
  42         | Pred(p) -> HASHINT2(PRIME5, Uid.to_int p.Tree.Predicate.id)
  43   end
  44
  45 type t = Node.t
  46 let hash x = x.Node.key
  47 let uid x = x.Node.id
  48 let equal = Node.equal
  49 let expr f = f.Node.node.pos
  50 let st f = f.Node.node.st
  51 let size f = f.Node.node.size
  52 let compare f1 f2 = compare f1.Node.id  f2.Node.id
  53 let prio f =
  54   match expr f with
  55     | True | False -> 10
  56     | Pred _ -> 9
  57     | Atom _ -> 8
  58     | And _ -> 6
  59     | Or _ -> 1
  60
  61 let rec print ?(parent=false) ppf f =
  62   if parent then fprintf ppf "(";
  63   let _ = match expr f with
  64     | True -> fprintf ppf "%s" Pretty.top
  65     | False -> fprintf ppf "%s" Pretty.bottom
  66     | And(f1,f2) ->
  67         print ~parent:(prio f > prio f1) ppf f1;
  68         fprintf ppf " %s "  Pretty.wedge;
  69         print ~parent:(prio f > prio f2) ppf f2;
  70     | Or(f1,f2) ->
  71         (print ppf f1);
  72         fprintf ppf " %s " Pretty.vee;
  73         (print ppf f2);
  74     | Atom(dir, b, s) ->
  75         let _ = flush_str_formatter() in
  76         let fmt = str_formatter in
  77         let a_str, d_str =
  78           match  dir with
  79             | `Left ->  Pretty.down_arrow, Pretty.subscript 1
  80             | `Right -> Pretty.down_arrow, Pretty.subscript 2
  81             | `Epsilon -> Pretty.epsilon, ""
  82         in
  83           fprintf fmt "%s%s" a_str d_str;
  84           State.print fmt s;
  85           let str = flush_str_formatter() in
  86             if b then fprintf ppf "%s" str
  87             else Pretty.pp_overline ppf str
  88     | Pred p -> fprintf ppf "P%s" (Pretty.subscript (Uid.to_int p.Tree.Predicate.id))
  89   in
  90     if parent then fprintf ppf ")"
  91
  92 let print ppf f =  print ~parent:false ppf f
  93
  94 let is_true f = (expr f) == True
  95 let is_false f = (expr f) == False
  96
  97
  98 let cons pos neg s1 s2 size1 size2 =
  99   let nnode = Node.make { pos = neg; neg = (Obj.magic 0); st = s2; size = size2 } in
 100   let pnode = Node.make { pos = pos; neg = nnode ; st = s1; size = size1 } in
 101     (Node.node nnode).neg <- pnode; (* works because the neg field isn't taken into
 102                                       account for hashing ! *)
 103     pnode,nnode
 104
 105 let empty_triple = StateSet.empty,StateSet.empty,StateSet.empty
 106 let empty_hex = empty_triple,empty_triple
 107 let true_,false_ = cons True False empty_hex empty_hex 0 0
 108 let atom_ d p s =
 109   let si = StateSet.singleton s in
 110   let ss = match d with
 111     | `Left -> (si,StateSet.empty,si),empty_triple
 112     | `Right -> empty_triple,(si,StateSet.empty,si)
 113     | `Epsilon -> empty_triple, empty_triple
 114   in fst (cons (Atom(d,p,s)) (Atom(d,not p,s)) ss ss 1 1)
 115
 116 let pred_ p =
 117   let fneg = !(p.Tree.Predicate.node) in
 118   let pneg = Tree.Predicate.make (ref (fun t n -> not (fneg t n))) in
 119   fst (cons (Pred p) (Pred pneg) empty_hex empty_hex 1 1)
 120
 121 let not_ f = f.Node.node.neg
 122 let union_hex  ((l1,ll1,lll1),(r1,rr1,rrr1))  ((l2,ll2,lll2),(r2,rr2,rrr2)) =
 123   (StateSet.mem_union l1 l2 ,StateSet.mem_union ll1 ll2,StateSet.mem_union lll1 lll2),
 124   (StateSet.mem_union r1 r2 ,StateSet.mem_union rr1 rr2,StateSet.mem_union rrr1 rrr2)
 125
 126 let merge_states f1 f2 =
 127   let sp =
 128     union_hex (st f1) (st f2)
 129   and sn =
 130     union_hex (st (not_ f1)) (st (not_ f2))
 131   in
 132     sp,sn
 133
 134 let order f1 f2 = if uid f1  < uid f2 then f2,f1 else f1,f2
 135
 136 let or_ f1 f2 =
 137   (* Tautologies: x|x, x|not(x) *)
 138
 139   if equal f1 f2 then f1
 140   else if equal f1 (not_ f2) then true_
 141
 142       (* simplification *)
 143   else if is_true f1 || is_true f2 then true_
 144   else if is_false f1 && is_false f2 then false_
 145   else if is_false f1 then f2
 146   else if is_false f2 then f1
 147
 148               (* commutativity of | *)
 149   else
 150     let f1, f2 = order f1 f2 in
 151     let psize = (size f1) + (size f2) in
 152     let nsize = (size (not_ f1)) + (size (not_ f2)) in
 153     let sp, sn = merge_states f1 f2 in
 154       fst (cons (Or(f1,f2)) (And(not_ f1, not_ f2)) sp sn psize nsize)
 155
 156
 157 let and_ f1 f2 =
 158   not_ (or_ (not_ f1) (not_ f2))
 159
 160
 161 let of_bool = function true -> true_ | false -> false_
 162
 163 let or_pred f1 f2 =
 164   match expr f1, expr f2 with
 165     | Pred p1, Pred p2 ->
 166         let fp1 = !(p1.Tree.Predicate.node)
 167         and fp2 = !(p2.Tree.Predicate.node) in
 168         pred_ (Tree.Predicate.make (ref (fun t n -> (fp1 t n) || (fp2 t n))))
 169     | _ -> or_ f1 f2
 170
 171 let and_pred f1 f2 =
 172   match expr f1, expr f2 with
 173       Pred p1, Pred p2 ->
 174         let fp1 = !(p1.Tree.Predicate.node)
 175         and fp2 = !(p2.Tree.Predicate.node) in
 176         pred_ (Tree.Predicate.make (ref (fun t n -> (fp1 t n) && (fp2 t n))))
 177     | _ -> and_ f1 f2
 178
 179
 180 module Infix = struct
 181   let ( +| ) f1 f2 = or_ f1 f2
 182
 183   let ( *& ) f1 f2 = and_ f1 f2
 184
 185   let ( *+ ) d s = atom_ d true s
 186   let ( *- ) d s = atom_ d false s
 187 end