(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export cvterm.
Require Export substitution3.

Require Export continuity_axiom2.
Require Export continuity_type_aux.

Require Export cequiv_tacs.
Require Export subst_tacs.

Require Export continuity_per.

Require Export lift_lsubst_tacs.

Require Export list. (* why? *)

(*
Definition of_type_int {o} lib (t : @NTerm o) :=
  {z : Z & reduces_to lib t (mk_integer z)}.

Definition of_type_int_to_val {o} lib (f : @NTerm o) :=
  forall a,
    of_type_int lib a
    -> {v : NTerm
        & reduces_to lib (mk_apply f a) v
        # isvalue_like v}.

Definition of_type_int_to_val_TO_int {o} lib (F : @NTerm o) :=
  forall f,
    of_type_int_to_val lib f
    -> {z : Z & reduces_to lib (mk_apply F f) (mk_integer z)}.
*)

Definition value_like_type {o} lib (T : @CTerm o) :=
  forall t, member lib t T -> isvaluec_like t.

Definition agree_upto_b_c {o} lib (b f g : @CTerm o) :=
  forall (t : CTerm),
    member lib (absolute_value_c t) (mkc_natk b) (* take t's absolute value *)
    -> equality lib (mkc_apply f t) (mkc_apply g t) mkc_int.

Definition continuous2 {o} lib (F : @CTerm o) :=
  forall f,
    member lib f (mkc_fun mkc_int mkc_int)
    -> {b : CTerm
        & member lib b mkc_tnat
        # forall g : CTerm,
            member lib g (mkc_fun mkc_int mkc_int)
            -> agree_upto_b_c lib b f g
            -> equality lib (mkc_apply F f) (mkc_apply F g) mkc_int}.

Definition agree_upto_b_type_c {o} (b f g : @CTerm o) : CTerm :=
  mkc_isect
    (mkc_set
       mkc_int
       nvarx
       (mkcv_member
          [nvarx]
          (absolute_value_cv [nvarx] (mkc_var nvarx))
          (mkcv_natk [nvarx] (mk_cv [nvarx] b))))
    nvarx
    (mkcv_equality
       [nvarx]
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_int [nvarx])).

Definition agree_upto_b_type_cv {o} vs (b f g : @CVTerm o vs) : CVTerm vs :=
  mkcv_isect
    vs
    (mkcv_set
       vs
       (mkcv_int vs)
       nvarx
       (mkcv_member
          (nvarx :: vs)
          (absolute_value_cv (nvarx :: vs) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
          (mkcv_natk (nvarx :: vs) (mk_cv_app_l [nvarx] vs b))))
    nvarx
    (mkcv_equality
       (nvarx :: vs)
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs f) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs g) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mkcv_int (nvarx :: vs))).

Definition continuous_type_c {o} (F f : @CTerm o) :=
  mkc_product
    mkc_tnat
    nvarb
    (mkcv_isect
       [nvarb]
       (mkcv_fun [nvarb] (mkcv_int [nvarb]) (mkcv_int [nvarb]))
       nvarg
       (mkcv_ufun
          [nvarg, nvarb]
          (agree_upto_b_type_cv
             [nvarg,nvarb]
             (mk_cv_app_l [nvarg] [nvarb] (mkc_var nvarb))
             (mk_cv [nvarg,nvarb] f)
             (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg)))
          (mkcv_equality
             [nvarg,nvarb]
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv [nvarg,nvarb] f))
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg)))
             (mkcv_int [nvarg,nvarb])))).

Definition continuous_type_aux {o} vb vg vi (F f : @NTerm o) :=
  mk_product
    mk_tnat
    vb
    (mk_isect
       int2int
       vg
       (mk_ufun
          (agree_upto_b_type
             vi
             (mk_var vb)
             f
             (mk_var vg))
          (mk_equality
             (mk_apply F f)
             (mk_apply F (mk_var vg))
             mk_int))).

Definition continuous_type {o} (F f : @NTerm o) :=
  match newvars3 [F,f] with
    | (vb,vg,vi) => continuous_type_aux vb vg vi F f
  end.

Lemma lsubstc_continuous_type {o} :
  forall (F f : @NTerm o)
         (w : wf_term (continuous_type F f))
         (s : CSub)
         (c : cover_vars (continuous_type F f) s),
    {wF : wf_term F
     & {wf : wf_term f
     & {cF : cover_vars F s
     & {cf : cover_vars f s
     & alphaeqc
         (lsubstc (continuous_type F f) w s c)
         (continuous_type_c (lsubstc F wF s cF) (lsubstc f wf s cf))}}}}.
Proof.
  introv.

  assert (wf_term F # wf_term f) as wf.
  { unfold continuous_type in w.
    remember (newvars3 [F,f]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply wf_product_iff in w; repnd.
    apply wf_isect_iff in w; repnd.
    apply wf_ufun in w; repnd.
    apply wf_equality_iff in w; repnd.
    apply wf_apply_iff in w3; repnd; auto. }

  destruct wf as [wF wf].
  exists wF wf.

  assert (cover_vars F s # cover_vars f s) as cov.
  { unfold continuous_type in c.
    remember (newvars3 [F,f]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply cover_vars_product in c; repnd.
    apply cover_vars_upto_isect in c; repnd.
    apply cover_vars_upto_ufun in c; repnd.
    apply cover_vars_upto_equality in c; repnd.
    apply cover_vars_upto_apply in c3; repnd.
    allrw <- @csub_filter_app_r; allsimpl.
    apply cover_vars_upto_csub_filter_disjoint in c5;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allrw disjoint_cons_r; sp].
    apply cover_vars_upto_csub_filter_disjoint in c3;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allrw disjoint_cons_r; sp].
    sp. }

  destruct cov as [cF cf].
  exists cF cf.

  unfold alphaeqc; simpl.
  unfold csubst, lsubst.
  allrw <- @sub_free_vars_is_flat_map_free_vars_range.
  allrw @sub_free_vars_csub2sub; boolvar; tcsp;
  try (complete (destruct n; tcsp)).

  simpl.
  allrw @sub_filter_nil_r.
  allrw <- @sub_filter_app_r; simpl.
  allrw @sub_find_sub_filter; simpl; tcsp.
  repeat gen_newvar.
  fold_terms.

  allrw @lsubst_aux_sub_filter;
    try (complete (repeat get_newvar_prop; allsimpl;
                   allrw remove_nvars_nil_l; allrw app_nil_r;
                   allrw in_app_iff; allrw not_over_or; repnd;
                   allrw disjoint_cons_r; sp)).

  fold_terms.
  unfold mk_natk.
  fold (@mk_natk_aux o n1 (mk_var n)).
  allfold (@mk_tnat o).
  allfold (@int2int o).
  pose proof (newvar_not_in_free_vars (@mk_var o nvarb)) as nve; simpl in nve.
  autodimp nve hyp;[intro k; repndors; tcsp; ginv|rw nve; clear nve].
  fold (agree_upto_b_type n1 (mk_var n) (lsubst_aux f (csub2sub s)) (mk_var n0)).
  fold (agree_upto_b_type nvarx (mk_var nvarb) (lsubst_aux f (csub2sub s)) (mk_var nvarg)).
  fold (continuous_type_aux_aux n n0 n1 n5 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s))).
  unfold mk_ufun.
  gen_newvar.
  fold (continuous_type_aux_aux nvarb nvarg nvarx n6 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s))).
  clear dependent n2.
  clear dependent n3.
  clear dependent n4.

  apply alphaeq_eq.
  repeat get_newvar_prop.
  allsimpl; allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw in_app_iff; allsimpl; allrw not_over_or; repnd; GC.
  apply alphaeq_continuous_type_aux_aux; tcsp;
  try (complete (apply cover_vars_iff_closed_lsubst_aux; auto));
  try (complete (intro k; inversion k)).
Qed.

Tactic Notation "one_lift_lsubst_cont" constr(T) ident(name) tactic(tac) :=
  match T with
    | context [lsubstc (continuous_type ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      pose proof (lsubstc_continuous_type a b w s c) as name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
  end.

Ltac one_lift_lsubst_cont_concl :=
  match goal with
    | [ |- ?T ] =>
      let name := fresh "eq" in
      one_lift_lsubst_cont
        T
        name
        (first [ rewrite name
               | progress (apply alphaeqc_sym in name; rwal_c name)
               ]);
        clear name
  end.

Ltac one_lift_lsubst_cont_hyp H :=
  let T := type of H in
  let name := fresh "eq" in
  one_lift_lsubst_cont
    T name
    (first [ rewrite name in H
           | progress (rwal_h name H)
           ]); clear name.

Ltac lift_lsubsts_cont :=
  repeat (match goal with
            | [ H : context [lsubstc _ _ _ _ ] |- _ ] => one_lift_lsubst_cont_hyp H
            | [ |- context [lsubstc _ _ _ _ ] ] => one_lift_lsubst_cont_concl
          end).


(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

From Coq Require Import ssreflect ssrfun ssrbool.
Require Import Psatz.
Require Import Coq.Lists.List.
Require Import Coq.NArith.BinNat.
Import ListNotations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import SetoidList.
Require Import Coq.Logic.ProofIrrelevance.

Require Import GHC.Base.

Require Import Proofs.Prelude.

Require Import CoreFVs.
Require Import Id.
Require Import Core.
Require UniqFM.

Require Import Proofs.Base.
Require Import Proofs.Axioms.
Require Import Proofs.ContainerProofs.
Require Import Proofs.GhcTactics.
Require Import Proofs.Unique.
Require Import Proofs.Var.
Require Import Proofs.VarSetFSet.

Open Scope Z_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Lemma IntMapEq_VarSetEq : forall x y,
    x == y ->
    UniqSet.Mk_UniqSet (UniqFM.UFM x) [=] UniqSet.Mk_UniqSet (UniqFM.UFM y).
Proof.
  intros. constructor.
  - unfold In. simpl. intros.
    eapply IntMap.Eq_membership in H.
    erewrite H0 in H. symmetry. move /Eq_eq in H. assumption.
  - unfold In. simpl. intros.
    eapply IntMap.Eq_membership in H.
    erewrite H0 in H. move /Eq_eq in H. assumption.
Qed.

(* Stephanie's hack. *)
Lemma fold_is_true : forall b, b = true <-> b.
Proof. intros. unfold is_true. reflexivity. Qed.

Lemma false_is_not_true :
  forall b, b = false <-> b <> true.
Proof.
  destruct b; intuition.
Qed.

(* Why is this not part of ssr? *)
Lemma eqE : forall (a b:bool), a = b <-> (a <-> b).
Proof.
  move=> a b.
  elim Ea: a;
  elim Eb: b;
  try tauto.
  intuition.
  symmetry.
  rewrite fold_is_true.
  apply H0. auto.
  intuition.
Qed.

Lemma andE a b : a && b <-> a /\ b.
Proof.
  elim: a; elim: b; try tauto.
  split; move=> /andP; try done.
  split; move=> /andP; try done.
Qed.

Lemma orE : forall a b, (a || b) <-> a \/ b.
Proof. intros a b. unfold is_true. rewrite orb_true_iff. tauto. Qed.

Lemma notE : forall a, ~~a <-> ~ a.
Proof. move=>a. unfold is_true. rewrite negb_true_iff.
split. move=>h. rewrite h. auto.
apply not_true_is_false.
Qed.

(** ** NOTE: VarSets and equality *)

(* VarSets have several different notions of equality.
   In all three definitions, equal varsets must have the same domain.
   Now suppose:
       lookupVarSet m1 x = Some v1 and
       lookupVarSet m2 x = Some v2
   The sets are equal when:
    - v1 = v2                (i.e. coq equality)
    - almostEqual v1 v2
    - v1 == v2               (i.e. same uniques ONLY)

   The last (coarsest) equality is the one used in the FSet signature,
   and denoted by the [=] notation.

   The almostEqual equality is denoted by {=}.

   Because of this distinction, we have to do some lemmas twice: once
   for [=] equality, and once for {=} equality.

*)

(** ** VarSet operations respect GHC.Base.==  *)

Lemma elemVarSet_eq : forall v1 v2 vs,
  (v1 == v2) ->
  elemVarSet v1 vs = elemVarSet v2 vs.
Proof.
  intros v1 v2 vs h.
  unfold elemVarSet, UniqSet.elementOfUniqSet.
  destruct vs.
  unfold UniqFM.elemUFM.
  destruct getUniqSet'.
  move: h.
  rewrite eq_unique.
  move=> h.
  f_equal.
  auto.
Qed.

Lemma lookupVarSet_eq :
  forall v1 v2 vs,
    (v1 == v2) ->
    lookupVarSet vs v1 = lookupVarSet vs v2.
Proof.
  intros v1 v2 vs.
  unfold lookupVarSet.
  unfold UniqSet.lookupUniqSet.
  destruct vs.
  unfold UniqFM.lookupUFM.
  destruct getUniqSet'.
  intro h.
  rewrite -> eq_unique in h.
  rewrite h.
  reflexivity.
Qed.

Lemma extendVarSet_eq :
  forall x y vs, x == y -> extendVarSet vs x [=] extendVarSet vs y.
Proof.
  move => x y vs Eq.
  set_b_iff.
  move: (add_m) => h.
  unfold Proper,respectful in h.
  apply h.
  assumption.
  reflexivity.
Qed.

Lemma delVarSet_eq :
  forall x y vs, x == y -> delVarSet vs x = delVarSet vs y.
Proof.
  move => x y vs Eq.
  unfold delVarSet.
  move: vs => [i].
  move: i => [m].
  rewrite -> eq_unique in Eq.
  unfold UniqSet.delOneFromUniqSet.
  unfold UniqFM.delFromUFM.
  rewrite Eq.
  reflexivity.
Qed.

(** ** List based operations in terms of folds *)

Lemma extendVarSetList_foldl' : forall x xs,
    extendVarSetList x xs = Foldable.foldl' (fun x y => add y x) x xs.
Proof.
  intros.
  unfold extendVarSetList, UniqSet.addListToUniqSet;
  replace UniqSet.addOneToUniqSet with
      (fun x y => add y x).
  auto.
  auto.
Qed.

Lemma delVarSetList_foldl : forall vl vs,
    delVarSetList vs vl = Foldable.foldl delVarSet vs vl.
Proof.
  induction vl.
  - intro vs.
    destruct vs. destruct getUniqSet'.
    unfold_Foldable_foldl.
    simpl.
    auto.
  - intro vs.
    unfold delVarSetList in *.
    unfold UniqSet.delListFromUniqSet in *.
    destruct vs.
    unfold UniqFM.delListFromUFM in *.
    revert IHvl.
    unfold_Foldable_foldl.
    simpl.
    intro IHvl.
    rewrite (IHvl (UniqSet.Mk_UniqSet (UniqFM.delFromUFM getUniqSet' a))).
    auto.
Qed.

Lemma mkVarSet_extendVarSetList : forall xs,
    mkVarSet xs = extendVarSetList emptyVarSet xs.
Proof.
  reflexivity.
Qed.

Hint Rewrite mkVarSet_extendVarSetList : hs_simpl.

(** ** [lookupVarSet] and [elemVarSet] correspondence *)

Lemma lookupVarSet_In:
  forall vs v, (exists v', lookupVarSet vs v = Some v') <-> In v vs.
Proof.
  unfold lookupVarSet, UniqSet.lookupUniqSet,
    UniqFM.lookupUFM, Unique.getWordKey, Unique.getKey.
  intros.
  destruct vs.
  destruct getUniqSet'.
  destruct (Unique.getUnique v) as [n] eqn:Hv.
  unfold In, elemVarSet, UniqSet.elementOfUniqSet,
  UniqFM.elemUFM, Unique.getKey, Unique.getWordKey,
  Unique.getKey.
  rewrite Hv.
  rewrite <- member_lookup.
  reflexivity.
Qed.

Lemma lookupVarSet_elemVarSet :
  forall v1 v2 vs, lookupVarSet vs v1 = Some v2 -> elemVarSet v1 vs.
Proof.
  intros.
  unfold lookupVarSet, elemVarSet in *.
  unfold UniqSet.lookupUniqSet, UniqSet.elementOfUniqSet in *.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.elemUFM in *.
  destruct getUniqSet'.
  set (key := Unique.getWordKey (Unique.getUnique v1)) in *.
  rewrite member_lookup.
  exists v2. auto.
Qed.

Lemma lookupVarSet_None_elemVarSet:
  forall v1 vs, lookupVarSet vs v1 = None <-> elemVarSet v1 vs = false.
Proof.
  intros.
  unfold lookupVarSet, elemVarSet in *.
  unfold UniqSet.lookupUniqSet, UniqSet.elementOfUniqSet in *.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.elemUFM in *.
  destruct getUniqSet'.
  set (key := Unique.getWordKey (Unique.getUnique v1)) in *.
  rewrite non_member_lookup.
  intuition.
Qed.

Lemma elemVarSet_lookupVarSet :
  forall v1 vs, elemVarSet v1 vs -> exists v2, lookupVarSet vs v1 = Some v2.
Proof.
  intros.
  unfold lookupVarSet, elemVarSet in *.
  unfold UniqSet.lookupUniqSet, UniqSet.elementOfUniqSet in *.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.elemUFM in *.
  destruct getUniqSet'.
  set (key := Unique.getWordKey (Unique.getUnique v1)) in *.
  rewrite <- member_lookup.
  auto.
Qed.

(** ** [lookupVarSet] is Proper  *)

Instance lookupVarSet_m :
  Proper (Equal ==> (fun x y => x == y) ==> (fun x y => x == y)) lookupVarSet.
Proof.
  unfold Equal.
  intros x y H v1 v2 EV.
  erewrite lookupVarSet_eq; eauto.
  pose (h1 := H v1).
  pose (h2 := H v2).
  repeat rewrite -> mem_iff in h1.
  repeat rewrite -> mem_iff in h2.
  destruct (lookupVarSet x v2) eqn:LX;
  destruct (lookupVarSet y v2) eqn:LY;
  hs_simpl.
  - apply ValidVarSet_Axiom in LX.
    apply ValidVarSet_Axiom in LY.
    eapply Eq_trans.
    rewrite Eq_sym.
    eapply LX.
    eapply LY.
  - apply lookupVarSet_elemVarSet in LX.
    rewrite -> lookupVarSet_None_elemVarSet in LY.
    set_b_iff.
    intuition.
  - apply lookupVarSet_elemVarSet in LY.
    rewrite -> lookupVarSet_None_elemVarSet in LX.
    set_b_iff.
    intuition.
  - auto.
Qed.

(** ** [lookupVarSet . extendVarSet ] simplification *)

Lemma lookupVarSet_extendVarSet_self:
  forall v vs,
  lookupVarSet (extendVarSet vs v) v = Some v.
Proof.
  intros.
  unfold lookupVarSet, extendVarSet in *.
  unfold UniqSet.lookupUniqSet, UniqSet.addOneToUniqSet in *.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.addToUFM in *.
  destruct getUniqSet'.
  set (key := Unique.getWordKey (Unique.getUnique v)) in *.
  apply lookup_insert.
Qed.

Hint Rewrite lookupVarSet_extendVarSet_self : hs_simpl.

Lemma lookupVarSet_extendVarSet_eq :
      forall v1 v2 vs,
      v1 == v2  ->
      lookupVarSet (extendVarSet vs v1) v2 = Some v1.
Proof.
  intros v1 v2 vs H.
  rewrite Eq_sym in H.
  rewrite (lookupVarSet_eq _ H).
  unfold lookupVarSet, extendVarSet.
  unfold UniqSet.lookupUniqSet, UniqSet.addOneToUniqSet.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.addToUFM.
  destruct getUniqSet'.
  set (k1 := Unique.getWordKey (Unique.getUnique v1)).
  rewrite lookup_insert.
  reflexivity.
Qed.

Lemma lookupVarSet_extendVarSet_neq :
      forall v1 v2 vs,
      not (v1 == v2) ->
      lookupVarSet (extendVarSet vs v1) v2 = lookupVarSet vs v2.
Proof.
  intros v1 v2 vs H.
  assert (Unique.getWordKey (Unique.getUnique v1) <>
          Unique.getWordKey (Unique.getUnique v2)).
  { intro h.
    eapply H.
    rewrite eq_unique.
    auto.
  }
  unfold lookupVarSet, extendVarSet.
  unfold UniqSet.lookupUniqSet, UniqSet.addOneToUniqSet.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.addToUFM.
  destruct getUniqSet'.
  eapply lookup_insert_neq.
  auto.
Qed.

(* --------------------------------- *)

(* Tactics that don't really work. *)

Local Ltac unfold_VarSet_to_IntMap :=
  repeat match goal with
         | [vs : VarSet |- _ ] =>
           let u := fresh "u" in
           destruct vs as [u]; destruct u; simpl
         | [ |- UniqSet.Mk_UniqSet _ = UniqSet.Mk_UniqSet _ ] =>
           f_equal
         | [ |- UniqFM.UFM _ = UniqFM.UFM _ ] =>
           f_equal
         end.

(*
(* Q: is there a way to do the automatic destructs safely? Sometimes
   loses too much information. *)

Ltac unfold_VarSet :=
  unfold subVarSet,elemVarSet, isEmptyVarSet,
         minusVarSet, extendVarSet, extendVarSetList in *;
  unfold UniqSet.elementOfUniqSet,
         UniqSet.isEmptyUniqSet,
         UniqSet.addOneToUniqSet,
         UniqSet.minusUniqSet,
         UniqSet.addListToUniqSet in *;
  try repeat match goal with
  | vs: VarSet, H : context[match ?vs with _ => _ end]  |- _ => destruct vs
  end;
  try repeat match goal with
  | vs: VarSet |- context[match ?vs with _ => _ end ] => destruct vs
  end;

  unfold UniqFM.addToUFM,
         UniqFM.minusUFM, UniqFM.isNullUFM,
         UniqFM.elemUFM in *;
  try repeat match goal with
  | u: UniqFM.UniqFM ?a, H : context[match ?u with _ => _ end]  |- _ => destruct u
  end;
  try repeat match goal with
  | u: UniqFM.UniqFM ?a |- context[match ?u with _ => _ end] => destruct u
  end.

Ltac safe_unfold_VarSet :=
  unfold subVarSet,elemVarSet, isEmptyVarSet,
         minusVarSet, extendVarSet, extendVarSetList in *;
  unfold UniqSet.elementOfUniqSet,
         UniqSet.isEmptyUniqSet,
         UniqSet.addOneToUniqSet,
         UniqSet.minusUniqSet,
         UniqSet.addListToUniqSet in *;
  unfold UniqFM.addToUFM,
         UniqFM.minusUFM, UniqFM.isNullUFM,
         UniqFM.elemUFM in *. *)

(**************************************)

(** ** [extendVarSetList] simplifications *)

Lemma extendVarSetList_nil:
  forall s,
  extendVarSetList s [] = s.
Proof.
  intro s.
  reflexivity.
Qed.

Lemma extendVarSetList_cons:
  forall s v vs,
  extendVarSetList s (v :: vs) = extendVarSetList (extendVarSet s v) vs.
Proof.
  intros.
  rewrite extendVarSetList_foldl'.
  autorewrite with hs_simpl.
  reflexivity.
Qed.

Lemma extendVarSetList_singleton:
  forall vs v, extendVarSetList vs [v] = extendVarSet vs v.
Proof. intros. reflexivity. Qed.

Lemma extendVarSetList_append:
  forall s vs1 vs2,
  extendVarSetList s (vs1 ++ vs2) = extendVarSetList (extendVarSetList s vs1) vs2.
Proof.
  intros.
  rewrite extendVarSetList_foldl'.
  autorewrite with hs_simpl.
  reflexivity.
Qed.

Hint Rewrite extendVarSetList_nil
             extendVarSetList_cons
             extendVarSetList_singleton
             extendVarSetList_append : hs_simpl.

(** ** [delVarSetList] simplification  *)

Lemma delVarSetList_nil:
  forall e, delVarSetList e [] = e.
Proof.
  intros.
  rewrite delVarSetList_foldl.
  reflexivity.
Qed.

Lemma delVarSetList_single:
  forall e a, delVarSetList e [a] = delVarSet e a.
Proof.
  intros.
  rewrite delVarSetList_foldl.
  autorewrite with hs_simpl.
  reflexivity.
Qed.

Lemma delVarSetList_cons:
  forall e a vs, delVarSetList e (a :: vs) = delVarSetList (delVarSet e a) vs.
Proof.
  intros.
  repeat rewrite delVarSetList_foldl.
  autorewrite with hs_simpl.
  reflexivity.
Qed.

Lemma delVarSetList_app:
  forall e vs vs', delVarSetList e (vs ++ vs') = delVarSetList (delVarSetList e vs) vs'.
Proof.
  intros.
  repeat rewrite delVarSetList_foldl.
  autorewrite with hs_simpl.
  reflexivity.
Qed.

Hint Rewrite delVarSetList_nil
             delVarSetList_cons
             delVarSetList_single
             delVarSetList_app : hs_simpl.

(** ** [elemVarSet] simplification *)

Lemma elemVarSet_emptyVarSet : forall v, (elemVarSet v emptyVarSet) = false.
  intro v.
  set_b_iff.
  fsetdec.
Qed.

Lemma elemVarSet_unionVarSet:
  forall v vs1 vs2,
    elemVarSet v (unionVarSet vs1 vs2) = elemVarSet v vs1 || elemVarSet v vs2.
Proof.
  move => v [[i]] [[i0]] /=.
  rewrite member_union.
  auto.
Qed.

Hint Rewrite elemVarSet_emptyVarSet elemVarSet_unionVarSet : hs_simpl.

(** ** [extendVarSet]  *)

Lemma extendVarSet_elemVarSet_true : forall set v,
    elemVarSet v set -> extendVarSet set v [=] set.
Proof.
  intros.
  apply add_equal.
  auto.
Qed.

Lemma elemVarSet_extendVarSet:
  forall v vs v',
  elemVarSet v (extendVarSet vs v') = (v' == v) || elemVarSet v vs.
Proof.
  intros.
  rewrite var_eq_realUnique.
  replace (realUnique v' == realUnique v)%N with
      (F.eqb v' v).

  eapply F.add_b.
  unfold F.eqb.
  cbn.
  destruct F.eq_dec.
  - unfold Var_as_DT.eq in e.
    rewrite <- realUnique_eq in e; auto.
  - unfold Var_as_DT.eq in n.
    rewrite <- realUnique_eq in n; apply not_true_is_false in n; auto.
Qed.

Hint Rewrite elemVarSet_extendVarSet : hs_simpl.

Lemma elemVarSet_extendVarSetList:
  forall v vs vs',
  elemVarSet v (extendVarSetList vs vs') = Foldable.elem v vs' || elemVarSet v vs.
Proof.
  intros.
  generalize vs.
  induction vs'.
  + intros vs0. hs_simpl.
    simpl.
    auto.
  + intros vs0. hs_simpl.
    rewrite IHvs'.
    hs_simpl.
    rewrite Eq_sym.
    ssrbool.bool_congr.
    reflexivity.
Qed.

Hint Rewrite elemVarSet_extendVarSetList : hs_simpl.

Lemma extendVarSet_commute : forall x y vs,
    extendVarSet (extendVarSet vs y) x  [=] extendVarSet (extendVarSet vs x) y.
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

(** ** [extendVarSetList] and [delVarSetList] are Proper **)

(* These lemmas show that extendVarSetList respects [=] *)

Lemma extendVarSetList_iff : forall l x vs,
  In x (extendVarSetList vs l) <->
  In x vs \/ Foldable.elem x l.
Proof.
  induction l.
  - intros x vs.
    hs_simpl.
    intuition.
    inversion H0.
  - intros x vs.
    hs_simpl.
    rewrite IHl.
    set_b_iff.
    rewrite add_iff.
    unfold Var_as_DT.eqb.
    rewrite Eq_sym.
    rewrite orE.
    intuition.
Qed.

Lemma delVarSetList_iff : forall l x vs,
  In x (delVarSetList vs l) <->
  In x vs /\ ~ (Foldable.elem x l).
Proof.
  induction l.
  - intros x vs.
    hs_simpl.
    intuition.
  - intros x vs.
    hs_simpl.
    rewrite IHl.
    rewrite delVarSet_remove. rewrite remove_iff.
    unfold Var_as_DT.eqb.
    rewrite Eq_sym.
    rewrite orE.
    intuition.
Qed.

Instance extendVarSetList_m :
  Proper (Equal ==> (eqlistA (fun x y => x == y)) ==> Equal) extendVarSetList.
Proof.
  unfold Equal.
  intros x y H s s' H0 a.
  do 2 rewrite extendVarSetList_iff.
  rewrite H.
  intuition; right.
  erewrite <- eqlist_Foldable_elem; eauto.
  eapply EqLaws_Var.
  erewrite eqlist_Foldable_elem; eauto.
  eapply EqLaws_Var.
Qed.

Instance delVarSetList_m :
  Proper (Equal ==> (eqlistA (fun x y => x == y)) ==> Equal) delVarSetList.
Proof.
  unfold Equal.
  intros x y H s s' H0 a.
  do 2 rewrite delVarSetList_iff.
  rewrite H.
  intuition.
  apply H3.
  erewrite eqlist_Foldable_elem; eauto using EqLaws_Var.
  apply H3.
  erewrite <- eqlist_Foldable_elem; eauto using EqLaws_Var.
Qed.

Instance delVarSet_m :
  Proper (Equal ==> (fun x y => x == y) ==> Equal) delVarSet.
Proof.
  intros x y H s s' H0 a.
  replace (delVarSet x s) with (delVarSetList x [s]).
  replace (delVarSet y s') with (delVarSetList y [s']).
  assert (eqlistA (_==_) [s] [s']).
  { constructor; [assumption|constructor]. }
  rewrite H. rewrite H1. reflexivity.
  rewrite delVarSetList_cons delVarSetList_nil //=.
  rewrite delVarSetList_cons delVarSetList_nil //=.
Qed.

(* We can commute the order of addition to varsets.
   This is only true for [=] *)
Lemma extendVarSetList_extendVarSet_iff: forall l x vs,
  extendVarSetList (extendVarSet vs x) l [=]
  extendVarSet (extendVarSetList vs l) x.
Proof.
  induction l.
  - intros.
    hs_simpl.
    reflexivity.
  - intros.
    hs_simpl.
    rewrite extendVarSet_commute.
    rewrite IHl.
    reflexivity.
Qed.

Lemma elemVarSet_extend_add : forall v s vs a,
  elemVarSet v (extendVarSetList s vs) ->
  elemVarSet v (extendVarSetList (add a s) vs).
Proof.
  intros v s vs a.
  rewrite InE.
  rewrite InE.
  rewrite extendVarSetList_iff.
  rewrite extendVarSetList_iff.
  intuition.
  left.
  fsetdec.
Qed.

Lemma elemVarSet_extendVarSetList_r:
  forall v s vs,
  elemVarSet v (mkVarSet vs)  ->
  elemVarSet v (extendVarSetList s vs) .
Proof.
  intros v s vs.
  rewrite mkVarSet_extendVarSetList.
  rewrite InE.
  rewrite InE.
  rewrite extendVarSetList_iff.
  rewrite extendVarSetList_iff.
  intuition.
Qed.

Lemma elemVarSet_mkVarSet_cons:
  forall v v' vs,
  elemVarSet v (mkVarSet (v' :: vs)) = false
  <-> (v' == v) = false /\ elemVarSet v (mkVarSet vs) = false.
Proof.
  intros v v' vs.
  rewrite mkVarSet_extendVarSetList.
  rewrite extendVarSetList_cons.
  rewrite mkVarSet_extendVarSetList.
  rewrite <- not_mem_iff.
  rewrite <- not_mem_iff.
  rewrite extendVarSetList_iff.
  rewrite extendVarSetList_iff.
  set_b_iff.
  rewrite add_iff.
  unfold Var_as_DT.eqb.
  intuition.
  apply not_true_is_false.
  unfold not. auto.
  destruct H.
  rewrite H1 in H0.
  done.
Qed.

(* ** Properties about [lookupVarSet (extendVarSetList vs vars) v]

   Note, we can specify what happens when v is an Foldable.elem of vars with
   varying degrees of precision. When we lookup v, we won't get [Some v]
   exactly, but we will get something == to v, and that was the most recently
   added var in vars.

*)

Lemma lookupVarSet_extendVarSetList_false:
  forall (vars:list Var) v vs,
    ~~ (Foldable.elem v vars ) ->
    lookupVarSet (extendVarSetList vs vars) v = lookupVarSet vs v.
Proof.
  elim=> [|x xs IH] //.   (* // is try done. *)
  - move => v vs.
    hs_simpl.
    rewrite negb_or.     (* de morgan law to push ~~ in *)
    move => /andP [h1 h2]. (* split && into two hypotheses *)
    rewrite IH //.
    rewrite lookupVarSet_extendVarSet_neq //.
    rewrite Eq_sym. by apply /negP.
Qed.

Lemma lookupVarSet_extendVarSetList_l
  v vs vars :
  ~~ elemVarSet v (mkVarSet vars) ->
  lookupVarSet (extendVarSetList vs vars) v = lookupVarSet vs v.
Proof.
  hs_simpl.
  elim: vars vs => [|a vars IH] vs //.
  hs_simpl.

  rewrite negb_orb => /andP [? ?].

  rewrite lookupVarSet_extendVarSetList_false //.
  rewrite lookupVarSet_extendVarSet_neq //.

  apply /negP.
  rewrite Eq_sym //.
Qed.

Lemma lookupVarSet_extendVarSetList_self_in:
  forall (vars:list Var) v vs,
    List.In v vars ->
    NoDup (map varUnique vars) ->
    lookupVarSet (extendVarSetList vs vars) v = Some v.
Proof.
  induction vars.
  - intros v vs H.
    inversion H.
  - intros v vs H ND.
    hs_simpl.
    simpl in ND.
    inversion ND. subst.
    inversion H; subst.
    + rewrite lookupVarSet_extendVarSetList_false.
      by hs_simpl.
      apply /negP.
      by rewrite -In_varUnique_elem.
    + eauto.
Qed.

Lemma lookupVarSet_extendVarSetList_self:
  forall (vars:list Var) v vs,
    (Foldable.elem v vars) ->
    lookupVarSet (extendVarSetList vs vars) v == Some v.
Proof.
  induction vars.
  - intros v vs H.
    rewrite elem_nil in H.
    done.
  - intros v vs H.
    rewrite elem_cons in H.
    hs_simpl.
    rewrite -> orE in H.
    elim: H.
    move => H.
    destruct (Foldable.elem v vars) eqn:Hv.
    + specialize (IHvars v (extendVarSet vs a)).
      unfold is_true in *.
      apply IHvars.
      done.
    + rewrite (lookupVarSet_eq _ H).
      rewrite lookupVarSet_extendVarSetList_false.
      rewrite lookupVarSet_extendVarSet_self.
      hs_simpl.
      symmetry. done.
      setoid_rewrite H in Hv.
      rewrite Hv. done.
    + move=> h.
      apply IHvars.
      auto.
Qed.

Inductive LastIn : Var -> list Var -> Prop :=
  | LastIn_head: forall v1 vs,
      Foldable.elem v1 vs = false ->
      LastIn v1 (v1 :: vs)
  | LastIn_tail: forall v1 v2 vs,
      LastIn v1 vs ->
      LastIn v1 (v2 :: vs).

Lemma LastIn_elem : forall v vs,
    LastIn v vs -> Foldable.elem v vs.
Proof.
  move => v vs h.
  induction h; hs_simpl; apply /orP.
  left. reflexivity.
  right. assumption.
Qed.

Lemma LastIn_inj : forall v1 v2 vs,
    LastIn v1 vs -> v1 == v2 -> LastIn v2 vs -> v1 = v2.
Proof.
  move=> v1 v2 vs h. induction h.
  - move=> eq FI.
    inversion FI. auto.
    subst.
    move: (LastIn_elem H2) => h.
    rewrite -> HSUtil.elem_resp_eq with (a:= v2) in H; try done.
    rewrite Eq_sym. done.
  - move=> eq FI. inversion FI.
    subst.
    move: (LastIn_elem h) => h0.
    rewrite -> HSUtil.elem_resp_eq with (a:= v1) in H1; try done.
    subst. eauto.
Qed.

Lemma lookupVarSet_extendVarSetList_self_exists_LastIn:
  forall (vars:list Var) v vs,
    (Foldable.elem v vars) ->
    exists v', and3 (lookupVarSet (extendVarSetList vs vars) v = Some v')
               (v == v')
               (LastIn v' vars).
Proof.
  elim => // a vars IH.       (* Do induction on first var,
                                then trivially discharge goal. *)
                          (* Then introduce names for list components *)
  move=> v vs.
  hs_simpl.

  move => /orP [h1 | h1].  (* case analysis on boolean || *)

  destruct (Foldable.elem v vars) eqn:IN.

  + unfold is_true in *.
    move: (IH v (extendVarSet vs a) IN) => [v' [p q r]].
    exists v'; split; eauto.
    eapply LastIn_tail. auto.
  + rewrite lookupVarSet_extendVarSetList_false ; try by rewrite IN.
    exists a. split; eauto.
    rewrite lookupVarSet_extendVarSet_eq //.
    symmetry => //.
    eapply LastIn_head.
    rewrite <- (elem_eq vars _ _ h1).
    done.
  + unfold is_true in *.
    move: (IH v (extendVarSet vs a) h1) => [v' [p q r]].
    exists v'; split; eauto.
    eapply LastIn_tail. auto.
Qed.

(*
Lemma lookupVarSet_extendVarSetList_self_exists_in:
  forall (vars:list Var) v vs,
    (Foldable.elem v vars) ->
    exists v', and3 (lookupVarSet (extendVarSetList vs vars) v = Some v')
               (v == v')
               (List.In v' vars).
Proof.
  elim => // a vars IH.       (* Do induction on first var,
                                then trivially discharge goal. *)
                          (* Then introduce names for list components *)
  move=> v vs.
  hs_simpl.

  move => /orP [h1 | h1].  (* case analysis on boolean || *)

  case IN: (Foldable.elem v vars).

  all: try ( unfold is_true in * ; match goal with
      [ H : Foldable.elem ?v ?vars = true |- _ ] =>
        move: (IH v (extendVarSet vs a) H) => [v'[]]* ;
        exists v'; split; eauto using in_cons
     end ).

   + rewrite lookupVarSet_extendVarSetList_false ; try by rewrite IN.
     exists a. split; eauto.
       rewrite lookupVarSet_extendVarSet_eq //.
       symmetry => //.
       eapply in_eq.
Qed.
*)

Lemma extendVarSetList_same v vars : forall vs1 vs2 ,
  Foldable.elem v vars ->
  lookupVarSet (extendVarSetList  vs1 vars) v =
  lookupVarSet (extendVarSetList vs2 vars)  v.
Proof.
  elim: vars => // a vars IHvars.
  - move => vs1 vs2.
    hs_simpl.
    move=> /orP [h1|h2].
    + destruct (Foldable.elem v vars) eqn:h; eauto.
      (* ! rewrites one or more times. *)
      rewrite !lookupVarSet_extendVarSetList_false; try (rewrite h; done).
      rewrite !lookupVarSet_extendVarSet_eq // ; symmetry ; done.
    + auto.
Qed.

(** ** [mkVarSet]  *)

Lemma elemVarSet_mkVarset_iff_In:
  forall v vs,
  elemVarSet v (mkVarSet vs)  <->  List.In (varUnique v) (map varUnique vs).
Proof.
  intros.
  rewrite mkVarSet_extendVarSetList.
  induction vs.
  - hs_simpl.
    simpl.
    done.
  - hs_simpl.
    simpl map.
    split.
    + move /orP.
      rewrite -> varUnique_iff.
      rewrite -In_varUnique_elem //.
      move => [h1|h2] //.
      rewrite h1.
      apply in_eq.
      apply in_cons => //.
    + move => h.
      apply /orP.
      inversion h.
      ++ left.
         rewrite varUnique_iff //.
      ++ right.
         apply In_varUnique_elem => //.
Qed.

(** ** [delVarSet]  *)

Lemma delVarSet_elemVarSet_false : forall v set,
    elemVarSet v set = false -> delVarSet set v [=] set.
intros.
set_b_iff.
apply remove_equal.
auto.
Qed.

Lemma delVarSet_emptyVarSet x :
  delVarSet emptyVarSet x = emptyVarSet.
Proof.
  unfold delVarSet, emptyVarSet.
  unfold  UniqSet.delOneFromUniqSet , UniqSet.emptyUniqSet.
  unfold UniqFM.delFromUFM, UniqFM.emptyUFM.
  repeat f_equal. unfold IntMap.delete, IntMap.empty.
  f_equal. apply proof_irrelevance.
Qed.
Hint Rewrite delVarSet_emptyVarSet : hs_simpl.

Lemma delVarSet_extendVarSet :
  forall set v,
    elemVarSet v set = false -> (delVarSet (extendVarSet set v) v) [=] set.
Proof.
  intros.
  set_b_iff.
  apply remove_add.
  auto.
Qed.

Lemma elemVarSet_delVarSet: forall v1 fvs v2,
  elemVarSet v1 (delVarSet fvs v2) = negb (v2 == v1) && elemVarSet v1 fvs.
Proof.
  intros.
  destruct elemVarSet eqn:EL.
  + symmetry.
    apply andb_true_intro.
    set_b_iff.
    rewrite -> remove_iff in EL.
    unfold Var_as_DT.eqb in EL. unfold not in EL.
    rewrite negb_true_iff.
    intuition.
    apply not_true_is_false.
    auto.
  + symmetry.
    apply not_true_is_false.
    intro H.
    apply andb_prop in H.
    set_b_iff.
    rewrite -> remove_iff in EL.
    unfold Var_as_DT.eqb in *.
    intuition.
    rewrite -> negb_true_iff in H0.
    apply H2.
    intro h.
    unfold Var_as_DT.t in *.
    rewrite h in H0.
    inversion H0.
Qed.

Hint Rewrite elemVarSet_delVarSet : hs_simpl.

Lemma lookupVarSet_delVarSet_neq :
      forall v1 v2 vs,
      not (v1 == v2) ->
      lookupVarSet (delVarSet vs v1) v2 = lookupVarSet vs v2.
Proof.
  intros v1 v2 vs H.
  unfold lookupVarSet,delVarSet.
  unfold UniqSet.lookupUniqSet, UniqSet.delOneFromUniqSet.
  destruct vs.
  unfold UniqFM.lookupUFM, UniqFM.delFromUFM.
  destruct getUniqSet'.
  assert (Unique.getWordKey (Unique.getUnique v1) <>
          Unique.getWordKey (Unique.getUnique v2)).
  { intro h. apply H. rewrite eq_unique. done. }
  rewrite delete_neq.
  auto.
  auto.
Qed.

Lemma elemVarSet_delVarSet_eq x y vs :
  (x == y) -> elemVarSet x (delVarSet vs y) = false.
Proof.
  rewrite -> eq_unique.
  move => Eq.
  unfold elemVarSet, delVarSet.
  unfold UniqSet.elementOfUniqSet, UniqSet.delOneFromUniqSet.
  move: vs => [i].
  move: i => [m].
  unfold UniqFM.elemUFM, UniqFM.delFromUFM.
  rewrite Eq.
  set key :=  Unique.getWordKey (Unique.getUnique y).
  move: (@delete_eq key Var m).
  rewrite <- non_member_lookup.
  move => h. rewrite h.
  done.
Qed.

(** ** [delVarSetList]  *)

(* These next two rely on this strong property about the unique
   representations of IntMaps. *)
Lemma delVarSet_commute : forall x y vs,
    delVarSet (delVarSet vs x) y [=] delVarSet (delVarSet vs y) x.
Proof.
  intros.
  unfold delVarSet.
  unfold UniqSet.delOneFromUniqSet.
  destruct vs.
  unfold UniqFM.delFromUFM. destruct getUniqSet'.
  apply IntMapEq_VarSetEq.
  eapply delete_commute; eauto.
  apply EqLaws_Var.
Qed.

Lemma delVarSetList_cons2:
  forall vs e a, delVarSetList e (a :: vs) [=] delVarSet (delVarSetList e vs) a.
Proof.
  induction vs; intros e a1;
  rewrite -> delVarSetList_cons in *.
  - set_b_iff.
    hs_simpl.
    reflexivity.
  - rewrite delVarSetList_cons.
    rewrite delVarSetList_cons.
    rewrite delVarSet_commute.
    rewrite <- IHvs.
    rewrite delVarSetList_cons.
    reflexivity.
Qed.

Lemma delVarSetList_rev:
  forall vs1 vs2,
  delVarSetList vs1 (rev vs2) [=] delVarSetList vs1 vs2.
Proof.
  induction vs2.
  - simpl. reflexivity.
  - simpl rev.
    rewrite delVarSetList_cons.
    rewrite delVarSetList_app.
    rewrite IHvs2.
    rewrite delVarSetList_cons.
    rewrite delVarSetList_nil.
    rewrite <- delVarSetList_cons2.
    rewrite delVarSetList_cons.
    reflexivity.
Qed.

Lemma elemVarSet_delVarSetList_false_l:
  forall v vs vs2,
  elemVarSet v vs = false ->
  elemVarSet v (delVarSetList vs vs2) = false.
Proof.
  intros.
  revert vs H; induction vs2; intros.
  * rewrite delVarSetList_nil.
    assumption.
  * rewrite delVarSetList_cons.
    apply IHvs2.
    set_b_iff; fsetdec.
Qed.

Lemma delVarSet_unionVarSet:
  forall vs1 vs2 x,
  delVarSet (unionVarSet vs1 vs2) x [=]
  unionVarSet (delVarSet vs1 x) (delVarSet vs2 x).
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma delVarSetList_unionVarSet:
  forall vs3 vs1 vs2,
  delVarSetList (unionVarSet vs1 vs2) vs3 [=]
  unionVarSet (delVarSetList vs1 vs3) (delVarSetList vs2 vs3).
Proof.
  induction vs3; intros.
  - repeat rewrite delVarSetList_nil.
    reflexivity.
  - repeat rewrite delVarSetList_cons.
    rewrite delVarSet_unionVarSet.
    rewrite IHvs3.
    reflexivity.
Qed.

(**************************************)

(** ** [subVarSet]  *)

Lemma subVarSet_refl:
  forall vs1,
  subVarSet vs1 vs1 .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_trans:
  forall vs1 vs2 vs3,
  subVarSet vs1 vs2  ->
  subVarSet vs2 vs3  ->
  subVarSet vs1 vs3 .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_emptyVarSet:
  forall vs,
  subVarSet emptyVarSet vs .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_unitVarSet:
  forall v vs,
  subVarSet (unitVarSet v) vs = elemVarSet v vs.
Proof.
  intros.
  destruct subVarSet eqn:SV; symmetry.
  + set_b_iff.
    fsetdec.
  + rewrite -> false_is_not_true in *.
    set_b_iff.
    intro h.
    unfold Subset in SV.
    apply SV.
    intros.
    rewrite In_eq_iff; eauto.
    apply singleton_1 in H; symmetry; auto.
Qed.

Lemma elemVarSet_false_true:
  forall v1 fvs v2,
  elemVarSet v1 fvs = false ->
  elemVarSet v2 fvs  ->
  varUnique v1 <> varUnique v2.
Proof.
  intros v1 fvs v2.
  intros.
  assert (not (v2 == v1 )).
  intro h.
  set_b_iff.
  rewrite -> In_eq_iff in H0; eauto.
  intro h.
  rewrite <- varUnique_iff in h.
  apply H1.
  rewrite Eq_sym.
  auto.
Qed.

Lemma subVarSet_elemVarSet_true:
  forall v vs vs',
  subVarSet vs vs'  ->
  elemVarSet v vs  ->
  elemVarSet v vs' .
Proof.
  intros v vs vs'.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_elemVarSet_false:
  forall v vs vs',
  subVarSet vs vs'  ->
  elemVarSet v vs' = false ->
  elemVarSet v vs = false.
Proof.
  intros v vs vs'.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_extendVarSetList_l:
  forall vs1 vs2 vs,
  subVarSet vs1 vs2  ->
  subVarSet vs1 (extendVarSetList vs2 vs) .
Proof.
  intros vs1 vs2 vs.
  generalize dependent vs2.
  induction vs.
  - intro vs2. rewrite extendVarSetList_nil. auto.
  - intro vs2. intro h.
    rewrite extendVarSetList_cons.
    rewrite IHvs. auto.
    set_b_iff. fsetdec.
Qed.

Lemma subVarSet_extendVarSet_both:
  forall vs1 vs2 v,
  subVarSet vs1 vs2  ->
  subVarSet (extendVarSet vs1 v) (extendVarSet vs2 v) .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_extendVarSet:
  forall vs1 vs2 v,
  subVarSet vs1 vs2  ->
  subVarSet vs1 (extendVarSet vs2 v) .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_extendVarSetList:
  forall vs1 vs2 vs3,
  subVarSet vs1 vs2  ->
  subVarSet vs1 (extendVarSetList vs2 vs3) .
Proof.

  induction vs3; autorewrite with hs_simpl.
  - auto.
  - intro h.
    rewrite extendVarSetList_extendVarSet_iff.
    rewrite subVarSet_extendVarSet; auto.
Qed.

Lemma subVarSet_extendVarSet_l:
  forall vs1 vs2 v v',
  subVarSet vs1 vs2  ->
  lookupVarSet vs2 v = Some v' ->
  subVarSet (extendVarSet vs1 v) vs2 .
Proof.
  intros.
  set_b_iff.
  apply MP.subset_add_3; try assumption.
  apply lookupVarSet_In.
  eauto.
Qed.

Lemma extendVarSet_subset: forall v1 v2 x,
  v1 [<=] v2 ->
  extendVarSet v1 x [<=] extendVarSet v2 x.
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma extendVarSetList_subset: forall x y vs,
  x [<=] y ->
  extendVarSetList x vs [<=] extendVarSetList y vs.
Proof.
  intros.
  induction vs; hs_simpl; [assumption|].
  do 2 rewrite extendVarSetList_extendVarSet_iff.
  apply extendVarSet_subset.
  assumption.
Qed.

Lemma subVarSet_extendVarSetList_r:
  forall vs vs1 vs2,
  subVarSet vs1 (mkVarSet vs)  ->
  subVarSet vs1 (extendVarSetList vs2 vs) .
Proof.
  intros vs.
  rewrite mkVarSet_extendVarSetList.
  induction vs; intros vs1 vs2.
  - autorewrite with hs_simpl.
    set_b_iff.
    fsetdec.
  - intro h.
    autorewrite with hs_simpl in *.
    rewrite -> extendVarSetList_extendVarSet_iff in *.
    destruct (mem a (extendVarSetList empty vs)) eqn:Hd;
    [|destruct (mem a vs1) eqn:Hd'].
    + specialize (IHvs vs1 vs2).
      set_b_iff.
      assert (Hvs2: In a (extendVarSetList vs2 vs)).
      * clear -Hd.
        eapply MP.in_subset.
        apply Hd. clear Hd a.
        apply extendVarSetList_subset.
        fsetdec.
      * pose proof (subset_equal
                     (equal_sym (add_equal Hvs2))).
        eapply (Subset_trans); [apply IHvs| apply H].
        pose proof (subset_equal (add_equal Hd)).
        fsetdec.
    + specialize (IHvs (remove a vs1) vs2).
      set_b_iff.
      apply remove_s_m with (x:= a) (y:=a) in h;
        [|fsetdec].
      assert (Hs: remove a (add a
                                (extendVarSetList empty vs))
                         [<=] (extendVarSetList empty vs)).
      { apply subset_equal.
        apply remove_add.
        assumption. }
        specialize (IHvs (Subset_trans h Hs)).
      apply add_s_m with (x:= a) (y:=a) in IHvs;
        [|fsetdec].
      assert (Hs': vs1 [<=] add a (remove a vs1)).
      { apply subset_equal.
        apply equal_sym.
        apply add_remove.
        assumption. }
      eapply Subset_trans.
      apply Hs'.
      assumption.
    + specialize (IHvs vs1 vs2).
      set_b_iff.
      apply subset_add_2.
      apply IHvs.
      eapply remove_s_m with (x:= a) (y:=a) in h;
        [|fsetdec].
      apply remove_equal in Hd'.
      fsetdec.
Qed.

Lemma subVarSet_delVarSet:
  forall vs1 v,
  subVarSet (delVarSet vs1 v) vs1 .
Proof.
  intros.
  set_b_iff.
  fsetdec.
Qed.

Lemma subVarSet_delVarSetList:
  forall vs1 vl,
  subVarSet (delVarSetList vs1 vl) vs1 .
Proof.
  intros.
  set_b_iff.
  generalize vs1. clear vs1. induction vl.
  - intros vs1. hs_simpl.
    fsetdec.
  - intros vs1. revert IHvl.
    hs_simpl.
    simpl.
    intro IH.
    rewrite -> IH with (vs1 := delVarSet vs1 a).
    set_b_iff.
    fsetdec.
Qed.

Lemma subVarSet_delVarSetList_both:
  forall vs1 vs2 vl,
  subVarSet vs1 vs2  ->
  subVarSet (delVarSetList vs1 vl) (delVarSetList vs2 vl) .
Proof.
  intros.
  revert vs1 vs2 H. induction vl; intros.
  - rewrite !delVarSetList_nil.
    assumption.
  - rewrite !delVarSetList_cons.
    apply IHvl.
    set_b_iff.
    fsetdec.
Qed.

Lemma subVarSet_delVarSet_extendVarSet:
  forall jps isvs v,
  subVarSet jps isvs  ->
  subVarSet (delVarSet jps v) (extendVarSet isvs v) .
Proof.
  intros.
  eapply subVarSet_trans.
  apply subVarSet_delVarSet.
  apply subVarSet_extendVarSet.
  assumption.
Qed.

Lemma subVarSet_delVarSetList_extendVarSetList:
  forall jps isvs vs,
  subVarSet jps isvs  ->
  subVarSet (delVarSetList jps vs) (extendVarSetList isvs vs) .
Proof.
  intros.
  eapply subVarSet_trans.
  apply subVarSet_delVarSetList.
  apply subVarSet_extendVarSetList.
  assumption.
Qed.

Lemma subVarSet_delVarSetList_extendVarSetList_dual:
  forall jps isvs vs,
  subVarSet jps (extendVarSetList isvs vs)  ->
  subVarSet (delVarSetList jps vs) isvs .
Proof.
  intros.
  revert jps isvs H.
  induction vs; intros.
  - rewrite !delVarSetList_nil.
    rewrite !extendVarSetList_nil in H.
    assumption.
  - rewrite delVarSetList_cons2.
    revert H.
    hs_simpl.
    intro H.
    apply IHvs in H.
    set_b_iff.
    fsetdec.
Qed.

Lemma mapUnionVarSet_In_subVarSet:
  forall a (x : a) xs f,
  List.In x xs ->
  subVarSet (f x) (mapUnionVarSet f xs).
Proof.
  intros a x xs f H.
  generalize dependent x.
  induction xs; intros x H.
  - inversion H.
  -
    inversion H as [H'|H'].
    + unfold mapUnionVarSet.
      unfold_Foldable_foldr.
      subst.
      simpl.
      set_b_iff.
      fsetdec.
    + apply IHxs in H'.
      clear H IHxs.
      revert H'.
      unfold mapUnionVarSet.
      unfold_Foldable_foldr.
      intros H'.
      eapply subVarSet_trans.
      apply H'.
      clear H'.
      set_b_iff.
      simpl.
      fsetdec.
Qed.

Lemma subVarSet_mapUnionVarSet:
  forall a (xs : list a) f vs,
  Forall (fun x => subVarSet (f x) vs ) xs ->
  subVarSet (mapUnionVarSet f xs) vs.
Proof.
  intros a xs f vs H.
  induction xs.
  - unfold mapUnionVarSet.
    unfold_Foldable_foldr.
    simpl.
    apply subVarSet_emptyVarSet.
  - inversion H.
    subst.
    apply IHxs in H3.
    clear IHxs.
    revert H3.
    unfold mapUnionVarSet.
    unfold_Foldable_foldr.
    intros H3.
    set_b_iff.
    simpl.
    fsetdec.
Qed.

Lemma subVarSet_unionVarSet:
  forall vs1 vs2 vs3,
  subVarSet (unionVarSet vs1 vs2) vs3 = subVarSet vs1 vs3 && subVarSet vs2 vs3.
Proof.
  intros.
  apply eq_iff_eq_true.
  rewrite andb_true_iff.
  set_b_iff.
  split; intro H.
  - split; fsetdec.
  - destruct H; fsetdec.
Qed.

(** ** [disjointVarSet]  *)

Instance disjointVarSet_m : Proper (Equal ==> Equal ==> Logic.eq) disjointVarSet.
Proof.

  move => x1 y1.
  move: (@ValidVarSet_Axiom x1).
  move: (@ValidVarSet_Axiom y1).
  move: x1 => [x1]. move: y1=> [y1].
  move: x1 => [x1]. move: y1=> [y1].
  move=> vx1 vy1 Eq1.
  move=> x2 y2.
  move: (@ValidVarSet_Axiom x2).   move: (@ValidVarSet_Axiom y2).
  move: x2 => [x2]. move: y2=> [y2].
  move: x2 => [x2]. move: y2=> [y2].
  move=> vx2 vy2 Eq2.

  unfold ValidVarSet, disjointVarSet,
         UniqFM.disjointUFM,
         UniqSet.getUniqSet,
         UniqSet.getUniqSet' in *.
  unfold lookupVarSet, UniqSet.lookupUniqSet,UniqFM.lookupUFM in *.
  unfold Equal, In, elemVarSet, UniqSet.elementOfUniqSet, UniqFM.elemUFM in Eq1.
  unfold Equal, In, elemVarSet, UniqSet.elementOfUniqSet, UniqFM.elemUFM in Eq2.
  apply null_intersection_eq; eauto.
  move=> k1.
  specialize (Eq1 (Mk_Id GHC.Err.default k1 GHC.Err.default GHC.Err.default GHC.Err.default GHC.Err.default)).
  simpl in Eq1.
  auto.
  move=> k1.
  specialize (Eq2 (Mk_Id GHC.Err.default k1 GHC.Err.default GHC.Err.default GHC.Err.default GHC.Err.default)).
  simpl in Eq2.
  auto.
Qed.

(*
Lemma foldl'_simplify (a b c :Type) (f:c -> b) (g:b->c) (h:b -> a -> b)
      (xb:b) (xs : list a):
  (forall x, f (g x) = x) ->
  Foldable.foldl' (fun x y => g (h (f x) y)) (g xb) xs =
  g (Foldable.foldl' h xb xs).
Proof.
  move => eq.
  induction xs.
  hs_simpl. auto.
  hs_simpl.
  rewrite eq.
*)

Lemma UniqSet_Mk_UniqSet_eta :
  forall a b (x : UniqSet.UniqSet a) (f : UniqSet.UniqSet a -> b),
    match x with
    | UniqSet.Mk_UniqSet set => f (UniqSet.Mk_UniqSet set)
    end = f x.
Proof.
  move => a b [set] //.
Qed.

Lemma disjointVarSet_empytVarSet:
  forall vs,
  disjointVarSet vs emptyVarSet.
Proof.
  move => vs1.
  elim: vs1 => [i].
  unfold disjointVarSet, emptyVarSet, elemVarSet.
  simpl.
  elim: i => [j].
  simpl.
  apply intersection_empty.
  done.
Qed.
Hint Rewrite disjointVarSet_empytVarSet:hs_simpl.

Lemma disjointVarSet_mkVarSet_nil:
  forall vs,
  disjointVarSet vs (mkVarSet []).
Proof.
  rewrite mkVarSet_extendVarSetList.
  hs_simpl.
  apply disjointVarSet_empytVarSet.
Qed.

Lemma disjointVarSet_extendVarSet vs1 var vs2 :
  disjointVarSet vs1 (extendVarSet vs2 var) <->
  elemVarSet var vs1 = false /\ disjointVarSet vs1 vs2.
Proof.
  move: vs1 vs2 => [[i1]] [[i2]].
  unfold disjointVarSet, elemVarSet, extendVarSet.
  unfold UniqSet.getUniqSet,UniqSet.getUniqSet',
         UniqSet.elementOfUniqSet, UniqSet.addOneToUniqSet.
  unfold UniqFM.disjointUFM, UniqFM.elemUFM, UniqFM.addToUFM.
  set k:=  (Unique.getWordKey (Unique.getUnique var)).
  apply null_intersection_non_member.
Qed.

Lemma disjointVarSet_mkVarSet_cons:
  forall v vs1 vs2,
  disjointVarSet vs1 (mkVarSet (v :: vs2))  <->
  elemVarSet v vs1 = false /\ disjointVarSet vs1 (mkVarSet vs2) .
Proof.
  move=> v vs1 vs2.
  rewrite mkVarSet_extendVarSetList.
  hs_simpl.
  rewrite extendVarSetList_extendVarSet_iff.
  rewrite disjointVarSet_extendVarSet.
  tauto.
Qed.

Lemma disjointVarSet_mkVarSet_append:
  forall vs1 vs2 vs3,
  disjointVarSet vs1 (mkVarSet (vs2 ++ vs3))  <->
  disjointVarSet vs1 (mkVarSet vs2)  /\ disjointVarSet vs1 (mkVarSet vs3).
Proof.
  move=> vs1 vs2 vs3.
  rewrite mkVarSet_extendVarSetList.
  hs_simpl.
  elim: vs3 => [|var vars IH]; hs_simpl.
  + rewrite mkVarSet_extendVarSetList.
    intuition.
  + rewrite disjointVarSet_mkVarSet_cons.
    rewrite and_comm.
    rewrite and_assoc.
    rewrite -> and_comm in IH.
    rewrite <- IH.
    rewrite extendVarSetList_extendVarSet_iff.
    rewrite disjointVarSet_extendVarSet.
    tauto.
Qed.

Lemma disjointVarSet_mkVarSet:
  forall vs1 vs2,
  disjointVarSet vs1 (mkVarSet vs2)  <->
  Forall (fun v => elemVarSet v vs1 = false) vs2.
Proof.
  move => vs1 vs2.
  elim: vs2 => [|v vars IH].
  rewrite disjointVarSet_mkVarSet_nil. intuition.
  rewrite disjointVarSet_mkVarSet_cons. rewrite IH.
  intuition.
  - inversion H1. auto.
  - inversion H1. auto.
Qed.

Lemma disjointVarSet_subVarSet_l:
  forall vs1 vs2 vs3,
  disjointVarSet vs2 vs3  ->
  subVarSet vs1 vs2  ->
  disjointVarSet vs1 vs3 .
Proof.
  move=> [[i1]][[i2]][[i3]].
  unfold disjointVarSet, subVarSet, isEmptyVarSet,minusVarSet.
  unfold UniqSet.getUniqSet,UniqSet.getUniqSet',
  UniqSet.isEmptyUniqSet, UniqSet.minusUniqSet.
  unfold UniqFM.disjointUFM, UniqFM.isNullUFM, UniqFM.minusUFM.
  apply disjoint_difference.
Qed.

(** ** [filterVarSet] *)

Lemma filterVarSet_comp : forall f f' vs,
    filterVarSet f (filterVarSet f' vs) [=] filterVarSet (fun v => f v && f' v) vs.
Proof.
  intros. destruct vs, getUniqSet'. simpl.
  apply IntMapEq_VarSetEq, filter_comp, EqLaws_Var.
Qed.

Lemma filterSingletonTrue : forall f x,
  RespectsVar f ->
  f x = true ->
  filterVarSet f (unitVarSet x) [=] unitVarSet x.
Proof.
  move=> f x RR TR.
  set_b_iff.
  replace (singleton x) with (add x empty).
  - rewrite -> filter_add_1; auto.
    fsetdec.
  - simpl. unfold singleton, unitVarSet, UniqSet.unitUniqSet.
    f_equal. unfold UniqFM.unitUFM; f_equal.
    unfold IntMap.insert, IntMap.singleton; f_equal.
    apply proof_irrelevance.
Qed.

Lemma filterSingletonFalse : forall f x,
  RespectsVar f ->
  f x = false ->
  filterVarSet f (unitVarSet x) [=] emptyVarSet.
Proof.
  move=> f x RR TR.
  set_b_iff.
  replace (singleton x) with (add x empty).
  - rewrite -> filter_add_2; auto.
    fsetdec.
  - simpl. unfold singleton, unitVarSet, UniqSet.unitUniqSet.
    f_equal. unfold UniqFM.unitUFM; f_equal.
    unfold IntMap.insert, IntMap.singleton; f_equal.
    apply proof_irrelevance.
Qed.

Lemma filterVarSet_emptyVarSet f :
  filterVarSet f emptyVarSet = emptyVarSet.
Proof.
  set_b_iff.
  simpl. unfold empty, emptyVarSet, UniqSet.emptyUniqSet.
  f_equal. unfold UniqFM.emptyUFM. f_equal.
  unfold IntMap.filter, IntMap.empty. simpl.
  f_equal. apply proof_irrelevance.
Qed.
Hint Rewrite filterVarSet_emptyVarSet : hs_simpl.

Lemma filterVarSet_constTrue vs :
  filterVarSet (const true) vs [=] vs.
Proof.
  unfold filterVarSet.
  elim: vs => [i].
  elim: i => [m].
  simpl. apply IntMapEq_VarSetEq.
  apply filter_true, EqLaws_Var.
Qed.
Hint Rewrite filterVarSet_constTrue : hs_simpl.

Lemma elemVarSet_filterVarSet x f vs :
  RespectsVar f ->
  elemVarSet x (filterVarSet f vs) = f x && elemVarSet x vs.
Proof.
  move => h.
  rewrite eqE.
  set_b_iff.
  rewrite andE.
  unfold is_true.
  set_b_iff.
  rewrite and_comm.
  apply F.filter_iff.
  auto.
Qed.

Lemma filterVarSet_iff (f1 f2 : Var -> bool) vs :
  (forall x, (f1 x) <-> (f2 x)) ->
  filterVarSet f1 vs [=] filterVarSet f2 vs.
Proof.
  intros. destruct vs, getUniqSet'. simpl.
  apply IntMapEq_VarSetEq.
Abort.

Lemma filterVarSet_equal f vs1 vs2 :
  RespectsVar f ->
  vs1 [=] vs2 ->
  filterVarSet f vs1 [=] filterVarSet f vs2.
Proof.
  move => RF EQ.
  set_b_iff.
  eapply filter_equal; eauto.
Qed.

Lemma filterVarSet_extendVarSet :
  forall f v vs,
    RespectsVar f ->
    filterVarSet f (extendVarSet vs v) [=]
    if (f v) then extendVarSet (filterVarSet f vs) v
    else (filterVarSet f vs).
Proof.
  intros.
  set_b_iff.
  destruct (f v) eqn:Hfv; auto.
  rewrite -> filter_add_1; try done.
  rewrite -> filter_add_2; try done.
Qed.

Lemma lookupVarSet_filterVarSet_true : forall f v vs,
  RespectsVar f ->
  f v = true ->
  lookupVarSet (filterVarSet f vs) v = lookupVarSet vs v.
Proof.
  intros.
  destruct (lookupVarSet (filterVarSet f vs) v) eqn:Hl.
  - revert Hl.
    unfold_VarSet_to_IntMap.
    unfold IntMap.filter.
    symmetry.
    erewrite lookup_filterWithKey.
    + reflexivity.
    + apply Hl.
  - apply lookupVarSet_None_elemVarSet in Hl.
    symmetry.
    apply lookupVarSet_None_elemVarSet.
    set_b_iff.
    intros Hin.
    eapply filter_3 in Hin; eauto.
Qed.

Lemma lookupVarSet_filterVarSet_false : forall f v vs,
  RespectsVar f ->
  f v = false ->
  lookupVarSet (filterVarSet f vs) v = None.
Proof.
  intros.
  apply lookupVarSet_None_elemVarSet.
  set_b_iff.
  rewrite filter_iff; [|auto].
  intros [H1 H2].
  rewrite H0 in H2.
  inversion H2.
Qed.

Lemma unionVarSet_filterVarSet f vs1 vs2 :
  RespectsVar f ->
  unionVarSet (filterVarSet f vs1) (filterVarSet f vs2) [=] filterVarSet f (unionVarSet vs1 vs2).
Proof.
  move=> g.
  set_b_iff.
  rewrite <- filter_union.
  reflexivity.
  eauto.
Qed.

Lemma filterVarSet_delVarSet f vs v :
  RespectsVar f ->
  filterVarSet f (delVarSet vs v) [=]
  delVarSet (filterVarSet f vs) v.
Proof.
  move=> Ff. unfold RespectsVar in Ff.
  set_b_iff.
  unfold Equal.
  move=> x.
  rewrite filter_iff; auto.
  rewrite remove_iff; auto.
  rewrite remove_iff; auto.
  rewrite filter_iff; auto.
  fsetdec.
Qed.

Lemma filterVarSet_delVarSetList:
  forall (f : Var -> bool)  (vars : list Var) (vs : VarSet),
  RespectsVar f ->
  filterVarSet f (delVarSetList  vs vars) [=] delVarSetList (filterVarSet f vs) vars.
Proof.
  induction vars.
  - move=> vs h. hs_simpl. reflexivity.
  - move=> vs h.  hs_simpl.
    rewrite IHvars; try done.
    rewrite <- filterVarSet_delVarSet; try done.
Qed.

(** ** [unionVarSet] *)

Lemma unionVarSet_sym vs1 vs2 : unionVarSet vs1 vs2 [=] unionVarSet vs2 vs1.
Proof. set_b_iff. fsetdec. Qed.

Lemma unionEmpty_l : forall vs,
    unionVarSet emptyVarSet vs [=] vs.
Proof. set_b_iff. fsetdec. Qed.
Lemma unionEmpty_r : forall vs,
    unionVarSet vs emptyVarSet [=] vs.
Proof. set_b_iff. fsetdec. Qed.
Lemma unionSingle_l : forall x s,
    unionVarSet (unitVarSet x) s [=] extendVarSet s x.
Proof. intros. set_b_iff. fsetdec. Qed.
Lemma unionSingle_r : forall x s,
    unionVarSet s (unitVarSet x) [=] extendVarSet s x.
Proof. intros. set_b_iff. fsetdec. Qed.

Hint Rewrite unionEmpty_l unionEmpty_r
     unionSingle_l unionSingle_r :
  hs_simpl.

(** ** [unionVarSets] *)

Lemma unionVarSet_commute (ss : list VarSet) : forall v a,
      unionVarSet v (Foldable.foldr unionVarSet a ss)
  [=] unionVarSet a (Foldable.foldr unionVarSet v ss).
Proof.
  induction ss.
  + intros v a. hs_simpl. eapply unionVarSet_sym.
  + intros v b. hs_simpl.
    rewrite (IHss a b).
    rewrite (IHss a v).
    fsetdec.
Qed.

Lemma unionVarSets_cons a ss : unionVarSets (a :: ss) [=] unionVarSet a (unionVarSets ss).
Proof.
  unfold unionVarSets.
  unfold UniqSet.unionManyUniqSets.
  destruct ss.
  + hs_simpl. reflexivity.
  + hs_simpl. rewrite unionVarSet_commute.
    reflexivity.
Qed.
Hint Rewrite unionVarSets_cons : hs_simpl.

Lemma unionVarSets_def ss :
  unionVarSets ss [=] Foldable.foldr unionVarSet emptyVarSet ss.
Proof.
  induction ss. cbv. done.
  hs_simpl.
  rewrite IHss. reflexivity.
Qed.

Lemma unionsVarSet_equal : forall vss1 vss2, Forall2 Equal vss1 vss2 ->
  (Foldable.foldr unionVarSet emptyVarSet) vss1 [=]
  (Foldable.foldr unionVarSet emptyVarSet) vss2.
Proof.
  move=>vss1 vss2.
  elim.
  hs_simpl. reflexivity.
  move=> x y l l' Eq1 Eq2 IH.
  hs_simpl.
  f_equiv; auto.
Qed.

Instance unionsVarSet_m :
   Proper (Forall2 Equal ==> Equal) unionVarSets.
Proof.
  move=> vss1 vss2 Eq.
  rewrite unionVarSets_def. rewrite unionVarSets_def.
  eapply unionsVarSet_equal. auto.
Defined.

Lemma delVarSet_unionVarSets ss x :
  delVarSet (unionVarSets ss) x [=] unionVarSets (List.map (fun s => delVarSet s x) ss).
Proof.
  induction ss.
  + cbv. done.
  + hs_simpl.
    rewrite delVarSet_unionVarSet. rewrite IHss.
    rewrite unionVarSets_cons.
    unfold map. reflexivity.
Qed.

Lemma mapUnionVarSet_cons {A} f (x:A) xs :
  mapUnionVarSet f (x :: xs) [=] unionVarSet (f x) (mapUnionVarSet f xs).
Proof.
  unfold mapUnionVarSet.
  hs_simpl. unfold Base.op_z2218U__.
  reflexivity.
Qed.

Lemma mapUnionVarSets_unionVarSets {A} (f : A -> VarSet) ss :
  mapUnionVarSet f ss [=] unionVarSets (List.map f ss).
Proof.
  induction ss. cbv. done.
  rewrite mapUnionVarSet_cons.
  rewrite unionVarSets_cons.
  rewrite IHss.
  reflexivity.
Qed.

(** ** [minusVarSet] *)

Lemma minusVarSet_emptyVarSet vs :
  minusVarSet vs emptyVarSet = vs.
Proof.
  unfold minusVarSet, emptyVarSet.
  unfold UniqSet.minusUniqSet, UniqSet.emptyUniqSet.
  elim: vs => [i].
  elim: i => [m].
  unfold UniqFM.minusUFM, UniqFM.emptyUFM.
  f_equal.
  f_equal.
  unfold IntMap.empty.
  rewrite difference_nil_r.
  reflexivity.
Qed.

Hint Rewrite minusVarSet_emptyVarSet : hs_simpl.

Lemma minusVarSet_emptyVarSet_l vs :
  minusVarSet emptyVarSet vs = emptyVarSet.
Proof.
  unfold minusVarSet, emptyVarSet.
  unfold UniqSet.minusUniqSet, UniqSet.emptyUniqSet.
  elim: vs => [i].
  elim: i => [m].
  unfold UniqFM.minusUFM, UniqFM.emptyUFM.
  f_equal.
  f_equal.
  unfold IntMap.empty.
  rewrite difference_nil_l.
  reflexivity.
Qed.

Hint Rewrite minusVarSet_emptyVarSet_l : hs_simpl.

Lemma elemVarSet_minusVarSetTrue : forall x s,
  elemVarSet x s = true ->
  minusVarSet (unitVarSet x) s [=] emptyVarSet.
Proof. intros. set_b_iff.
       split; try fsetdec.
       move=> h.
       move: (diff_1 _ _ _ h) => h1.
       move: (diff_2 _ _ _ h) => h2.
       inversion h1. clear h1.
       unfold IntMap.member, Internal.member in H1; simpl in H1.
       destruct (compare _ _) eqn:H2 in H1;
         try solve [inversion H1].
       apply Bounds.compare_Eq in H2.
       rewrite <- var_eq_realUnique in H2.
       rewrite -> fold_is_true in H2.
       unfold In in H, h2.
       rewrite (@elemVarSet_eq a x) in h2; done.
Qed.

Lemma elemVarSet_minusVarSetFalse : forall x s,
  elemVarSet x s = false ->
  minusVarSet (unitVarSet x) s [=] unitVarSet x.
Proof.
  intros.
  set_b_iff.
  split; try fsetdec.
  move=> h.
  apply diff_3; try done.
  inversion h.
  unfold In, singleton in *.
  rewrite  (@elemVarSet_eq x a) in H; try done.
  rewrite var_eq_realUnique.
  unfold IntMap.member, Internal.member in H1; simpl in H1.
  destruct (compare _ _) eqn:H2 in H1; try solve [inversion H1].
  apply Bounds.compare_Eq in H2.
  rewrite Eq_sym; done.
Qed.

Lemma elemVarSet_minusVarSet x vs1 vs2 :
  elemVarSet x (minusVarSet vs1 vs2) = elemVarSet x vs1 && ~~ elemVarSet x vs2.
Proof.
  rewrite eqE.
  set_b_iff.
  rewrite F.diff_iff.
  split.
  move => [h1 h2]. apply /andP. split. auto.
  apply /negPf.
  set_b_iff. auto.
  move => /andP [h1 h2].
  move: h2 => /negPf => h2.
  set_b_iff. auto.
Qed.

Lemma unionVarSet_minusVarSet vs1 vs2 vs :
  unionVarSet (minusVarSet vs1 vs) (minusVarSet vs2 vs) [=]
  minusVarSet (unionVarSet vs1 vs2) vs.
Proof.
  unfold Equal.
  move=> x.
  unfold In.
  rewrite! elemVarSet_minusVarSet.
  rewrite! elemVarSet_unionVarSet.
  rewrite! elemVarSet_minusVarSet.
  rewrite! andb_orb_distrib_l.
  reflexivity.
Qed.

(** ** Compatibility with [almostEqual] *)

Lemma lookupVarSet_ae :
  forall vs v1 v2,
    almostEqual v1 v2 ->
    lookupVarSet vs v1 = lookupVarSet vs v2.
Proof.
  induction 1; simpl; unfold UniqFM.lookupUFM; simpl; auto.
Qed.

Lemma delVarSet_ae:
  forall vs v1 v2,
  almostEqual v1 v2 ->
  delVarSet vs v1 = delVarSet vs v2.
Proof.
  induction 1; simpl;
  unfold UniqFM.delFromUFM; simpl; auto.
Qed.

Lemma elemVarSet_ae:
  forall vs v1 v2,
  almostEqual v1 v2 ->
  elemVarSet v1 vs = elemVarSet v2 vs.
Proof.
  induction 1; simpl;
  unfold UniqFM.delFromUFM; simpl; auto.
Qed.

Lemma elemNegbDisjoint : forall vs vs2,
    disjointVarSet vs (mkVarSet vs2) ->
    forall v, Foldable.elem v vs2 -> negb (elemVarSet v vs).
Proof.
  move=> vs.
  elim => [|x xs IHxs].
  - move => ? v. hs_simpl. done.
  - rewrite disjointVarSet_mkVarSet_cons.
    move => [h1 h2] v.
    hs_simpl.
    move => /orP [h3|h3].
    erewrite (@elemVarSet_eq x v) in h1.
    rewrite h1. done.
    symmetry. done.
    apply IHxs; try done.
Qed.

Lemma Forall2_diag:
  forall a P (xs: list a),
  Forall2 P xs xs <-> Forall (fun x => P x x) xs.
Proof.
  intros.
  induction xs.
  * split; intro; constructor.
  * split; intro H; constructor; inversion H; intuition.
Qed.

Lemma lookupVarSet_delVarSet_None:
  forall v vs, lookupVarSet (delVarSet vs v) v = None.
Proof.
  intros.
  unfold lookupVarSet,
  UniqSet.lookupUniqSet,
  UniqFM.lookupUFM.
  unfold delVarSet,
  UniqSet.delOneFromUniqSet,
  UniqFM.delFromUFM.
  destruct vs.
  destruct getUniqSet'.
  simpl.
  apply delete_eq.
Qed.

(* A list of variables is fresh for a given varset when
   any variable with a unique found in the list is not found
   in the set. i.e. this is list membership using GHC.Base.==
   for vars.
*)

Definition freshList (vars: list Var) (vs :VarSet) :=
  (forall (v:Var), Foldable.elem v vars  ->
              lookupVarSet vs v = None).

Lemma freshList_nil : forall v,  freshList nil v.
Proof.
  unfold freshList. intros v v0 H. inversion H.
Qed.

Lemma freshList_cons : forall (x:Var) l (v:VarSet),
    lookupVarSet v x = None /\ freshList l v <-> freshList (x :: l) v.
Proof.
  unfold freshList. intros.
  split.
  + intros [? ?] ? ?.
    rewrite elem_cons in H1.
    destruct (orb_prop _ _ H1) as [EQ|IN].
    rewrite -> lookupVarSet_eq with (v2 := x); auto.
    eauto.
  + intros. split.
    eapply H.
    rewrite elem_cons.
    eapply orb_true_intro.
    left. eapply Base.Eq_refl.
    intros.
    eapply H.
    rewrite elem_cons.
    eapply orb_true_intro.
    right. auto.
Qed.

Lemma freshList_app :
  forall v l1 l2, freshList (l1 ++ l2) v <-> freshList l1 v /\ freshList l2 v.
Proof.
  intros.
  induction l1; simpl.
  split.
  intros. split. apply freshList_nil. auto.
  tauto.
  split.
  + intros.
    rewrite <- freshList_cons in *. tauto.
  + intros.
    rewrite <- freshList_cons in *. tauto.
Qed.

Lemma elemVarSet_unitVarSet_is_eq :
  forall x v, elemVarSet x (unitVarSet v) = GHC.Base.op_zeze__ x v.
Proof.
  intros.
  destruct (GHC.Base.op_zeze__ x v) eqn:Hcomp.
  - apply varUnique_iff in Hcomp; inversion Hcomp.
    cbn. rewrite H0 N.compare_refl =>//.
  - apply ssrbool.negbT, notE in Hcomp.
    cbn. apply not_true_iff_false.
    destruct (N.compare _ _) eqn:Hcomp'; auto.
    contradiction Hcomp.
    apply varUnique_iff. rewrite /varUnique.
    f_equal. apply N.compare_eq_iff =>//.
Qed.

(** A very specialized [Proper] instance, written for the sole purpose
    of proving [delVarSetList_commute]. *)
Instance foldl_m :
  Proper (Equal ==> (fun (a b : list Var) => a = b) ==> Equal)
         (Foldable.foldl delVarSet).
Proof.
  intros s1 s2 Heqs l1 l2 Heql; subst.
  generalize dependent s2.
  generalize dependent s1.
  induction l2.
  - rewrite /Foldable.foldl //=.
  - intros s1 s2 Heqs. rewrite !Foldable_foldl_cons.
    apply IHl2. rewrite Heqs. reflexivity.
Qed.

Lemma delVarSetList_commute :forall (bndrs:list Var) vs bndr,
  Foldable.foldl delVarSet (delVarSet vs bndr) bndrs [=]
  delVarSet (Foldable.foldl delVarSet vs bndrs) bndr.
Proof.
  elim => [|bndr' bndrs].
  - move=> vs bndr. hs_simpl. reflexivity.
  - move=> IH vs bndr.
    hs_simpl.
    rewrite delVarSet_commute.
    eapply IH.
Qed.

(** A [Proper] instance, written for the sole purpose
    of proving [delVarSetList_commute]. *)
Instance foldr_m :
  Proper (((fun x y => (x == y)) ==> Equal ==> Equal) ==> Equal ==> (fun (a b : list Var) => a = b) ==> Equal)
         Foldable.foldr.
Proof.
  intros f1 f2 Hf s1 s2 Heqs l1 l2 Heql; subst.
  generalize dependent s2.
  generalize dependent s1.
  induction l2.
  - rewrite /Foldable.foldr //=.
  - intros s1 s2 Heqs. rewrite !Foldable_foldr_cons.
    specialize (IHl2 s1 s2 Heqs).
    eapply Hf. reflexivity.
    eapply IHl2.
Qed.

(** A [Proper] instance, written for showing that folding a unionVarSet like term  *)
Instance foldr_mE :
  Proper ((Equal ==> Equal ==> Equal) ==> Equal ==> (Forall2 Equal) ==> Equal)
         Foldable.foldr.
Proof.
  intros f1 f2 Hf s1 s2 Heqs l1 l2 Heql; subst.
  generalize dependent s2.
  generalize dependent s1.
  generalize dependent l1.
  induction l2.
  - move=> l1 Heql. inversion Heql. rewrite /Foldable.foldr //=.
  - move=> l1 Heql. inversion Heql. subst.
    intros s1 s2 Heqs. rewrite !Foldable_foldr_cons.
    specialize (IHl2 _ H3 s1 s2 Heqs).
    eapply Hf. auto.
    eapply IHl2.
Qed.

Lemma delVarSetList_commute_foldr : forall (bndrs:list Var) vs bndr,
  Foldable.foldr (fun x y => delVarSet y x) (delVarSet vs bndr) bndrs [=]
  delVarSet (Foldable.foldr (fun x y => delVarSet y x) vs bndrs) bndr.
Proof.
  elim => [|bndr' bndrs].
  - move=> vs bndr. hs_simpl. reflexivity.
  - move=> IH vs bndr.
    hs_simpl.
    rewrite delVarSet_commute.
    rewrite IH. reflexivity.
Qed.

Lemma delVarSetList_foldr ss xs :
  delVarSetList ss xs [=] Foldable.foldr (fun x ss => delVarSet ss x) ss xs.
Proof.
  generalize dependent ss.
  induction xs.
  cbv. destruct ss. auto.
  - move=> ss. hs_simpl.
    rewrite <- delVarSetList_commute_foldr.
    rewrite <- IHxs.
    reflexivity.
Qed.


(*******************************************************************
 * Este archivo especifica el estado.
 *
 ******************************************************************)

Require Export Maps.

Section State.

(** Identificadores de OSs e Hypercalls *)

Parameter os_ident : Set.
Parameter os_ident_eq : forall oi1 oi2 : os_ident, {oi1 = oi2} + {oi1 <> oi2}.

Parameter Hyperv_call: Set.

(* Memoria y direcciones *)

(* Direcciones Virtuales. *)
Parameter vadd: Set.
Parameter vadd_eq : forall va1 va2 : vadd, {va1 = va2} + {va1 <> va2}.

(** Direcciones de Máquina. *)
Parameter madd :  Set.
Parameter madd_eq : forall ma1 ma2 : madd, {ma1 = ma2} + {ma1 <> ma2}.

(** Direcciones Físicas :
Los sitemas operativos utilizan este tipo de direcciones para ver regiones de memoriea
contigua. Estos no ven direcciones de máquina. *)
Parameter padd: Set.
Parameter padd_eq : forall pa1 pa2 : padd, {pa1 = pa2} + {pa1 <> pa2}.

(** Memory values. *)
Parameter value: Set.
Parameter value_eq:forall val1 val2 : value, {val1 = val2} + {val1 <> val2}.

(* Environment *)
Record context : Set :=
  Context
    {(** una dirección virtual es accesible, i.e. no está reserveda
         por el Hypervisor *)
       ctxt_vadd_accessible: vadd -> bool;
     (** guest Oss (Confiable/No Confiable) **)
       ctxt_oss : os_ident -> bool
    }.

(* Ejercicio 1 *)
Inductive exec_mode : Set :=
  | usr : exec_mode
  | svc : exec_mode.

Record os : Set :=
  Os
    {
      curr_page : padd;
      hcall : option Hyperv_call
    }.

Definition oss_map := mapping os_ident os.

Inductive os_activity : Set :=
  | running : os_activity
  | waiting : os_activity.

Definition hypervisor_map := mapping os_ident (mapping padd madd).

Inductive content : Set :=
  | RW : option value -> content
  | PT : mapping vadd madd -> content
  | Other : content.

Inductive page_owner : Set :=
  | Hyp : page_owner
  | OS : os_ident -> page_owner
  | No_Owner : page_owner.

Record page : Set :=
  Page
    {
      page_content : content;
      page_owned_by : page_owner
    }.

Definition system_memory := mapping madd page.

Record state : Set :=
  State
    {
      active_os : os_ident;
      aos_exec_mode : exec_mode;
      aos_activity : os_activity;
      oss : oss_map;
      hypervisor : hypervisor_map;
      memory : system_memory
    }.

End State.


(** * Generation of a H-VHDL top-level design from an SITPN model *)

Require Import common.CoqLib.
Require Import common.GlobalTypes.
Require Import common.ListPlus.
Require Import common.ListDep.
Require Import common.StateAndErrorMonad.
Require Import common.ListMonad.
Require Import String.

Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.Petri.
Require Import hvhdl.HVhdlTypes.

Require Import sitpn.Sitpn.

Require Import transformation.Sitpn2HVhdlTypes.
Require Import transformation.GenerateInfos.
Require Import transformation.GenerateArchitecture.
Require Import transformation.GenerateInterconnections.
Require Import transformation.GeneratePorts.

Open Scope abss_scope.

(** ** Transformation from an SITPN to an H-VHDL design *)

Section Sitpn2HVhdl.

  Variable sitpn : Sitpn.

  (* Macro for the state-and-error monad instantiated with the
     compile-time state.  *)

  Definition CompileTimeState := @Mon (Sitpn2HVhdlState sitpn).

  (** ** Generation of an H-VHDL design *)

  (** Defines the transformation function that generates an H-VHDL design
      from an SITPN. *)

  Definition generate_design_and_binder : CompileTimeState (design * Sitpn2HVhdlBinder sitpn):=
    do s <- Get; Ret ((design_ [] (ports s) (sigs s) (beh s)), (γ s)).

  Definition sitpn2hvhdl (b : P sitpn -> nat) :
    (design * Sitpn2HVhdlBinder sitpn) + string :=
    RedV
      ((do _ <- generate_sitpn_infos sitpn;
        do _ <- generate_architecture b;
        do _ <- generate_interconnections;
        do _ <- generate_ports;
        generate_design_and_binder) (InitS2HState sitpn Petri.ffid)).

End Sitpn2HVhdl.

Require Import FunInd.

Functional Scheme sitpn2hvhdl_ind := Induction for sitpn2hvhdl Sort Prop.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq ssrnat.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext machine_int multi_int.
Import MachineInt.
Require Import uniq_tac.
Require Import mips_seplog mips_tactics mips_contrib mapstos.
Require Import multi_sub_u_u_prg.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope multi_int_scope.
Local Open Scope zarith_ext_scope.

Section multi_sub.

Variables k a b t j u bor atmp btmp : reg.

Lemma multi_sub_u_u_L_triple : uniq(k, a, b, t, j, u, bor, atmp, btmp, r0) ->
forall nk va vb, u2Z va + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk ->
{{ fun s h => [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B) s h }}
 multi_sub_u_u k a b a t j u bor atmp btmp
{{ fun s h => exists A', size A' = nk /\ [a]_s = va /\ [b]_s = vb /\
  u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [bor]_s <= 1 /\
  \S_{ nk } A' = \S_{ nk } A - \S_{ nk } B + u2Z [bor]_s * \B^nk }}.
Proof.
move=> Hset nk va vb Hna A B Ha Hb; rewrite /multi_sub_u_u.

(** addiu j zero zero16; *)

NextAddiu.
move=> s h [Hra [Hrb [Hrk H]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** addi t c zero16 *)

NextAddiu.
move=> s h [[Hra [Hrb [Hrk H]]] Hj].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** addi bor zero zero16; *)

NextAddiu.
move=> s h [[[Hra [Hrb [Hrk H]]] Hj] Ht].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** while (bne j k) ( *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj <= nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj A = drop nj A').

move=> s h [[[[Hra [Hrb [Hrk H]]] Hj] Ht Hbor]].
exists A, O, 0; repeat (split => //).
by rewrite store.get_r0 add0i sext_Z2u // Z2uK in Hj.
rewrite Ht sext_0 addi0 Hra //; ring.
by rewrite Hbor sext_0 addi0 // store.get_r0 Z2uK.

move=> s h [[A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv Hnth]]]]]]]]]]]]] Hjk]].
rewrite /= Hrj Hrk in Hjk. move/negPn/eqP/Z_of_nat_inj in Hjk; subst nj.
exists A'; repeat (split; trivial).
by rewrite Hrbor.
by rewrite Hrbor -HInv.

(** lwxs atmp j b; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj A = drop nj A' /\ [atmp]_s = B `32_ nj).

move=> s h [ [A' [nj [nbor [HlenA' [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv Hnth]]]]]]]]]]]]] Hjk]].
rewrite /= in Hjk; move/eqP in Hjk.

exists (B `32_ nj); split.
- Decompose_32 B nj B1 B2 HlenB' HB'; last by ssromega.
  rewrite HB' (decompose_equiv _ _ _ _ _ HlenB') in Hmem.
  rewrite assert_m.conCE !assert_m.conAE in Hmem.
  rewrite assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u Hrj inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

ssromega.

(** addu btmp atmp bor; *)

apply hoare_addu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj A = drop nj A' /\ [atmp]_s = B `32_ nj /\
  [btmp]_s = B `32_ nj `+ [bor]_s).

move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth Hratmp]]]]]]]]]]]]]]].

exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hratmp.

(** sltu btmp atmp; *)

apply hoare_sltu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  drop nj A = drop nj A' /\
  [btmp]_s = B `32_ nj `+ [bor]_s /\
  [u]_s = if Zlt_bool (u2Z [btmp]_s) (u2Z (B `32_ nj)) then one32 else zero32).

move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hratmp Hrbtmp]]]]]]]]]]]]]]]].

exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hratmp.

(** lwxs atmp j a; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\ u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\
  u2Z [bor]_s = nbor /\ nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj  /\
  drop nj A = drop nj A' /\ [atmp]_s = A `32_ nj /\
  [btmp]_s = B `32_ nj `+ [bor]_s /\
  [u]_s = if Zlt_bool (u2Z [btmp]_s) (u2Z (B `32_ nj)) then one32 else zero32).

move=> s h [A' [nj [nbor [HlenA' [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hrbtmp Hru]]]]]]]]]]]]]]]].
exists (A' `32_ nj); split.
- Decompose_32 A' nj A'1 A'2 HlenA'1 HA''; last by ssromega.
  rewrite HA'' (decompose_equiv _ _ _ _ _ HlenA'1) !assert_m.conAE assert_m.conCE
    !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u Hrj inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  rewrite (drop_nth zero32) in Hnth; last by ssromega.
  symmetry in Hnth.
  rewrite (drop_nth zero32) in Hnth; last by ssromega.
  by case: Hnth.

(** ifte_beq u, zero thendo *)

apply while.hoare_seq with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ drop nj A = drop nj A' /\
  u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } A' + u2Z [atmp]_s * \B^nj =
  \S_{ nj } A - \S_{ nj } B + u2Z (A `32_ nj) * \B^nj - u2Z (B `32_ nj) * \B^nj + nbor * \B^nj.+1).

apply while.hoare_ifte.

(** addiu u r0 one16; *)

apply hoare_addiu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\ drop nj A = drop nj A' /\ [btmp]_s = B `32_ nj `+ [bor]_s /\
  u2Z [btmp]_s = u2Z (B `32_ nj) + nbor).

move=> s h [ [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hratmp [Hrbtmp Hru]]]]]]]]]]]]]]]]] Huzero]; rewrite /= in Huzero.
exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.
rewrite Hrbtmp -Hrbor u2Z_add //.
apply u2Z_add_no_overflow.
rewrite -Hrbtmp.
apply Znot_gt_le; move/Z.gt_lt/ltZP => X.
by rewrite Hru X Z2uK // Z2uK in Huzero.

(** multu atmp one; *)

apply hoare_multu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
  nbor <= 1 /\ \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\ drop nj A = drop nj A' /\ [btmp]_s = B `32_ nj `+ [bor]_s /\
  u2Z [btmp]_s = u2Z (B `32_ nj) + nbor /\ store.utoZ s = u2Z (A `32_ nj)).

move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrone [Hrj [Hjk2 [Hrt [Hrbor [Hnbor [HInv [Hnth [Hratmp [Hrbtmp Hru]]]]]]]]]]]]]]]]]].
exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.utoZ_multu Hnth Hrone umul_1 (@u2Z_zext 32).

(** msubu btmp one; *)

apply hoare_msubu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  [u]_s = one32 /\ u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\ nbor <= 1 /\
  \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\ [atmp]_s = A `32_ nj /\
  drop nj A = drop nj A' /\
  [btmp]_s = B `32_ nj `+ [bor]_s /\ u2Z [btmp]_s = u2Z (B `32_ nj) + nbor /\
  ((u2Z [btmp]_s <= u2Z (A `32_ nj) -> store.utoZ s = u2Z (A `32_ nj) - u2Z [btmp]_s) /\
   (u2Z (A `32_ nj) < u2Z [btmp]_s -> store.utoZ s = \B^ 2 + u2Z (A `32_ nj) - u2Z [btmp]_s))).

move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hone [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hratmp [Hnth [Hrbtmp [Hrbtmp2 Hm]]]]]]]]]]]]]]]]]]].
exists A', nj, nbor.
rewrite Hone umul_1.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
move=> H; rewrite store.msubu_utoZ Hm ?(@u2Z_zext 32) //.
apply (@ltZ_trans (\B^1)); by [apply max_u2Z | ].
exact/Z.le_ge.
move=> H; rewrite store.msubu_utoZ_overflow Hm ?(@u2Z_zext 32) //.
apply (@ltZ_trans (\B^1)); by [exact: max_u2Z | ].

(** sltu bor atmp btmp; *)

apply hoare_sltu with (fun s h => exists A' nj nbor,
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A' ** var_e b |--> B) s h /\
  u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
  u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ nbor <= 1 /\
  \S_{ nj } A' = \S_{ nj } A - \S_{ nj } B + nbor * \B^nj /\
  [atmp]_s = A `32_ nj /\
  drop nj A = drop nj A' /\
  [btmp]_s = B `32_ nj `+ Z2u 32 nbor /\
  u2Z [btmp]_s = u2Z (B `32_ nj) + nbor /\
  (u2Z [btmp]_s <= u2Z (A `32_ nj) -> store.utoZ s = u2Z (A `32_ nj) - u2Z [btmp]_s) /\
  (u2Z (A `32_ nj) < u2Z [btmp]_s -> store.utoZ s = \B^2 + u2Z (A `32_ nj) - u2Z [btmp]_s) /\
  [bor]_s = if Zlt_bool (u2Z (A `32_ nj)) (u2Z [btmp]_s) then one32 else zero32).

move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hone [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hratmp [Hnth [Hrbtmp [Hrbtmp2 [Hinv1 Hinv2]]]]]]]]]]]]]]]]]]]].

exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite -Hrbor Z2u_u2Z.
by rewrite -Hratmp.

(** mflhxu atmp *)

apply hoare_mflhxu'.
move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem  [Hrj [Hjk [Hrt [Hnbor [Hinv [Hratmp [Hrbtmp [Hnth [Hrbtmp2 [Hm1 [Hm2 Hrbor]]]]]]]]]]]]]]]]]]].

case: (Z_lt_le_dec (u2Z (A `32_ nj)) (u2Z [btmp]_s)).
- move/ltZP => X.
  rewrite X in Hrbor.
  move/ltZP in X.
  exists A', nj, (u2Z one32); repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite Hrbor.
  by rewrite Z2uK.
  move: {Hm1 Hm2}(Hm2 X) => Hm.
  have Hacx0 : store.acx s = Z2u store.acx_size 0 by apply store.utoZ_acx_beta2; rewrite Hm; lia.
  rewrite store.utoZ_def Hacx0{Hacx0} Z2uK // in Hm.
  rewrite mul0Z addZ0 in Hm.
  rewrite (_ : \B^2 = \B^1 * (\B^1 - 1) + \B^1) // addZC (mulZC (\B^1)) in Hm.
  rewrite (_ : forall a b c d, a + b + c - d = a + (b + c - d)) in Hm; last by (move=> *; ring).
  apply poly_eq_inv in Hm; last first.
    rewrite Zbeta1E.
    split; first exact: min_u2Z.
    split; first by split; [apply min_u2Z | apply max_u2Z].
    split; first by [].
    move: (min_u2Z (A `32_ nj)) (max_u2Z [btmp]_s) => ? ?; lia.
  case: Hm => _ ->.
  rewrite Hinv (Zbeta_S nj) Hrbtmp2 Z2uK //; ring.
- move/leZNgt/ltZP/negbTE => X.
  rewrite X in Hrbor.
  move/ltZP/leZNgt in X.
  exists A', nj, (u2Z zero32); repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite Hrbor.
  by rewrite Z2uK.
  move: {Hm1 Hm2}(Hm1 X) => Hm.
  have Hm_Zbeta1 : store.utoZ s < \B^1.
    move: (max_u2Z (A `32_ nj)) (min_u2Z [btmp]_s).
    rewrite Hm -Zbeta1E => ? ?; lia.
  case/store.utoZ_lo_beta1 : Hm_Zbeta1 => _ [_ <-].
  rewrite Hinv Hm Hrbtmp2 Z2uK //; ring.

(** nop; *)

apply hoare_nop'.

(** we are in the branch where btmp = atmp + bor has overflowed *)

move=> s h [[A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hrbor [Hnbor [Hinv [Hnth [Hratmp [Hrbtmp Hru]]]]]]]]]]]]]]]]] Huzero].
rewrite /= in Huzero. move/negbTE/eqP in Huzero.
exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
have [X1 X2] : nbor = 1 /\ u2Z (B `32_ nj) = \B^1 - 1.
  have H : u2Z [btmp]_s < u2Z (B `32_ nj).
    apply/ltZP.
    apply: Bool.not_false_is_true => X; by rewrite Hru X in Huzero.
  rewrite Hrbtmp in H.
  apply u2Z_add_overflow' in H; rewrite -Zbeta1E in H.
  move: (max_u2Z (B `32_ nj)) => H'; rewrite -Zbeta1E in H'; lia.
rewrite Hratmp Hinv X1 X2 !mul1Z (Zbeta_S nj); ring.

(** sw atmp zero16 t; *)

apply hoare_sw_back'' with (fun s h => exists A' nj nbor,
 size A' = nk /\ [a]_s = va /\ [b]_s = vb /\
 u2Z [k]_s = Z_of_nat nk /\ (var_e a |--> A' ** var_e b |--> B) s h /\
 u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
 u2Z [t]_s = u2Z va + 4 * Z_of_nat nj /\ u2Z [bor]_s = nbor /\
 nbor <= 1 /\ \S_{ S nj } A' = \S_{ S nj } A - \S_{ S nj } B + nbor * \B^nj.+1 /\
 drop (S nj) A = drop (S nj) A').

move=> s h [A' [nj [nbor [HlenA' [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hnth [Hrbor [Hnbor Hinv]]]]]]]]]]]]]].

have Htmp : [ var_e t \+ int_e (sext 16 zero16) ]e_ s = [ var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nj))) ]e_ s.
  rewrite /= sext_Z2u // addi0.
  apply u2Z_inj.
  rewrite u2Z_add_Z_of_nat.
  rewrite inj_mult Hrt Hra; ring.
  rewrite inj_mult -Zbeta1E Hra; simpl Z_of_nat; ssromega.

exists (int_e (A' `32_ nj)).
Decompose_32 A' nj A'1 A'2 HlenA'1 HA''; last by ssromega.

rewrite HA'' (decompose_equiv _ _ _ _ _ HlenA'1) !assert_m.conAE assert_m.conCE
  !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
exact/mapsto_ext.
apply currying => h' H'; simpl app in H'.
exists (upd_nth A' nj [atmp]_s), nj, nbor; repeat (split; trivial).
exact: size_upd_nth.
rewrite HA'' upd_nth_cat HlenA'1 // subnn /= (decompose_equiv _ _ _ _ _ HlenA'1).
rewrite cat0s in H'.
assoc_comm H'.
exact: mapsto_ext H'.

rewrite HA'' -cat1s.
rewrite catA upd_nth_cat'; last by rewrite size_cat /= HlenA'1; ssromega.
rewrite upd_nth_cat; last by rewrite HlenA'1; ssromega.
rewrite HlenA'1 subnn; simpl upd_nth; rewrite -lSum_beyond; last by rewrite size_cat /= HlenA'1 addnC.
rewrite (lSum_cut_last _ A'1) //; last by rewrite size_cat /= HlenA'1 addnC.
rewrite HA'' -lSum_beyond // in Hinv.
rewrite subn1 [_.+1.-1]/= -/(\B^nj) mulZC Hinv.

Decompose_32 A nj A1 A2 HlenA1 HA'; last by ssromega.
rewrite {3}HA' -cat1s.
rewrite -> catA. rewrite -lSum_beyond; last by rewrite size_cat /= HlenA1 addnC.
rewrite (lSum_cut_last _ A1) //; last by rewrite size_cat /= HlenA1 addnC.
rewrite -/(_ `32_ nj) subn1 [_.+1.-1]/=.

Decompose_32 B nj B1 B2 HlenB1 HB'; last by ssromega.
rewrite {3}HB' -[in X in _ = _ + _ - X + _]cat1s.
rewrite -> catA. rewrite -lSum_beyond; last by rewrite size_cat /= HlenB1 addnC.
rewrite (lSum_cut_last _ B1) //; last by rewrite size_cat /= HlenB1 addnC.
rewrite -/(_ `32_ nj) subn1 [_.+1.-1]/=.

rewrite HB' -lSum_beyond //.
have -> : (B1 ++ (B `32_ nj :: B2)) `32_ nj = B `32_ nj.
  by rewrite /nth' nth_cat HlenB1 ltnn subnn.
rewrite HA' -lSum_beyond //.
have -> : (A1 ++ (A `32_ nj :: A2)) `32_ nj = A `32_ nj.
  by rewrite /nth' nth_cat HlenA1 ltnn subnn.
rewrite -ZbetaE /=; ring.

rewrite drop_upd_nth //.
rewrite (drop_nth zero32) in Hnth; last by rewrite Ha.
symmetry in Hnth.
rewrite (drop_nth zero32) in Hnth; last by rewrite HlenA'.
by case: Hnth.

(** addiu t t four16; *)

apply hoare_addiu with (fun s h => exists A' nj nbor,
 size A' = nk /\ [a]_s = va /\ [b]_s = vb /\
 u2Z [k]_s = Z_of_nat nk /\ (var_e a |--> A' ** var_e b |--> B) s h /\
 u2Z [j]_s = Z_of_nat nj /\ (nj < nk)%nat /\
 u2Z [t]_s = u2Z va + 4 * ((Z_of_nat nj) + 1) /\ u2Z [bor]_s = nbor /\
 nbor <= 1 /\ \S_{ S nj } A' = \S_{ S nj } A - \S_{ S nj } B + nbor * \B^nj.+1 /\ drop (S nj) A = drop (S nj) A').

move=> s h [A' [nj [nbor [HlenA' [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hbor [Hnbor [Hinv Hnth]]]]]]]]]]]]]].

exists A', nj, nbor; repeat Reg_upd; repeat (split; trivial).
- by Assert_upd.
- rewrite u2Z_add sext_Z2u // Z2uK //.
  lia.
  rewrite -Zbeta1E; ssromega.

(** addiu j j one16 *)

apply hoare_addiu'.
move=> s h [A' [nj [nbor [HlenC [Hra [Hrb [Hrk [Hmem [Hrj [Hjk [Hrt [Hbor [Hnbor [Hinv Hnth]]]]]]]]]]]]]].

exists A', (S nj), nbor.
rewrite Z_S.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite u2Z_add sext_Z2u // Z2uK //.
- lia.
- move: (min_u2Z va) => ?; rewrite -Zbeta1E; ssromega.
Qed.

Lemma multi_sub_u_u_L_triple_B_le_A : uniq(k, a, b, t, j, u, bor, atmp, btmp, r0) ->
forall nk va vb, u2Z va + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk -> \S_{ nk } B <= \S_{ nk } A ->
{{ fun s h => [a]_s = va /\ [b]_s = vb /\
  u2Z [k]_s = Z_of_nat nk /\
  (var_e a |--> A ** var_e b |--> B) s h }}
 multi_sub_u_u k a b a t j u bor atmp btmp
{{ fun s h => exists A', size A' = nk /\ [a]_s = va /\
   [b]_s = vb /\ u2Z [k]_s = Z_of_nat nk /\
   [bor]_s = zero32 /\
   (var_e a |--> A' ** var_e b |--> B) s h /\
   \S_{ nk } A' = \S_{ nk } A - \S_{ nk } B }}.
Proof.
move=> Hset nk va vb Hna A B Ha Hb HAB.
eapply hoare_prop_m.hoare_weak; last by eapply multi_sub_u_u_L_triple; eauto.
move=> s h [A' [HlenA [Hra [Hrb [Hrk [Hmem [Hbor Hsum]]]]]]].
have X : u2Z [bor]_s = 0.
  have {}Hsum : u2Z [bor ]_ s * \B^nk + (\S_{ nk } A - \S_{ nk } B - \S_{ nk } A') = 0 * \B^nk + 0.
    rewrite Hsum; ring.
  apply poly_eq0_inv in Hsum.
  tauto.
  exact: expZ_ge0.
  move: (min_lSum nk B) (min_lSum nk A') (max_lSum nk A) (max_lSum nk A') => ????.
  rewrite ZbetaE; ssromega.
exists A'; repeat (split => //).
rewrite (_ : 0 = u2Z zero32) in X; last by rewrite Z2uK.
by move/u2Z_inj : X.
rewrite Hsum X mul0Z addZ0; reflexivity.
Qed.

End multi_sub.


Require Import McExamples.PolyRewrite.Monads.Monad.
Require Import McExamples.PolyRewrite.Monads.LtacDemo.

Declare Module M : Monad.Monad.
Declare Module F : Frob M.

Module Automation := LtacDemo.TheMonad M F.
Goal Automation.Demo.goal NNN .
  Automation.Demo.prep.
  Time Automation.Demo.run.
  Automation.Demo.cleanup.
Time Qed.


Require Export Coq.NArith.NArith.

Require Export Bedrock.Memory Bedrock.Word.
Require Export
        Fiat.BinEncoders.Env.Automation.SolverOpt
        Fiat.BinEncoders.Env.BinLib.Bool
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.BinLib.Enum
        Fiat.BinEncoders.Env.BinLib.FixInt
        Fiat.BinEncoders.Env.Common.Compose
        Fiat.BinEncoders.Env.Common.ComposeCheckSum
        Fiat.BinEncoders.Env.Common.ComposeIf
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.WordFacts
        Fiat.BinEncoders.Env.Lib.FixList
        Fiat.BinEncoders.Env.Lib.IList
        Fiat.BinEncoders.Env.Lib2.Bool
        Fiat.BinEncoders.Env.Lib2.EnumOpt
        Fiat.BinEncoders.Env.Lib2.FixListOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.NoCache
        Fiat.BinEncoders.Env.Lib2.SumTypeOpt
        Fiat.BinEncoders.Env.Lib2.Vector
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.IPChecksum.

Unset Implicit Arguments.

Open Scope nat_scope.

Notation BoundedList A size := { ls: list A | List.length ls < size }.
Notation BoundedNat size := { n: nat | (n < pow2 size)%nat }.
Notation BoundedN size := { n: N | (n < FixInt.exp2 size)%N }.

Definition BoundedListLength {A size} (ls : BoundedList A (pow2 size)) : BoundedNat size :=
  exist _ (length (` ls)) (proj2_sig ls).

Section Nat.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {transformer : Transformer B}.
  Context {transformerUnit : TransformerUnitOpt transformer bool}.

  (* TODO move *)
  Definition EncodeBoundedNat {k} (n : BoundedNat k) (ce : CacheEncode) : B * CacheEncode :=
    (* NToWord + N.of_nat needed for performance (otherwise [apply] doesn't terminate) *)
    encode_word_Impl (@NToWord k (N.of_nat (`n))) ce.
End Nat.

(* TODO move *)
Definition BtoW (b: B) : W :=
  (zext b 24).