(* 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 Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.

Lemma BDDneg_memo_OK_1_lemma_2_1' :
 forall (cfg : BDDconfig) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 BDDneg_memo_OK_2 cfg memo ->
 BDDneg_memo_OK_2 cfg (BDDneg_memo_put memo BDDzero BDDone).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros memo H H0.  unfold BDDneg_memo_OK_2 in |- *.  intros node node' bound H1 H2.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H1.
  rewrite (MapPut_semantics ad memo BDDzero BDDone node) in H1.  elim (sumbool_of_bool (N.eqb BDDzero node)).
  intro y.  cut (BDDzero = node).  intro H3.  rewrite y in H1.  injection H1.  intros H4.
  rewrite <- H3.  rewrite <- H4.  split.  left; reflexivity.  elim bound.
  simpl in |- *.  elim H.  intros H5 H6.  elim H5; intros.  rewrite H7.  reflexivity.
  intros n H5.  simpl in |- *.  elim H.  intros H6 H7.  elim H6; intros.  simpl in H9.  rewrite H8.
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H1.
  unfold BDDneg_memo_OK_2 in H0.  apply H0.  assumption.  assumption.
Qed.

Lemma BDDneg_memo_OK_1_lemma_3_1' :
 forall (cfg : BDDconfig) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 BDDneg_memo_OK_2 cfg memo ->
 BDDneg_memo_OK_2 cfg (BDDneg_memo_put memo BDDone BDDzero).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros memo H H0.  unfold BDDneg_memo_OK_2 in |- *.  intros node node' bound H1 H2.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H1.
  rewrite (MapPut_semantics ad memo BDDone BDDzero node) in H1.  elim (sumbool_of_bool (N.eqb BDDone node)).
  intro y.  cut (BDDone = node).  intro H3.  rewrite y in H1.  injection H1.  intros H4.
  rewrite <- H3.  rewrite <- H4.  split.  right; left; reflexivity.  elim bound.
  simpl in |- *.  elim H.  intros H5 H6.  elim H5; intros.  rewrite (proj1 H8).  reflexivity.
  intros n H5.  simpl in |- *.  elim H.  intros H6 H7.  elim H6; intros.  rewrite (proj1 H9).
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H1.  unfold BDDneg_memo_OK_2 in H0.
  apply H0.  assumption.  assumption.
Qed.

Lemma BDDneg_memo_OK_1_lemma_1_2' :
 forall (cfg : BDDconfig) (x : BDDvar) (l r node : ad)
   (n m : nat) (memo : BDDneg_memo),
 BDDconfig_OK cfg ->
 MapGet _ (fst cfg) node = Some (x, (l, r)) ->
 nat_of_N (var cfg node) < n ->
 n = S m ->
 BDDneg_memo_OK_2 (fst (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) memo ->
 BDDneg_memo_OK_2 (fst (BDDneg_2 cfg node n))
   (BDDneg_memo_put memo node (snd (BDDneg_2 cfg node n))).
Proof.
  intro cfg.  elim cfg; clear cfg; intros bs y; elim y; clear y; intros share counter.
  intros x l r node n m memo H H0 H1.  intro H3.  intros H2.  unfold BDDneg_memo_OK_2 in |- *.
  intros node0 node' bound H4 H5.  unfold BDDneg_memo_put, BDDneg_memo_lookup in H4.  rewrite
   (MapPut_semantics ad memo node
      (snd (BDDneg_2 (bs, (share, counter)) node n)) node0)
    in H4.
  elim (sumbool_of_bool (N.eqb node node0)).  intro y.  rewrite y in H4.  injection H4; intros.
  cut (node = node0).  intro H7.  rewrite <- H7.  rewrite <- H7 in H5.  split.
  apply nodes_preserved_2 with (cfg := (bs, (share, counter))).  right; right.  unfold in_dom in |- *.
  rewrite H0.  reflexivity.  unfold nodes_preserved in |- *.  cut (config_node_OK (bs, (share, counter)) node).
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H8 H9.  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H9 H8))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  apply BDDneg_memo_OK_1_lemma_1_1_1.  cut (config_node_OK (bs, (share, counter)) node).
  intro H8.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H9.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9)).
  intro H9.  assumption.  right.  right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  apply nodes_preserved_2 with (cfg := (bs, (share, counter))).  right; right.  unfold in_dom in |- *.
  rewrite H0.  reflexivity.  unfold nodes_preserved in |- *.  cut (config_node_OK (bs, (share, counter)) node).
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H8 H9.  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H9 H8))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  rewrite <- H6.  cut (config_node_OK (bs, (share, counter)) node).  intro H8.
  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intros H9.  exact
   (proj1
      (proj2
         (proj2
            (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))))).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0; reflexivity.
  assumption.  rewrite <- H6.  cut (config_node_OK (bs, (share, counter)) node).
  intro H8.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H9.  apply
   bool_fun_eq_trans
    with (bf2 := bool_fun_neg (bool_fun_of_BDD (bs, (share, counter)) node)).
  exact
   (proj2
      (proj2
         (proj2
            (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))))).
  apply bool_fun_eq_neg_1.  apply bool_fun_eq_symm.  apply bool_fun_preservation.
  assumption.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9)).
  exact
   (proj1 (proj2 (BDDneg_2_lemma n (bs, (share, counter)) node H H8 H9))).
  assumption.  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.
  reflexivity.  apply Neqb_complete.  assumption.  intro y.  rewrite y in H4.
  unfold BDDneg_memo_OK_2 in H2.  split.  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  apply nodes_preserved_1 with (n := n) (x := x).
  assumption.  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_1_lemma_1_1_1.
  cut (config_node_OK (bs, (share, counter)) node).  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro H7.  assumption.  right.  right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  apply nodes_preserved_1 with (n := n) (x := x).  assumption.
  assumption.  assumption.  assumption.  cut
   (config_node_OK
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node').
  intro H6.  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  intro H7.  apply
   nodes_preserved_2
    with
      (cfg := fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)).
  assumption.  assumption.  apply nodes_preserved_1 with (x := x).  assumption.
  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_lemma_1_4' with (memo := memo) (node := node0).
  apply BDDneg_2_config_OK_lemma_2 with (n := n) (x := x) (node := node).  assumption.  assumption.
  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_of_BDD
                (fst
                   (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
                node').
  apply bool_fun_preservation.  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).
  assumption.  assumption.  assumption.  assumption.  cut (config_node_OK (bs, (share, counter)) node).
  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  unfold nodes_preserved in |- *.  intro H6.  assumption.  apply nodes_preserved_1 with (x := x).
  assumption.  assumption.  assumption.  assumption.  apply BDDneg_memo_OK_lemma_1_4' with (memo := memo) (node := node0).
  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).  assumption.  assumption.
  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_neg
                (bool_fun_of_BDD
                   (fst
                      (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                         m)) node0)).
  apply BDDneg_memo_OK_bool_fun_1' with (memo := memo).  apply BDDneg_2_config_OK_lemma_2 with (node := node) (x := x) (n := n).
  assumption.  assumption.  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.  assumption.  apply bool_fun_eq_neg_1.  apply bool_fun_eq_symm.
  apply bool_fun_preservation.  apply BDDneg_2_config_OK_lemma_2 with (n := n) (x := x) (node := node).
  assumption.  assumption.  assumption.  assumption.  cut (config_node_OK (bs, (share, counter)) node).
  intro H6.  cut
   (is_internal_node (bs, (share, counter)) node ->
    nat_of_N (var (bs, (share, counter)) node) < n).
  intro H7.  exact (proj1 (BDDneg_2_lemma n (bs, (share, counter)) node H H6 H7)).
  intro; assumption.  right; right.  unfold in_dom in |- *.  rewrite H0.  reflexivity.
  cut
   (nodes_preserved
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
      (fst (BDDneg_2 (bs, (share, counter)) node n))).
  unfold nodes_preserved in |- *.  intro H6.  assumption.  apply nodes_preserved_1 with (x := x).
  assumption.  assumption.  assumption.  assumption.  cut
   (is_internal_node
      (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m)) node0 ->
    nat_of_N
      (var (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
         node0) <
    S
      (nat_of_N
         (var
            (fst (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r m))
            node0))).
  intro H6.  exact
   (proj1
      (H2 node0 node'
         (S
            (nat_of_N
               (var
                  (fst
                     (BDDneg_2 (fst (BDDneg_2 (bs, (share, counter)) l m)) r
                        m)) node0))) H4 H6)).
  intro H6.  unfold lt in |- *.  apply le_n.
Qed.

Lemma BDDneg_1_lemma' :
 forall (bound : nat) (arg : BDDconfig * ad * BDDneg_memo),
 BDDconfig_OK (fst (fst arg)) ->
 config_node_OK (fst (fst arg)) (snd (fst arg)) ->
 BDDneg_memo_OK_2 (fst (fst arg)) (snd arg) ->
 (is_internal_node (fst (fst arg)) (snd (fst arg)) ->
  nat_of_N (var (fst (fst arg)) (snd (fst arg))) < bound) ->
 fst (BDDneg_1 arg bound) = BDDneg_2 (fst (fst arg)) (snd (fst arg)) bound /\
 BDDneg_memo_OK_2 (fst (fst (BDDneg_1 arg bound))) (snd (BDDneg_1 arg bound)).
Proof.
  intro bound.  apply
   lt_wf_ind
    with
      (P := fun bound : nat =>
            forall arg : BDDconfig * ad * BDDneg_memo,
            BDDconfig_OK (fst (fst arg)) ->
            config_node_OK (fst (fst arg)) (snd (fst arg)) ->
            BDDneg_memo_OK_2 (fst (fst arg)) (snd arg) ->
            (is_internal_node (fst (fst arg)) (snd (fst arg)) ->
             nat_of_N (var (fst (fst arg)) (snd (fst arg))) < bound) ->
            fst (BDDneg_1 arg bound) =
            BDDneg_2 (fst (fst arg)) (snd (fst arg)) bound /\
            BDDneg_memo_OK_2 (fst (fst (BDDneg_1 arg bound)))
              (snd (BDDneg_1 arg bound))).
  intros n H arg.  elim arg; clear arg; intro y.  elim y; clear y.  intros cfg node memo.
  intros H0 H1 H2 H3.  elim
   (option_sum _
      (BDDneg_memo_lookup (snd (cfg, node, memo))
         (snd (fst (cfg, node, memo))))).
  intro y.  elim y; clear y; intros node' H4.  rewrite (BDDneg_1_lemma_1 (cfg, node, memo) node' n H4).
  simpl in |- *.  split.  simpl in H2.  unfold BDDneg_memo_OK_2 in H2.  rewrite (proj2 (H2 node node' n H4 H3)).
  reflexivity.  assumption.  intro y.  elim
   (option_sum _
      (MapGet _ (fst (fst (fst (cfg, node, memo))))
         (snd (fst (cfg, node, memo))))).
  intro y0.  elim y0; clear y0.  intro x.  elim x; clear x.  intros x y0.  elim y0; clear y0; intros l r H4.
  elim (nat_sum n).  intros y0.  elim y0; clear y0.  intros m H5.  rewrite (BDDneg_1_lemma_4 (cfg, node, memo) x l r n m H5 y H4).

  simpl in |- *.  cut
   (fst (BDDneg_1 (cfg, l, memo) m) =
    BDDneg_2 (fst (fst (cfg, l, memo))) (snd (fst (cfg, l, memo))) m /\
    BDDneg_memo_OK_2 (fst (fst (BDDneg_1 (cfg, l, memo) m)))
      (snd (BDDneg_1 (cfg, l, memo) m))).
  intro H6.  cut
   (fst
      (BDDneg_1
         (fst
            (fst
               (BDDneg_1
                  (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m)),
         r,
         snd
           (BDDneg_1 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
              m)) m) =
    BDDneg_2
      (fst
         (fst
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))))
      (snd
         (fst
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))))
      m /\
    BDDneg_memo_OK_2
      (fst
         (fst
            (BDDneg_1
               (fst
                  (fst
                     (BDDneg_1
                        (fst (fst (cfg, node, memo)), l,
                        snd (cfg, node, memo)) m)), r,
               snd
                 (BDDneg_1
                    (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))
               m)))
      (snd
         (BDDneg_1
            (fst
               (fst
                  (BDDneg_1
                     (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo))
                     m)), r,
            snd
              (BDDneg_1
                 (fst (fst (cfg, node, memo)), l, snd (cfg, node, memo)) m))
            m))).  intro H7.  simpl in H6, H7.
  rewrite (proj1 H7).  rewrite (proj1 H6).  cut
   (BDDmake (fst (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) x
      (snd (BDDneg_2 cfg l m)) (snd (BDDneg_2 (fst (BDDneg_2 cfg l m)) r m)) =
    BDDneg_2 cfg node n).

  intro H8.  split.  assumption.  rewrite (proj1 H6) in H7.
  elim H7; intros. rewrite H9 in H7. clear H9 H10. (* instead of Rewrite (proj1 ? ? H7) in H7. which does not work in 6.3. *)
  rewrite H8.  apply BDDneg_memo_OK_1_lemma_1_2' with (x := x) (l := l) (r := r) (m := m).  assumption.
  assumption.  apply H3.  split with x; split with l; split with r; assumption.
  assumption.  exact (proj2 H7).  rewrite H5.  simpl in |- *.  simpl in H4.  rewrite H4.
  reflexivity.  apply H.  rewrite H5.  unfold lt in |- *.  apply le_n.  simpl in |- *.  rewrite (proj1 H6).
  simpl in |- *.  cut (config_node_OK cfg l).  intro.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intros H8.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H7 H8)).  intro H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  cut (l = low cfg node).  intro H9.  rewrite H9.  apply BDDcompare_lt.  apply BDDvar_ordered_low.

  assumption.  split with x; split with l; split with r.  assumption.  rewrite <- H9; assumption.
  unfold low in |- *.  simpl in H4.  rewrite H4.  reflexivity.  rewrite <- H5.  apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node); intros.
  rewrite H7.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  simpl in |- *.  rewrite (proj1 H6).
  simpl in |- *.  cut (config_node_OK cfg l).  intro H7.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H8.  cut (config_node_OK cfg r).  intro H9.  elim H9; intro.  rewrite H10.
  left; reflexivity.  elim H10; intro.  rewrite H11; right; left; reflexivity.
  right; right.  unfold in_dom in |- *.  cut (is_internal_node cfg r).  intro H12.  inversion H12.
  inversion H13.  inversion H14.  simpl in H0.  simpl in |- *.  cut
   (MapGet (BDDvar * (ad * ad)) (fst (fst (BDDneg_2 cfg l m))) r =
    Some (x0, (x1, x2))).
  intro H16.  rewrite H16.  reflexivity.  exact (proj1 (proj2 (BDDneg_2_lemma m cfg l H0 H7 H8)) x0 x1 x2 r H15).
  apply in_dom_is_internal.  assumption.  cut (r = high cfg node).  intro H9.  rewrite H9.
  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *.  simpl in H4; rewrite H4; reflexivity.  intro H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  apply BDDcompare_lt.  cut (l = low cfg node).  intro; rewrite H9.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H9; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node).
  intro H7.  rewrite H7.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  simpl in |- *.  exact (proj2 H6).

  simpl in |- *.  rewrite (proj1 H6).  simpl in |- *.  intro H7.  cut (var (fst (BDDneg_2 cfg l m)) r = var cfg r).
  intro H8.  rewrite H8.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  apply BDDcompare_lt.
  cut (r = high cfg node).  intro H9.  rewrite H9.  apply BDDvar_ordered_high.  assumption.
  split with x; split with l; split with r; assumption.  cut (config_node_OK cfg (high cfg node)).
  intro H10.  elim H10; intro.  inversion H7.  inversion H12.  inversion H13.
  rewrite H9 in H14; rewrite H11 in H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).
  intro H15.  rewrite (config_OK_zero (fst (BDDneg_2 cfg l m)) H15) in H14.  discriminate H14.
  cut (config_node_OK cfg l).  intro H15.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H16.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H15 H16)).  intro H16.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  cut (l = low cfg node).  intro H17.  rewrite H17.  apply BDDcompare_lt.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H17; assumption.
  unfold low in |- *; simpl in H4; rewrite H4.  reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node).
  intro H15.  rewrite H15.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  elim H11; intro.  rewrite H9 in H7.
  rewrite H12 in H7.  inversion H7.  inversion H13.  inversion H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).
  intro H16.  rewrite (config_OK_one (fst (BDDneg_2 cfg l m)) H16) in H15.  discriminate H15.
  cut (config_node_OK cfg l).  intro H16.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).

  intros H17.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H16 H17)).  intro H17.
  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  cut (l = low cfg node).
  intro H18.  rewrite H18.  apply BDDcompare_lt.  apply BDDvar_ordered_low.  assumption.
  split with x; split with l; split with r.  assumption.  rewrite <- H18; assumption.
  unfold low in |- *.  simpl in H4.  rewrite H4.  reflexivity.  rewrite <- H5.  apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  cut (l = low cfg node); intros.
  rewrite H16.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  apply in_dom_is_internal.
  assumption.  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *.  simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  inversion H7.
  inversion H8.  inversion H9.  unfold var in |- *.  rewrite H10.  cut (l = low cfg node).
  cut (r = high cfg node).  intros H11 H12.  cut (config_node_OK cfg l).  cut (config_node_OK cfg r).
  intros H13 H14.  cut (BDDconfig_OK (fst (BDDneg_2 cfg l m))).  intro H15.  elim H13; intro.

  rewrite H16 in H10.  rewrite (config_OK_zero (fst (BDDneg_2 cfg l m)) H15) in H10; discriminate.
  elim H16; intro.  rewrite H17 in H10.  rewrite (config_OK_one (fst (BDDneg_2 cfg l m)) H15) in H10; discriminate.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (fst cfg) r)).  intro y0.  elim y0; intro x3.
  elim x3; intro y1; intro y2.  elim y2; intros y3 y4 y5.  rewrite y5.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H18.  cut
   (MapGet (BDDvar * (ad * ad)) (fst (fst (BDDneg_2 cfg l m))) r =
    Some (y1, (y3, y4))).
  intro H19.  rewrite H19 in H10.  injection H10.  intros H20 H21 H22.  rewrite H22; reflexivity.
  exact (proj1 (proj2 (BDDneg_2_lemma m cfg l H0 H14 H18)) y1 y3 y4 r y5).
  intro H18.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).  apply BDDcompare_lt.
  rewrite H12.  apply BDDvar_ordered_low.  assumption.  split with x; split with l; split with r; assumption.
  rewrite <- H12.  assumption.  rewrite <- H5.  apply H3.  simpl in |- *.  split with x; split with l; split with r; assumption.
  intro y0.  unfold in_dom in H17.  rewrite y0 in H17.  discriminate.  cut (is_internal_node cfg l -> nat_of_N (var cfg l) < m).
  intro H15.  exact (proj1 (BDDneg_2_lemma m cfg l H0 H14 H15)).  intro H15.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).

  apply BDDcompare_lt.  rewrite H12.  apply BDDvar_ordered_low.  assumption.
 split with x; split with l; split with r; assumption.  rewrite <- H12; assumption.
  rewrite <- H5; apply H3.  simpl in |- *.  split with x; split with l; split with r; assumption.
  rewrite H11.  apply high_OK.  assumption.  split with x; split with l; split with r; assumption.
  rewrite H12.  apply low_OK.  assumption.  split with x; split with l; split with r; assumption.
  unfold high in |- *; simpl in H4; rewrite H4; reflexivity.  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.
  apply H.  rewrite H5.  unfold lt in |- *.  apply le_n.  simpl in |- *.  assumption.  simpl in |- *.
  cut (l = low cfg node).  intro; rewrite H6.  apply low_OK.  assumption.
  split with x; split with l; split with r; assumption.  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.
  simpl in |- *.  assumption.  simpl in |- *.  intro H6.  apply lt_trans_1 with (y := nat_of_N (var cfg node)).
  apply BDDcompare_lt.  cut (l = low cfg node).  intro H7.  rewrite H7.  apply BDDvar_ordered_low.
  assumption.  split with x; split with l; split with r; assumption.  rewrite <- H7; assumption.
  unfold low in |- *; simpl in H4; rewrite H4; reflexivity.  rewrite <- H5; apply H3.
  simpl in |- *.  split with x; split with l; split with r; assumption.  intro y0.  rewrite y0.
  rewrite (BDDneg_1_lemma_3 (cfg, node, memo) x l r y H4).  simpl in |- *.  simpl in H4.
  rewrite H4.  split.  reflexivity.  unfold BDDneg_memo_OK_2 in |- *.  intros node0 node' bound0 H5 H6.  unfold BDDneg_memo_lookup in H5.
  rewrite (newMap_semantics ad node0) in H5.  discriminate.  simpl in |- *.  intro y0.  rewrite (BDDneg_1_lemma_2 (cfg, node, memo) n y y0).
  simpl in |- *.  unfold BDDneg_2 in |- *.  elim n; rewrite y0.  elim (N.eqb node BDDzero).

  simpl in |- *.  split.  reflexivity.  apply BDDneg_memo_OK_1_lemma_2_1'.  assumption.
  assumption.  simpl in |- *.  split.  reflexivity.  apply BDDneg_memo_OK_1_lemma_3_1'.
  assumption. assumption.
  fold BDDneg_2 in |- *.  intro n0.  intro H4.  elim (N.eqb node BDDzero).  simpl in |- *.  split.
  reflexivity.  apply BDDneg_memo_OK_1_lemma_2_1'.  assumption.  assumption.
  simpl in |- *.  split.
  reflexivity.  apply BDDneg_memo_OK_1_lemma_3_1'.  assumption.  assumption.
Qed.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.NetworkConstruction.

Opaque set_cell.
Opaque io_types.

Lemma same_inputs_make_network':
  forall A G (s: Syntax A) (descr: Description G) k N,
    forall k', k' < k -> inputs (make_network' s descr k N) k' = inputs N k'.
Proof.
  induction s;
    repeat light || destruct_match || invert_constructor_equalities ||
           match goal with
           | H: context[make_network' ?s _ _ _] |- context[make_network' ?s ?descr ?k ?N] =>
               unshelve epose proof (H descr k N ); clear H
           | H: forall k, _ -> inputs _ _ = inputs _ _ |- _ => rewrite H in * by lia
           end;
    try lia.
Qed.

Lemma same_inputs_make_network2':
  forall A G (s: Syntax A) (descr: Description G) k N,
    forall k', k' >= k + syntax_size s -> inputs (make_network' s descr k N) k' = inputs N k'.
Proof.
  induction s;
    repeat light || destruct_match || invert_constructor_equalities ||
           match goal with
           | H: context[make_network' ?s _ _ _] |- context[make_network' ?s ?descr ?k ?N] =>
               unshelve epose proof (H descr k N ); clear H
           | H: forall k, _ -> inputs _ _ = inputs _ _ |- _ => rewrite H in * by lia
           end;
    try lia.
Qed.

Lemma cell_make_network':
  forall A (s: Syntax A) G (descr: Description G) k N,
    cells (make_network' s descr k N) k = make_cell_with_state s descr None.
Proof.
  destruct s;
    repeat light || destruct_match || invert_constructor_equalities.
Qed.

Lemma cell_make_network:
  forall A (s : Syntax A) G (descr : Description G),
    cells (make_network s descr) (sum_sizes vars) = make_cell_with_state s descr None.
Proof.
  unfold make_network;
    repeat light || rewrite cell_make_network'.
Qed.

Lemma same_cells_make_network':
  forall A (s: Syntax A) G (descr: Description G) k N,
    forall k', k' < k -> cells (make_network' s descr k N) k' = cells N k'.
Proof.
  induction s;
    repeat light || destruct_match || invert_constructor_equalities ||
           match goal with
           | H: context[make_network' ?s _ _ _] |- context[make_network' ?s ?descr ?k ?N] =>
               unshelve epose proof (H _ descr k N); clear H
           | H: forall k, _ -> cells _ _ = cells _ _ |- _ => rewrite H in * by lia
           end;
    try lia.
Qed.

Lemma same_cells_make_network2':
  forall A (s: Syntax A) G (descr: Description G) k N,
    forall k', k' >= k + syntax_size s -> cells (make_network' s descr k N) k' = cells N k'.
Proof.
  induction s;
    repeat light || destruct_match || invert_constructor_equalities ||
           match goal with
           | H: context[make_network' ?s _ _ _] |- context[make_network' ?s ?descr ?k ?N] =>
               unshelve epose proof (H _ descr k N); clear H
           | H: forall k, _ -> cells _ _ = cells _ _ |- _ => rewrite H in * by lia
           end;
    try lia.
Qed.


(* 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 Export DistributedReferenceCounting.machine1.invariant0.
Require Export DistributedReferenceCounting.machine1.invariant1.
Require Export DistributedReferenceCounting.machine1.invariant2.
Require Export DistributedReferenceCounting.machine1.invariant3.

Unset Standard Proposition Elimination Names.

(* Where send_table on the owner is defined in terms of the other components *)

Section INVARIANT4.

Definition new_inc_count (m : Message) :=
  match m with
  | inc_dec s => 1%Z
  | _ => 0%Z
  end.

(* Below five remarks aux1, aux2, aux3, aux4, aux5 ... followed by
  the real meat the invariant 4. *)

Remark aux1 :
 forall c : Config,
 legal c ->
 st c owner =
 (sigma_receive_table (rt c) + sigma_weight (bm c) -
  sigma_table_but_owner Z (fun (_ : Site) (x : Z) => x) (st c))%Z.
Proof.
  intros.
  unfold sigma_send_table in |- *.
  generalize (invariant1 c H).
  unfold sigma_send_table in |- *.
  rewrite sigma_sigma_but_owner.
  generalize (sigma_table_but_owner Z (fun (_ : Site) (x : Z) => x) (st c)).
  intros.
  omega.
Qed.

Remark aux2 :
 forall c : Config,
 legal c ->
 sigma_table_but_owner Z (fun (_ : Site) (x : Z) => x) (st c) =
 sigma_but Site owner eq_site_dec LS (fun s : Site => sigma_rooted s (bm c)).
Proof.
  intros.
  unfold sigma_table_but_owner in |- *.
  apply sigma_but_simpl.
  intros.
  rewrite (invariant2 c s).
  auto.
  auto.
  auto.
Qed.

Remark aux3 :
 forall (s1 s2 : Site) (q : queue Message),
 (cardinal q -
  sigma_but Site owner eq_site_dec LS (fun s : Site => rooted s s1 s2 q))%Z =
 reduce Message
   (fun a : Message =>
    (cardinal_count a -
     sigma_but Site owner eq_site_dec LS
       (fun s : Site => rooted_fun s s1 s2 a))%Z) q.
Proof.
  intros.
  unfold rooted in |- *.
  unfold cardinal in |- *.
  rewrite permute_sigma_but_reduce.
  rewrite <- disjoint_reduce3.
  unfold fun_minus in |- *.
  auto.
Qed.

Remark aux4 :
 forall t : Site -> Site -> queue Message,
 sigma2_table Site LS LS (queue Message)
   (fun (s1 s2 : Site) (q : queue Message) =>
    (cardinal q -
     sigma_but Site owner eq_site_dec LS (fun s : Site => rooted s s1 s2 q))%Z)
   t =
 sigma2_table Site LS LS (queue Message)
   (fun (s1 s2 : Site) (q : queue Message) =>
    reduce Message
      (fun a : Message =>
       (cardinal_count a -
        sigma_but Site owner eq_site_dec LS
          (fun s : Site => rooted_fun s s1 s2 a))%Z) q) t.
Proof.
  intros.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intros.
  apply sigma_table_simpl2.
  intros.
  apply aux3.
Qed.

Remark aux5 :
 forall c : Config,
 legal c ->
 sigma2_table Site LS LS (queue Message)
   (fun (s1 s2 : Site) (q : queue Message) =>
    reduce Message
      (fun a : Message =>
       (cardinal_count a -
        sigma_but Site owner eq_site_dec LS
          (fun s : Site => rooted_fun s s1 s2 a))%Z) q)
   (bm c) =
 (sigma2_table Site LS LS (queue Message)
    (fun (s1 s2 : Site) (q : queue Message) =>
     if eq_site_dec s2 owner
     then reduce Message dec_count q
     else 0) (bm c) +
  sigma2_table Site LS LS (queue Message)
    (fun (s1 s2 : Site) (q : queue Message) =>
     if eq_site_dec s1 owner
     then reduce Message copy_count q
     else 0) (bm c) -
  sigma2_table Site LS LS (queue Message)
    (fun (s1 s2 : Site) (q : queue Message) => reduce Message new_inc_count q)
    (bm c))%Z.

Proof.
  intros.
  rewrite <- sigma2_disjoint.
  rewrite <- sigma2_disjoint2.
  apply sigma2_table_simpl_partial.
  unfold fun_minus_site2 in |- *.
  unfold fun_minus_site in |- *.
  unfold fun_sum_site2 in |- *.
  unfold fun_sum_site in |- *.
  intros.
  generalize (not_owner_inc4 c s1 s2 H).
  generalize (inc_dec_owner4 c s1 s2 H).
  generalize (inc_dec_owner2 c s1 s2 H).
  generalize (empty_queue2 c H s1 s2 owner).
  rewrite H0.
  clear H0.
  elim d.
  intros; simpl in |- *.
  case (eq_site_dec s2 owner).
  case (eq_site_dec s1 owner).
  intros; omega.

  intros; omega.

  case (eq_site_dec s1 owner).
  intros; omega.

  intros; omega.

  intros.
  simpl in |- *.
  rewrite H0.
  case (eq_site_dec s2 owner).
  intro.
  case (eq_site_dec s1 owner).
  intro.
  generalize (H1 e0 e).
  intro.
  discriminate.

  intro.
  rewrite e.
  unfold cardinal_count in |- *.
  unfold fun_sum in |- *.
  generalize (H4 d0).
  elim d0.
  intros.
  rewrite sigma_rooted_fun3.
  simpl in |- *.
  omega.

  intros.
  rewrite sigma_rooted_fun5.
  simpl in |- *.
  omega.

  apply finite_site.

  apply H5.
  auto.

  simpl in |- *.
  left; auto.

  intros.
  rewrite sigma_rooted_fun7.
  simpl in |- *.
  omega.

  apply finite_site.

  auto.

  intros.
  case (eq_site_dec s1 owner).
  intro.
  rewrite e.
  simpl in |- *.
  replace
   (cardinal_count d0 -
    sigma_but Site owner eq_site_dec LS
      (fun s : Site => rooted_fun s owner s2 d0))%Z with
   (copy_count d0 - new_inc_count d0)%Z.
  omega.

  unfold cardinal_count in |- *.
  unfold fun_sum in |- *.
  generalize H3.
  elim d0.
  intros.
  rewrite sigma_rooted_fun9.
  simpl in |- *.
  auto.

  apply finite_site.

  auto.

  intros.
  generalize (H5 e s).
  simpl in |- *.
  intro.
  elim H6.
  left; auto.

  rewrite sigma_rooted_fun10.
  simpl in |- *.
  auto.

  intro.
  replace
   (cardinal_count d0 -
    sigma_but Site owner eq_site_dec LS
      (fun s : Site => rooted_fun s s1 s2 d0))%Z with
   (- new_inc_count d0)%Z.
  omega.

  simpl in |- *.
  generalize (H2 n0 n).
  elim d0.
  intros.
  rewrite sigma_rooted_fun12.
  simpl in |- *.
  auto.

  auto.

  auto.

  apply finite_site.

  intros.
  generalize (H5 s).
  simpl in |- *.
  intro.
  elim H6.
  left; auto.

  intros.
  rewrite sigma_rooted_fun14.
  simpl in |- *.
  auto.

  auto.

  auto.

  apply finite_site.

  intros.
  generalize (H1 H5 H6).
  intro; discriminate.

  intros.
  generalize (H2 H5 H6 s0).
  simpl in |- *.
  intuition.

  intros.
  generalize (H3 H5 s0).
  simpl in |- *.
  intuition.

  intros.
  generalize (H4 m s0 H5).
  simpl in |- *.
  intro.
  apply H7.
  right; auto.
Qed.

Lemma simpl_dec_sum :
 forall c : Config,
 legal c ->
 sigma2_table Site LS LS (queue Message)
   (fun (s1 s2 : Site) (q : queue Message) =>
    if eq_site_dec s2 owner
    then reduce Message dec_count q
    else 0%Z) (bm c) =
 sigma_table Site LS Z (Z_id Site)
   (fun s1 : Site => reduce Message dec_count (bm c s1 owner)).

Proof.
  intros.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intros.
  unfold sigma_table in |- *.
  rewrite
   (sigma_sigma_but Site owner eq_site_dec
      (fun s : Site =>
       match eq_site_dec s owner with
       | left _ => reduce Message dec_count (bm c e s)
       | right _ => 0%Z
       end)).
  replace
   (sigma_but Site owner eq_site_dec LS
      (fun s : Site =>
       match eq_site_dec s owner with
       | left _ => reduce Message dec_count (bm c e s)
       | right _ => 0%Z
       end)) with 0%Z.
  case (eq_site_dec owner owner).
  intro; auto.
  intuition.
  rewrite sigma_but_null.
  auto.
  intros.
  rewrite case_ineq.
  auto.
  auto.
  apply finite_site.
Qed.

Lemma simpl_copy_sum :
 forall c : Config,
 legal c ->
 sigma2_table Site LS LS (queue Message)
   (fun (s1 _ : Site) (q : queue Message) =>
    match eq_site_dec s1 owner with
    | left _ => reduce Message copy_count q
    | right _ => 0%Z
    end) (bm c) =
 sigma_table Site LS Z (Z_id Site)
   (fun s2 : Site => reduce Message copy_count (bm c owner s2)).
Proof.
  intros.
  unfold sigma2_table in |- *.
  unfold sigma in |- *.
  unfold sigma_table in |- *.
  rewrite
   (sigma_sigma_but Site owner eq_site_dec
      (fun s : Site =>
       Z_id Site s
         (sigma Site LS
            (fun s0 : Site =>
             match eq_site_dec s owner with
             | left _ => reduce Message copy_count (bm c s s0)
             | right _ => 0%Z
             end)))).
  rewrite Z_id_reduce.
  replace
   (sigma_but Site owner eq_site_dec LS
      (fun s : Site =>
       Z_id Site s
         (sigma Site LS
            (fun s0 : Site =>
             match eq_site_dec s owner with
             | left _ => reduce Message copy_count (bm c s s0)
             | right _ => 0%Z
             end)))) with 0%Z.
  simpl in |- *.
  apply sigma_simpl.
  intros.
  rewrite case_eq.
  rewrite Z_id_reduce.
  auto.

  rewrite sigma_but_null.
  auto.

  intros.
  rewrite Z_id_reduce.
  case (eq_site_dec s owner).
  intro; elim H0; auto.

  intro.
  apply sigma_null.

  apply finite_site.
Qed.

Lemma no_inc_dec :
 forall q : queue Message,
 (forall s0 : Site, ~ In_queue Message (inc_dec s0) q) ->
 reduce Message new_inc_count q = 0%Z.
Proof.
  simple induction q.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros d q0 H.
  elim d.
  simpl in |- *.
  intro.
  rewrite H.
  auto.

  intro.
  generalize (H0 s0).
  intuition.

  simpl in |- *.
  intro.
  intro.
  generalize (H0 s).
  intro.
  elim H1; left; auto.

  simpl in |- *.
  intro.
  rewrite H.
  auto.

  intro.
  generalize (H0 s0).
  intuition.
Qed.

Lemma simpl_inc_sum :
 forall c : Config,
 legal c ->
 sigma2_table Site LS LS (queue Message)
   (fun (_ _ : Site) (q : queue Message) => reduce Message new_inc_count q)
   (bm c) =
 sigma_table Site LS Z (Z_id Site)
   (fun s1 : Site => reduce Message new_inc_count (bm c s1 owner)).

Proof.
  intros.
  unfold sigma2_table in |- *.
  generalize (inc_dec_owner2 c).
  generalize (inc_dec_owner3 c).
  generalize (bm c).
  intros.
  apply sigma_table_simpl.
  apply funct_eq.
  intros.
  unfold sigma_table in |- *.
  case (eq_site_dec e owner).
  intro.
  rewrite
   (sigma_sigma_but Site owner eq_site_dec
      (fun s : Site => reduce Message new_inc_count (b e s)))
   .
  replace
   (sigma_but Site owner eq_site_dec LS
      (fun s : Site => reduce Message new_inc_count (b e s))) with 0%Z.
  omega.

  rewrite sigma_but_null.
  auto.

  intros.
  generalize (H0 e s H H2).
  intro.
  apply no_inc_dec.
  auto.

  apply finite_site.

  intro.
  rewrite
   (sigma_sigma_but Site owner eq_site_dec
      (fun s : Site => reduce Message new_inc_count (b e s)))
   .
  replace
   (sigma_but Site owner eq_site_dec LS
      (fun s : Site => reduce Message new_inc_count (b e s))) with 0%Z.
  auto.

  rewrite sigma_but_null.
  auto.

  intros.
  generalize (H1 e s H n H2).
  intro.
  apply no_inc_dec.
  auto.

  apply finite_site.
Qed.

Remark add_reduce :
 forall x y a u w z : Z,
 (y - a)%Z = (z + w - u)%Z -> (x + y - a)%Z = (x + z + w - u)%Z.
Proof.
intros; omega.
Qed.

Lemma invariant4 :
 forall c : Config,
 legal c ->
 st c owner =
 (sigma_receive_table (rt c) +
  sigma_table Site LS Z (Z_id Site)
    (fun s1 : Site => reduce Message dec_count (bm c s1 owner)) +
  sigma_table Site LS Z (Z_id Site)
    (fun s2 : Site => reduce Message copy_count (bm c owner s2)) -
  sigma_table Site LS Z (Z_id Site)
    (fun s1 : Site => reduce Message new_inc_count (bm c s1 owner)))%Z.
Proof.
  intros.
  rewrite (aux1 c H).
  rewrite aux2.
  unfold sigma_weight in |- *.
  unfold sigma_rooted in |- *.
  rewrite sigma2_sigma_but.
  apply add_reduce.
  rewrite <- sigma2_disjoint2.
  unfold fun_minus_site2 in |- *.
  unfold fun_minus_site in |- *.
  rewrite aux4.
  rewrite aux5.
  rewrite simpl_dec_sum.
  rewrite simpl_copy_sum.
  rewrite simpl_inc_sum.
  auto.
  auto.
  auto.
  auto.
  auto.
  auto.
Qed.

End INVARIANT4.


Require Import Bool String List Arith.Peano_dec.
Require Import Lib.FMap Lib.Struct Lib.CommonTactics Lib.Concat Lib.Indexer Lib.StringEq.
Require Import Kami.Syntax Kami.Semantics Kami.SemFacts Kami.RefinementFacts.
Require Import Kami.Specialize Kami.Duplicate Kami.Notations.

Import ListNotations.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section ModuleBound.
  Variable m: Modules.
  Variable n: nat. (* Assume that all indexed names in "m" is parametrized by "n" *)

  Record NameBound :=
    { originals : list string;
      prefixes : list string
    }.

  Definition emptyNameBound := Build_NameBound nil nil.
  Definition addOriginal s nb := Build_NameBound (s :: originals nb) (prefixes nb).
  Definition addPrefix p nb := Build_NameBound (originals nb) (p :: prefixes nb).

  Definition appendNameBound (nb1 nb2: NameBound) :=
    Build_NameBound (originals nb1 ++ originals nb2)
                    (prefixes nb1 ++ prefixes nb2).

  Declare Scope namebound_scope.
  Notation "nb1 ++ nb2" := (appendNameBound nb1 nb2) : namebound_scope.
  Delimit Scope namebound_scope with nb.

  Definition intersectNameBound (nb1 nb2: NameBound) :=
    Build_NameBound (filter (fun o => string_in o (originals nb2)) (originals nb1))
                    (filter (fun p => string_in p (prefixes nb2)) (prefixes nb1)).

  Definition subtractNameBound (nb1 nb2: NameBound) :=
    Build_NameBound (filter (fun o => negb (string_in o (originals nb2))) (originals nb1))
                    (filter (fun p => negb (string_in p (prefixes nb2))) (prefixes nb1)).

  Definition unfoldNameBound (nb: NameBound) :=
    (originals nb) ++ (concat (map (fun p => duplicateElt p n) (prefixes nb))).

  Definition Abstracted (nb: NameBound) (ls: list string) :=
    EquivList (unfoldNameBound nb) ls.

  Lemma abstracted_nil: Abstracted (Build_NameBound nil nil) nil.
  Proof. compute; auto. Qed.

  Lemma abstracted_originals_refl: forall l, Abstracted (Build_NameBound l nil) l.
  Proof.
    unfold Abstracted, unfoldNameBound; simpl; intros.
    rewrite app_nil_r; apply EquivList_refl.
  Qed.

  Lemma abstracted_EquivList:
    forall nb l1 l2, Abstracted nb l1 -> EquivList l1 l2 -> Abstracted nb l2.
  Proof.
    unfold Abstracted; intros.
    eapply EquivList_trans; eauto.
  Qed.

  Lemma abstracted_app_1:
    forall a1 a2 l1 l2,
      Abstracted a1 l1 -> Abstracted a2 l2 ->
      Abstracted (a1 ++ a2)%nb (l1 ++ l2).
  Proof.
    unfold Abstracted, unfoldNameBound; intros.
    destruct a1 as [o1 p1], a2 as [o2 p2]; simpl in *.
    rewrite map_app, concat_app.
    inv H; inv H0; split.
    - subList_app_tac.
    - repeat apply SubList_app_3.
      + eapply SubList_trans; eauto; subList_app_tac.
      + eapply SubList_trans; eauto; subList_app_tac.
  Qed.

  Lemma abstracted_app_2:
    forall a l1 l2,
      Abstracted a l1 -> Abstracted a l2 ->
      Abstracted a (l1 ++ l2).
  Proof.
    unfold Abstracted, unfoldNameBound; intros.
    destruct a as [o p]; simpl in *.
    inv H; inv H0; split.
    - subList_app_tac.
    - apply SubList_app_3; auto.
  Qed.

  Lemma EquivList_filter:
    forall l1 l2 l3 l4,
      EquivList l1 l2 -> EquivList l3 l4 ->
      EquivList (filter (fun d => string_in d l3) l1)
                (filter (fun d => string_in d l4) l2).
  Proof.
    unfold EquivList, SubList; intros; dest; split; intros.
    - specializeAll e.
      apply filter_In; apply filter_In in H3; dest; split; auto.
      apply eq_sym, string_in_dec_in in H4.
      remember (string_in e l4) as ein; destruct ein; auto.
      exfalso; apply string_in_dec_not_in in Heqein; auto.
    - specializeAll e.
      apply filter_In; apply filter_In in H3; dest; split; auto.
      apply eq_sym, string_in_dec_in in H4.
      remember (string_in e l3) as ein; destruct ein; auto.
      exfalso; apply string_in_dec_not_in in Heqein; auto.
  Qed.

  Lemma EquivList_filter_neg:
    forall l1 l2 l3 l4,
      EquivList l1 l2 -> EquivList l3 l4 ->
      EquivList (filter (fun d => negb (string_in d l3)) l1)
                (filter (fun d => negb (string_in d l4)) l2).
  Proof.
    unfold EquivList, SubList; intros; dest; split; intros.
    - specializeAll e.
      apply filter_In; apply filter_In in H3; dest; split; auto.
      rewrite negb_true_iff in *.
      apply eq_sym, string_in_dec_not_in in H4.
      remember (string_in e l4) as ein; destruct ein; auto.
      exfalso; apply string_in_dec_in in Heqein; auto.
    - specializeAll e.
      apply filter_In; apply filter_In in H3; dest; split; auto.
      rewrite negb_true_iff in *.
      apply eq_sym, string_in_dec_not_in in H4.
      remember (string_in e l3) as ein; destruct ein; auto.
      exfalso; apply string_in_dec_in in Heqein; auto.
  Qed.

  Lemma filter_app:
    forall {A} (l1 l2: list A) f,
      filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
  Proof.
    induction l1; simpl; intros; [reflexivity|].
    destruct (f a); auto.
    simpl; f_equal; auto.
  Qed.

  Lemma filter_Forall_true:
    forall {A} (l: list A) f,
      Forall (fun a => f a = true) l ->
      filter f l = l.
  Proof.
    induction l; simpl; intros; [reflexivity|].
    inv H; rewrite H2, IHl; auto.
  Qed.

  Lemma filter_DisjList_app_1:
    forall l1 l2 l3,
      DisjList l1 l3 ->
      filter (fun d => string_in d (l2 ++ l3)) l1 =
      filter (fun d => string_in d l2) l1.
  Proof.
    induction l1; simpl; intros; auto.
    remember (string_in a l2) as ain; destruct ain; simpl.
    - apply string_in_dec_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + rewrite IHl1; [reflexivity|].
        eapply DisjList_cons; eauto.
      + exfalso; apply string_in_dec_not_in in Heqaain; elim Heqaain.
        apply in_or_app; auto.
    - apply string_in_dec_not_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + exfalso; apply string_in_dec_in in Heqaain.
        apply in_app_or in Heqaain; destruct Heqaain; auto.
        specialize (H a); destruct H; auto.
        elim H; left; auto.
      + apply IHl1; eapply DisjList_cons; eauto.
  Qed.

  Lemma filter_DisjList_app_2:
    forall l1 l2 l3,
      DisjList l1 l2 ->
      filter (fun d => string_in d (l2 ++ l3)) l1 =
      filter (fun d => string_in d l3) l1.
  Proof.
    induction l1; simpl; intros; auto.
    remember (string_in a l3) as ain; destruct ain; simpl.
    - apply string_in_dec_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + rewrite IHl1; [reflexivity|].
        eapply DisjList_cons; eauto.
      + exfalso; apply string_in_dec_not_in in Heqaain; elim Heqaain.
        apply in_or_app; auto.
    - apply string_in_dec_not_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + exfalso; apply string_in_dec_in in Heqaain.
        apply in_app_or in Heqaain; destruct Heqaain; auto.
        specialize (H a); destruct H; auto.
        elim H; left; auto.
      + apply IHl1; eapply DisjList_cons; eauto.
  Qed.

  Lemma filter_DisjList_app_neg_1:
    forall l1 l2 l3,
      DisjList l1 l3 ->
      filter (fun d => negb (string_in d (l2 ++ l3))) l1 =
      filter (fun d => negb (string_in d l2)) l1.
  Proof.
    induction l1; simpl; intros; auto.
    remember (string_in a l2) as ain; destruct ain; simpl.
    - apply string_in_dec_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + apply IHl1; eapply DisjList_cons; eauto.
      + exfalso; apply string_in_dec_not_in in Heqaain; elim Heqaain.
        apply in_or_app; auto.
    - apply string_in_dec_not_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + apply string_in_dec_in in Heqaain.
        exfalso; apply in_app_or in Heqaain; destruct Heqaain; auto.
        specialize (H a); destruct H; auto.
        elim H; left; auto.
      + f_equal; apply IHl1; eapply DisjList_cons; eauto.
  Qed.

  Lemma filter_DisjList_app_neg_2:
    forall l1 l2 l3,
      DisjList l1 l2 ->
      filter (fun d => negb (string_in d (l2 ++ l3))) l1 =
      filter (fun d => negb (string_in d l3)) l1.
  Proof.
    induction l1; simpl; intros; auto.
    remember (string_in a l3) as ain; destruct ain; simpl.
    - apply string_in_dec_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + apply IHl1; eapply DisjList_cons; eauto.
      + exfalso; apply string_in_dec_not_in in Heqaain; elim Heqaain.
        apply in_or_app; auto.
    - apply string_in_dec_not_in in Heqain.
      remember (string_in _ _) as aain; destruct aain; simpl.
      + apply string_in_dec_in in Heqaain.
        exfalso; apply in_app_or in Heqaain; destruct Heqaain; auto.
        specialize (H a); destruct H; auto.
        elim H; left; auto.
      + f_equal; apply IHl1; eapply DisjList_cons; eauto.
  Qed.

  Lemma duplicateElt_in_DisjList:
    forall p n l,
      ~ In p l ->
      DisjList (duplicateElt p n) (concat (map (fun t => duplicateElt t n) l)).
  Proof.
    induction l; simpl; intros; [apply DisjList_nil_2|].
    apply DisjList_comm, DisjList_app_4.
    - apply duplicateElt_DisjList; intuition.
    - apply DisjList_comm; auto.
  Qed.

  Lemma duplicateElt_in_filter:
    forall p n l,
      In p l ->
      duplicateElt p n =
      filter (fun d => string_in d (concat (map (fun p => duplicateElt p n) l)))
             (duplicateElt p n).
  Proof.
    intros.
    rewrite filter_Forall_true; [reflexivity|].
    apply Forall_forall; intros pn ?.
    destruct (string_in _ _) eqn:Hin; [reflexivity|].
    exfalso.
    apply eq_sym, string_in_dec_not_in in Hin; elim Hin; clear Hin.
    induction l; simpl; intros; [dest_in|].
    inv H.
    - apply in_or_app; left; assumption.
    - apply in_or_app; right; auto.
  Qed.

  Lemma duplicateElt_concat_DisjList:
    forall n l1 l2,
      DisjList l1 l2 ->
      DisjList (concat (map (fun t => duplicateElt t n) l1))
               (concat (map (fun t => duplicateElt t n) l2)).
  Proof.
    induction l1; simpl; intros; [apply DisjList_nil_1|].
    apply DisjList_app_4.
    - apply duplicateElt_in_DisjList.
      specialize (H a); destruct H; auto.
      elim H; left; auto.
    - apply IHl1; eapply DisjList_cons; eauto.
  Qed.

  Lemma concat_filter_comm:
    forall p1 p2 n,
      concat
        (map (fun p => duplicateElt p n)
             (filter (fun p => string_in p p2) p1)) =
      filter
        (fun d => string_in d (concat (map (fun p => duplicateElt p n) p2)))
        (concat (map (fun p => duplicateElt p n) p1)).
  Proof.
    induction p1; simpl; intros; auto.
    remember (string_in a p2) as ain; destruct ain; simpl.
    - rewrite IHp1.
      generalize (concat (map (fun p : string => duplicateElt p n0) p1)); intros.
      rewrite filter_app; f_equal.
      apply string_in_dec_in in Heqain.
      apply duplicateElt_in_filter; assumption.
    - rewrite IHp1; clear -Heqain.
      generalize (concat (map (fun p : string => duplicateElt p n0) p1)); intros.
      rewrite filter_app.
      replace (filter (fun d => string_in d (concat (map (fun p => duplicateElt p n0) p2)))
                      (duplicateElt a n0)) with (@nil string); [reflexivity|].
      apply eq_sym.
      apply string_in_dec_not_in in Heqain.
      rewrite <-app_nil_l with (l:= (concat (map (fun p : string => duplicateElt p n0) p2))).
      rewrite filter_DisjList_app_1.
      + induction (duplicateElt a n0); auto.
      + apply duplicateElt_in_DisjList; auto.
  Qed.

  Lemma concat_filter_comm_neg:
    forall p1 p2 n,
      concat
        (map (fun p => duplicateElt p n)
             (filter (fun p => negb (string_in p p2)) p1)) =
      filter
        (fun d => negb (string_in d (concat (map (fun p => duplicateElt p n) p2))))
        (concat (map (fun p => duplicateElt p n) p1)).
  Proof.
    induction p1; simpl; intros; auto.
    remember (string_in a p2) as ain; destruct ain; simpl.
    - rewrite filter_app.
      replace (filter
                (fun d => negb (string_in d (concat (map (fun p => duplicateElt p n0) p2))))
                (duplicateElt a n0)) with (nil (A:= string)).
      + rewrite app_nil_l; auto.
      + apply string_in_dec_in in Heqain; clear -Heqain.
        induction n0; simpl.
        * remember (string_in _ _) as iin; destruct iin; auto.
          exfalso; apply string_in_dec_not_in in Heqiin; elim Heqiin; clear Heqiin.
          induction p2; [inv Heqain|].
          inv Heqain; simpl; auto.
        * remember (string_in _ _) as iin; destruct iin; simpl.
          { clear -IHn0; induction (duplicateElt a n0); simpl in *; auto.
            remember (string_in a0 (concat (map (fun p => duplicateElt p n0) p2)))
              as allin; destruct allin; simpl in IHn0; [|inv IHn0].
            remember (string_in a0 (concat (map (fun p => (p) __ (S n0) :: duplicateElt p n0) p2)))
              as cllin; destruct cllin; simpl; auto.
            exfalso; apply string_in_dec_not_in in Heqcllin; elim Heqcllin.
            apply string_in_dec_in in Heqallin; clear -Heqallin.
            apply in_concat_iff in Heqallin; dest.
            apply in_map_iff in H; dest; subst.
            apply in_concat_iff; eexists; split.
            { apply in_map_iff; eexists; split; eauto. }
            { right; auto. }
          }
          { exfalso; apply string_in_dec_not_in in Heqiin; elim Heqiin; clear Heqiin.
            apply in_concat_iff; eexists; split.
            { apply in_map_iff; eexists; split; eauto. }
            { left; auto. }
          }
    - rewrite IHp1; clear -Heqain.
      generalize (concat (map (fun p : string => duplicateElt p n0) p1)); intros.
      rewrite filter_app; f_equal.
      apply string_in_dec_not_in in Heqain.
      rewrite <-app_nil_l with (l:= (concat (map (fun p : string => duplicateElt p n0) p2))).
      rewrite filter_DisjList_app_neg_1.
      + induction (duplicateElt a n0); auto.
        simpl; f_equal; auto.
      + apply duplicateElt_in_DisjList; auto.
  Qed.

  Lemma hasNoIndex_duplicateElt_DisjList:
    forall l p n,
      hasNoIndex l = true ->
      DisjList l (duplicateElt p n).
  Proof.
    induction n0; simpl; intros.
    - unfold DisjList; intros.
      destruct (in_dec string_dec e [p __ 0]); auto.
      destruct (in_dec string_dec e l); auto.
      exfalso; inv i; [|inv H0].
      pose proof (hasNoIndex_in _ H _ i0).
      clear -H0.
      Transparent withIndex.
      unfold withIndex in H0; generalize H0; apply badIndex.
      Opaque withIndex.
    - apply DisjList_comm, DisjList_string_cons; [|apply DisjList_comm; auto].
      intro Hx; pose proof (hasNoIndex_in _ H _ Hx).
      Transparent withIndex.
      unfold withIndex in H0; generalize H0; apply badIndex.
      Opaque withIndex.
  Qed.

  Lemma subtractNameBound_filter_abstracted:
    forall nb1 nb2 l1 l2,
      hasNoIndex (originals nb1) = true ->
      hasNoIndex (originals nb2) = true ->
      Abstracted nb1 l1 -> Abstracted nb2 l2 ->
      Abstracted (subtractNameBound nb1 nb2)
                 (filter (fun d => negb (string_in d l2)) l1).
  Proof.
    unfold Abstracted, unfoldNameBound; intros.
    destruct nb1 as [o1 p1], nb2 as [o2 p2]; simpl in *.
    eapply EquivList_trans; [|eapply EquivList_filter_neg; eauto].
    rewrite filter_app; apply EquivList_app.
    - rewrite filter_DisjList_app_neg_1; [apply EquivList_refl|].
      clear -H; induction p2; [apply DisjList_nil_2|].
      simpl; apply DisjList_comm, DisjList_app_4.
      + apply DisjList_comm.
        apply hasNoIndex_duplicateElt_DisjList; auto.
      + apply DisjList_comm; auto.
    - rewrite filter_DisjList_app_neg_2.
      + rewrite concat_filter_comm_neg; apply EquivList_refl.
      + clear -H0; apply DisjList_comm.
        induction p1; [apply DisjList_nil_2|].
        simpl; apply DisjList_comm, DisjList_app_4.
        * apply DisjList_comm, hasNoIndex_duplicateElt_DisjList; auto.
        * apply DisjList_comm; auto.
  Qed.

  Lemma intersectNameBound_filter_abstracted:
    forall nb1 nb2 l1 l2,
      hasNoIndex (originals nb1) = true ->
      hasNoIndex (originals nb2) = true ->
      Abstracted nb1 l1 -> Abstracted nb2 l2 ->
      Abstracted (intersectNameBound nb1 nb2)
                 (filter (fun d => string_in d l2) l1).
  Proof.
    unfold Abstracted, unfoldNameBound; intros.
    destruct nb1 as [o1 p1], nb2 as [o2 p2]; simpl in *.
    eapply EquivList_trans; [|eapply EquivList_filter; eauto].
    rewrite filter_app; apply EquivList_app.
    - rewrite filter_DisjList_app_1; [apply EquivList_refl|].
      clear -H; induction p2; [apply DisjList_nil_2|].
      simpl; apply DisjList_comm, DisjList_app_4.
      + apply DisjList_comm.
        apply hasNoIndex_duplicateElt_DisjList; auto.
      + apply DisjList_comm; auto.
    - rewrite filter_DisjList_app_2.
      + rewrite concat_filter_comm; apply EquivList_refl.
      + clear -H0; apply DisjList_comm.
        induction p1; [apply DisjList_nil_2|].
        simpl; apply DisjList_comm, DisjList_app_4.
        * apply DisjList_comm, hasNoIndex_duplicateElt_DisjList; auto.
        * apply DisjList_comm; auto.
  Qed.

  Definition RegsBound (regnb: NameBound) := Abstracted regnb (namesOf (getRegInits m)).
  Definition DmsBound (dmnb: NameBound) := Abstracted dmnb (getDefs m).
  Definition CmsBound (cmnb: NameBound) := Abstracted cmnb (getCalls m).

  Definition DisjPrefixes (ss1 ss2: list string) :=
    forall p1,
      In p1 ss1 ->
      forall p2,
        In p2 ss2 ->
        prefix p1 p2 = false /\ prefix p2 p1 = false.

  Definition DisjNameBound (nb1 nb2: NameBound) :=
    hasNoIndex (originals nb1) = true /\
    hasNoIndex (originals nb2) = true /\
    DisjList (originals nb1) (originals nb2) /\
    DisjList (prefixes nb1) (prefixes nb2).

  Fixpoint disjListStr (l1 l2: list string) :=
    match l1 with
    | nil => true
    | h1 :: t1 => if string_in h1 l2 then false else disjListStr t1 l2
    end.

  Lemma disjListStr_DisjList:
    forall l1 l2, disjListStr l1 l2 = true -> DisjList l1 l2.
  Proof.
    induction l1; simpl; intros; [apply DisjList_nil_1|].
    remember (string_in a l2) as ain; destruct ain; [inv H|].
    apply DisjList_string_cons; auto.
    apply string_in_dec_not_in in Heqain; auto.
  Qed.

  Definition disjNameBound (nb1 nb2: NameBound) :=
    (hasNoIndex (originals nb1))
      && (hasNoIndex (originals nb2))
      && (disjListStr (originals nb1) (originals nb2))
      && (disjListStr (prefixes nb1) (prefixes nb2)).

  Lemma disjNameBound_DisjNameBound:
    forall nb1 nb2, disjNameBound nb1 nb2 = true -> DisjNameBound nb1 nb2.
  Proof.
    unfold disjNameBound, DisjNameBound; intros.
    repeat (apply andb_true_iff in H; dest).
    Opaque DisjPrefixes. repeat split; auto. Transparent DisjPrefixes.
    - apply disjListStr_DisjList; auto.
    - apply disjListStr_DisjList; auto.
  Qed.

End ModuleBound.

Section Bounds.
  Declare Scope namebound_scope.
  Notation "nb1 ++ nb2" := (appendNameBound nb1 nb2) : namebound_scope.
  Delimit Scope namebound_scope with nb.

  Lemma concatMod_regsBound_1:
    forall m1 m2 n rb1 rb2,
      RegsBound m1 n rb1 ->
      RegsBound m2 n rb2 ->
      RegsBound (m1 ++ m2)%kami n (rb1 ++ rb2)%nb.
  Proof.
    unfold RegsBound; simpl; intros.
    unfold RegInitT; rewrite namesOf_app.
    apply abstracted_app_1; auto.
  Qed.

  Lemma concatMod_regsBound_2:
    forall m1 m2 n rb,
      RegsBound m1 n rb ->
      RegsBound m2 n rb ->
      RegsBound (m1 ++ m2)%kami n rb.
  Proof.
    unfold RegsBound; simpl; intros.
    unfold RegInitT; rewrite namesOf_app.
    apply abstracted_app_2; auto.
  Qed.

  Lemma concatMod_dmsBound_1:
    forall m1 m2 n db1 db2,
      DmsBound m1 n db1 ->
      DmsBound m2 n db2 ->
      DmsBound (m1 ++ m2)%kami n (db1 ++ db2)%nb.
  Proof.
    unfold DmsBound; simpl; intros.
    rewrite getDefs_app.
    apply abstracted_app_1; auto.
  Qed.

  Lemma concatMod_dmsBound_2:
    forall m1 m2 n db,
      DmsBound m1 n db ->
      DmsBound m2 n db ->
      DmsBound (m1 ++ m2)%kami n db.
  Proof.
    unfold DmsBound; simpl; intros.
    rewrite getDefs_app.
    apply abstracted_app_2; auto.
  Qed.

  Lemma concatMod_cmsBound_1:
    forall m1 m2 n cb1 cb2,
      CmsBound m1 n cb1 ->
      CmsBound m2 n cb2 ->
      CmsBound (m1 ++ m2)%kami n (cb1 ++ cb2)%nb.
  Proof.
    unfold CmsBound in *; simpl; intros.
    apply EquivList_trans with (l2:= getCalls m1 ++ getCalls m2).
    - apply abstracted_app_1; auto.
    - split; [apply getCalls_subList_1|apply getCalls_subList_2].
  Qed.

  Lemma concatMod_cmsBound_2:
    forall m1 m2 n cb,
      CmsBound m1 n cb ->
      CmsBound m2 n cb ->
      CmsBound (m1 ++ m2)%kami n cb.
  Proof.
    unfold CmsBound in *; simpl; intros.
    apply EquivList_trans with (l2:= getCalls m1 ++ getCalls m2).
    - apply abstracted_app_2; auto.
    - split; [apply getCalls_subList_1|apply getCalls_subList_2].
  Qed.

  (** normal boundaries *)

  Definition getRegsBound (m: Modules) := Build_NameBound (namesOf (getRegInits m)) nil.
  Definition getDmsBound (m: Modules) := Build_NameBound (getDefs m) nil.
  Definition getCmsBound (m: Modules) := Build_NameBound (getCalls m) nil.

  Lemma getRegsBound_bounded:
    forall m n, RegsBound m n (getRegsBound m).
  Proof. intros; apply abstracted_originals_refl. Qed.

  Lemma getDmsBound_bounded:
    forall m n, DmsBound m n (getDmsBound m).
  Proof. intros; apply abstracted_originals_refl. Qed.

  Lemma getCmsBound_bounded:
    forall m n, CmsBound m n (getCmsBound m).
  Proof. intros; apply abstracted_originals_refl. Qed.

  Lemma getRegsBound_modular:
    forall m1 m2 n,
      RegsBound m1 n (getRegsBound m1) ->
      RegsBound m2 n (getRegsBound m2) ->
      RegsBound (m1 ++ m2)%kami n (getRegsBound (m1 ++ m2)%kami).
  Proof.
    intros.
    replace (getRegsBound (m1 ++ m2)%kami) with (getRegsBound m1 ++ getRegsBound m2)%nb.
    - apply concatMod_regsBound_1; auto.
    - unfold getRegsBound, appendNameBound; simpl.
      unfold RegInitT; rewrite namesOf_app; reflexivity.
  Qed.

  Lemma getDmsBound_modular:
    forall m1 m2 n,
      DmsBound m1 n (getDmsBound m1) ->
      DmsBound m2 n (getDmsBound m2) ->
      DmsBound (m1 ++ m2)%kami n (getDmsBound (m1 ++ m2)%kami).
  Proof.
    intros.
    replace (getDmsBound (m1 ++ m2)%kami) with (getDmsBound m1 ++ getDmsBound m2)%nb.
    - apply concatMod_dmsBound_1; auto.
    - unfold getDmsBound; rewrite getDefs_app; reflexivity.
  Qed.

  Lemma getCmsBound_modular:
    forall m1 m2 n,
      CmsBound m1 n (getCmsBound m1) ->
      CmsBound m2 n (getCmsBound m2) ->
      CmsBound (m1 ++ m2)%kami n (getCmsBound (m1 ++ m2)%kami).
  Proof.
    intros; pose proof (concatMod_cmsBound_1 H H0); clear H H0.
    eapply EquivList_trans; eauto.
    unfold unfoldNameBound.
    apply EquivList_app; [|apply EquivList_refl].
    split; [apply getCalls_subList_2|apply getCalls_subList_1].
  Qed.

  (** duplicate boundaries *)

  Definition getDupRegsBound m :=
    Build_NameBound nil (namesOf (getRegInits m)).
  Definition getDupDmsBound m :=
    Build_NameBound nil (getDefs m).
  Definition getDupCmsBound m :=
    Build_NameBound nil (getCalls m).

  Lemma getDupNameBound_concat_vertical:
    forall names n,
      EquivList
        (concat (map (fun p => (p) __ (S n) :: duplicateElt p n) names))
        ((map (spf (S n)) names)
           ++ (concat (map (fun p : string => duplicateElt p n) names))).
  Proof.
    induction names; simpl; intros; [apply EquivList_nil|].
    apply EquivList_cons; auto.
    eapply EquivList_trans.
    - apply EquivList_app.
      + apply EquivList_refl.
      + apply IHnames.
    - clear; equivList_app_tac.
  Qed.

  Lemma getDupRegsBound_bounded:
    forall m n,
      (forall i, Specializable (m i)) ->
      (forall i j, getDupRegsBound (m i) = getDupRegsBound (m j)) ->
      RegsBound (duplicate m n) n (getDupRegsBound (m 0)).
  Proof.
    unfold RegsBound, Abstracted, unfoldNameBound; simpl; intros.
    induction n; simpl; intros.
    - rewrite specializeMod_regs by auto.
      generalize (namesOf (getRegInits (m 0))) as regs; clear.
      induction regs; simpl; intros; [apply EquivList_nil|].
      apply EquivList_cons; auto.
    - unfold RegInitT; rewrite namesOf_app.
      rewrite specializeMod_regs by auto.
      match goal with
      | [H: EquivList ?ilhs _ |- EquivList ?lhs (?nl ++ _) ] =>
        apply EquivList_trans with (l2:= (nl ++ ilhs))
      end.
      + specialize (H0 0 (S n)); inv H0.
        apply getDupNameBound_concat_vertical.
      + apply EquivList_app; [apply EquivList_refl|auto].
  Qed.

  Lemma getDupDmsBound_bounded:
    forall m n,
      (forall i, Specializable (m i)) ->
      (forall i j, getDupDmsBound (m i) = getDupDmsBound (m j)) ->
      DmsBound (duplicate m n) n (getDupDmsBound (m 0)).
  Proof.
    unfold DmsBound, Abstracted, unfoldNameBound; simpl; intros.
    induction n; simpl; intros.
    - rewrite specializeMod_defs by auto.
      generalize (getDefs (m 0)) as dms; clear.
      induction dms; simpl; intros; [apply EquivList_nil|].
      apply EquivList_cons; auto.
    - rewrite getDefs_app.
      rewrite specializeMod_defs by auto.
      match goal with
      | [H: EquivList ?ilhs _ |- EquivList ?lhs (?nl ++ _) ] =>
        apply EquivList_trans with (l2:= (nl ++ ilhs))
      end.
      + specialize (H0 0 (S n)); inv H0.
        apply getDupNameBound_concat_vertical.
      + apply EquivList_app; [apply EquivList_refl|auto].
  Qed.

  Lemma getDupCmsBound_bounded:
    forall m n,
      (forall i, Specializable (m i)) ->
      (forall i j, getDupCmsBound (m i) = getDupCmsBound (m j)) ->
      CmsBound (duplicate m n) n (getDupCmsBound (m 0)).
  Proof.
    unfold CmsBound, Abstracted, unfoldNameBound; simpl; intros.
    induction n; simpl; intros.
    - rewrite specializeMod_calls by auto.
      generalize (getCalls (m 0)) as cms; clear.
      induction cms; simpl; intros; [apply EquivList_nil|].
      apply EquivList_cons; auto.
    - apply EquivList_trans with
      (l2:= getCalls (specializeMod (m (S n)) (S n)) ++ getCalls (duplicate m n));
        [|split; [apply getCalls_subList_1|apply getCalls_subList_2]].
      rewrite specializeMod_calls by auto.
      match goal with
      | [H: EquivList ?ilhs _ |- EquivList ?lhs (?nl ++ _) ] =>
        apply EquivList_trans with (l2:= (nl ++ ilhs))
      end.
      + specialize (H0 0 (S n)); inv H0.
        apply getDupNameBound_concat_vertical.
      + apply EquivList_app; [apply EquivList_refl|auto].
  Qed.

End Bounds.

Section Correctness.

  Lemma disjNameBound_DisjList:
    forall ss1 ss2,
      DisjNameBound ss1 ss2 ->
      forall n l1 l2,
        Abstracted n ss1 l1 -> Abstracted n ss2 l2 ->
        DisjList l1 l2.
  Proof.
    unfold DisjNameBound, Abstracted, DisjList; intros.
    destruct (in_dec string_dec e l1); [|left; auto].
    destruct (in_dec string_dec e l2); [|right; auto].

    exfalso; dest.
    inv H0; inv H1; clear H0 H5.
    specialize (H6 _ i); specialize (H7 _ i0); clear i i0.
    unfold unfoldNameBound in H6, H7.
    apply in_app_or in H6; apply in_app_or in H7.
    destruct H6, H7.
    - destruct (H3 e); auto.
    - clear -H H0 H1 H2; apply in_concat_iff in H1; destruct H1 as [l ?]; dest.
      apply in_map_iff in H1; destruct H1 as [s ?]; dest; subst; simpl in *.
      pose proof (hasNoIndex_duplicateElt_DisjList _ s n H e) as Hd.
      destruct Hd; auto.
    - clear -H0 H1 H2.
      induction (prefixes ss1); [inv H0|].
      simpl in H0; apply in_app_or in H0; destruct H0; auto.
      pose proof (hasNoIndex_duplicateElt_DisjList _ a n H2 e) as Hd.
      destruct Hd; auto.
    - clear -H0 H1 H4.
      pose proof (duplicateElt_concat_DisjList n H4 e); destruct H; auto.
  Qed.

  Lemma regsBound_disj_regs:
    forall mb1 mb2,
      DisjNameBound mb1 mb2 ->
      forall n m1 m2,
        RegsBound m1 n mb1 -> RegsBound m2 n mb2 ->
        DisjList (namesOf (getRegInits m1)) (namesOf (getRegInits m2)).
  Proof.
    intros; eapply disjNameBound_DisjList; eauto.
  Qed.

  Lemma dmsBound_disj_dms:
    forall mb1 mb2,
      DisjNameBound mb1 mb2 ->
      forall n m1 m2,
        DmsBound m1 n mb1 -> DmsBound m2 n mb2 ->
        DisjList (getDefs m1) (getDefs m2).
  Proof.
    intros; eapply disjNameBound_DisjList; eauto.
  Qed.

  Lemma cmsBound_disj_calls:
    forall mb1 mb2,
      DisjNameBound mb1 mb2 ->
      forall n m1 m2,
        CmsBound m1 n mb1 -> CmsBound m2 n mb2 ->
        DisjList (getCalls m1) (getCalls m2).
  Proof.
    intros; eapply disjNameBound_DisjList; eauto.
  Qed.

  Lemma bound_disj_dms_calls:
    forall mb1 mb2,
      DisjNameBound mb1 mb2 ->
      forall n m1 m2,
        DmsBound m1 n mb1 -> CmsBound m2 n mb2 ->
        DisjList (getDefs m1) (getCalls m2).
  Proof.
    intros; eapply disjNameBound_DisjList; eauto.
  Qed.

  Lemma bound_disj_calls_dms:
    forall mb1 mb2,
      DisjNameBound mb1 mb2 ->
      forall n m1 m2,
        CmsBound m1 n mb1 -> DmsBound m2 n mb2 ->
        DisjList (getCalls m1) (getDefs m2).
  Proof.
    intros; eapply disjNameBound_DisjList; eauto.
  Qed.

  Lemma bound_disj_extDefs_calls:
    forall dnb1 cnb1 cnb2,
      hasNoIndex (originals dnb1) = true ->
      hasNoIndex (originals cnb1) = true ->
      DisjNameBound (subtractNameBound dnb1 cnb1) cnb2 ->
      forall n m1 m2,
        DmsBound m1 n dnb1 -> CmsBound m1 n cnb1 -> CmsBound m2 n cnb2 ->
        DisjList (getExtDefs m1) (getCalls m2).
  Proof.
    intros.
    eapply disjNameBound_DisjList; eauto.
    apply subtractNameBound_filter_abstracted; auto.
  Qed.

  Lemma bound_disj_extCalls_defs:
    forall dnb1 cnb1 dnb2,
      hasNoIndex (originals dnb1) = true ->
      hasNoIndex (originals cnb1) = true ->
      DisjNameBound (subtractNameBound cnb1 dnb1) dnb2 ->
      forall n m1 m2,
        DmsBound m1 n dnb1 -> CmsBound m1 n cnb1 -> DmsBound m2 n dnb2 ->
        DisjList (getExtCalls m1) (getDefs m2).
  Proof.
    intros.
    eapply disjNameBound_DisjList; eauto.
    apply subtractNameBound_filter_abstracted; auto.
  Qed.

  Lemma bound_disj_intCalls_calls:
    forall dnb1 cnb1 cnb2,
      hasNoIndex (originals dnb1) = true ->
      hasNoIndex (originals cnb1) = true ->
      DisjNameBound (intersectNameBound cnb1 dnb1) cnb2 ->
      forall n m1 m2,
        DmsBound m1 n dnb1 -> CmsBound m1 n cnb1 -> CmsBound m2 n cnb2 ->
        DisjList (getIntCalls m1) (getCalls m2).
  Proof.
    intros.
    eapply disjNameBound_DisjList; eauto.
    apply intersectNameBound_filter_abstracted; auto.
  Qed.

  Lemma bound_disj_calls_intCalls:
    forall cnb1 dnb2 cnb2,
      hasNoIndex (originals dnb2) = true ->
      hasNoIndex (originals cnb2) = true ->
      DisjNameBound cnb1 (intersectNameBound cnb2 dnb2) ->
      forall n m1 m2,
        CmsBound m1 n cnb1 -> DmsBound m2 n dnb2 -> CmsBound m2 n cnb2 ->
        DisjList (getCalls m1) (getIntCalls m2).
  Proof.
    intros.
    eapply disjNameBound_DisjList; eauto.
    apply intersectNameBound_filter_abstracted; auto.
  Qed.

End Correctness.

(** Tactics *)

Ltac get_regs_bound_ex m :=
  lazymatch m with
  | ConcatMod ?m1 ?m2 =>
    let nb1 := get_regs_bound_ex m1 in
    let nb2 := get_regs_bound_ex m2 in
    constr:(appendNameBound nb1 nb2)
  | duplicate ?sm _ => constr:(getDupRegsBound (sm 0))
  | makeModule _ => constr:(getRegsBound m)
  | PrimMod _ => constr:(getRegsBound m)
  | Mod _ _ _ => constr:(getRegsBound m)
  | _ => let m' := eval red in m in get_regs_bound_ex m'
  end.

Ltac get_dms_bound_ex m :=
  lazymatch m with
  | ConcatMod ?m1 ?m2 =>
    let nb1 := get_dms_bound_ex m1 in
    let nb2 := get_dms_bound_ex m2 in
    constr:(appendNameBound nb1 nb2)
  | duplicate ?sm _ => constr:(getDupDmsBound (sm 0))
  | makeModule _ => constr:(getDmsBound m)
  | PrimMod _ => constr:(getDmsBound m)
  | Mod _ _ _ => constr:(getDmsBound m)
  | _ => let m' := eval red in m in get_dms_bound_ex m'
  end.

Ltac get_cms_bound_ex m :=
  lazymatch m with
  | ConcatMod ?m1 ?m2 =>
    let nb1 := get_cms_bound_ex m1 in
    let nb2 := get_cms_bound_ex m2 in
    constr:(appendNameBound nb1 nb2)
  | duplicate ?sm _ => constr:(getDupCmsBound (sm 0))
  | makeModule _ => constr:(getCmsBound m)
  | PrimMod _ => constr:(getCmsBound m)
  | Mod _ _ _ => constr:(getCmsBound m)
  | _ => let m' := eval red in m in get_cms_bound_ex m'
  end.

Ltac red_to_regs_bound_ex rn :=
  match goal with
  | [ |- DisjList (namesOf (getRegInits ?m1))
                  (namesOf (getRegInits ?m2)) ] =>
    let mb1' := get_regs_bound_ex m1 in
    let mb2' := get_regs_bound_ex m2 in
    apply regsBound_disj_regs with (n:= rn) (mb1 := mb1') (mb2 := mb2')
  | [ |- DisjList (map _ (getRegInits ?m1))
                  (map _ (getRegInits ?m2)) ] =>
    let mb1' := get_regs_bound_ex m1 in
    let mb2' := get_regs_bound_ex m2 in
    apply regsBound_disj_regs with (n:= rn) (mb1 := mb1') (mb2 := mb2')
  end.

Ltac red_to_dms_bound_ex dn :=
  match goal with
  | [ |- DisjList (getDefs ?m1) (getDefs ?m2) ] =>
    let mb1' := get_dms_bound_ex m1 in
    let mb2' := get_dms_bound_ex m2 in
    apply dmsBound_disj_dms with (n:= dn) (mb1 := mb1') (mb2 := mb2')
  | [ |- DisjList (namesOf (getDefsBodies ?m1)) (namesOf (getDefsBodies ?m2)) ] =>
    let mb1' := get_dms_bound_ex m1 in
    let mb2' := get_dms_bound_ex m2 in
    apply dmsBound_disj_dms with (n:= dn) (mb1 := mb1') (mb2 := mb2')
  end.

Ltac red_to_cms_bound_ex cn :=
  match goal with
  | [ |- DisjList (getCalls ?m1) (getCalls ?m2) ] =>
    let mb1' := get_cms_bound_ex m1 in
    let mb2' := get_cms_bound_ex m2 in
    apply cmsBound_disj_calls with (n:= cn) (mb1 := mb1') (mb2 := mb2')
  end.

Ltac red_to_dc_bound_ex cn :=
  match goal with
  | [ |- DisjList (getDefs ?m1) (getCalls ?m2) ] =>
    let mb1' := get_dms_bound_ex m1 in
    let mb2' := get_cms_bound_ex m2 in
    apply bound_disj_dms_calls with (n:= cn) (mb1 := mb1') (mb2 := mb2')
  end.

Ltac red_to_cd_bound_ex cn :=
  match goal with
  | [ |- DisjList (getCalls ?m1) (getDefs ?m2) ] =>
    let mb1' := get_cms_bound_ex m1 in
    let mb2' := get_dms_bound_ex m2 in
    apply bound_disj_calls_dms with (n:= cn) (mb1 := mb1') (mb2 := mb2')
  end.

Ltac red_to_edc_bound_ex cn :=
  match goal with
  | [ |- DisjList (getExtDefs ?m1) (getCalls ?m2) ] =>
    let dnb1' := get_dms_bound_ex m1 in
    let cnb1' := get_cms_bound_ex m1 in
    let cnb2' := get_cms_bound_ex m2 in
    apply bound_disj_extDefs_calls with (n:= cn) (dnb1:= dnb1') (cnb1:= cnb1') (cnb2:= cnb2')
  end.

Ltac red_to_ecd_bound_ex cn :=
  match goal with
  | [ |- DisjList (getExtCalls ?m1) (getDefs ?m2) ] =>
    let dnb1' := get_dms_bound_ex m1 in
    let cnb1' := get_cms_bound_ex m1 in
    let dnb2' := get_dms_bound_ex m2 in
    apply bound_disj_extCalls_defs with (n:= cn) (dnb1:= dnb1') (cnb1:= cnb1') (dnb2:= dnb2')
  end.

Ltac red_to_icc_bound_ex cn :=
  match goal with
  | [ |- DisjList (getIntCalls ?m1) (getCalls ?m2) ] =>
    let dnb1' := get_dms_bound_ex m1 in
    let cnb1' := get_cms_bound_ex m1 in
    let cnb2' := get_cms_bound_ex m2 in
    apply bound_disj_intCalls_calls with (n:= cn) (dnb1:= dnb1') (cnb1:= cnb1') (cnb2:= cnb2')
  end.

Ltac red_to_cic_bound_ex cn :=
  match goal with
  | [ |- DisjList (getCalls ?m1) (getIntCalls ?m2) ] =>
    let cnb1' := get_cms_bound_ex m1 in
    let dnb2' := get_dms_bound_ex m2 in
    let cnb2' := get_cms_bound_ex m2 in
    apply bound_disj_calls_intCalls with (n:= cn) (cnb1:= cnb1') (dnb2:= dnb2') (cnb2:= cnb2')
  end.

Ltac regs_bound_tac_unit_ex :=
  match goal with
  | [ |- RegsBound (ConcatMod _ _) _ (appendNameBound _ _) ] =>
    apply concatMod_regsBound_1
  | [ |- RegsBound (ConcatMod _ _) _ _ ] =>
    apply getRegsBound_modular
  | [ |- RegsBound (duplicate _ _) _ _ ] =>
    apply getDupRegsBound_bounded; auto
  | [ |- RegsBound ?m _ _ ] => unfold_head m
  | _ => apply getRegsBound_bounded
  end.
Ltac regs_bound_tac_ex := repeat regs_bound_tac_unit_ex.

Ltac dms_bound_tac_unit_ex :=
  match goal with
  | [ |- DmsBound (ConcatMod _ _) _ (appendNameBound _ _) ] =>
    apply concatMod_dmsBound_1
  | [ |- DmsBound (ConcatMod _ _) _ _ ] =>
    apply getDmsBound_modular
  | [ |- DmsBound (duplicate _ _) _ _ ] =>
    apply getDupDmsBound_bounded; auto
  | [ |- DmsBound ?m _ _ ] => unfold_head m
  | _ => apply getDmsBound_bounded
  end.
Ltac dms_bound_tac_ex := repeat dms_bound_tac_unit_ex.

Ltac cms_bound_tac_unit_ex :=
  match goal with
  | [ |- CmsBound (ConcatMod _ _) _ (appendNameBound _ _) ] =>
    apply concatMod_cmsBound_1
  | [ |- CmsBound (ConcatMod _ _) _ _ ] =>
    apply getCmsBound_modular
  | [ |- CmsBound (duplicate _ _) _ _ ] =>
    apply getDupCmsBound_bounded; auto
  | [ |- CmsBound ?m _ _ ] => unfold_head m
  | _ => apply getCmsBound_bounded
  end.
Ltac cms_bound_tac_ex := repeat cms_bound_tac_unit_ex.

Ltac kdisj_regs_ex n :=
  red_to_regs_bound_ex n;
  [apply disjNameBound_DisjNameBound; reflexivity
  |regs_bound_tac_ex
  |regs_bound_tac_ex].

Ltac kdisj_dms_ex n :=
  red_to_dms_bound_ex n;
  [apply disjNameBound_DisjNameBound; reflexivity
  |dms_bound_tac_ex
  |dms_bound_tac_ex].

Ltac kdisj_cms_ex n :=
  red_to_cms_bound_ex n;
  [apply disjNameBound_DisjNameBound; reflexivity
  |cms_bound_tac_ex
  |cms_bound_tac_ex].

Ltac kdisj_dms_cms_ex n :=
  red_to_dc_bound_ex n;
  [apply disjNameBound_DisjNameBound; reflexivity
  |dms_bound_tac_ex
  |cms_bound_tac_ex].

Ltac kdisj_cms_dms_ex n :=
  red_to_cd_bound_ex n;
  [apply disjNameBound_DisjNameBound; reflexivity
  |cms_bound_tac_ex
  |dms_bound_tac_ex].

Ltac kdisj_edms_cms_ex n :=
  red_to_edc_bound_ex n;
  [reflexivity|reflexivity
   |apply disjNameBound_DisjNameBound; reflexivity
   |dms_bound_tac_ex
   |cms_bound_tac_ex
   |cms_bound_tac_ex].

Ltac kdisj_ecms_dms_ex n :=
  red_to_ecd_bound_ex n;
  [reflexivity|reflexivity
   |apply disjNameBound_DisjNameBound; reflexivity
   |dms_bound_tac_ex
   |cms_bound_tac_ex
   |dms_bound_tac_ex].

Ltac kdisj_icms_cms_ex n :=
  red_to_icc_bound_ex n;
  [reflexivity|reflexivity
   |apply disjNameBound_DisjNameBound; reflexivity
   |dms_bound_tac_ex
   |cms_bound_tac_ex
   |cms_bound_tac_ex].

Ltac kdisj_cms_icms_ex n :=
  red_to_cic_bound_ex n;
  [reflexivity|reflexivity
   |apply disjNameBound_DisjNameBound; reflexivity
   |cms_bound_tac_ex
   |dms_bound_tac_ex
   |cms_bound_tac_ex].


(*******************************************************************************)
(*  © Université de Lille, The Pip Development Team (2015-2021)                *)
(*                                                                             *)
(*  This software is x computer program whose purpose is to run x minimal,     *)
(*  hypervisor relying on proven properties such as memory isolation.          *)
(*                                                                             *)
(*  This software is governed by the CeCILL license under French law and       *)
(*  abiding by the rules of distribution of free software.  You can  use,      *)
(*  modify and/ or redistribute the software under the terms of the CeCILL     *)
(*  license as circulated by CEA, CNRS and INRIA at the following URL          *)
(*  "http://www.cecill.info".                                                  *)
(*                                                                             *)
(*  As x counterpart to the access to the source code and  rights to copy,     *)
(*  modify and redistribute granted by the license, users are provided only    *)
(*  with a limited warranty  and the software's author,  the holder of the     *)
(*  economic rights,  and the successive licensors  have only  limited         *)
(*  liability.                                                                 *)
(*                                                                             *)
(*  In this respect, the user's attention is drawn to the risks associated     *)
(*  with loading,  using,  modifying and/or developing or reproducing the      *)
(*  software by the user in light of its specific status of free software,     *)
(*  that may mean  that it is complicated to manipulate,  and  that  also      *)
(*  therefore means  that it is reserved for developers  and  experienced      *)
(*  professionals having in-depth computer knowledge. Users are therefore      *)
(*  encouraged to load and test the software's suitability as regards their    *)
(*  requirements in conditions enabling the security of their systems and/or   *)
(*  data to be ensured and,  more generally, to use and operate it in the      *)
(*  same conditions as regards security.                                       *)
(*                                                                             *)
(*  The fact that you are presently reading this means that you have had       *)
(*  knowledge of the CeCILL license and that you accept its terms.             *)
(*******************************************************************************)

(** * Summary
    This module defines operations (both pure and monadic) on pip data types *)

Require Import Pip.Model.ADT Pip.Model.Hardware Pip.Model.Lib.
Require Import List Arith Lia.

Definition idxEq (x y : index) : bool := x =? y.
Definition idxGe (x y : index) : bool := y <=? x.
Definition idxGt (x y : index) : bool := y <? x.
Definition idxLe (x y : index) : bool := x <=? y.
Definition idxLt (x y : index) : bool := x <? y.

Definition idxEqM (x y : index) := ret (idxEq x y).
Definition idxGeM (x y : index) := ret (idxGe x y).
Definition idxGtM (x y : index) := ret (idxGt x y).
Definition idxLeM (x y : index) := ret (idxLe x y).
Definition idxLtM (x y : index) := ret (idxLt x y).

Program Definition idxPredM (n : index) : LLI index :=
  let (i,P) := n in
  if gt_dec i 0
  then let ipred := i-1 in
       ret (Build_index ipred _)
  else undefined 27.
Next Obligation. lia. Qed.

Program Definition idxSuccM (n : index) : LLI index :=
  let isucc := n+1 in
  if lt_dec isucc tableSize
  then ret (Build_index isucc _)
  else undefined 28.

Definition vaddrEq (x y : vaddr) : bool := eqList x y idxEq.
Definition vaddrEqM (x y : vaddr) := ret (vaddrEq x y).

Definition pageEq (x y : page) : bool := x =? y.
Definition pageEqM (x y : page) := ret (pageEq x y).

Definition levelEq (x y : level) : bool := x =? y.
Definition levelGt (x y : level) : bool := y <? x.

Definition levelEqM (x y : level) := ret (levelEq x y).
Definition levelGtM (x y : level) := ret (levelGt x y).

Program Definition levelPredM (n : level) : LLI level :=
  if gt_dec n 0
  then let ipred := n-1 in
       ret (Build_level ipred _)
  else undefined 30.
Next Obligation.
destruct n; simpl; lia.
Qed.

Program Definition levelSuccM (n : level) : LLI level :=
  let isucc := n+1 in
  if lt_dec isucc nbLevel
  then ret (Build_level isucc _)
  else undefined 31.

Definition countEq (x y : count) : bool := x =? y.
Definition countGe (x y : count) : bool := y <=? x.

Definition countEqM (x y : count) := ret (countEq x y).
Definition countGeM (x y : count) := ret (countGe x y).

Program Definition countSuccM (n : count) : LLI count :=
  let isucc := n+1 in
  if le_dec isucc (3 * nbLevel + 1)
  then ret (Build_count isucc _)
  else undefined 34.

Program Definition countFromLevelM (x : level) : LLI count :=
  ret (Build_count (x * 3) _).
Next Obligation.
  destruct x; simpl.
  (* BEGIN SIMULATION
    unfold nbLevel in Hl.
     END SIMULATION *)
  lia.
Qed.