(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
Section BDDgc.
Definition set_closed (bs : BDDstate) (marked : Map unit) :=
forall node node' : ad,
in_dom _ node marked = true ->
nodes_reachable bs node node' ->
in_dom _ node' bs = true -> in_dom _ node' marked = true.
Fixpoint add_used_nodes_1 (bs : BDDstate) (node : ad)
(marked : Map unit) (bound : nat) {struct bound} :
Map unit :=
match bound with
| O => (* Error *)  M0 unit
| S bound' =>
match MapGet _ marked node with
| None =>
match MapGet _ bs node with
| None => marked
| Some (x, (l, r)) =>
MapPut _
(add_used_nodes_1 bs r (add_used_nodes_1 bs l marked bound')
bound') node tt
end
| Some tt => marked
end
end.
Definition add_used_nodes (bs : BDDstate) (node : ad)
(marked : Map unit) :=
add_used_nodes_1 bs node marked (S (nat_of_N (bs_node_height bs node))).
Definition mark (bs : BDDstate) (used : list ad) :=
fold_right (add_used_nodes bs) (M0 unit) used.
Definition new_bs (bs : BDDstate) (used : list ad) :=
MapDomRestrTo _ _ bs (mark bs used).
Definition new_fl (bs : BDDstate) (used : list ad)
(fl : BDDfree_list) :=
MapDomRestrByApp1 _ _ (fun a0 : ad => a0) fl bs (mark bs used).
Definition used_node_bs_1 (marked : Map unit) (node : ad) :=
match MapGet _ marked node with
| Some _ => true
| None => Neqb node BDDzero || Neqb node BDDone
end.
Fixpoint clean'1_1 (pf : ad -> ad) (m' : Map unit)
(m : Map ad) {struct m} : Map ad :=
match m with
| M0 => m
| M1 a a' =>
if used_node_bs_1 m' (pf a) && used_node_bs_1 m' a' then m else M0 _
| M2 m1 m2 =>
makeM2 _ (clean'1_1 (fun a0 : ad => pf (Ndouble a0)) m' m1)
(clean'1_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m2)
end.
Definition clean'1 (m : Map ad) (m' : Map unit) :=
clean'1_1 (fun a : ad => a) m' m.
(* Cleans memoization table  for negation *)
Fixpoint clean'2_1 (pf : ad -> ad) (m' : Map unit)
(m : Map (Map ad)) {struct m} : Map (Map ad) :=
match m with
| M0 => m
| M1 a y =>
if used_node_bs_1 m' (pf a) then M1 _ a (clean'1 y m') else M0 _
| M2 m1 m2 =>
makeM2 _ (clean'2_1 (fun a0 : ad => pf (Ndouble a0)) m' m1)
(clean'2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m2)
end.
Definition clean'2 (m : Map (Map ad)) (m' : Map unit) :=
clean'2_1 (fun a : ad => a) m' m.
(* Cleans memoization table for disjunction *)
Fixpoint clean1 (m' : Map unit) (m : Map ad) {struct m} :
Map ad :=
match m with
| M0 => m
| M1 a a' => if used_node_bs_1 m' a' then m else M0 _
| M2 m1 m2 => makeM2 _ (clean1 m' m1) (clean1 m' m2)
end.
Fixpoint clean2_1 (pf : ad -> ad) (m' : Map unit) (m : Map (Map ad))
{struct m} : Map (Map ad) :=
match m with
| M0 => m
| M1 a y => if used_node_bs_1 m' (pf a) then M1 _ a (clean1 m' y) else M0 _
| M2 m1 m2 =>
makeM2 _ (clean2_1 (fun a0 : ad => pf (Ndouble a0)) m' m1)
(clean2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m2)
end.
Definition clean2 (m : Map (Map ad)) (m' : Map unit) :=
clean2_1 (fun a : ad => a) m' m.
Fixpoint clean3_1 (pf : ad -> ad) (m' : Map unit) (m : Map (Map (Map ad)))
{struct m} : Map (Map (Map ad)) :=
match m with
| M0 => m
| M1 a y => if used_node_bs_1 m' (pf a) then M1 _ a (clean2 y m') else M0 _
| M2 m1 m2 =>
makeM2 _ (clean3_1 (fun a0 : ad => pf (Ndouble a0)) m' m1)
(clean3_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m2)
end.
Definition clean3 (m : Map (Map (Map ad))) (m' : Map unit) :=
clean3_1 (fun a : ad => a) m' m.
(* Cleans sharing map *)
Inductive dummy_mark : Set :=
DM : Map unit -> dummy_mark.
Definition gc_0 (cfg : BDDconfig) (used : list ad) :=
match cfg with
| (bs, (share, (fl, (cnt, (negm, (orm, um)))))) =>
match DM (mark bs used) with
| DM marked =>
let bs' := MapDomRestrTo _ _ bs marked in
let fl' :=
MapDomRestrByApp1 _ _ (fun a0 : ad => a0) fl bs marked in
let share' := clean3 share marked in
let negm' := clean'1 negm marked in
let orm' := clean'2 orm marked in
let um' := clean2 um marked in
(bs', (share', (fl', (cnt, (negm', (orm', um'))))))
end
end.
Definition gc_inf (cfg : BDDconfig) (used : list ad) := cfg.
(* Temporary *)
Definition is_nil (A : Set) (l : list A) :=
match l with
| nil => true
| _ => false
end.
(* inefficient because Nleb works by converting from ad to nat *)
Definition gc_x (x : ad) (cfg : BDDconfig) :=
if is_nil _ (fst (snd (snd cfg))) && Nleb x (fst (snd (snd (snd cfg))))
then gc_0 cfg
else gc_inf cfg.
(* efficient version of gc_x *)
Definition gc_x_opt (x : ad) (cfg : BDDconfig) :=
match fl_of_cfg cfg with
| nil =>
match BDDcompare x (cnt_of_cfg cfg) with
| Datatypes.Lt => gc_0 cfg
| _ => gc_inf cfg
end
| _ => gc_inf cfg
end.

(* Specifications: *)
Lemma add_used_nodes_1_lemma_1 :
forall (bound : nat) (bs : BDDstate) (node : ad) (marked : Map unit),
BDDstate_OK bs ->
nat_of_N (bs_node_height bs node) < bound ->
forall node' : ad,
in_dom _ node' marked = true ->
in_dom _ node' (add_used_nodes_1 bs node marked bound) = true.
Lemma add_used_nodes_1_lemma_2 :
forall (bound : nat) (bs : BDDstate) (node : ad) (marked : Map unit),
BDDstate_OK bs ->
nat_of_N (bs_node_height bs node) < bound ->
set_closed bs marked ->
(forall node' : ad,
nodes_reachable bs node node' /\ in_dom _ node' bs = true ->
in_dom _ node' (add_used_nodes_1 bs node marked bound) = true) /\
(forall node' : ad,
in_dom _ node' (add_used_nodes_1 bs node marked bound) = true ->
in_dom _ node' marked = true \/
in_dom _ node' bs = true /\ nodes_reachable bs node node') /\
set_closed bs (add_used_nodes_1 bs node marked bound).
Lemma add_used_nodes_lemma_1 :
forall (bs : BDDstate) (node : ad) (marked : Map unit),
BDDstate_OK bs ->
forall node' : ad,
in_dom _ node' marked = true ->
in_dom _ node' (add_used_nodes bs node marked) = true.
Lemma add_used_nodes_lemma_2 :
forall (bs : BDDstate) (node : ad) (marked : Map unit),
BDDstate_OK bs ->
set_closed bs marked ->
(forall node' : ad,
nodes_reachable bs node node' /\ in_dom _ node' bs = true ->
in_dom _ node' (add_used_nodes bs node marked) = true) /\
(forall node' : ad,
in_dom _ node' (add_used_nodes bs node marked) = true ->
in_dom _ node' marked = true \/
in_dom _ node' bs = true /\ nodes_reachable bs node node') /\
set_closed bs (add_used_nodes bs node marked).
Lemma mark_lemma_1 :
forall (used : list ad) (bs : BDDstate),
BDDstate_OK bs ->
set_closed bs (fold_right (add_used_nodes bs) (M0 unit) used) /\
(forall node : ad,
in_dom _ node (fold_right (add_used_nodes bs) (M0 unit) used) = true <->
(exists node' : ad,
In node' used /\
nodes_reachable bs node' node /\ in_dom _ node bs = true)).
Lemma mark_lemma_2 :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs ->
forall node : ad,
in_dom _ node (mark bs used) = true <->
(exists node' : ad,
In node' used /\ nodes_reachable bs node' node /\ in_dom _ node bs = true).
Lemma mark_lemma_3 :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs ->
forall node : ad,
in_dom _ node (mark bs used) = true <->
used_node_bs bs used node /\ in_dom _ node bs = true.
Lemma new_bs_lemma_1 :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs ->
forall node : ad,
used_node_bs bs used node ->
MapGet _ bs node = MapGet _ (new_bs bs used) node.
Lemma new_bs_lemma_2 :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs ->
forall node : ad,
in_dom _ node (new_bs bs used) = true -> used_node_bs bs used node.
Lemma no_new_node_new_bs :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs -> no_new_node_bs bs (new_bs bs used).
Lemma new_bs_zero :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs -> in_dom _ BDDzero (new_bs bs used) = false.
Lemma new_bs_one :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs -> in_dom _ BDDone (new_bs bs used) = false.
Lemma new_bs_BDDhigh :
forall (bs : BDDstate) (used : list ad) (x : BDDvar) (l r node : ad),
BDDstate_OK bs ->
MapGet _ (new_bs bs used) node = Some (x, (l, r)) ->
in_dom _ r (new_bs bs used) = in_dom _ r bs.
Lemma new_bs_BDDlow :
forall (bs : BDDstate) (used : list ad) (x : BDDvar) (l r node : ad),
BDDstate_OK bs ->
MapGet _ (new_bs bs used) node = Some (x, (l, r)) ->
in_dom _ l (new_bs bs used) = in_dom _ l bs.
Lemma new_bs_used_nodes_preserved :
forall (bs : BDDstate) (used : list ad) (node : ad),
BDDstate_OK bs ->
used_node_bs bs used node -> node_preserved_bs bs (new_bs bs used) node.
Lemma new_bsBDDbounded_1 :
forall (n : nat) (bs : BDDstate) (used : list ad) (node : ad) (x : BDDvar),
BDDstate_OK bs ->
n = nat_of_N x ->
in_dom _ node (new_bs bs used) = true ->
BDDbounded bs node x -> BDDbounded (new_bs bs used) node x.
Lemma new_bs_OK :
forall (bs : BDDstate) (used : list ad),
BDDstate_OK bs -> BDDstate_OK (new_bs bs used).
Lemma new_cnt_OK :
forall (bs : BDDstate) (used : list ad) (cnt : ad),
BDDstate_OK bs -> cnt_OK bs cnt -> cnt_OK (new_bs bs used) cnt.
Lemma new_fl_OK :
forall (bs : BDDstate) (used : list ad) (fl : BDDfree_list) (cnt : ad),
BDDstate_OK bs ->
BDDfree_list_OK bs fl cnt ->
cnt_OK bs cnt -> BDDfree_list_OK (new_bs bs used) (new_fl bs used fl) cnt.
Lemma used_node_bs_1_preserved :
forall (bs : BDDstate) (used : list ad) (node : ad),
BDDstate_OK bs ->
used_node_bs_1 (mark bs used) node = true ->
node_preserved_bs bs (new_bs bs used) node.
Lemma clean'1_1_lemma :
forall (m : Map ad) (m' : Map unit) (pf : ad -> ad) (a a' : ad),
MapGet _ (clean'1_1 pf m' m) a = Some a' <->
used_node_bs_1 m' (pf a) && used_node_bs_1 m' a' = true /\
MapGet _ m a = Some a'.
Lemma clean'1_lemma :
forall (m : Map ad) (m' : Map unit) (a a' : ad),
MapGet _ (clean'1 m m') a = Some a' <->
used_node_bs_1 m' a && used_node_bs_1 m' a' = true /\
MapGet _ m a = Some a'.
Lemma clean'2_1_lemma :
forall (m : Map (Map ad)) (m' : Map unit) (pf : ad -> ad) (a b c : ad),
MapGet2 _ (clean'2_1 pf m' m) a b = Some c <->
used_node_bs_1 m' (pf a) && (used_node_bs_1 m' b && used_node_bs_1 m' c) =
true /\ MapGet2 _ m a b = Some c.
Lemma clean'2_lemma :
forall (m : Map (Map ad)) (m' : Map unit) (a b c : ad),
MapGet2 _ (clean'2 m m') a b = Some c <->
used_node_bs_1 m' a && (used_node_bs_1 m' b && used_node_bs_1 m' c) = true /\
MapGet2 _ m a b = Some c.
Lemma clean1_lemma :
forall (m' : Map unit) (m : Map ad) (a a' : ad),
MapGet _ (clean1 m' m) a = Some a' <->
used_node_bs_1 m' a' = true /\ MapGet _ m a = Some a'.
Lemma clean2_1_lemma :
forall (m' : Map unit) (m : Map (Map ad)) (pf : ad -> ad) (a b c : ad),
MapGet2 _ (clean2_1 pf m' m) a b = Some c <->
used_node_bs_1 m' (pf a) && used_node_bs_1 m' c = true /\
MapGet2 _ m a b = Some c.
Lemma clean2_lemma :
forall (m : Map (Map ad)) (m' : Map unit) (a b c : ad),
MapGet2 _ (clean2 m m') a b = Some c <->
used_node_bs_1 m' a && used_node_bs_1 m' c = true /\
MapGet2 _ m a b = Some c.
Lemma clean3_1_lemma :
forall (m' : Map unit) (m : Map (Map (Map ad))) (pf : ad -> ad)
(a b c d : ad),
MapGet3 _ (clean3_1 pf m' m) a b c = Some d <->
used_node_bs_1 m' (pf a) && (used_node_bs_1 m' b && used_node_bs_1 m' d) =
true /\ MapGet3 _ m a b c = Some d.
Lemma clean3_lemma :
forall (m : Map (Map (Map ad))) (m' : Map unit) (a b c d : ad),
MapGet3 _ (clean3 m m') a b c = Some d <->
used_node_bs_1 m' a && (used_node_bs_1 m' b && used_node_bs_1 m' d) = true /\
MapGet3 _ m a b c = Some d.
Lemma new_negm_OK :
forall (bs : BDDstate) (used : list ad) (negm : BDDneg_memo),
BDDstate_OK bs ->
BDDneg_memo_OK bs negm ->
BDDneg_memo_OK (new_bs bs used) (clean'1 negm (mark bs used)).
Lemma new_orm_OK :
forall (bs : BDDstate) (used : list ad) (orm : BDDor_memo),
BDDstate_OK bs ->
BDDor_memo_OK bs orm ->
BDDor_memo_OK (new_bs bs used) (clean'2 orm (mark bs used)).
Lemma new_univm_OK :
forall (bs : BDDstate) (used : list ad) (univm : BDDuniv_memo),
BDDstate_OK bs ->
BDDuniv_memo_OK bs univm ->
BDDuniv_memo_OK (new_bs bs used) (clean2 univm (mark bs used)).
Lemma new_share_OK :
forall (bs : BDDstate) (used : list ad) (share : BDDsharing_map),
BDDstate_OK bs ->
BDDsharing_OK bs share ->
BDDsharing_OK (new_bs bs used) (clean3 share (mark bs used)).
Lemma new_cfg_OK :
forall (bs : BDDstate) (share : BDDsharing_map) (fl : BDDfree_list)
(cnt : ad) (negm : BDDneg_memo) (orm : BDDor_memo)
(um : BDDuniv_memo) (used : list ad),
BDDconfig_OK (bs, (share, (fl, (cnt, (negm, (orm, um)))))) ->
BDDconfig_OK
(new_bs bs used,
(clean3 share (mark bs used),
(new_fl bs used fl,
(cnt,
(clean'1 negm (mark bs used),
(clean'2 orm (mark bs used), clean2 um (mark bs used))))))).
Lemma gc_0_OK : gc_OK gc_0.
Lemma gc_inf_OK : gc_OK gc_inf.
Lemma gc_x_OK : forall x : ad, gc_OK (gc_x x).
Lemma gc_x_opt_OK : forall x : ad, gc_OK (gc_x_opt x).
End BDDgc.