232 lines
7.1 KiB
OCaml
232 lines
7.1 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id: bdd.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
|
|
|
|
(* Translated to Caml by Xavier Leroy *)
|
|
(* Original code written in SML by ... *)
|
|
|
|
type bdd = One | Zero | Node of bdd * int * int * bdd
|
|
|
|
let rec eval bdd vars =
|
|
match bdd with
|
|
Zero -> false
|
|
| One -> true
|
|
| Node(l, v, _, h) ->
|
|
if vars.(v) then eval h vars else eval l vars
|
|
|
|
let getId bdd =
|
|
match bdd with
|
|
Node(_,_,id,_) -> id
|
|
| Zero -> 0
|
|
| One -> 1
|
|
|
|
let initSize_1 = 8*1024 - 1
|
|
let nodeC = ref 1
|
|
let sz_1 = ref initSize_1
|
|
let htab = ref(Array.create (!sz_1+1) [])
|
|
let n_items = ref 0
|
|
let hashVal x y v = x lsl 1 + y + v lsl 2
|
|
|
|
let resize newSize =
|
|
let arr = !htab in
|
|
let newSz_1 = newSize-1 in
|
|
let newArr = Array.create newSize [] in
|
|
let rec copyBucket bucket =
|
|
match bucket with
|
|
[] -> ()
|
|
| n :: ns ->
|
|
match n with
|
|
| Node(l,v,_,h) ->
|
|
let ind = hashVal (getId l) (getId h) v land newSz_1
|
|
in
|
|
newArr.(ind) <- (n :: newArr.(ind));
|
|
copyBucket ns
|
|
| _ -> assert false
|
|
in
|
|
for n = 0 to !sz_1 do
|
|
copyBucket(arr.(n))
|
|
done;
|
|
htab := newArr;
|
|
sz_1 := newSz_1
|
|
|
|
|
|
let rec insert idl idh v ind bucket newNode =
|
|
if !n_items <= !sz_1
|
|
then ( (!htab).(ind) <- (newNode :: bucket);
|
|
incr n_items )
|
|
else ( resize(!sz_1 + !sz_1 + 2);
|
|
let ind = hashVal idl idh v land (!sz_1)
|
|
in
|
|
(!htab).(ind) <- newNode :: (!htab).(ind)
|
|
)
|
|
|
|
|
|
let resetUnique () = (
|
|
sz_1 := initSize_1;
|
|
htab := Array.create (!sz_1+1) [];
|
|
n_items := 0;
|
|
nodeC := 1
|
|
)
|
|
|
|
let mkNode low v high =
|
|
let idl = getId low in
|
|
let idh = getId high
|
|
in
|
|
if idl = idh
|
|
then low
|
|
else let ind = hashVal idl idh v land (!sz_1) in
|
|
let bucket = (!htab).(ind) in
|
|
let rec lookup b =
|
|
match b with
|
|
[] -> let n = Node(low, v, (incr nodeC; !nodeC), high)
|
|
in
|
|
insert (getId low) (getId high) v ind bucket n; n
|
|
| n :: ns ->
|
|
match n with
|
|
| Node(l,v',id,h) ->
|
|
if v = v' && idl = getId l && idh = getId h
|
|
then n else lookup ns
|
|
| _ -> assert false
|
|
in
|
|
lookup bucket
|
|
|
|
|
|
type ordering = LESS | EQUAL | GREATER
|
|
|
|
let cmpVar (x : int) (y : int) =
|
|
if x<y then LESS else if x>y then GREATER else EQUAL
|
|
|
|
let zero = Zero
|
|
let one = One
|
|
|
|
let mkVar x = mkNode zero x one
|
|
|
|
|
|
let cacheSize = 1999
|
|
let andslot1 = Array.create cacheSize 0
|
|
let andslot2 = Array.create cacheSize 0
|
|
let andslot3 = Array.create cacheSize zero
|
|
let xorslot1 = Array.create cacheSize 0
|
|
let xorslot2 = Array.create cacheSize 0
|
|
let xorslot3 = Array.create cacheSize zero
|
|
let notslot1 = Array.create cacheSize 0
|
|
let notslot2 = Array.create cacheSize one
|
|
let hash x y = ((x lsl 1)+y) mod cacheSize
|
|
|
|
let rec not n =
|
|
match n with
|
|
Zero -> One
|
|
| One -> Zero
|
|
| Node(l, v, id, r) -> let h = id mod cacheSize
|
|
in
|
|
if id=notslot1.(h) then notslot2.(h)
|
|
else let f = mkNode (not l) v (not r)
|
|
in
|
|
notslot1.(h) <- id; notslot2.(h) <- f; f
|
|
|
|
let rec and2 n1 n2 =
|
|
match n1 with
|
|
Node(l1, v1, i1, r1)
|
|
-> (match n2 with
|
|
Node(l2, v2, i2, r2)
|
|
-> let h = hash i1 i2
|
|
in
|
|
if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
|
|
else let f = match cmpVar v1 v2 with
|
|
EQUAL -> mkNode (and2 l1 l2) v1 (and2 r1 r2)
|
|
| LESS -> mkNode (and2 l1 n2) v1 (and2 r1 n2)
|
|
| GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2)
|
|
in
|
|
andslot1.(h) <- i1;
|
|
andslot2.(h) <- i2;
|
|
andslot3.(h) <- f;
|
|
f
|
|
| Zero -> Zero
|
|
| One -> n1)
|
|
| Zero -> Zero
|
|
| One -> n2
|
|
|
|
|
|
let rec xor n1 n2 =
|
|
match n1 with
|
|
Node(l1, v1, i1, r1)
|
|
-> (match n2 with
|
|
Node(l2, v2, i2, r2)
|
|
-> let h = hash i1 i2
|
|
in
|
|
if i1=andslot1.(h) && i2=andslot2.(h) then andslot3.(h)
|
|
else let f = match cmpVar v1 v2 with
|
|
EQUAL -> mkNode (xor l1 l2) v1 (xor r1 r2)
|
|
| LESS -> mkNode (xor l1 n2) v1 (xor r1 n2)
|
|
| GREATER -> mkNode (xor n1 l2) v2 (xor n1 r2)
|
|
in
|
|
andslot1.(h) <- i1;
|
|
andslot2.(h) <- i2;
|
|
andslot3.(h) <- f;
|
|
f
|
|
| Zero -> n1
|
|
| One -> not n1)
|
|
| Zero -> n2
|
|
| One -> not n2
|
|
|
|
let hwb n =
|
|
let rec h i j = if i=j
|
|
then mkVar i
|
|
else xor (and2 (not(mkVar j)) (h i (j-1)))
|
|
(and2 (mkVar j) (g i (j-1)))
|
|
and g i j = if i=j
|
|
then mkVar i
|
|
else xor (and2 (not(mkVar i)) (h (i+1) j))
|
|
(and2 (mkVar i) (g (i+1) j))
|
|
in
|
|
h 0 (n-1)
|
|
|
|
(* Testing *)
|
|
let seed = ref 0
|
|
|
|
let random() =
|
|
seed := !seed * 25173 + 17431; !seed land 1 > 0
|
|
|
|
let random_vars n =
|
|
let vars = Array.create n false in
|
|
for i = 0 to n - 1 do vars.(i) <- random() done;
|
|
vars
|
|
|
|
let test_hwb bdd vars =
|
|
(* We should have
|
|
eval bdd vars = vars.(n-1) if n > 0
|
|
eval bdd vars = false if n = 0
|
|
where n is the number of "true" elements in vars. *)
|
|
let ntrue = ref 0 in
|
|
for i = 0 to Array.length vars - 1 do
|
|
if vars.(i) then incr ntrue
|
|
done;
|
|
eval bdd vars = (if !ntrue > 0 then vars.(!ntrue-1) else false)
|
|
|
|
let main () =
|
|
let n =
|
|
if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 22 in
|
|
let ntests =
|
|
if Array.length Sys.argv >= 3 then int_of_string Sys.argv.(2) else 100 in
|
|
let bdd = hwb n in
|
|
let succeeded = ref true in
|
|
for i = 1 to ntests do
|
|
succeeded := !succeeded && test_hwb bdd (random_vars n)
|
|
done;
|
|
if !succeeded
|
|
then print_string "OK\n"
|
|
else print_string "FAILED\n";
|
|
exit 0
|
|
|
|
let _ = main()
|