Require Import Coq.Strings.String Coq.Strings.Ascii Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Reflective.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.Gensym.

Delimit Scope item_scope with item.
Bind Scope item_scope with item.
Delimit Scope production_scope with production.
Delimit Scope prod_assignment_scope with prod_assignment.
Bind Scope production_scope with production.
Delimit Scope productions_scope with productions.
Delimit Scope productions_assignment_scope with prods_assignment.
Bind Scope productions_scope with productions.
Delimit Scope grammar_scope with grammar.
Bind Scope grammar_scope with grammar.

(** [abstract] doesn't work in definitions *)
Class NoDupR {T} beq (ls : list T) := nodupr : uniquize beq ls = ls.
Hint Extern 5 (NoDupR _ _) => clear; (*abstract*) (vm_compute; reflexivity) : typeclass_instances.

Definition list_to_productions {T} (default : T) (ls : list (string * T)) : string -> T
  := fun nt
     => option_rect
          (fun _ => T)
          snd
          default
          (find (fun k => string_beq nt (fst k)) ls).

Record pregrammar Char :=
  {
    pregrammar_rproductions : list (string * rproductions Char);
    pregrammar_idata : interp_RCharExpr_data Char;
    pregrammar_rnonterminals : list string
    := map fst pregrammar_rproductions;
    rnonterminals_unique
    : NoDupR string_beq pregrammar_rnonterminals;
    RLookup_idx : nat -> rproductions Char
    := fun n => nth n (map snd pregrammar_rproductions) nil
  }.

Global Existing Instance pregrammar_idata.

Record pregrammar' (Char : Type) :=
  {
    pregrammar_productions :> list (string * productions Char);
    pregrammar_nonterminals : list string
    := map fst pregrammar_productions;
    invalid_nonterminal : string
    := gensym pregrammar_nonterminals;
    Lookup_idx : nat -> productions Char
    := fun n => nth n (map snd pregrammar_productions) nil;
    Lookup_string : string -> productions Char
    := list_to_productions nil pregrammar_productions;
    nonterminals_unique
    : NoDupR string_beq pregrammar_nonterminals
  }.

Global Arguments pregrammar_nonterminals / .
Global Arguments Lookup_idx {_} !_ !_  / .
Global Arguments Lookup_string {_} !_ !_ / .

Existing Instance nonterminals_unique.
Arguments nonterminals_unique {_} _.

Definition pregrammar'_of_pregrammar {Char} (g : pregrammar Char) : pregrammar' Char.
Proof.
  eapply {| pregrammar_productions := List.map (fun xy => (fst xy, interp_rproductions (snd xy))) (pregrammar_rproductions g) |}.
  Grab Existential Variables.
  2:eapply (pregrammar_idata g). (* wheee, dependent subgoals in Coq 8.4 *)
  abstract (
      rewrite map_map; simpl;
      apply (rnonterminals_unique g)
    ).
Defined.

Coercion pregrammar'_of_pregrammar : pregrammar >-> pregrammar'.

Coercion grammar_of_pregrammar {Char} (g : pregrammar' Char) : grammar Char
  := {| Start_symbol := hd ""%string (pregrammar_nonterminals g);
        Lookup := Lookup_string g;
        Valid_nonterminals := (pregrammar_nonterminals g) |}.

Global Instance valid_nonterminals_unique {Char} {G : pregrammar' Char}
: NoDupR string_beq (Valid_nonterminals G)
  := nonterminals_unique _.

Definition list_to_grammar {T} (default : productions T) (ls : list (string * productions T)) : grammar T
  := {| Start_symbol := hd ""%string (map fst ls);
        Lookup := list_to_productions default ls;
        Valid_nonterminals := map fst ls |}.

Global Arguments list_to_grammar {_} _ _.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.WordFacts
        Fiat.BinEncoders.Env.Common.ComposeCheckSum
        Fiat.BinEncoders.Env.Common.ComposeIf
        Fiat.BinEncoders.Env.Common.ComposeOpt
        Fiat.BinEncoders.Env.Automation.Solver
        Fiat.BinEncoders.Env.Lib2.Bool
        Fiat.BinEncoders.Env.Lib2.Option
        Fiat.BinEncoders.Env.Lib2.FixListOpt
        Fiat.BinEncoders.Env.Lib2.NoCache
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.Vector
        Fiat.BinEncoders.Env.Lib2.EnumOpt
        Fiat.BinEncoders.Env.Lib2.SumTypeOpt
        Fiat.BinEncoders.Env.Lib2.IPChecksum.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Start Example Derivation. *)
Section TCPPacketDecoder.

  Definition TCP_Packet :=
    @Tuple <"SourcePort" :: word 16,
    "DestPort" :: word 16,
    "SeqNumber" :: word 32,
    "AckNumber" :: word 32,
    "NS" :: bool, (* ECN-nonce concealment protection flag *)
    "CWR" :: bool, (* Congestion Window Reduced (CWR) flag *)
    "ECE" :: bool, (* ECN-Echo flag *)
    (* We can infer the URG flag from the Urgent Pointer field *)
    "ACK" :: bool, (* Acknowledgment field is significant flag *)
    "PSH" :: bool, (* Push function flag *)
    "RST" :: bool, (* Reset the connection flag *)
    "SYN" :: bool, (* Synchronize sequence numbers flag *)
    "FIN" :: bool, (* No more data from sender flag*)
    "WindowSize" :: word 16,
    "UrgentPointer" :: option (word 16),
    "Options" :: list (word 32),
    "Payload" :: list char >.

  (* These values are provided by the IP header for checksum calculation.*)

  Variable srcAddr : word 32.
  Variable destAddr : word 32.
  Variable tcpLength : word 16.

  Definition TCP_Checksum_Valid
             (n : nat)
             (b : ByteString)
    := IPChecksum_Valid (96 + n)
       (transform (transform (encode_word srcAddr)
                  (transform (encode_word destAddr)
                  (transform (encode_word (wzero 8))
                  (transform (encode_word (natToWord 8 6))
                  (encode_word tcpLength)))))
                  b).

  Definition encode_TCP_Packet_Spec
             (tcp : TCP_Packet) :=
         (      encode_word_Spec (tcp!"SourcePort")
          ThenC encode_word_Spec (tcp!"DestPort")
          ThenC encode_word_Spec (tcp!"SeqNumber")
          ThenC encode_word_Spec (tcp!"AckNumber")
          ThenC encode_nat_Spec 4 (5 + |tcp!"Options"|)
          ThenC encode_unused_word_Spec 3 (* These bits are reserved for future use. *)
          ThenC encode_bool_Spec tcp!"NS"
          ThenC encode_bool_Spec tcp!"CWR"
          ThenC encode_bool_Spec tcp!"ECE"
          ThenC encode_bool_Spec (match tcp!"UrgentPointer" with
                                  | Some _ => true
                                  | _ => false
                                  end)
          ThenC encode_bool_Spec tcp!"ACK"
          ThenC encode_bool_Spec tcp!"PSH"
          ThenC encode_bool_Spec tcp!"RST"
          ThenC encode_bool_Spec tcp!"SYN"
          ThenC encode_bool_Spec tcp!"FIN"
          ThenC encode_word_Spec tcp!"WindowSize" DoneC)
ThenChecksum (TCP_Checksum_Valid) OfSize 16
ThenCarryOn (encode_option_Spec encode_word_Spec (encode_unused_word_Spec' 16 ByteString_id) tcp!"UrgentPointer"
       ThenC encode_list_Spec encode_word_Spec tcp!"Options"
       ThenC encode_list_Spec encode_word_Spec tcp!"Payload" DoneC).

  Definition TCP_Packet_OK (tcp : TCP_Packet) :=
    lt (|tcp!"Options"|) 11
    /\ wordToNat tcpLength = 20 (* length of packet header *)
                             + (4 * |tcp!"Options"|) (* length of option field *)
                             + (|tcp!"Payload"|).

  Local Arguments NPeano.modulo : simpl never.

  Definition TCP_Length :=
    (fun _ : ByteString => (wordToNat tcpLength) * 8).

  Lemma TCP_Packet_Header_Len_OK
    : forall (tcp : TCP_Packet) (ctx ctx' ctx'' : CacheEncode) (c : word 16) (b b'' ext : ByteString),
      (      encode_word_Spec (tcp!"SourcePort")
          ThenC encode_word_Spec (tcp!"DestPort")
          ThenC encode_word_Spec (tcp!"SeqNumber")
          ThenC encode_word_Spec (tcp!"AckNumber")
          ThenC encode_nat_Spec 4 (5 + |tcp!"Options"|)
          ThenC encode_unused_word_Spec 3 (* These bits are reserved for future use. *)
          ThenC encode_bool_Spec tcp!"NS"
          ThenC encode_bool_Spec tcp!"CWR"
          ThenC encode_bool_Spec tcp!"ECE"
          ThenC encode_bool_Spec (match tcp!"UrgentPointer" with
                                  | Some _ => true
                                  | _ => false
                                  end)
          ThenC encode_bool_Spec tcp!"ACK"
          ThenC encode_bool_Spec tcp!"PSH"
          ThenC encode_bool_Spec tcp!"RST"
          ThenC encode_bool_Spec tcp!"SYN"
          ThenC encode_bool_Spec tcp!"FIN"
          ThenC encode_word_Spec tcp!"WindowSize" DoneC) ctx ↝ (b, ctx') ->
      (encode_option_Spec encode_word_Spec (encode_unused_word_Spec' 16 ByteString_id) tcp!"UrgentPointer"
       ThenC encode_list_Spec encode_word_Spec tcp!"Options"
       ThenC encode_list_Spec encode_word_Spec tcp!"Payload" DoneC) ctx' ↝ (b'', ctx'') ->
      (lt (|tcp!"Options"|) 11
       /\ wordToNat tcpLength = 20 (* length of packet header *)
                                + (4 * |tcp!"Options"|) (* length of option field *)
                                + (|tcp!"Payload"|)) ->
      (fun _ : TCP_Packet =>
    16 +
    (16 + (32 + (32 + (4 + (3 + (1 + (1 + (1 + (1 + (1 + (1 + (1 + (1 + (1 + (16 + length_ByteString ByteString_id))))))))))))))))
     tcp +
   (fun a0 : TCP_Packet =>
    16 + ((|a0!"Options"|) * 32 + ((|a0!"Payload" |) * 8 + length_ByteString ByteString_id))) tcp + 16 =
    (TCP_Length
       (transform (transform b (transform (encode_checksum ByteString transformer ByteString_QueueTransformerOpt 16 c) b'')) ext)).
Proof.
  intros.
  intros; change transform_id with ByteString_id; rewrite length_ByteString_ByteString_id.
  unfold TCP_Length; rewrite (proj2 H1).
  match goal with
    |- context [ @length ?A ?l] => remember (@length A l)
  end.
  match goal with
    |- context [ @length ?A ?l] => remember (@length A l)
  end.
  omega.
Qed.

Definition TCP_Packet_decoder'
  : CorrectDecoderFor TCP_Packet_OK encode_TCP_Packet_Spec.
Proof.
  start_synthesizing_decoder.
  normalize_compose transformer.
  apply_IPChecksum_dep TCP_Packet_Header_Len_OK.

  - unfold TCP_Packet_OK; intros ? H'; repeat split.
    simpl; destruct H'.
    unfold pow2; simpl in *.
    unfold GetAttribute, GetAttributeRaw in H0; simpl in H0.
    revert H0; clear; unfold StringId13; intros; omega.

  - decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.

    simpl in *. intros; split_and; decompose_pair_hyp.
    instantiate (1 := fst (snd (snd (snd (snd (snd (snd (snd (snd proj))))))))).

    first [ rewrite <- H12
          | rewrite <- H13 ].
    match goal with
      |- context [decides (negb match ?b with _ => _ end) (?b' = None) ] =>
      assert (b = b') as H' by reflexivity; rewrite H'; destruct b';
        simpl; intuition eauto
    end.
    discriminate.
    destruct a'; intros; exact I.

    decode_step idtac.
    decode_step idtac.
    decode_step idtac.

    simpl in *. intros; split_and. decompose_pair_hyp.
    simpl; intros; instantiate (1 := fst (snd (snd (snd (snd proj)))) - 5).
    intuition; subst; simpl; auto with arith.
    first [ rewrite <- H12
          | rewrite <- H11]; simpl in *; auto with arith.

    decode_step idtac.
    decode_step idtac.
    decode_step idtac.
    decode_step idtac.

    simpl in *; intros.
    do 4 destruct H3.
    split; eauto.
    instantiate (1 := (wordToNat tcpLength) - 20 - (4 * (fst (snd (snd (snd (snd proj)))) - 5))).
    first [ rewrite <- H6
          | rewrite <- H5].
    rewrite H7.
    unfold snd, fst.
    unfold GetAttribute, GetAttributeRaw in *; simpl in *.
    repeat match goal with
             |- context [ @length ?A (prim_fst ?l)] => remember (@length A (prim_fst l))
           end.
    assert (n = n1) by (subst; reflexivity).
    rewrite H8; clear; omega.

    decode_step idtac.
    decode_step idtac.

  - synthesize_cache_invariant.
  - optimize_decoder_impl.

    Time Defined.

  Definition TCP_Packet_decoder_impl :=
    Eval simpl in (fst (projT1 TCP_Packet_decoder')).

End TCPPacketDecoder.

Print TCP_Packet_decoder_impl.


(* 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                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Map.
From IntMap Require Import Allmaps.
Require Import List.
Require Import Wf_nat.

Require Import misc.
Require Import bool_fun.
Require Import config.
Require Import myMap.

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.

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.
Proof.
  simple induction bound.  intros bs node marked H00.  intros.
  absurd (nat_of_N (bs_node_height bs node) < 0).  apply lt_n_O.  assumption.
  intros n H bs node marked H00.  intros.  simpl in |- *.  elim (option_sum _ (MapGet _ marked node)).
  intro y.  elim y; clear y.  intros u H2.  rewrite H2.  simpl in |- *.  elim u.
  assumption.  intro y.  rewrite y.  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) bs node)).
  intro y0.  elim y0; clear y0.  intro x.  elim x; clear x.  intros x y0.
  elim y0; clear y0; intros l r.  intro y0.  rewrite y0.  unfold in_dom in |- *.
  rewrite
   (MapPut_semantics unit
      (add_used_nodes_1 bs r (add_used_nodes_1 bs l marked n) n) node tt
      node').
  elim (sumbool_of_bool (Neqb node node')).  intro y1.  rewrite y1.  reflexivity.
  intro y1.  rewrite y1.  cut (in_dom _ node' (add_used_nodes_1 bs l marked n) = true).
  intro.  cut
   (in_dom _ node' (add_used_nodes_1 bs r (add_used_nodes_1 bs l marked n) n) =
    true).
  intro.  unfold in_dom in H3.  elim
   (option_sum _
      (MapGet unit (add_used_nodes_1 bs r (add_used_nodes_1 bs l marked n) n)
         node')).
  intro y2.  elim y2; intros x0 y3.  rewrite y3.  reflexivity.  intro y2.  rewrite y2 in H3.
  discriminate.  apply H.  assumption.  apply lt_trans_1 with (y := nat_of_N (bs_node_height bs node)).
  apply BDDcompare_lt.  apply bs_node_height_right with (bs := bs) (x := x) (l := l) (r := r).
  assumption.  assumption.  assumption.  assumption.  apply H.  assumption.
  apply lt_trans_1 with (y := nat_of_N (bs_node_height bs node)).  apply BDDcompare_lt.
  apply bs_node_height_left with (bs := bs) (x := x) (l := l) (r := r).  assumption.  assumption.
  assumption.  assumption.  intro y0.  rewrite y0.  assumption.
Qed.

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).
Proof.
  simple induction bound.  intros.  absurd (nat_of_N (bs_node_height bs node) < 0).
  apply lt_n_O.  assumption.  intros n H bs node marked H00.  intros.  simpl in |- *.
  elim (option_sum _ (MapGet _ marked node)).
  intro y.  elim y; clear y.  intros u H2.  rewrite H2.  simpl in |- *.  elim u.  split.
  intros.  unfold set_closed in H1.  apply H1 with (node := node).  unfold in_dom in |- *.
  rewrite H2.  reflexivity.  exact (proj1 H3).  exact (proj2 H3).
  split.  intros.  left; assumption.  assumption.  intro y.  rewrite y.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) bs node)).  intro y0.  elim y0; clear y0.
  intro x.  elim x; clear x.  intros x y0.  elim y0; clear y0; intros l r.
  intros y0.  rewrite y0.  cut (exists markedl : Map unit, markedl = add_used_nodes_1 bs l marked n).
  intro.  elim H2; clear H2.  intro markedl.  intros.  rewrite <- H2.
  cut (exists markedr : Map unit, markedr = add_used_nodes_1 bs r markedl n).
  intro.  elim H3; clear H3.  intros markedr H3.  rewrite <- H3.
  cut
   ((forall node' : ad,
     nodes_reachable bs l node' /\ in_dom _ node' bs = true ->
     in_dom _ node' markedl = true) /\
    (forall node' : ad,
     in_dom _ node' markedl = true ->
     in_dom _ node' marked = true \/
     in_dom _ node' bs = true /\ nodes_reachable bs l node') /\
    set_closed bs markedl).
  intro.  elim H4; clear H4; intros.  elim H5; clear H5; intros.
  cut
   ((forall node' : ad,
     nodes_reachable bs r node' /\ in_dom _ node' bs = true ->
     in_dom _ node' markedr = true) /\
    (forall node' : ad,
     in_dom _ node' markedr = true ->
     in_dom _ node' markedl = true \/
     in_dom _ node' bs = true /\ nodes_reachable bs r node') /\
    set_closed bs markedr).
  intros.  elim H7; clear H7; intros.  elim H8; clear H8; intros.
  cut
   (forall node' : ad,
    nodes_reachable bs node node' /\
    in_dom (BDDvar * (ad * ad)) node' bs = true ->
    in_dom unit node' (MapPut unit markedr node tt) = true).
  intro.  cut
   (forall node' : ad,
    in_dom unit node' (MapPut unit markedr node tt) = true ->
    in_dom unit node' marked = true \/
    in_dom (BDDvar * (ad * ad)) node' bs = true /\
    nodes_reachable bs node node').
  intros.  split.  assumption.  split.  assumption.  unfold set_closed in |- *.
  intros.  unfold in_dom in H12.  rewrite (MapPut_semantics unit markedr node tt node0) in H12.
  elim (sumbool_of_bool (Neqb node node0)).  intro y1.  rewrite <- (Neqb_complete _ _ y1) in H13.
  apply H10.  split.  assumption.  assumption.  intro y1.  rewrite y1 in H12.
  unfold set_closed in H9.  unfold in_dom in |- *.  rewrite (MapPut_semantics unit markedr node tt node').
  elim (sumbool_of_bool (Neqb node node')).  intro y2.  rewrite y2.  reflexivity.
  intro y2.  rewrite y2.  fold (in_dom _ node' markedr) in |- *.  apply H9 with (node := node0).
  assumption.  assumption.  assumption.  intros.  unfold in_dom in H11.
  rewrite (MapPut_semantics unit markedr node tt node') in H11.
  elim (sumbool_of_bool (Neqb node node')).  intro y1.  rewrite y1 in H11.
  rewrite <- (Neqb_complete _ _ y1).  right.  split.  unfold in_dom in |- *.
  rewrite y0.  reflexivity.  apply nodes_reachable_0.  intro y1.  rewrite y1 in H11.
  fold (in_dom _ node' markedr) in H11.  elim (H8 node' H11).  intro.
  elim (H5 node' H12).  intro.  left; assumption.  intro.  elim H13; clear H13; intros.
  right.  split.  assumption.  apply nodes_reachable_1 with (x := x) (l := l) (r := r).
  assumption.  assumption.  intro.  right.  split.  exact (proj1 H12).
  apply nodes_reachable_2 with (x := x) (l := l) (r := r).  assumption.  exact (proj2 H12).
  intros.  unfold in_dom in |- *.  rewrite (MapPut_semantics unit markedr node tt node').
  elim (sumbool_of_bool (Neqb node node')).  intro y1.  rewrite y1.  reflexivity.
  intro y1.  rewrite y1.  fold (in_dom _ node' markedr) in |- *.  elim H10; clear H10; intros.
  elim (nodes_reachable_lemma_1 bs node node' H10).  intro.  rewrite H12 in y1.
  rewrite (Neqb_correct node') in y1.  discriminate.  intro.  inversion H12.
  inversion H13.  inversion H14.  clear H12 H13 H14.  inversion H15.  clear H15.
  elim H13; clear H13; intro.  rewrite y0 in H12.  injection H12.  clear H12; intros.
  rewrite <- H14 in H13.  rewrite H3.  apply add_used_nodes_1_lemma_1. assumption.
  apply lt_trans_1 with (y := nat_of_N (bs_node_height bs node)).  apply BDDcompare_lt.
  apply bs_node_height_right with (bs := bs) (x := x) (l := l) (r := r).  assumption.  assumption.
  assumption.  apply H4.  split.  assumption.  assumption.  apply H7.  split.
  rewrite y0 in H12.  injection H12; intros.  rewrite H14.  assumption.
  assumption.  rewrite H3.  apply H.  assumption.
  apply lt_trans_1 with (y := nat_of_N (bs_node_height bs node)).
  apply BDDcompare_lt.  apply bs_node_height_right with (bs := bs) (x := x) (l := l) (r := r).
  assumption.  assumption.  assumption.  assumption.  rewrite H2.  apply H.
  assumption.  apply lt_trans_1 with (y := nat_of_N (bs_node_height bs node)).
  apply BDDcompare_lt.  apply bs_node_height_left with (bs := bs) (x := x) (l := l) (r := r).
  assumption.  assumption.  assumption.  assumption.  split with (add_used_nodes_1 bs r markedl n).
  reflexivity.  split with (add_used_nodes_1 bs l marked n).  intros.
  reflexivity.  intro y0.  rewrite y0.  split.  intros.  elim H2; intros.
  elim (nodes_reachable_lemma_1 bs node node' H3).  intro.  rewrite <- H5 in H4.
  unfold in_dom in H4.  rewrite y0 in H4.  discriminate.  intro.  inversion H5.
  inversion H6.  inversion H7.  inversion H8.  rewrite y0 in H9.  discriminate.
  split.  intros.  left; assumption.  assumption.
Qed.

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.
Proof.
  intros.  unfold add_used_nodes in |- *.  apply add_used_nodes_1_lemma_1.  assumption.
  unfold lt in |- *.  apply le_n.  assumption.
Qed.

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).
Proof.
  intros.  unfold add_used_nodes in |- *.  apply add_used_nodes_1_lemma_2.  assumption.
  unfold lt in |- *.  apply le_n.  assumption.
Qed.

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)).
Proof.
  simple induction used.  intros.  simpl in |- *.  split.  unfold set_closed in |- *.  unfold in_dom in |- *.
  simpl in |- *.  intros; discriminate.  unfold in_dom in |- *.  simpl in |- *.  split.
  intro; discriminate.  intro.  inversion H0.  absurd False.
  unfold not in |- *; trivial.  exact (proj1 H1).  intros.  simpl in |- *.  split.
  refine
   (proj2
      (proj2
         (add_used_nodes_lemma_2 bs a
            (fold_right (add_used_nodes bs) (M0 unit) l) _ _))).
  assumption.  exact (proj1 (H bs H0)).  split.  intro.
  elim
   (add_used_nodes_lemma_2 bs a (fold_right (add_used_nodes bs) (M0 unit) l)
      H0).
  intros.  elim H3; clear H3; intros.  elim (H3 node H1).  intro.
  elim (proj1 (proj2 (H bs H0) node)).  intros.  split with x.  split.
  right.  exact (proj1 H6).  exact (proj2 H6).  assumption.  intro.
  split with a.  split.  left; reflexivity.  split.  exact (proj2 H5).
  exact (proj1 H5).  exact (proj1 (H bs H0)).  intro.
  elim H1; clear H1.  intros.  elim H1; clear H1; intros.
  elim H1; clear H1.  intros.  rewrite <- H1 in H2.
  apply
   (proj1
      (add_used_nodes_lemma_2 bs a
         (fold_right (add_used_nodes bs) (M0 unit) l) H0
         (proj1 (H bs H0)))).
  assumption.  intro.  lapply (proj2 (proj2 (H bs H0) node)).  intro.
  refine (add_used_nodes_lemma_1 _ _ _ _ _ _).  assumption.  assumption.
  split with x.  split.  assumption.  assumption.
Qed.

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).
Proof.
  intros.  unfold mark in |- *.  apply (proj2 (mark_lemma_1 used bs H)).
Qed.

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.
Proof.
  split.  intro.  elim (proj1 (mark_lemma_2 _ _ H _) H0).  intros.
  split.  unfold used_node_bs in |- *.  split with x.  split.  exact (proj1 H1).
  exact (proj1 (proj2 H1)).  exact (proj2 (proj2 H1)).  intro.
  apply (proj2 (mark_lemma_2 bs used H node)).  elim H0; intros.
  elim H1; intros.  split with x.  split.  exact (proj1 H3).  split.
  exact (proj2 H3).  assumption.
Qed.

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.
Proof.
  intros.  unfold new_bs in |- *.  rewrite (MapDomRestrTo_semantics _ _ bs (mark bs used) node).
  elim (option_sum _ (MapGet unit (mark bs used) node)).  intro y.
  elim y; clear y; intros x y.  rewrite y.  reflexivity.  intro y.  rewrite y.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) bs node)).  intro y0.
  elim y0; clear y0; intros x y0.  cut (in_dom _ node (mark bs used) = true).
  unfold in_dom in |- *.  rewrite y.  intro.  discriminate.
  apply (proj2 (mark_lemma_3 bs used H node)).  split.  assumption.
  unfold in_dom in |- *.  rewrite y0.  reflexivity.  tauto.
Qed.

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.
Proof.
  intros.  unfold new_bs in H0.  unfold in_dom in H0.
  rewrite
   (MapDomRestrTo_semantics (BDDvar * (ad * ad)) unit bs (mark bs used) node)
    in H0.
  elim (option_sum _ (MapGet unit (mark bs used) node)).  intro y.
  elim y; clear y; intros x y.  cut (in_dom _ node (mark bs used) = true).  intro.
  elim (proj1 (mark_lemma_3 bs used H node) H1).  tauto.  unfold in_dom in |- *.
  rewrite y.  reflexivity.  intro y.  rewrite y in H0.  discriminate.
Qed.

Lemma no_new_node_new_bs :
 forall (bs : BDDstate) (used : list ad),
 BDDstate_OK bs -> no_new_node_bs bs (new_bs bs used).
Proof.
  intros.  unfold no_new_node_bs in |- *.  intros.  cut (used_node_bs bs used node).
  intro.  rewrite (new_bs_lemma_1 bs used H node H1).  assumption.
  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
Qed.

Lemma new_bs_zero :
 forall (bs : BDDstate) (used : list ad),
 BDDstate_OK bs -> in_dom _ BDDzero (new_bs bs used) = false.
Proof.
  intros.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (MapGet _ bs BDDzero = MapGet _ (new_bs bs used) BDDzero).
  rewrite (proj1 H).  intro.  unfold in_dom in H0.  rewrite <- H1 in H0.
  discriminate.  apply new_bs_lemma_1.  assumption.  apply new_bs_lemma_2.
  assumption.  assumption.
Qed.

Lemma new_bs_one :
 forall (bs : BDDstate) (used : list ad),
 BDDstate_OK bs -> in_dom _ BDDone (new_bs bs used) = false.
Proof.
  intros.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (MapGet _ bs BDDone = MapGet _ (new_bs bs used) BDDone).
  rewrite (proj1 (proj2 H)).  intro.  unfold in_dom in H0.
  rewrite <- H1 in H0.  discriminate.  apply new_bs_lemma_1.  assumption.
  apply new_bs_lemma_2.  assumption.  assumption.
Qed.

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.
Proof.
  intros.  cut (MapGet _ (new_bs bs used) r = MapGet _ bs r).  intro.
  unfold in_dom in |- *.  rewrite H1.  reflexivity.  symmetry  in |- *.  apply new_bs_lemma_1.
  assumption.  unfold used_node_bs in |- *.  cut (used_node_bs bs used node).  intro.
  elim H1.  intros.  split with x0.  split.  exact (proj1 H2).
  apply nodes_reachable_trans with (node2 := node).  exact (proj2 H2).
  apply nodes_reachable_2 with (x := x) (l := l) (r := r).  rewrite <- H0.
  apply new_bs_lemma_1.  assumption.  assumption.  apply nodes_reachable_0.
  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
Qed.

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.
Proof.
  intros.  cut (MapGet _ (new_bs bs used) l = MapGet _ bs l).  intro.
  unfold in_dom in |- *.  rewrite H1.  reflexivity.  symmetry  in |- *.  apply new_bs_lemma_1.
  assumption.  unfold used_node_bs in |- *.  cut (used_node_bs bs used node).  intro.
  elim H1.  intros.  split with x0.  split.  exact (proj1 H2).
  apply nodes_reachable_trans with (node2 := node).  exact (proj2 H2).
  apply nodes_reachable_1 with (x := x) (l := l) (r := r).  rewrite <- H0.
  apply new_bs_lemma_1.  assumption.  assumption.  apply nodes_reachable_0.
  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
Qed.

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.
Proof.
  intros.  unfold node_preserved_bs in |- *.  intros.
  rewrite <- (new_bs_lemma_1 _ used H node').  assumption.  elim H0.  intros.
  split with x0.  split.  exact (proj1 H3).
  apply nodes_reachable_trans with (node2 := node).  exact (proj2 H3).
  assumption.
Qed.

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.
Proof.
  intro.  apply
   lt_wf_ind
    with
      (P := fun n : nat =>
            forall (bs : BDDstate) (used : list ad) (node : ad) (x : BDDvar),
            BDDstate_OK bs ->
            n = nat_of_N x ->
            in_dom (BDDvar * (ad * ad)) node (new_bs bs used) = true ->
            BDDbounded bs node x -> BDDbounded (new_bs bs used) node x).
  clear n.  intro.  intro H00.  intros.  elim (BDDbounded_lemma bs node x H2).
  intro.  rewrite H3.  apply BDDbounded_0.  intro.  elim H3; clear H3; intro.
  rewrite H3.  apply BDDbounded_1.  elim H3; clear H3.  intros x0 H3.
  elim H3; clear H3.  intros l H3.  elim H3; clear H3.  intros r H3.
  elim H3; clear H3; intros.  elim H4; clear H4; intros.
  elim H5; clear H5; intros.  elim H6; clear H6; intros.
  cut (MapGet _ (new_bs bs used) node = Some (x0, (l, r))).  intro.
  cut (BDDbounded (new_bs bs used) l x0).  cut (BDDbounded (new_bs bs used) r x0).
  intros.  apply BDDbounded_2 with (x := x0) (l := l) (r := r).  assumption.  assumption.
  assumption.  assumption.  assumption.  cut (node_OK bs r).  intro.
  unfold node_OK in H9.  elim H9; intro.  rewrite H10.  apply BDDbounded_0.
  elim H10; intro.  rewrite H11.  apply BDDbounded_1.
  apply H00 with (m := nat_of_N x0).  rewrite H0.  apply BDDcompare_lt.
  assumption.  assumption.  reflexivity.  rewrite <- H11.
  apply new_bs_BDDhigh with (x := x0) (l := l) (node := node).  assumption.  assumption.
  assumption.  apply BDDbounded_node_OK with (n := x0).  assumption.
  cut (node_OK bs l).  intro.  unfold node_OK in H9.  elim H9; intro.
  rewrite H10.  apply BDDbounded_0.  elim H10; intro.  rewrite H11.
  apply BDDbounded_1.  apply H00 with (m := nat_of_N x0).  rewrite H0.
  apply BDDcompare_lt.  assumption.  assumption.  reflexivity.  rewrite <- H11.
  apply new_bs_BDDlow with (x := x0) (r := r) (node := node).  assumption.  assumption.
  assumption.  apply BDDbounded_node_OK with (n := x0).  assumption.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (new_bs bs used) node)).  intro y.
  elim y; clear y; intro x1.  elim x1; clear x1.  intro y.  intro y0.
  elim y0; intros y1 y2 y3.  rewrite <- H3.  symmetry  in |- *.  apply new_bs_lemma_1.
   assumption.  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite y3.
  unfold in_dom in |- *.  reflexivity.  intro y.  unfold in_dom in H1.  rewrite y in H1.
  discriminate.
Qed.

Lemma new_bs_OK :
 forall (bs : BDDstate) (used : list ad),
 BDDstate_OK bs -> BDDstate_OK (new_bs bs used).
Proof.
  intros.  unfold BDDstate_OK in |- *.  unfold BDDstate_OK in H.  split.
  lapply (new_bs_zero bs used).  unfold in_dom in |- *.
  elim (MapGet (BDDvar * (ad * ad)) (new_bs bs used) BDDzero).  Focus 2. reflexivity.  intros.
  discriminate.  assumption.  split.  lapply (new_bs_one bs used).
  unfold in_dom in |- *.  elim (MapGet (BDDvar * (ad * ad)) (new_bs bs used) BDDone).
  Focus 2.
  reflexivity.  intros.  discriminate.  assumption.  intros a H0.  unfold BDD_OK in |- *.
  cut (BDD_OK bs a).  unfold BDD_OK in |- *.
  cut
   (MapGet (BDDvar * (ad * ad)) (new_bs bs used) a =
    MapGet (BDDvar * (ad * ad)) bs a).
  intro.  rewrite H1.  elim (MapGet (BDDvar * (ad * ad)) bs a).  Focus 2. tauto.  intro a0.
  elim a0.  intros y y0 H2.  apply new_bsBDDbounded_1 with (n := nat_of_N (ad_S y)).
  assumption.  reflexivity.  assumption.  assumption.  symmetry  in |- *.
  apply new_bs_lemma_1.  assumption.  apply new_bs_lemma_2.  assumption.
  assumption.  apply (proj2 (proj2 H)).
  cut (MapGet _ bs a = MapGet _ (new_bs bs used) a).  intro.  unfold in_dom in |- *.
  rewrite H1.  assumption.  apply new_bs_lemma_1.  assumption.
  apply new_bs_lemma_2.  assumption.  assumption.
Qed.

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.
Proof.
  intros.  unfold cnt_OK in |- *.  unfold cnt_OK in H0.
  elim H0; clear H0; intros.  split.  assumption.  intros.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (new_bs bs used) a)).  intro y.
  elim y; clear y; intros x y.  cut (used_node_bs bs used a).  intro.
  rewrite <- (new_bs_lemma_1 bs used H a H3).  apply H1.  assumption.
  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite y.  reflexivity.
  tauto.
Qed.

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.
Proof.
  unfold BDDfree_list_OK in |- *.  intros bs used fl cnt H H0 H00.
  elim H0; clear H0; intros.  split.  unfold new_fl in |- *.
  apply MapDomRestrByApp1_lemma_4 with (fp := fun a0 : ad => a0).  reflexivity.
  intros.  unfold not in |- *.  intro.  unfold in_dom in H2.
  rewrite (proj2 (proj2 (proj1 (H1 a) H4))) in H2.  discriminate.
  assumption.  split.  intros.  unfold new_fl in H2.  unfold BDDfree_list in fl.
  unfold BDDstate in bs.  cut (forall a : ad, (fun a0 : ad => a0) ((fun a0 : ad => a0) a) = a).  intro.
  elim
   (MapDomRestrByApp1_lemma_3 (BDDvar * (ad * ad)) unit bs
      (mark bs used) fl (fun a : ad => a) (fun a : ad => a) H3 node H2).
  intro.  elim (proj1 (H1 node) H4).  intros.  elim H6; clear H6; intros.
  split.  assumption.  split.  assumption.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (new_bs bs used) node)).  intro y.
  elim y; clear y; intro x.  elim x.  intro y.  intro y0.  elim y0.  intros y1 y2 y3.
  rewrite (no_new_node_new_bs bs used H y y1 y2 node) in H7.  discriminate.
  assumption.  tauto.  intro.  elim H4; clear H4; intros.
  elim H5; clear H5; intros.  clear H6.  unfold cnt_OK in H00.  split.
  apply ad_gt_1_lemma.  unfold not in |- *; intro.  unfold BDDstate_OK in H.
  unfold BDDzero in H.  rewrite <- H6 in H.  unfold in_dom in H4.
  rewrite (proj1 H) in H4.  discriminate.  unfold not in |- *; intro.
  unfold BDDstate_OK in H.  unfold BDDone in H.  rewrite <- H6 in H.
  unfold in_dom in H4.  rewrite (proj1 (proj2 H)) in H4.  discriminate.
  split.  apply Nltb_lebmma.  apply not_true_is_false.  unfold not in |- *; intro.
  unfold in_dom in H4.  rewrite (proj2 H00 _ H6) in H4.  discriminate.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (new_bs bs used) node)).  intro y.
  elim y; clear y; intros x y.  cut (used_node_bs bs used node).  intro.  elim H6.
  intros.  cut (in_dom unit node (mark bs used) = true).  intro.
  rewrite H8 in H5.  discriminate.  apply (proj2 (mark_lemma_2 bs used H node)).
  split with x0.  split.  exact (proj1 H7).  split.  exact (proj2 H7).
  assumption.  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite y.
  reflexivity.  tauto.  reflexivity.  intro.
(*
  Decompose Record H2.
*)
  elim H2; intros H3 H4; elim H4; intros H5 H6; clear H4.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) bs node)).  intro y.  elim y; clear y.
  intro x.  elim x; clear x.  intros x y.  elim y; clear y; intros l r H7.
  unfold new_fl in |- *.  apply MapDomRestrByApp1_lemma_2 with (pf := fun a0 : ad => a0).
  unfold in_dom in |- *.  rewrite H7.  reflexivity.  apply not_true_is_false.
  unfold not in |- *.  intro.  cut (used_node_bs bs used node).  intro.
  rewrite (new_bs_lemma_1 bs used H node H8) in H7.  rewrite H6 in H7.
  discriminate.  exact (proj1 (proj1 (mark_lemma_3 bs used H node) H4)).
  intro.  unfold new_fl in |- *.  apply MapDomRestrByApp1_lemma_1.
  apply (proj2 (H1 node)).  split.  assumption.  split.  assumption.
  assumption.
Qed.

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.
Proof.
  intros.  unfold used_node_bs_1 in H0.
  elim (option_sum _ (MapGet unit (mark bs used) node)).  intro y.  inversion y.
  apply new_bs_used_nodes_preserved.  assumption.
  refine (proj1 (proj1 (mark_lemma_3 bs used H node) _)).
  unfold in_dom in |- *.  rewrite H1.  reflexivity.  intro y.  rewrite y in H0.
  elim (orb_prop _ _ H0).  intro.  rewrite (Neqb_complete _ _ H1).
  apply BDDzero_preserved.  assumption.  intro.
  rewrite (Neqb_complete _ _ H1).  apply BDDone_preserved.  assumption.
Qed.

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'.
Proof.
  simple induction m.  simpl in |- *.  intros.  split.  intro.  discriminate.  tauto.  intros.
  simpl in |- *.  split.  intro.
  elim (sumbool_of_bool (used_node_bs_1 m' (pf a) && used_node_bs_1 m' a0)).
  intro y.  rewrite y in H.  simpl in H.  elim (sumbool_of_bool (Neqb a a1)).
  intro y0.  rewrite y0 in H.  injection H.  intro.  split.  rewrite H0 in y.
  rewrite (Neqb_complete _ _ y0) in y.  assumption.  rewrite y0.  assumption.
  intro y0.  rewrite y0 in H.  discriminate.  intro y.  rewrite y in H.  simpl in H.
  discriminate.  intro.  elim H; clear H; intros.  elim (sumbool_of_bool (Neqb a a1)).
  intro y.  rewrite y in H0.  injection H0.  intro.  rewrite H1.
  rewrite (Neqb_complete _ _ y).  rewrite H.  simpl in |- *.
  rewrite (Neqb_correct a1).  reflexivity.  intro y.  rewrite y in H0.
  discriminate.  intros.  split.  intro.  simpl in H1.
  rewrite
   (makeM2_M2 _ (clean'1_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'1_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  rewrite
   (MapGet_M2_bit_0_if _ (clean'1_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'1_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y in H1.
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).  rewrite y.
  lapply
   (proj1 (H0 m' (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) a')).
  intro.  rewrite (Ndiv2_double_plus_one a) in H2.  assumption.  assumption.
  assumption.  intro y.  rewrite y in H1.  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).
  rewrite y.  lapply (proj1 (H m' (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) a')).
  intro.  rewrite (Ndiv2_double a) in H2.  assumption.  assumption.
  assumption.  intro.  simpl in |- *.
  rewrite
   (makeM2_M2 _ (clean'1_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'1_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite
   (MapGet_M2_bit_0_if _ (clean'1_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'1_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.  rewrite y in H1.
  apply
   (proj2 (H0 m' (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) a')).
  rewrite (Ndiv2_double_plus_one _ y).  assumption.  intro y.  rewrite y.
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.  rewrite y in H1.
  apply (proj2 (H m' (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) a')).
  rewrite (Ndiv2_double _ y).  assumption.
Qed.

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'.
Proof.
  intros.  unfold clean'1 in |- *.  apply clean'1_1_lemma with (pf := fun a : ad => a).
Qed.

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.
Proof.
  simple induction m.  simpl in |- *.  intros.  split.  intro.  unfold MapGet2 in H.
  simpl in H.  discriminate.  tauto.  intros.  unfold MapGet2 in |- *.  simpl in |- *.  split.
  intro.  elim (sumbool_of_bool (used_node_bs_1 m' (pf a))).  intro y.
  rewrite y in H.  simpl in H.  elim (sumbool_of_bool (Neqb a a1)).  intro y0.
  rewrite y0 in H.  rewrite y0.  rewrite <- (Neqb_complete _ _ y0).
  rewrite y.  simpl in |- *.  apply (proj1 (clean'1_lemma a0 m' b c)).  assumption.
  intro y0.  rewrite y0 in H.  discriminate.  intro y.  rewrite y in H.  simpl in H.
  discriminate.  intro.  elim H; clear H; intros.  elim (andb_prop _ _ H).
  clear H; intros.  elim (sumbool_of_bool (Neqb a a1)).  intro y.
  rewrite y in H0.  rewrite <- (Neqb_complete _ _ y) in H.  rewrite H.
  simpl in |- *.  rewrite y.  apply (proj2 (clean'1_lemma a0 m' b c)).  split.
  assumption.  assumption.  intro y.  rewrite y in H0.  discriminate.  intros.
  split.  intro.  unfold MapGet2 in H1.  simpl in H1.
  rewrite
   (makeM2_M2 _ (clean'2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  rewrite
   (MapGet_M2_bit_0_if _ (clean'2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  unfold MapGet2 in |- *.  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  lapply
   (proj1 (H0 m' (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c)).
  intro.  elim H2; intros.  unfold MapGet2 in H4.  split.
  rewrite (Ndiv2_double_plus_one a y) in H3.  assumption.  assumption.
  assumption.  intro y.  rewrite y in H1.  rewrite y.
  lapply (proj1 (H m' (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c)).  intro.
  rewrite (Ndiv2_double a y) in H2.  assumption.  assumption.  intros.
  simpl in |- *.  unfold MapGet2 in |- *.
  rewrite
   (makeM2_M2 _ (clean'2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite
   (MapGet_M2_bit_0_if _ (clean'2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean'2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  unfold MapGet2 in H1.  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  lapply
   (proj2 (H0 m' (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c)).
  intro.  assumption.  rewrite (Ndiv2_double_plus_one _ y).  assumption.
  intro y.  rewrite y in H1.  rewrite y.
  apply (proj2 (H m' (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c)).
  rewrite (Ndiv2_double _ y).  assumption.
Qed.

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.
Proof.
  unfold clean'2 in |- *.  intros.  apply clean'2_1_lemma with (pf := fun a : ad => a).
Qed.

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'.
Proof.
  simple induction m.  simpl in |- *.  split.  intro.  discriminate.  intro.  elim H.  intros.
  discriminate.  simpl in |- *.  split.  intros.
  elim (sumbool_of_bool (used_node_bs_1 m' a0)).  intro y.  rewrite y in H.
  simpl in H.  elim (sumbool_of_bool (Neqb a a1)).  intro y0.  rewrite y0 in H.
  injection H.  intro.  rewrite y0.  rewrite H0.  rewrite H0 in y.  split.
  assumption.  reflexivity.  intro y0.  rewrite y0 in H.  discriminate.  intro y.
  rewrite y in H.  simpl in H.  discriminate.  intro.  elim H; intros.
  elim (sumbool_of_bool (Neqb a a1)).  intro y.  rewrite y in H1.  injection H1.
  intro.  rewrite H2.  rewrite H0.  simpl in |- *.  rewrite y.  reflexivity.  intro y.
  rewrite y in H1.  discriminate.  intros.  split.  intro.  simpl in H1.
  rewrite (makeM2_M2 _ (clean1 m' m0) (clean1 m' m1) a) in H1.
  rewrite (MapGet_M2_bit_0_if _ (clean1 m' m0) (clean1 m' m1) a) in H1.
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).  elim (sumbool_of_bool (Nbit0 a)).
  intro y.  rewrite y.  apply (proj1 (H0 (Ndiv2 a) a')).  rewrite y in H1.
  assumption.  intro y.  rewrite y.  rewrite y in H1.
  apply (proj1 (H (Ndiv2 a) a')).  assumption.  intro.
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.  simpl in |- *.
  rewrite (makeM2_M2 _ (clean1 m' m0) (clean1 m' m1) a).
  rewrite (MapGet_M2_bit_0_if _ (clean1 m' m0) (clean1 m' m1) a).
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  apply (proj2 (H0 (Ndiv2 a) a')).  assumption.  intro y.  rewrite y in H1.
  rewrite y.  apply (proj2 (H (Ndiv2 a) a')).  assumption.
Qed.

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.
Proof.
  simple induction m.  unfold MapGet2 in |- *.  simpl in |- *.  split.  intro.  discriminate.  tauto.
  simpl in |- *.  split.  intro.  unfold MapGet2 in |- *.  simpl in |- *.  unfold MapGet2 in H.
  elim (sumbool_of_bool (used_node_bs_1 m' (pf a))).  intro y.  rewrite y in H.
  simpl in H.  elim (sumbool_of_bool (Neqb a a1)).  intro y0.  rewrite y0 in H.
  rewrite y0.  rewrite <- (Neqb_complete _ _ y0).  rewrite y.  simpl in |- *.
  apply (proj1 (clean1_lemma m' a0 b c)).  assumption.  intro y0.
  rewrite y0 in H.  discriminate.  intro y.  rewrite y in H.  simpl in H.
  discriminate.  intro.  unfold MapGet2 in |- *.  unfold MapGet2 in H.  simpl in H.
  elim (sumbool_of_bool (Neqb a a1)).  intro y.  rewrite y in H.
  elim H; intros.  rewrite <- (Neqb_complete _ _ y).
  rewrite <- (Neqb_complete _ _ y) in H0.  elim (andb_prop _ _ H0).  intros.
  rewrite H2.  simpl in |- *.  rewrite (Neqb_correct a).
  apply (proj2 (clean1_lemma m' a0 b c)).  split.  assumption.  assumption.
  intro y.  rewrite y in H.  elim H; intros.  discriminate.  intros.  split.
  intro.  simpl in H1.  unfold MapGet2 in H1.
  rewrite
   (makeM2_M2 (Map ad) (clean2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  rewrite
   (MapGet_M2_bit_0_if _ (clean2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  unfold MapGet2 in |- *.  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  lapply
   (proj1 (H0 (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c)).
  intro.  rewrite (Ndiv2_double_plus_one a y) in H2.  assumption.
  assumption.  intro y.  rewrite y.  rewrite y in H1.
  lapply (proj1 (H (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c)).
  rewrite (Ndiv2_double a y).  tauto.  assumption.  intro.  simpl in |- *.
  unfold MapGet2 in |- *.  unfold MapGet2 in H1.
  rewrite
   (makeM2_M2 _ (clean2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite
   (MapGet_M2_bit_0_if _ (clean2_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean2_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  apply
   (proj2 (H0 (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c)).
  rewrite (Ndiv2_double_plus_one _ y).  assumption.  intro y.  rewrite y in H1.
  rewrite y.  apply (proj2 (H (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c)).
  rewrite (Ndiv2_double _ y).  assumption.
Qed.

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.
Proof.
  intros.  unfold clean2 in |- *.  apply clean2_1_lemma with (pf := fun a : ad => a).
Qed.

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.
Proof.
  simple induction m.  unfold MapGet3 in |- *.  simpl in |- *.  split.  intro.  discriminate.  tauto.
  simpl in |- *.  split.  intro.  unfold MapGet3 in |- *.  simpl in |- *.  unfold MapGet3 in H.
  elim (sumbool_of_bool (used_node_bs_1 m' (pf a))).  intro y.  rewrite y in H.
  simpl in H.  elim (sumbool_of_bool (Neqb a a1)).  intro y0.  rewrite y0 in H.
  rewrite y0.  rewrite <- (Neqb_complete _ _ y0).  rewrite y.  simpl in |- *.
  apply (proj1 (clean2_lemma a0 m' b c d)).  assumption.  intro y0.
  rewrite y0 in H.  discriminate.  intro y.  rewrite y in H.  simpl in H.
  discriminate.  intro.  unfold MapGet3 in |- *.  unfold MapGet3 in H.  simpl in H.
  elim (sumbool_of_bool (Neqb a a1)).  intro y.  rewrite y in H.
  elim H; intros.  rewrite <- (Neqb_complete _ _ y).
  rewrite <- (Neqb_complete _ _ y) in H0.  elim (andb_prop _ _ H0).  intros.
  rewrite H2.  simpl in |- *.  rewrite (Neqb_correct a).
  apply (proj2 (clean2_lemma a0 m' b c d)).  split.  assumption.
  assumption.  intro y.  rewrite y in H.  elim H; intros.  discriminate.
  intros.  split.  intro.  simpl in H1.  unfold MapGet3 in H1.
  rewrite
   (makeM2_M2 _ (clean3_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean3_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  rewrite
   (MapGet_M2_bit_0_if _ (clean3_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean3_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
    in H1.
  unfold MapGet3 in |- *.  rewrite (MapGet_M2_bit_0_if _ m0 m1 a).
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  lapply
   (proj1 (H0 (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c d)).
  intro.  rewrite (Ndiv2_double_plus_one a y) in H2.  assumption.  assumption.
  intro y.  rewrite y.  rewrite y in H1.
  lapply (proj1 (H (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c d)).
  rewrite (Ndiv2_double a y).  tauto.  assumption.  intro.  simpl in |- *.
  unfold MapGet3 in |- *.  unfold MapGet3 in H1.
  rewrite
   (makeM2_M2 _ (clean3_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean3_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite
   (MapGet_M2_bit_0_if _ (clean3_1 (fun a0 : ad => pf (Ndouble a0)) m' m0)
      (clean3_1 (fun a0 : ad => pf (Ndouble_plus_one a0)) m' m1) a)
   .
  rewrite (MapGet_M2_bit_0_if _ m0 m1 a) in H1.
  elim (sumbool_of_bool (Nbit0 a)).  intro y.  rewrite y.  rewrite y in H1.
  apply
   (proj2 (H0 (fun a0 : ad => pf (Ndouble_plus_one a0)) (Ndiv2 a) b c d)).
   rewrite (Ndiv2_double_plus_one _ y).  assumption.  intro y.  rewrite y in H1.
  rewrite y.
  apply (proj2 (H (fun a0 : ad => pf (Ndouble a0)) (Ndiv2 a) b c d)).
  rewrite (Ndiv2_double _ y).  assumption.
Qed.

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.
Proof.
  intros.  unfold clean3 in |- *.  apply clean3_1_lemma with (pf := fun a : ad => a).
Qed.

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)).
Proof.
  unfold BDDneg_memo_OK in |- *.  intros.  elim (proj1 (clean'1_lemma _ _ _ _) H1).
  intros.  elim (H0 node node' H3).  clear H0.  intros.
  elim H4; clear H4; intros.  elim H5; clear H5; intros.
  elim (andb_prop _ _ H2).  intros.
  cut (node_preserved_bs bs (new_bs bs used) node).
  cut (node_preserved_bs bs (new_bs bs used) node').  intros.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node)
      (bs_node_height bs node)).
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node')
      (bs_node_height bs node')).
  assumption.  apply node_preserved_bs_node_height_eq.  assumption.  apply new_bs_OK.
  assumption.  assumption.  assumption.  apply node_preserved_bs_node_height_eq.
  assumption.  apply new_bs_OK.  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD_bs bs node').
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.
  apply
   bool_fun_eq_trans with (bf2 := bool_fun_neg (bool_fun_of_BDD_bs bs node)).
  assumption.  apply bool_fun_neg_preserves_eq.  apply bool_fun_eq_sym.
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.  apply used_node_bs_1_preserved.  assumption.
  assumption.  apply used_node_bs_1_preserved.  assumption.  assumption.
Qed.

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)).
Proof.
  unfold BDDor_memo_OK in |- *.  intros.  elim (proj1 (clean'2_lemma _ _ _ _ _) H1).
  intros.  elim (H0 node1 node2 node H3).  intros.  elim H5; clear H5; intros.
  elim H6; clear H6; intros.  elim H7; clear H7; intros.
  elim (andb_prop _ _ H2).  intros.
  cut (node_preserved_bs bs (new_bs bs used) node).
  cut (node_preserved_bs bs (new_bs bs used) node1).
  cut (node_preserved_bs bs (new_bs bs used) node2).  intros.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node)
      (bs_node_height bs node)).
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node1)
      (bs_node_height bs node1)).
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node2)
      (bs_node_height bs node2)).
  assumption.  apply node_preserved_bs_node_height_eq.  assumption.  apply new_bs_OK.
  assumption.  assumption.  assumption.  apply node_preserved_bs_node_height_eq.
  assumption.  apply new_bs_OK.  assumption.  assumption.  assumption.
  apply node_preserved_bs_node_height_eq.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD_bs bs node).
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_or (bool_fun_of_BDD_bs bs node1)
                (bool_fun_of_BDD_bs bs node2)).
  assumption.  apply bool_fun_eq_sym.  apply bool_fun_or_preserves_eq.
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.  apply node_preserved_bs_bool_fun.  assumption.
  apply new_bs_OK.  assumption.  assumption.  assumption.
  apply used_node_bs_1_preserved.  assumption.  elim (andb_prop _ _ H10).  tauto.
  apply used_node_bs_1_preserved.  assumption.  assumption.
  apply used_node_bs_1_preserved.  assumption.  elim (andb_prop _ _ H10).  tauto.
Qed.

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)).
Proof.
  unfold BDDuniv_memo_OK in |- *.  intros.
  elim (clean2_lemma univm (mark bs used) node x node').  intros.  elim H2.
  intros.  elim (andb_prop _ _ H4).  intros.
  cut (node_preserved_bs bs (new_bs bs used) node).
  cut (node_preserved_bs bs (new_bs bs used) node').  intros.
  decompose [and] (H0 x node node' H5).  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  apply node_preserved_OK_bs with (bs := bs).  assumption.  assumption.  split.
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node)
      (bs_node_height bs node)).
  rewrite
   (Neqb_complete (bs_node_height (new_bs bs used) node')
      (bs_node_height bs node')).
  assumption.  apply node_preserved_bs_node_height_eq.  assumption.  apply new_bs_OK.
  assumption.  assumption.  assumption.  apply node_preserved_bs_node_height_eq.
  assumption.  apply new_bs_OK.  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD_bs bs node').
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.  apply
   bool_fun_eq_trans
    with (bf2 := bool_fun_forall x (bool_fun_of_BDD_bs bs node)).
  assumption.  apply bool_fun_forall_preserves_eq.  apply bool_fun_eq_sym.
  apply node_preserved_bs_bool_fun.  assumption.  apply new_bs_OK.  assumption.
  assumption.  assumption.  apply used_node_bs_1_preserved.  assumption.  tauto.
  apply used_node_bs_1_preserved.  assumption.  assumption.  assumption.
Qed.

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)).
Proof.
  unfold BDDsharing_OK in |- *.  intros.  elim (H0 x l r a).  intros.  split.  intro.
  elim (proj1 (clean3_lemma share (mark bs used) l r x a) H3).  intros.
  elim (andb_prop _ _ H4).  intros.  elim (andb_prop _ _ H7).  intros.
  cut (node_preserved_bs bs (new_bs bs used) a).  intro.
  unfold node_preserved_bs in H10.  apply H10.  apply nodes_reachable_0.
  apply H1.  assumption.  apply used_node_bs_1_preserved.  assumption.
  assumption.  intro.
  apply (proj2 (clean3_lemma share (mark bs used) l r x a)).
  cut (MapGet _ bs a = Some (x, (l, r))).  intro.  cut (node_OK bs l).
  cut (node_OK bs r).  intros.  split.  apply andb_true_intro.
  cut
   (forall a : ad,
    MapGet _ bs a = None -> MapGet _ (mark bs used) a = None).
  intro.  split.  elim H6.  intro.  rewrite H8.  unfold used_node_bs_1 in |- *.
  rewrite (H7 BDDzero).  apply orb_true_intro.  left.  reflexivity.
  exact (proj1 H).  intro.  elim H8.  intro.  rewrite H9.
  unfold used_node_bs_1 in |- *.  rewrite (H7 BDDone).  apply orb_true_intro.  right.
  reflexivity.  exact (proj1 (proj2 H)).  intro.  unfold used_node_bs_1 in |- *.
  lapply (proj2 (mark_lemma_3 bs used H l)).  unfold in_dom in |- *.
  elim (MapGet unit (mark bs used) l).  Focus 2. intro. discriminate.  reflexivity.
  split.  unfold used_node_bs in |- *.  cut (used_node_bs bs used a).  intro.  elim H10.
  intros.  split with x0.  split.  exact (proj1 H11).
  apply nodes_reachable_trans with (node2 := a).  exact (proj2 H11).
  apply nodes_reachable_1 with (x := x) (l := l) (r := r).  assumption.
  apply nodes_reachable_0.  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.
  rewrite H3.  reflexivity.  assumption.  apply andb_true_intro.  split.
  elim H5.  intro.  rewrite H8.  unfold used_node_bs_1 in |- *.  rewrite (H7 BDDzero).
  apply orb_true_intro.  left.  reflexivity.  exact (proj1 H).  intro.
  elim H8.  intro.  rewrite H9.  unfold used_node_bs_1 in |- *.  rewrite (H7 BDDone).
  apply orb_true_intro.  right.  reflexivity.  exact (proj1 (proj2 H)).
  intro.  unfold used_node_bs_1 in |- *.  lapply (proj2 (mark_lemma_3 bs used H r)).
  unfold in_dom in |- *.  elim (MapGet unit (mark bs used) r). Focus 2. intro.  discriminate.
  reflexivity.  split.  unfold used_node_bs in |- *.  cut (used_node_bs bs used a).
  intro.  elim H10.  intros.  split with x0.  split.  exact (proj1 H11).
  apply nodes_reachable_trans with (node2 := a).  exact (proj2 H11).
  apply nodes_reachable_2 with (x := x) (l := l) (r := r).  assumption.
  apply nodes_reachable_0.  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.
  rewrite H3.  reflexivity.  assumption.
  cut (in_dom unit a (mark bs used) = true).  unfold in_dom in |- *.
  unfold used_node_bs_1 in |- *.  elim (MapGet unit (mark bs used) a).  Focus 2. intro.
  discriminate.  reflexivity.  apply (proj2 (mark_lemma_3 bs used H a)).
  split.  apply new_bs_lemma_2.  assumption.  unfold in_dom in |- *.  rewrite H3.
  reflexivity.  unfold in_dom in |- *.  rewrite H4.  reflexivity.  intros.
  elim (sumbool_of_bool (in_dom _ a0 (mark bs used))).  intro y.
  elim (proj1 (mark_lemma_3 bs used H a0) y).  intros.  unfold in_dom in H9.
  rewrite H7 in H9.  discriminate.  unfold in_dom in |- *.
  elim (MapGet unit (mark bs used) a0).  Focus 2. reflexivity.  intros.  discriminate.
  apply H2.  assumption.  apply high_OK with (node := a) (x := x) (l := l).  assumption.
  assumption.  apply low_OK with (node := a) (x := x) (r := r).  assumption.  assumption.
  rewrite (new_bs_lemma_1 bs used H a).  assumption.  apply new_bs_lemma_2.
  assumption.  unfold in_dom in |- *.  rewrite H3.  reflexivity.
Qed.

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))))))).
Proof.
  intros.  unfold BDDconfig_OK in |- *.  simpl in |- *.  unfold BDDconfig_OK in H.  simpl in H.
  elim H; intros.  elim H1; intros.  elim H3; intros.  elim H5; intros.
  split.  apply new_bs_OK.  assumption.  split.  apply new_share_OK.
  assumption.  assumption.  split.  apply new_fl_OK.  assumption.  assumption.
  assumption.  split.  apply new_cnt_OK.  assumption.  assumption.  split.
  apply new_negm_OK.  assumption.  exact (proj1 H7).  split.
  apply new_orm_OK.  assumption.  exact (proj1 (proj2 H7)).
  apply new_univm_OK.  assumption.  exact (proj2 (proj2 H7)).
Qed.

Lemma gc_0_OK : gc_OK gc_0.
Proof.
  unfold gc_0 in |- *.  unfold gc_OK in |- *.  intro.  elim cfg.  intro y.  intro y0.  elim y0.
  intro y1.  intro y2.  elim y2.  intro y3.  intro y4.  elim y4.  intro y5.  intro y6.  elim y6.
  intro y7.  intro y8.  elim y8.
  intros y9 y10 ul H H0.  split.  fold (new_bs y ul) in |- *.  fold (new_fl y ul y3) in |- *.
  apply new_cfg_OK with (um := y10).  assumption.  unfold used_nodes_preserved in |- *.
  simpl in |- *.  split.
  unfold used_nodes_preserved_bs in |- *.  intros.  fold (new_bs y ul) in |- *.
  apply new_bs_used_nodes_preserved.  exact (proj1 H).  unfold used_node_bs in |- *.
  split with node.  split.  assumption.  apply nodes_reachable_0.
  unfold no_new_node in |- *.  simpl in |- *.  fold (new_bs y ul) in |- *.  apply no_new_node_new_bs.
  exact (proj1 H).
Qed.

Lemma gc_inf_OK : gc_OK gc_inf.
Proof.
  unfold gc_inf in |- *.  unfold gc_OK in |- *.  intros.  split.  assumption.  split.
  apply used_nodes_preserved_refl.  unfold no_new_node in |- *.  unfold no_new_node_bs in |- *.
  tauto.
Qed.

Lemma gc_x_OK : forall x : ad, gc_OK (gc_x x).
Proof.
  intros.  unfold gc_x in |- *.  unfold gc_OK in |- *.  intros.
  elim
   (is_nil ad (fst (snd (snd cfg))) && Nleb x (fst (snd (snd (snd cfg))))).
  apply gc_0_OK.  assumption.  assumption.  apply gc_inf_OK.  assumption.
  assumption.
Qed.

Lemma gc_x_opt_OK : forall x : ad, gc_OK (gc_x_opt x).
Proof.
  intros.  unfold gc_x_opt in |- *.  unfold gc_OK in |- *.  intros.  elim (fl_of_cfg cfg).
  elim (BDDcompare x (cnt_of_cfg cfg)).  apply gc_inf_OK.  assumption.
  assumption.  apply gc_0_OK.  assumption.  assumption.  apply gc_inf_OK.
  assumption.  assumption.  intros.  apply gc_inf_OK.  assumption.  assumption.
Qed.

End BDDgc.


From iris.algebra Require Import excl auth cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.heap_lang Require Export notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode par.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "All".
Require Export auth_ext multicopy_lsm.

Section multicopy_lsm_util.
  Context {Σ} `{!heapG Σ, !multicopyG Σ, !multicopy_lsmG Σ}.
  Notation iProp := (iProp Σ).
  Local Notation "m !1 i" := (nzmap_total_lookup i m) (at level 20).

  (** Useful lemmas *)

  Lemma inFP_domm γ_f n D : inFP γ_f n -∗ own γ_f (● D) -∗ ⌜n ∈ D⌝.
  Proof.
    iIntros "FP HD".
    iPoseProof (own_valid_2 _ _ _ with "[$HD] [$FP]") as "H'".
    iDestruct "H'" as %H'.
    apply auth_both_valid_discrete in H'.
    destruct H' as [H' _].
    apply gset_included in H'.
    iPureIntro. set_solver.
  Qed.

  Lemma inFP_domm_glob γ_I γ_J γ_f γ_gh r hγ I J n :
    inFP γ_f n -∗ global_state γ_I γ_J γ_f γ_gh r hγ I J -∗ ⌜n ∈ domm I⌝.
  Proof.
    iIntros "#FP_n Hglob".
    iDestruct "Hglob" as "(HI & Out_I & HJ
            & Out_J & Inf_J & Hf & Hγ & FP_r & domm_IJ & domm_Iγ)".
    iPoseProof (inFP_domm with "[$FP_n] [$]") as "%".
    by iPureIntro.
  Qed.

  Lemma own_alloc_set (S: gset K): True ==∗
          ∃ (γ: gmap K gname), ([∗ set] k ∈ S, own (γ !!! k) (● (MaxNat 0))).
  Proof.
    iIntros "_".
    iInduction S as [| s S] "IH" using set_ind_L.
    - iModIntro. iExists _. try done.
    - iMod (own_alloc (● (MaxNat 0))) as (γs)"H'".
      { rewrite auth_auth_valid. try done. }
      iDestruct "IH" as ">IH".
      iDestruct "IH" as (γ)"IH".
      iModIntro. iExists (<[s := γs]> γ).
      rewrite (big_sepS_delete _ ({[s]} ∪ S) s); last by set_solver.
      iSplitL "H'". by rewrite lookup_total_insert.
      assert (({[s]} ∪ S) ∖ {[s]} = S) as HS. set_solver.
      rewrite HS.
      iApply (big_sepS_mono
                  (λ y, own (γ !!! y) (● {| max_nat_car := 0 |}) )%I
                  (λ y, own (<[s:=γs]> γ !!! y) (● {| max_nat_car := 0 |}))%I
                  S); try done.
      intros k k_in_S. iFrame. iIntros "H'".
      rewrite lookup_total_insert_ne; last by set_solver.
      done.
      (* No idea what is happening here *)
      Unshelve. exact (∅: gmap K gname).
  Qed.

  Lemma ghost_heap_sync γ_gh n γ_en γ_cn γ_qn γ_cirn
                                      γ_en' γ_cn' γ_qn' γ_cirn' :
    own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]})
      -∗ own γ_gh (◯ {[n := ghost_loc γ_en' γ_cn' γ_qn' γ_cirn']})
          -∗ ⌜γ_en = γ_en'⌝ ∗ ⌜γ_cn = γ_cn'⌝
              ∗ ⌜γ_qn = γ_qn'⌝ ∗ ⌜γ_cirn = γ_cirn'⌝.
  Proof.
    iIntros "H1 H2". iCombine "H1" "H2" as "H".
    iPoseProof (own_valid with "H") as "Valid".
    iDestruct "Valid" as %Valid.
    rewrite auth_frag_valid in Valid *; intros Valid.
    apply singleton_valid in Valid.
    apply to_agree_op_inv in Valid.
    apply leibniz_equiv in Valid.
    inversion Valid.
    by iPureIntro.
  Qed.

  Lemma ghost_heap_update γ_gh (hγ: gmap Node per_node_gl) n
                                γ_en γ_cn γ_qn γ_cirn :
    ⌜n ∉ dom (gset Node) hγ⌝ -∗
          own γ_gh (● hγ) ==∗
            own γ_gh (● <[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]> hγ)
          ∗ own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]}).
  Proof.
    iIntros "%". rename H into n_notin_hγ.
    iIntros "Hown". set (<[ n := ghost_loc γ_en γ_cn γ_qn γ_cirn ]> hγ) as hγ'.
    iDestruct (own_update _ _
        (● hγ' ⋅ ◯ {[ n := ghost_loc γ_en γ_cn γ_qn γ_cirn ]})
               with "Hown") as "Hown".
    { apply auth_update_alloc.
      rewrite /hγ'.
      apply alloc_local_update; last done.
      by rewrite <-not_elem_of_dom. }
    iMod (own_op with "Hown") as "[Ht● Ht◯]".
    iModIntro. iFrame.
  Qed.

  Lemma frac_eq γ_e γ_c γ_q es Cn Qn es' Cn' Qn' :
              frac_ghost_state γ_e γ_c γ_q es Cn Qn -∗
                  frac_ghost_state γ_e γ_c γ_q es' Cn' Qn' -∗
                    ⌜es = es'⌝ ∗ ⌜Cn = Cn'⌝ ∗ ⌜Qn = Qn'⌝.
  Proof.
    iIntros "H1 H2". unfold frac_ghost_state.
    iDestruct "H1" as "(H1_es & H1_c & H1_q)".
    iDestruct "H2" as "(H2_es & H2_c & H2_q)".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_es] [$H2_es]") as "Hes".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_c] [$H2_c]") as "Hc".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_q] [$H2_q]") as "Hq".
    iDestruct "Hes" as %Hes. iDestruct "Hc" as %Hc. iDestruct "Hq" as %Hq.
    apply frac_agree_op_valid in Hes. destruct Hes as [_ Hes].
    apply frac_agree_op_valid in Hc. destruct Hc as [_ Hc].
    apply frac_agree_op_valid in Hq. destruct Hq as [_ Hq].
    apply leibniz_equiv_iff in Hes.
    apply leibniz_equiv_iff in Hc.
    apply leibniz_equiv_iff in Hq.
    iPureIntro. repeat split; try done.
  Qed.

  Lemma frac_update γ_e γ_c γ_q es Cn Qn es' Cn' Qn' :
              frac_ghost_state γ_e γ_c γ_q es Cn Qn ∗
                 frac_ghost_state γ_e γ_c γ_q es Cn Qn ==∗
                      frac_ghost_state γ_e γ_c γ_q es' Cn' Qn' ∗
                        frac_ghost_state γ_e γ_c γ_q es' Cn' Qn'.
  Proof.
    iIntros "(H1 & H2)".
    iDestruct "H1" as "(H1_es & H1_c & H1_q)".
    iDestruct "H2" as "(H2_es & H2_c & H2_q)".
    iCombine "H1_es H2_es" as "Hes".
    iEval (rewrite <-frac_agree_op) in "Hes".
    iEval (rewrite Qp_half_half) in "Hes".
    iCombine "H1_c H2_c" as "Hc".
    iEval (rewrite <-frac_agree_op) in "Hc".
    iEval (rewrite Qp_half_half) in "Hc".
    iCombine "H1_q H2_q" as "Hq".
    iEval (rewrite <-frac_agree_op) in "Hq".
    iEval (rewrite Qp_half_half) in "Hq".
    iMod ((own_update (γ_e) (to_frac_agree 1 es)
                  (to_frac_agree 1 es')) with "[$Hes]") as "Hes".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid_instance.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hes".
    iEval (rewrite frac_agree_op) in "Hes".
    iDestruct "Hes" as "(H1_es & H2_es)".
    iMod ((own_update (γ_c) (to_frac_agree 1 Cn)
                  (to_frac_agree 1 Cn')) with "[$Hc]") as "Hc".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid_instance.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hc".
    iEval (rewrite frac_agree_op) in "Hc".
    iDestruct "Hc" as "(H1_c & H2_c)".
    iMod ((own_update (γ_q) (to_frac_agree 1 Qn)
                  (to_frac_agree 1 Qn')) with "[$Hq]") as "Hq".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid_instance.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hq".
    iEval (rewrite frac_agree_op) in "Hq".
    iDestruct "Hq" as "(H1_q & H2_q)".
    iModIntro. iFrame.
  Qed.

  Lemma flowint_update_result (γ: gname) (I I_n I_n': multiset_flowint_ur K) x :
    ⌜flowint_update_P (_) I I_n I_n' x⌝ ∗ own γ x -∗
    ∃ I', ⌜contextualLeq (_) I I'⌝
          ∗ ⌜∃ I_o, I = I_n ⋅ I_o ∧ I' = I_n' ⋅ I_o⌝
          ∗ own γ (● I' ⋅ ◯ I_n').
  Proof.
    unfold flowint_update_P.
    case_eq (view_auth_proj x); last first.
    - intros Hx. iIntros "(% & ?)". iExFalso. done.
    - intros [q a] Hx.
      iIntros "[HI' Hown]". iDestruct "HI'" as %HI'.
      destruct HI' as [I' HI'].
      destruct HI' as [Hagree [Hq [HIn [Hcontxl HIo]]]].
      iExists I'.
      iSplit. by iPureIntro.
      iSplit. by iPureIntro. destruct x.
      simpl in Hx. simpl in HIn.
      rewrite Hx. rewrite <-HIn.
      rewrite Hq Hagree.
      assert (● I' ⋅ ◯ I_n' = View (Some (1%Qp, to_agree I')) I_n') as H'.
      { rewrite /(● I' ⋅ ◯ I_n'). unfold cmra_op.
        simpl. unfold view_op_instance. simpl.
        assert (ε ⋅ I_n' = I_n') as H'. by rewrite left_id.
        rewrite H'. unfold op, cmra_op. by simpl. }
      by iEval (rewrite H').
  Qed.

  Lemma flowint_update_result' (γ: gname) (I I_n I_n': multiset_flowint_ur KT) x :
    ⌜flowint_update_P (_) I I_n I_n' x⌝ ∗ own γ x -∗
    ∃ I', ⌜contextualLeq (_) I I'⌝
          ∗ ⌜∃ I_o, I = I_n ⋅ I_o ∧ I' = I_n' ⋅ I_o⌝
          ∗ own γ (● I' ⋅ ◯ I_n').
  Proof.
    unfold flowint_update_P.
    case_eq (view_auth_proj x); last first.
    - intros Hx. iIntros "(% & ?)". iExFalso. done.
    - intros [q a] Hx.
      iIntros "[HI' Hown]". iDestruct "HI'" as %HI'.
      destruct HI' as [I' HI'].
      destruct HI' as [Hagree [Hq [HIn [Hcontxl HIo]]]].
      iExists I'.
      iSplit. by iPureIntro.
      iSplit. by iPureIntro. destruct x.
      simpl in Hx. simpl in HIn.
      rewrite Hx. rewrite <-HIn.
      rewrite Hq Hagree.
      assert (● I' ⋅ ◯ I_n' = View (Some (1%Qp, to_agree I')) I_n') as H'.
      { rewrite /(● I' ⋅ ◯ I_n'). unfold cmra_op.
        simpl. unfold view_op_instance. simpl.
        assert (ε ⋅ I_n' = I_n') as H'. by rewrite left_id.
        rewrite H'. unfold op, cmra_op. by simpl. }
      by iEval (rewrite H').
  Qed.

  Lemma dom_lookup (C: gmap K nat) k :
        C !! k ≠ None → k ∈ dom (gset K) C.
  Proof.
    intros Hcn. destruct (C !! k) eqn: Hcnk.
    rewrite elem_of_dom. rewrite Hcnk.
    by exists n. done.
  Qed.

  Definition map_subset (S: gset K) (C: gmap K nat) :=
              let f := λ a s', s' ∪ {[(a, C !!! a)]} in
                        set_fold f (∅: gset KT) S.

  Definition map_restriction (S: gset K) (C: gmap K T) :=
              let f := λ a m, <[a := C !!! a ]> m in
                        set_fold f (∅: gmap K T) S.

  Lemma lookup_map_restriction S (C: gmap K nat) (k: K):
              k ∈ S → map_restriction S C !! k = Some (C !!! k).
  Proof.
    set (P := λ (m: gmap K nat) (X: gset K),
                    ∀ x, x ∈ X → m !! x = Some (C !!! x)).
    apply (set_fold_ind_L P); try done.
    intros x X r Hx HP.
    unfold P in HP. unfold P.
    intros x' Hx'.
    destruct (decide (x' = x)).
    - subst x'. by rewrite lookup_insert.
    - assert (x' ∈ X) as x'_in_X. set_solver.
      rewrite lookup_insert_ne. apply HP.
      done. done.
  Qed.

  Lemma map_subset_member S C k t:
              (k, t) ∈ map_subset S C ↔ k ∈ S ∧ t = C !!! k.
  Proof.
    set (P := λ (m: gset KT) (X: gset K),
                    ∀ kx tx, (kx, tx) ∈ m ↔ kx ∈ X ∧ tx = C !!! kx).
    apply (set_fold_ind_L P); try done.
    - unfold P. intros kx tx. set_solver.
    - intros x X r Hx HP. unfold P.
      unfold P in HP. intros kx' tx'.
      split.
      + intros Hktx. rewrite elem_of_union in Hktx*; intros Hktx.
        destruct Hktx as [H' | H'].
        * apply HP in H'. destruct H' as [H' H''].
          split; try done. set_solver.
        * rewrite elem_of_singleton in H'*; intros H'.
          inversion H'. split; try done; set_solver.
      + intros [H' H'']. rewrite elem_of_union in H'*; intros H'.
        destruct H' as [H' | H'].
        rewrite elem_of_singleton in H'*; intros H'.
        rewrite H'. rewrite H''. set_solver.
        assert ((kx', tx') ∈ r) as Hkt.
        apply HP. split; try done.
        set_solver.
  Qed.

  Lemma map_restriction_dom S C :
              dom (gset K) (map_restriction S C) = S.
  Proof.
    set (P := λ (m: gmap K nat) (X: gset K), dom (gset K) m = X).
    apply (set_fold_ind_L P); try done.
    - unfold P; set_solver.
    - intros x X r Hx HP. unfold P. unfold P in HP.
      apply leibniz_equiv. rewrite dom_insert.
      rewrite HP. done.
  Qed.

  Lemma nodePred_nodeShared_eq γ_I γ_J γ_f γ_gh r n
                               γ_en γ_cn γ_qn γ_cirn
                               γ_en' γ_cn' γ_qn' γ_cirn'
                               es Tn Qn es' Tn' Qn'
                               Bn In Jn H :
        own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_qn γ_cirn]}) -∗
          frac_ghost_state γ_en γ_cn γ_qn es Tn Qn -∗
            nodeShared' γ_I γ_J γ_f γ_gh r n Tn' Qn' Bn H
                    γ_en' γ_cn' γ_qn' γ_cirn' es' In Jn -∗
              frac_ghost_state γ_en γ_cn γ_qn es Tn Qn
              ∗ nodeShared' γ_I γ_J γ_f γ_gh r n Tn Qn Bn H
                    γ_en γ_cn γ_qn γ_cirn es In Jn
              ∗ ⌜es' = es⌝ ∗ ⌜Tn' = Tn⌝  ∗ ⌜Qn' = Qn⌝.
  Proof.
    iIntros "HnP_gh HnP_frac HnS".
    iDestruct "HnS" as "(HnS_gh & HnS_frac & HnS_si & HnS_FP
                        & HnS_cl & HnS_oc & HnS_Bn & HnS_H  & HnS_star & Hφ)".
    iPoseProof (ghost_heap_sync with "[$HnP_gh] [$HnS_gh]")
                              as "(% & % & % & %)".
    subst γ_en'. subst γ_cn'. subst γ_qn'. subst γ_cirn'.
    iPoseProof (frac_eq with "[$HnP_frac] [$HnS_frac]") as "%".
    destruct H0 as [Hes [Hc Hq]].
    subst es'. subst Tn'. subst Qn'.
    iFrame. by iPureIntro.
  Qed.

  (** Lock module **)

  Lemma lockNode_spec_high N γ_te γ_he γ_s Prot γ_I γ_J γ_f γ_gh r n:
    ⊢ mcs_inv N γ_te γ_he γ_s Prot
                (Inv_LSM γ_s γ_I γ_J γ_f γ_gh r) -∗
        inFP γ_f n -∗
              <<< True >>>
                lockNode #n    @ ⊤ ∖ ↑(mcsN N)
              <<< ∃ Cn Qn, nodePred γ_gh γ_s r n Cn Qn, RET #() >>>.
  Proof.
    iIntros "#mcsInv #FP_n".
    iIntros (Φ) "AU".
    awp_apply (lockNode_spec n).
    iInv "mcsInv" as (T H) "(mcs_high & >Inv_LSM)".
    iDestruct "Inv_LSM" as (hγ I J) "(Hglob & Hstar)".
    iPoseProof (inFP_domm_glob with "[$FP_n] [$Hglob]") as "%".
    rename H0 into n_in_I.
    iEval (rewrite (big_sepS_elem_of_acc (_) (domm I) n);
           last by eauto) in "Hstar".
    iDestruct "Hstar" as "(Hn & Hstar')".
    iDestruct "Hn" as (b Cn Qn) "(HlockR & Hns)".
    iAaccIntro with "HlockR".
    { iIntros "HlockRn". iModIntro.
      iSplitR "AU".
      { iExists T, H. iNext. iFrame.
        iExists hγ, I, J. iFrame.
        iPoseProof ("Hstar'" with "[-]") as "Hstar".
        iExists b, Cn, Qn. iFrame.
        iFrame.
      }
      iFrame.
    }
    iIntros "(HlockRn & Hnp)".
    iMod "AU" as "[_ [_ Hclose]]".
    iMod ("Hclose" with "[Hnp]") as "HΦ"; try done.
    iModIntro. iSplitR "HΦ".
    iNext. iExists T, H. iFrame.
    iExists hγ, I, J. iFrame.
    iPoseProof ("Hstar'" with "[HlockRn Hns]") as "Hstar".
    iExists true, Cn, Qn. iFrame.
    iFrame. done.
  Qed.

  Lemma nodePred_lockR_true γ_gh γ_s r bn n es Cn Cn' Qn' :
    node r n es Cn -∗
      lockR bn n (nodePred γ_gh γ_s r n Cn' Qn') -∗
        ⌜bn = true⌝.
  Proof.
    iIntros "node Hl_n".
    destruct bn; try done.
    iDestruct "Hl_n" as "(Hl & HnP')".
    iDestruct "HnP'" as (? ? ? ? ? ? ?) "(n' & _)".
    iExFalso. iApply (node_sep_star r n). iFrame.
  Qed.

  Lemma lockR_true Cn' Qn' γ_gh γ_s r n Cn Qn:
    lockR true n (nodePred γ_gh γ_s r n Cn Qn) -∗
      lockR true n (nodePred γ_gh γ_s r n Cn' Qn').
  Proof.
    iIntros "(Hl & _)". iFrame.
  Qed.

  Lemma unlockNode_spec_high N γ_te γ_he γ_s Prot γ_I γ_J γ_f γ_gh r
                                                          n Cn Qn:
    ⊢ mcs_inv N γ_te γ_he γ_s Prot (Inv_LSM γ_s γ_I γ_J γ_f γ_gh r) -∗
        inFP γ_f n -∗ nodePred γ_gh γ_s r n Cn Qn -∗
              <<< True >>>
                unlockNode #n    @ ⊤ ∖ ↑(mcsN N)
              <<< True, RET #() >>>.
  Proof.
    iIntros "#mcsInv #FP_n Hnp". iIntros (Φ) "AU".
    awp_apply (unlockNode_spec n).
    iInv "mcsInv" as (T H) "(mcs_high & >Inv_LSM)".
    iDestruct "Inv_LSM" as (hγ I J) "(Hglob & Hstar)".
    iPoseProof (inFP_domm_glob with "[$FP_n] [$Hglob]") as "%".
    rename H0 into n_in_I.
    iEval (rewrite (big_sepS_elem_of_acc (_) (domm I) n);
           last by eauto) in "Hstar".
    iDestruct "Hstar" as "(Hn & Hstar')".
    iDestruct "Hn" as (b Cn' Qn') "(HlockR & Hns)".
    iAssert (lockR true n (nodePred γ_gh γ_s r n Cn Qn)
              ∗ (nodePred γ_gh γ_s r n Cn Qn))%I
      with "[HlockR Hnp]" as "HlockR".
    {
      destruct b eqn: Hb.
    - (* Case n locked *)
      iFrame "∗".
    - (* Case n unlocked: impossible *)
      iDestruct "Hnp" as (? ? ? ? ? ? ?)"(node & _)".
      iPoseProof (nodePred_lockR_true with "[$node] [$HlockR]") as "H'".
      iDestruct "H'" as %H'; inversion H'.
    }
    iAaccIntro with "HlockR".
    { iIntros "(HlockR & Hnp)". iModIntro.
      iSplitR "Hnp AU".
      iExists T, H. iNext. iFrame.
      iExists hγ, I, J. iFrame.
      iPoseProof ("Hstar'" with "[HlockR Hns]") as "Hstar".
      iExists true, Cn', Qn'. iFrame.
      iFrame. iFrame.
    }
    iIntros "HlockR".
    iMod "AU" as "[_ [_ Hclose]]".
    iMod ("Hclose" with "[]") as "HΦ"; try done.
    iModIntro. iSplitR "HΦ".
    iNext. iExists T, H. iFrame.
    iExists hγ, I, J. iFrame.
    iPoseProof ("Hstar'" with "[HlockR Hns]") as "Hstar".
    iExists false, Cn, Qn.
    iAssert (lockR false n (nodePred γ_gh γ_s r n Cn Qn)
                      ∗ nodeShared γ_I γ_J γ_f γ_gh r n Qn H)%I
      with "[Hns HlockR]" as "(HlockR & Hns)".
    {
      iDestruct "HlockR" as "(Hl & Hnp)".
      iDestruct "Hnp" as (γ_en γ_cn γ_qn γ_cirn esn Vn Tn)
                             "(node_n & #HnP_gh & HnP_frac & HnP_C & HnP_cts)".
      iDestruct "Hns" as (γ_en' γ_cn' γ_qn' γ_cirn' es' Tn' Bn' In0 Jn0) "Hns'".
      iPoseProof (nodePred_nodeShared_eq with "[$HnP_gh] [$HnP_frac] [$Hns']")
         as "(HnP_frac & Hns' & % & % & %)".
      iSplitR "Hns'".
      - iFrame. iExists γ_en, γ_cn, γ_qn, γ_cirn, esn, Vn, Tn.
        iFrame "∗#".
      - iExists γ_en, γ_cn, γ_qn, γ_cirn, esn, Tn, Bn', In0.
        iExists Jn0.
        iFrame.
    }
    iFrame. iFrame. iFrame.
  Qed.

End multicopy_lsm_util.