(*
  NOTE: This proof depends on:

  - mult_commutes in MultCommutes.v
  - left_distributive, plus_p_right in LeftDistributive.v
  - plus_commutes in PlusCommutes.v
*)

(*
  Add load path containing required files -
  feel free to edit path as necessary
*)
Add LoadPath "/path/to/lemmas_and_theorems".

(* Require lemmas and theorems *)
Require Export MultCommutes.
Require Export LeftDistributive.
Require Export PlusCommutes.

Theorem right_distributive : forall n m p : nat, (n + m) * p = n * p + m * p.
Proof.
  intros.
  rewrite mult_commutes.
  rewrite left_distributive.
  rewrite mult_commutes.
  rewrite plus_commutes.
  symmetry.
  rewrite plus_commutes.
  apply plus_p_right.
  rewrite mult_commutes.
  reflexivity.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

Parameter set : forall (a:Type), Type.

Parameter mem: forall (a:Type), a -> (set a) -> Prop.
Implicit Arguments mem.

(* Why3 assumption *)
Definition infix_eqeq (a:Type)(s1:(set a)) (s2:(set a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).
Implicit Arguments infix_eqeq.

Axiom extensionality : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset (a:Type)(s1:(set a)) (s2:(set a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).
Implicit Arguments subset.

Axiom subset_trans : forall (a:Type), forall (s1:(set a)) (s2:(set a))
  (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).

Parameter empty: forall (a:Type), (set a).
Set Contextual Implicit.
Implicit Arguments empty.
Unset Contextual Implicit.

(* Why3 assumption *)
Definition is_empty (a:Type)(s:(set a)): Prop := forall (x:a), ~ (mem x s).
Implicit Arguments is_empty.

Axiom empty_def1 : forall (a:Type), (is_empty (empty :(set a))).

Parameter add: forall (a:Type), a -> (set a) -> (set a).
Implicit Arguments add.

Axiom add_def1 : forall (a:Type), forall (x:a) (y:a), forall (s:(set a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall (a:Type), a -> (set a) -> (set a).
Implicit Arguments remove.

Axiom remove_def1 : forall (a:Type), forall (x:a) (y:a) (s:(set a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall (a:Type), forall (x:a) (s:(set a)),
  (subset (remove x s) s).

Parameter union: forall (a:Type), (set a) -> (set a) -> (set a).
Implicit Arguments union.

Axiom union_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall (a:Type), (set a) -> (set a) -> (set a).
Implicit Arguments inter.

Axiom inter_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall (a:Type), (set a) -> (set a) -> (set a).
Implicit Arguments diff.

Axiom diff_def1 : forall (a:Type), forall (s1:(set a)) (s2:(set a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (subset (diff s1 s2) s1).

Parameter all: forall (a:Type), (set a).
Set Contextual Implicit.
Implicit Arguments all.
Unset Contextual Implicit.

Axiom all_def : forall (a:Type), forall (x:a), (mem x (all :(set a))).

Parameter cardinal: forall (a:Type), (set a) -> Z.
Implicit Arguments cardinal.

Axiom cardinal_nonneg : forall (a:Type), forall (s:(set a)),
  (0%Z <= (cardinal s))%Z.

Axiom cardinal_empty : forall (a:Type), forall (s:(set a)),
  ((cardinal s) = 0%Z) <-> (is_empty s).

Axiom cardinal_add : forall (a:Type), forall (x:a), forall (s:(set a)),
  (~ (mem x s)) -> ((cardinal (add x s)) = (1%Z + (cardinal s))%Z).

Axiom cardinal_remove : forall (a:Type), forall (x:a), forall (s:(set a)),
  (mem x s) -> ((cardinal s) = (1%Z + (cardinal (remove x s)))%Z).

Axiom cardinal_subset : forall (a:Type), forall (s1:(set a)) (s2:(set a)),
  (subset s1 s2) -> ((cardinal s1) <= (cardinal s2))%Z.

Parameter take: forall (a:Type), (set a) -> a.
Implicit Arguments take.

Axiom take_def : forall (a:Type), forall (x:(set a)), (~ (is_empty x)) ->
  (mem (take x) x).

Axiom set_preserve_union : forall (a:Type), forall (a1:(set a)) (b:(set a))
  (e:a), (mem e a1) -> ((union (remove e a1) (add e b)) = (union a1 b)).

(* Why3 goal *)
Theorem set_preserve_inter : forall (a:Type), forall (a1:(set a)) (b:(set a))
  (e:a), ((mem e a1) /\ ~ (mem e b)) -> ((inter (remove e a1) (add e
  b)) = (inter a1 b)).

Require Import Classical.

intuition.
apply extensionality.
compute.
intuition; apply inter_def1 in H; apply inter_def1; destruct H.

apply remove_def1 in H.
apply add_def1 in H2.
destruct (classic (e = x)); subst; tauto.

destruct (classic (e = x)); subst; intuition.
apply remove_def1; intuition.
apply add_def1; intuition.

Qed.


Set Implicit Arguments.
Require Import Prelude.
Require Import InfrastructureFV.
Require Import InfrastructureOpen.
Require Import TLC.LibLogic.
Require Import TLC.LibLN.
(* large portions of this are based on the TLC formalisation of FSub *)

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_typ T -> subst_tt Z U T = T.
Proof.
  induction T using typ_ind' ; simpl; intros; f_equal*.
  - case_var*.
  - symmetry.
    apply map_id.
    introv Lin.
    handleforall.
    symmetry.
    apply* Hforall.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1 using typ_ind' ; intros k; simpls; f_equal*.
  - crush_compare.
  - case_var*. rewrite* <- open_tt_rec_type.
  - rewrite* List.map_map.
    rewrite* List.map_map.
    apply List.map_ext_in.
    handleforall.
    introv Lin.
    apply* Hforall.
Qed.

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_typ T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

Lemma subst_commutes_with_unrelated_opens : forall Xs T V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_tt Y V (open_tt_many_var Xs T) =
    (open_tt_many_var Xs (subst_tt Y V T)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_tt_many_var Xt (T open_tt_var Xh)).
    fold (open_tt_many_var Xt (subst_tt Y V T open_tt_var Xh)).
    rewrite* subst_tt_open_tt_var; eauto with listin.
Qed.

Lemma subst_intro_commutes_opens : forall Xs T Y V,
    Y \notin fv_typ T ->
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    open_tt_many_var Xs (open_tt T V) =
    subst_tt Y V (open_tt_many_var Xs (T open_tt_var Y)).
  induction Xs as [| Xh Xt]; introv Hfv Hneq Htyp.
  - cbn. apply* subst_tt_intro.
  - cbn.
    fold (open_tt_many_var Xt (open_tt T V open_tt_var Xh)).
    fold (open_tt_many_var Xt ((T open_tt_var Y) open_tt_var Xh)).
    rewrite* subst_commutes_with_unrelated_opens.
    f_equal.
    rewrite* <- subst_tt_open_tt_var.
    + rewrite* <- subst_tt_intro.
    + apply* Hneq. cbn; eauto.
    + eauto with listin.
Qed.

Lemma sublist_tail_prop : forall A (Uh : A) (Ut : list A) (P : A -> Prop),
  (forall U : A, List.In U (Uh :: Ut) -> P U) ->
  forall U : A, List.In U Ut -> P U.
  introv Hbigger Hin.
  apply* Hbigger.
  cbn.
  eauto.
Qed.

Lemma sublist_head_prop : forall A (Uh : A) (Ut : list A) (P : A -> Prop),
  (forall U : A, List.In U (Uh :: Ut) -> P U) ->
  P Uh.
  introv Hbigger.
  apply* Hbigger.
  cbn.
  eauto.
Qed.

Lemma subst_tt_intro_many : forall Xs T Us,
    length Xs = length Us ->
    DistinctList Xs ->
    (forall X, List.In X Xs -> X \notin fv_typ T) ->
    (forall X U, List.In X Xs -> List.In U Us -> X \notin fv_typ U) ->
    (forall U, List.In U Us -> type U) ->
    open_tt_many Us T = subst_tt_many Xs Us (open_tt_many_var Xs T).
Proof.
  induction Xs as [| Xh Xt]; introv Hleneq Hdistinct HXfv HXUfv XUtyp.
  - destruct Us.
    + cbv. trivial.
    + inversions Hleneq.
  - destruct Us as [| Uh Ut].
    + inversions Hleneq.
    + cbn.
      fold (open_tt_many_var Xt (T open_tt_var Xh)).
      rewrite* <- subst_intro_commutes_opens; eauto with listin.
      * apply* IHXt; try solve [intuition; eauto with listin].
        -- inversion* Hdistinct.
        -- introv XiXt.
           lets* Hless: fv_smaller T Uh 0.
           fold (open_tt T Uh) in Hless.
           intro Hin.
           apply Hless in Hin.
           rewrite in_union in Hin.
           destruct Hin as [Hin | Hin].
           ++ apply* HXfv. listin.
           ++ apply* HXUfv; listin.
      * inversions Hdistinct.
        introv XiXt.
        intro. subst. contradiction.
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_te_fresh : forall X U e,
  X \notin fv_trm e -> subst_te X U e = e.
Proof.
  induction e using trm_ind'; simpl; intros; f_equal*; autos* subst_tt_fresh.
  - symmetry.
    apply map_id. introv Lin.
    symmetry.
    apply* subst_tt_fresh.
  - apply* IHe.
    lets*: fv_fold_general H0.
  - unfold map_clause_trm_trm.
    rewrite List.Forall_forall in *.
    rewrite <- List.map_id.
    apply List.map_ext_in.
    intros cl clin.
    lets* Heq: H cl clin.
    destruct cl.
    f_equal.
    apply* Heq.
    lets*: fv_fold_in_clause.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e using trm_ind'; intro n0; simpls; f_equal*;
    autos* subst_tt_open_tt_rec.
  - unfold open_typlist_rec.
    rewrite List.map_map.
    rewrite List.map_map.
    apply List.map_ext.
    intro.
    apply* H0.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H0 cl clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_te_intro : forall X U e,
  X \notin fv_trm e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(** Substitution for a fresh name is identity. *)
Lemma subst_ee_fresh : forall x k u e,
  x \notin fv_trm e -> subst_ee x k u e = e.
Proof.
  induction e using trm_ind'; simpl; intros; f_equal*.
  - case_if*.
    inversions C.
    false* in_singleton_self.
  - apply IHe.
    lets*: fv_fold_base_clause.
  - unfold map_clause_trm_trm.
    rewrite <- List.map_id.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H clin.
    unfold clauseTerm in Heq.
    lets Hfv: fv_fold_in_clause.
    lets* Hfv2: Hfv cl clauses.
    unfold clauseTerm in Hfv2.
    destruct cl.
    f_equal.
    apply Heq.
    apply* Hfv2.
Qed.

(** Substitution distributes on the open operation. *)
Lemma subst_ee_open_ee : forall t1 t2 u k x, term u ->
  subst_ee x k u (open_ee t1 t2) =
  open_ee (subst_ee x k u t1) (subst_ee x k u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1 using trm_ind'; intro n0; simpls; f_equal*.
  - crush_eq.
  - case_if*. rewrite* <- open_ee_rec_term.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H0 clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitution and open_var for distinct names commute. *)
Lemma subst_ee_open_ee_var : forall vk x y k u e, y <> x -> term u ->
  open_ee (subst_ee x k u e) (trm_fvar vk y) = subst_ee x k u (open_ee e (trm_fvar vk y)).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_if*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall vk x u e,
  x \notin fv_trm e -> term u ->
  open_ee e u = subst_ee x vk u (open_ee e (trm_fvar vk x)).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_if*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P vk x e,
  open_ee (subst_te Z P e) (trm_fvar vk x) = subst_te Z P (open_ee e (trm_fvar vk x)).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e using trm_ind'; intros; simpl; f_equal*.
  - crush_eq.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z k u e X, term u ->
  (subst_ee z k u e) open_te_var X = subst_ee z k u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e using trm_ind'; intros; simpl; f_equal*.
  - case_if*. symmetry. autos* open_te_rec_term.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_map_reverse_type : forall Tparams Z P,
    type P ->
    (forall Tparam : typ,
        List.In Tparam Tparams -> type P -> type (subst_tt Z P Tparam)) ->
    forall Tparam : typ, List.In Tparam (List.map (subst_tt Z P) Tparams) -> type Tparam.
  introv HP HTP.
  introv Tin.
  apply List.in_map_iff in Tin.
  destruct Tin as [T Tand].
  destruct Tand as [Teq Tin].
  rewrite <- Teq.
  apply* HTP.
Qed.

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  - case_var*.
  - apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
  - econstructor.
    apply* subst_map_reverse_type.
Qed.

Lemma subst_commutes_with_unrelated_opens_te_te : forall Xs e V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_te Y V (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_te Y V e)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_te Y V e open_te_var Xh)).
    rewrite* subst_te_open_te_var; eauto with listin.
Qed.

Lemma subst_commutes_with_unrelated_opens_te_ee : forall Xs e v y k,
    term v ->
    subst_ee y k v (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_ee y k v e)).
  induction Xs as [| Xh Xt]; introv Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_ee y k v e open_te_var Xh)).
    rewrite* subst_ee_open_te_var; eauto with listin.
Qed.

Lemma subst_te_term : forall e Z P,
    term e -> type P -> term (subst_te Z P e)
with subst_te_value : forall e Z P,
    value e -> type P -> value (subst_te Z P e).
Proof.
  - lets: subst_tt_type. induction 1; intros; cbn; auto.
    + constructor*.
      apply* subst_map_reverse_type.
    + apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
    + apply_fresh* term_tabs as x.
      rewrite* subst_te_open_te_var.
      rewrite* subst_te_open_te_var.
    + apply_fresh* term_fix as x.
      rewrite* subst_te_open_ee_var.
      rewrite* subst_te_open_ee_var.
    + apply_fresh* term_let as x. rewrite* subst_te_open_ee_var.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H2 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      assert (Hpull:
          open_te_many_var Alphas (subst_te Z P cl'T) open_ee_varlam x
          =
          subst_te Z P (open_te_many_var Alphas cl'T open_ee_varlam x)
        ).
      * rewrite <- subst_commutes_with_unrelated_opens_te_te.
        rewrite* subst_te_open_ee_var.
        -- intros A AAlpha.
           assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
        -- eauto.
      * rewrite Hpull.
        apply* IH.
        introv Ain.
        assert (A \notin L \u \{ Z}); eauto.
  - lets: subst_tt_type; induction 1; intros; cbn; auto;
      match goal with
      | H: term _ |- _ => rename H into Hterm end.
    + apply value_abs.
      inversions Hterm.
      apply_fresh* term_abs as x.
      rewrite* subst_te_open_ee_var.
    + apply value_tabs. inversion Hterm.
      apply_fresh* term_tabs as x.
      rewrite* subst_te_open_te_var.
      rewrite* subst_te_open_te_var.
    + constructor*.
      constructor*.
      * apply* value_is_term.
      * apply* subst_map_reverse_type.
        inversion* Hterm.
Qed.

(* this may be problematic as I now require e2 to be value not only term, but maybe it will be enough? *)
Lemma subst_ee_term : forall e1 Z e2 k,
    term e1 -> value e2 -> term (subst_ee Z k e2 e1)
with subst_ee_value : forall e1 Z e2 k,
    value e1 -> value e2 -> value (subst_ee Z k e2 e1).
Proof.
  - induction 1; intros; simpl; auto.
    + case_if*. apply~ value_regular.
    + apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
      apply~ value_regular.
    + apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + apply_fresh* term_fix as y; rewrite* subst_ee_open_ee_var;
        apply~ value_regular.
    + apply_fresh* term_let as y. rewrite* subst_ee_open_ee_var;
                                    apply~ value_regular.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H1 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      rewrite* <- subst_commutes_with_unrelated_opens_te_ee.
      * rewrite* subst_ee_open_ee_var.
        apply* IH.
        intros A AAlpha.
        assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
        apply~ value_regular.
      * apply~ value_regular.
  - induction 1; intros; simpl; auto;
      try match goal with
      | H: term (trm_abs _ _) |- _ => rename H into Hterm
      | H: term (trm_tabs _) |- _ => rename H into Hterm
      end.
    + apply value_abs. inversions Hterm.
      apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
      apply~ value_regular.
    + apply value_tabs; inversions Hterm.
      apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + case_if~.
    + econstructor.
      * econstructor.
        -- apply* value_is_term.
        -- inversion* H.
      * apply* IHvalue.
Qed.

Lemma subst_idempotent : forall U Z P,
    Z \notin fv_typ P ->
    subst_tt Z P U = subst_tt Z P (subst_tt Z P U).
Proof.
  induction U using typ_ind'; introv FV; try solve [cbn; eauto].
  - cbn.
    case_if.
    + rewrite* subst_tt_fresh.
    + cbn. case_if. eauto.
  - cbn.
    rewrite* <- IHU1.
    rewrite* <- IHU2.
  - cbn.
    rewrite* <- IHU1.
    rewrite* <- IHU2.
  - cbn.
    rewrite* <- IHU.
  - cbn. f_equal.
    rewrite List.map_map.
    apply* List.map_ext_in.
    introv ain.
    rewrite List.Forall_forall in *.
    eauto.
Qed.

Lemma subst_idempotent_through_many_open : forall Tts Z U P,
    type P ->
    Z \notin fv_typ P ->
    subst_tt Z P (open_tt_many Tts U) =
    subst_tt Z P (open_tt_many Tts (subst_tt Z P U)).
  induction Tts; introv TP FV.
  - cbn. apply* subst_idempotent.
  - cbn.
    rewrite* IHTts.
    rewrite* (IHTts Z (open_tt (subst_tt Z P U) a) P).
    f_equal. f_equal.
    repeat rewrite* subst_tt_open_tt.
    f_equal.
    apply* subst_idempotent.
Qed.

Lemma subst_removes_var : forall T U Z,
    Z \notin fv_typ U ->
    Z \notin fv_typ (subst_tt Z U T).
  induction T using typ_ind'; introv FU; cbn; eauto.
  - case_if; cbn; eauto.
  - rewrite list_fold_map.
    rewrite List.Forall_forall in *.
    apply* notin_fold.
Qed.

Lemma subst_commutes_open_tt_many : forall Ts Z P U,
    type P ->
    Z \notin fv_typ P ->
    Z \notin fv_typ U ->
    subst_tt Z P (open_tt_many Ts U) =
    open_tt_many (List.map (subst_tt Z P) Ts) U.
Proof.
  induction Ts as [| Th Tts]; introv TP FP FU.
  - cbn. apply* subst_tt_fresh.
  - cbn.
    rewrite* subst_idempotent_through_many_open.
    rewrite* subst_tt_open_tt.
    rewrite* (@subst_tt_fresh Z P U).
    apply* IHTts.
    unfold open_tt.
    lets* FO: fv_open U (subst_tt Z P Th) 0.
    destruct FO as [FO | FO].
    + rewrite FO.
      apply notin_union; split*.
      apply* subst_removes_var.
    + rewrite* FO.
Qed.

Fixpoint subst_te_many (Xs : list var) (Us : list typ) (e : trm) :=
  match (Xs, Us) with
  (* | ((List.cons X Xt), (List.cons U Ut)) => subst_tt X U (subst_tt_many Xt Ut T) *)
  | ((List.cons X Xt), (List.cons U Ut)) => subst_te_many Xt Ut (subst_te X U e)
  | _ => e
  end.

Lemma subst_commutes_with_unrelated_opens_te : forall Xs e V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_te Y V (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_te Y V e)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_te Y V e open_te_var Xh)).
    rewrite* subst_te_open_te_var; eauto with listin.
Qed.

Lemma subst_intro_commutes_opens_te : forall Xs e Y V,
    Y \notin fv_trm e ->
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    open_te_many_var Xs (open_te e V) =
    subst_te Y V (open_te_many_var Xs (e open_te_var Y)).
  induction Xs as [| Xh Xt]; introv Hfv Hneq Htyp.
  - cbn. apply* subst_te_intro.
  - cbn.
    fold (open_te_many_var Xt (open_te e V open_te_var Xh)).
    fold (open_te_many_var Xt ((e open_te_var Y) open_te_var Xh)).
    rewrite* subst_commutes_with_unrelated_opens_te.
    f_equal.
    rewrite* <- subst_te_open_te_var.
    + rewrite* <- subst_te_intro.
    + apply* Hneq. cbn; eauto.
    + eauto with listin.
Qed.

Lemma subst_te_intro_many : forall Xs e Us,
    length Xs = length Us ->
    DistinctList Xs ->
    (forall X, List.In X Xs -> X \notin fv_trm e) ->
    (forall X U, List.In X Xs -> List.In U Us -> X \notin fv_typ U) ->
    (forall U, List.In U Us -> type U) ->
    open_te_many Us e = subst_te_many Xs Us (open_te_many_var Xs e).
Proof.
  induction Xs as [| Xh Xt]; introv Hleneq Hdistinct HXfv HXUfv XUtyp.
  - destruct Us.
    + cbv. trivial.
    + inversions Hleneq.
  - destruct Us as [| Uh Ut].
    + inversions Hleneq.
    + cbn.
      fold (open_te_many_var Xt (e open_te_var Xh)).
      inversions Hdistinct.
      rewrite IHXt; auto with listin.
      * f_equal.
        rewrite <- subst_intro_commutes_opens_te; eauto with listin.
        introv Xin.
        intro; subst. contradiction.
      * introv Xin.
        apply fv_open_te; eauto with listin.
Qed.

Lemma subst_tt_many_free : forall As Ts T,
    (forall A, List.In A As -> A \notin fv_typ T) ->
    T = subst_tt_many As Ts T.
  induction As; introv Afresh.
  - cbn. trivial.
  - destruct Ts.
    + cbn. trivial.
    + cbn. rewrite <- IHAs.
      * symmetry. apply subst_tt_fresh.
        auto with listin.
      * intros.
        rewrite subst_tt_fresh;
          auto with listin.
Qed.

Lemma subst_te_many_commutes_open : forall As Ts e x vk,
    length As = length Ts ->
    (forall A, List.In A As -> x <> A) ->
    open_ee (subst_te_many As Ts e) (trm_fvar vk x)
    =
    subst_te_many As Ts (open_ee e (trm_fvar vk x)).
  induction As as [| Ah Ats]; introv Hlen Afresh.
  - cbn. auto.
  - destruct Ts as [| Th Tts]; cbn in Hlen; try congruence.
    cbn. fold (open_ee (subst_te_many Ats Tts (subst_te Ah Th e)) (trm_fvar vk x)).
    rewrite IHAts; auto with listin.
    f_equal.
    apply subst_te_open_ee_var.
Qed.

Lemma subst_tb_id_on_fresh : forall E Z P,
    Z \notin fv_env E ->
    map (subst_tb Z P) E = E.
  induction E using env_ind; introv FE.
  - rewrite map_empty. trivial.
  - rewrite map_push.
    destruct v.
    rewrite fv_env_extend in FE.
    f_equal.
    + apply* IHE.
    + cbn.
      f_equal. f_equal.
      apply subst_tt_fresh. auto.
Qed.

Lemma subst_tt_many_id_on_fresh : forall T As Ps,
    (forall A, List.In A As -> A \notin fv_typ T) ->
    subst_tt_many As Ps T = T.
  induction As; destruct Ps; intros; try solve [cbn in *; congruence].
  cbn.
  rewrite subst_tt_fresh.
  - apply IHAs; auto with listin.
  - auto with listin.
Qed.

Lemma subst_tb_many_id_on_fresh_env : forall E As Ps,
    length As = length Ps ->
    (forall A, List.In A As -> A \notin fv_env E) ->
    map (subst_tb_many As Ps) E = E.
Proof.
  intros.
  rewrite map_def.
  rewrite <- LibList_map.
  symmetry.
  rewrite <- map_id; auto.
  intros vb xin.
  destruct vb. cbn.
  f_equal; auto.
  unfold subst_tb_many. destruct b.
  rewrite subst_tt_many_id_on_fresh; auto.
  intros.
  induction E as [| B E].
  - contradiction.
  - lets HA: H0 H1.
    cbn in HA. fold (fv_env E) in HA.
    lets [? | ?]: List.in_inv xin; subst; cbn in HA; auto.
    apply IHE; auto.
    intros A' Ain.
    lets HA': H0 Ain.
    destruct B; destruct b; cbn in HA'. fold (fv_env E) in HA'.
    auto.
Qed.

Lemma subst_commute:
  forall (X : var) (U : typ) (A : var) (P T : typ),
    X <> A ->
    A \notin fv_typ U ->
    subst_tt X U (subst_tt A P T) = subst_tt A (subst_tt X U P) (subst_tt X U T).
Proof.
  induction T using typ_ind'; introv Neq Fr; cbn; auto;
    try solve [
          rewrite~ IHT1; rewrite~ IHT2
        ].
  - repeat case_if; subst; cbn; repeat case_if; eauto.
    rewrite~ subst_tt_fresh.
  - rewrite~ IHT.
  - rewrite List.Forall_forall in *.
    f_equal.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros T Tin.
    apply~ H.
Qed.

Lemma subst_ee_fix_term : forall e1 Z e2,
    term e1 -> term e2 -> term (subst_ee Z fix_var e2 e1)
with subst_ee_fix_value : forall e1 Z e2,
    value e1 -> term e2 -> value (subst_ee Z fix_var e2 e1).
Proof.
  - induction 1; intros; simpl; auto.
    + case_if*.
    + apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
    + apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + apply_fresh* term_fix as y; rewrite* subst_ee_open_ee_var;
        apply~ value_regular.
    + apply_fresh* term_let as y. rewrite* subst_ee_open_ee_var;
                                    apply~ value_regular.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H1 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      rewrite* <- subst_commutes_with_unrelated_opens_te_ee.
      * rewrite* subst_ee_open_ee_var.
        apply* IH.
        intros A AAlpha.
        assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
  - induction 1; intros; simpl; auto;
      try match goal with
      | H: term (trm_abs _ _) |- _ => rename H into Hterm
      | H: term (trm_tabs _) |- _ => rename H into Hterm
      end.
    + apply value_abs. inversions Hterm.
      apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
    + apply value_tabs; inversions Hterm.
      apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + case_if~.
      inversions C.
      congruence.
    + econstructor.
      * econstructor.
        -- apply* value_is_term.
        -- inversion* H.
      * apply* IHvalue.
Qed.


Require Import Coq.ZArith.BinInt Coq.NArith.BinNat Coq.Numbers.BinNums Coq.ZArith.Zdiv Coq.ZArith.Znumtheory.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.EqdepFacts.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Coq.omega.Omega.
Require Import Crypto.Util.NumTheoryUtil.
Require Import Crypto.Tactics.VerdiTactics.
Require Export Crypto.Util.FixCoqMistakes.

Lemma Z_mod_mod x m : x mod m = (x mod m) mod m.
  symmetry.
  destruct (BinInt.Z.eq_dec m 0).
  - subst; rewrite !Zdiv.Zmod_0_r; reflexivity.
  - apply BinInt.Z.mod_mod; assumption.
Qed.

Lemma exist_reduced_eq: forall (m : Z) (a b : Z), a = b -> forall pfa pfb,
    exist (fun z : Z => z = z mod m) a pfa =
    exist (fun z : Z => z = z mod m) b pfb.
Proof.
  intuition; simpl in *; try congruence.
  subst_max.
  f_equal.
  eapply UIP_dec, Z.eq_dec.
Qed.

Definition mulmod m := fun a b => a * b mod m.
Definition powmod_pos m := Pos.iter_op (mulmod m).
Definition powmod m a x := match x with N0 => 1 mod m | Npos p => powmod_pos m p (a mod m) end.

Lemma mulmod_assoc:
  forall m x y z : Z, mulmod m x (mulmod m y z) = mulmod m (mulmod m x y) z.
Proof.
  unfold mulmod; intros.
  rewrite ?Zdiv.Zmult_mod_idemp_l, ?Zdiv.Zmult_mod_idemp_r; f_equal.
  apply Z.mul_assoc.
Qed.

Lemma powmod_1plus:
      forall m a : Z,
        forall x : N, powmod m a (1 + x) = (a * (powmod m a x mod m)) mod m.
Proof.
  intros m a x.
  rewrite N.add_1_l.
  cbv beta delta [powmod N.succ].
  destruct x. simpl; rewrite ?Zdiv.Zmult_mod_idemp_r, Z.mul_1_r; auto.
  unfold powmod_pos.
  rewrite Pos.iter_op_succ by (apply mulmod_assoc).
  unfold mulmod.
  rewrite ?Zdiv.Zmult_mod_idemp_l, ?Zdiv.Zmult_mod_idemp_r; f_equal.
Qed.

Lemma N_pos_1plus : forall p, (N.pos p = 1 + (N.pred (N.pos p)))%N.
  intros.
  rewrite <-N.pos_pred_spec.
  rewrite N.add_1_l.
  rewrite N.pos_pred_spec.
  rewrite N.succ_pred; eauto.
  discriminate.
Qed.

Lemma powmod_Zpow_mod : forall m a n, powmod m a n = (a^Z.of_N n) mod m.
Proof.
  induction n using N.peano_ind; [auto|].
  rewrite <-N.add_1_l.
  rewrite powmod_1plus.
  rewrite IHn.
  rewrite Zmod_mod.
  rewrite N.add_1_l.
  rewrite N2Z.inj_succ.
  rewrite Z.pow_succ_r by (apply N2Z.is_nonneg).
  rewrite ?Zdiv.Zmult_mod_idemp_l, ?Zdiv.Zmult_mod_idemp_r; f_equal.
Qed.

Local Obligation Tactic := idtac.

Program Definition pow_impl_sig {m} (a:{z : Z | z = z mod m}) (x:N) : {z : Z | z = z mod m}
  := powmod m (proj1_sig a) x.
Next Obligation.
  intros; destruct x; [simpl; rewrite Zmod_mod; reflexivity|].
  rewrite N_pos_1plus.
  rewrite powmod_1plus.
  rewrite Zmod_mod; reflexivity.
Qed.

Program Definition pow_impl {m} :
   {pow0
   : {z : BinNums.Z | z = z mod m} -> BinNums.N -> {z : BinNums.Z | z = z mod m}
   |
   forall a : {z : BinNums.Z | z = z mod m},
   pow0 a 0%N =
   exist (fun z : BinNums.Z => z = z mod m) (1 mod m) (Z_mod_mod 1 m) /\
   (forall x : BinNums.N,
    pow0 a (1 + x)%N =
    exist (fun z : BinNums.Z => z = z mod m)
      ((proj1_sig a * proj1_sig (pow0 a x)) mod m)
      (Z_mod_mod (proj1_sig a * proj1_sig (pow0 a x)) m))} := pow_impl_sig.
Next Obligation.
  split; intros; apply exist_reduced_eq;
    rewrite ?powmod_1plus, ?Zdiv.Zmult_mod_idemp_l, ?Zdiv.Zmult_mod_idemp_r; reflexivity.
Qed.

Program Definition mod_inv_sig {m} (a:{z : Z | z = z mod m}) : {z : Z | z = z mod m} :=
  let (a, _) := a in
  match a return _ with
  | 0%Z => 0 (* m = 2 *)
  | _ => powmod m a (Z.to_N (m-2))
  end.
Next Obligation.
  intros; break_match; rewrite ?powmod_Zpow_mod, ?Zmod_mod, ?Zmod_0_l; reflexivity.
Qed.

Program Definition inv_impl {m : BinNums.Z} :
   {inv0 : {z : BinNums.Z | z = z mod m} -> {z : BinNums.Z | z = z mod m} |
   inv0 (exist (fun z : BinNums.Z => z = z mod m) (0 mod m) (Z_mod_mod 0 m)) =
   exist (fun z : BinNums.Z => z = z mod m) (0 mod m) (Z_mod_mod 0 m) /\
   (Znumtheory.prime m ->
    forall a : {z : BinNums.Z | z = z mod m},
    a <> exist (fun z : BinNums.Z => z = z mod m) (0 mod m) (Z_mod_mod 0 m) ->
    exist (fun z : BinNums.Z => z = z mod m)
      ((proj1_sig (inv0 a) * proj1_sig a) mod m)
      (Z_mod_mod (proj1_sig (inv0 a) * proj1_sig a) m) =
    exist (fun z : BinNums.Z => z = z mod m) (1 mod m) (Z_mod_mod 1 m))}
     := mod_inv_sig.
Next Obligation.
  split.
  { apply exist_reduced_eq; rewrite Zmod_0_l; reflexivity. }
  intros Hm [a pfa] Ha'. apply exist_reduced_eq.
  assert (Hm':0 <= m - 2) by (pose proof prime_ge_2 m Hm; omega).
  assert (Ha:a mod m<>0) by (intro; apply Ha', exist_reduced_eq; congruence).
  cbv [proj1_sig mod_inv_sig].
  transitivity ((a*powmod m a (Z.to_N (m - 2))) mod m); [destruct a; f_equal; ring|].
  rewrite !powmod_Zpow_mod.
  rewrite Z2N.id by assumption.
  rewrite Zmult_mod_idemp_r.
  rewrite <-Z.pow_succ_r by assumption.
  replace (Z.succ (m - 2)) with (m-1) by omega.
  rewrite (Zmod_small 1) by omega.
  apply (fermat_little m Hm a Ha).
Qed.


Require Import Coq.ZArith.BinInt.
Require Import riscv.Utility.Encode.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Z.prove_Zeq_bitwise.

Lemma invert_encode_U: forall {opcode rd imm20},
  verify_U opcode rd imm20 ->
  forall inst,
  encode_U opcode rd imm20 = inst ->
  opcode = bitSlice inst 0 7 /\
  rd = bitSlice inst 7 12 /\
  imm20 = signExtend 32 (Z.shiftl (bitSlice inst 12 32) 12).
Proof. intros. unfold encode_U, verify_U in *. prove_Zeq_bitwise. Qed.


Require Import KeyEx.
Open Scope ecfield_scope.
Section test_pf.
Definition A2_begin_description := "Example A.2 on SM2p3 Annex A, page 11, begins. ".
Print A2_begin_description.
Definition p := hStoN
  "8542D69E 4C044F18 E8B92435 BF6FF7DE 45728391 5C45517D 722EDB8B 08F1DFC3".
Definition field := pf_builder p Logic.eq_refl.
Definition aN := hStoN
  "787968B4 FA32C3FD 2417842E 73BBFEFF 2F3C848B 6831D7E0 EC65228B 3937E498".
Definition a := wrapper field aN .

Definition bN := hStoN
  "63E4C6D3 B23B0C84 9CF84241 484BFE48 F61D59A5 B16BA06E 6E12D1DA 27C5249A".
Definition b := wrapper field bN .
Definition crv := @pf_curve _ field a b Logic.eq_refl.
Definition h := 1%N.
Definition xGN := hStoN
  "421DEBD6 1B62EAB6 746434EB C3CC315E 32220B3B ADD50BDC 4C4E6C14 7FEDD43D".
Definition xG := wrapper field xGN .
Definition yGN := hStoN
  "0680512B CBB42C07 D47349D2 153B70C4 E5D7FDFC BFA36EA1 A85841B9 E46E09A2".
Definition yG := wrapper field yGN .

Definition G := Cop field (xG, yG).

Definition n := hStoN
  "8542D69E 4C044F18 E8B92435 BF6FF7DD 29772063 0485628D 5AE74EE7 C32E79B7".
Definition w := ComputeW n.
Example wis127 : w = 127%N := Logic.eq_refl.
Definition dAN := hStoN
  "6FCBA2EF 9AE0AB90 2BC3BDE3 FF915D44 BA4CC78F 88E2F8E7 F8996D3B 8CCEEDEE".
Definition dA := wrapper field dAN.
Definition xAN := hStoN
  "3099093B F3C137D8 FCBBCDF4 A2AE50F3 B0F216C3 122D7942 5FE03A45 DBFE1655".
Definition xA := wrapper field xAN.
Definition yAN := hStoN
  "3DF79E8D AC1CF0EC BAA2F2B4 9D51A4B3 87F2EFAF 48233908 6A27A8E0 5BAED98B".
Definition yA := wrapper field yAN.
Definition dBN := hStoN
  "5E35D7D3 F3C54DBA C72E6181 9E730B01 9A84208C A3A35E4C 2E353DFC CB2A3B53".
Definition dB := wrapper field dBN.
Definition xBN := hStoN
  "245493D4 46C38D8C C0F11837 4690E7DF 633A8A4B FB3329B5 ECE604B2 B4F37F43".
Definition xB := wrapper field xBN.
Definition yBN := hStoN
  "53C0869F 4B9E1777 3DE68FEC 45E14904 E0DEA45B F6CECF99 18C85EA0 47C60A4C".
Definition yB := wrapper field yBN.
Definition ZA := hStobL
  "E4D1D0C3 CA4C7F11 BC8FF8CB 3F4C02A7 8F108FA0 98E51A66 8487240F 75E20F31".
Definition ZB := hStobL
  "6B4B6D0E 276691BD 4A11BF72 F4FB501A E309FDAC B72FA6CC 336E6656 119ABD67".

(*Test of A1-A3*)
Definition rA := hStoN
  "83A2C9C8 B96E5AF7 0BD480B4 72409A9A 327257F1 EBB73F5B 073354B2 48668563".
Definition x1bL := hStobL
  "6CB56338 16F4DD56 0B1DEC45 8310CBCC 6856C095 05324A6D 23150C40 8F162BF0".
Definition x1N := bLtoN x1bL.
Definition x1 := wrapper field x1N.
Definition y1bL := hStobL
  "0D6FCF62 F1036C0A 1B6DACCF 57399223 A65F7D7B F2D9637E 5BBBEB85 7961BF1A".
Definition y1N := bLtoN y1bL.
Definition y1 := wrapper field y1N.

(* Test of B1-B9 *)

Definition rB := hStoN
  "33FE2194 0342161C 55619C4A 0C060293 D543C80A F19748CE 176D8347 7DE71C80".
Definition x2bL := hStobL
  "1799B2A2 C7782953 00D9A232 5C686129 B8F2B533 7B3DCF45 14E8BBC1 9D900EE5".
Definition x2N := hStoN
  "1799B2A2 C7782953 00D9A232 5C686129 B8F2B533 7B3DCF45 14E8BBC1 9D900EE5".
Definition y2bL := hStobL
  "54C9288C 82733EFD F7808AE7 F27D0E73 2F7C73A7 D9AC98B7 D8740A91 D0DB3CF4".
Definition y2N := hStoN
  "54C9288C 82733EFD F7808AE7 F27D0E73 2F7C73A7 D9AC98B7 D8740A91 D0DB3CF4".
Definition x2 := wrapper field x2N.
Definition y2 := wrapper field y2N.

Definition x2_tilde := hStoN "B8F2B533 7B3DCF45 14E8BBC1 9D900EE5".

Example x2_tilde_test : x2_tilde = ComputeTilde field w x2.
Proof. vm_compute. reflexivity. Qed.
Definition tB := hStoN
  "2B2E11CB F03641FC 3D939262 FC0B652A 70ACAA25 B5369AD3 8B375C02 65490C9F".
Example tB_test : tB
  = ComputeT n (unwrapper field dB) x2_tilde rB := Logic.eq_refl.

Definition x1_tilde := hStoN "E856C095 05324A6D 23150C40 8F162BF0".
Example x1_tilde_test : x1_tilde = ComputeTilde field w x1.
Proof. vm_compute. reflexivity. Qed.
Definition RA := Cop field (x1, y1).
Example ra_test : GE_eqb RA (ComputeR crv G rA) = true.
Proof. Time vm_compute. reflexivity. Qed.   (* 34s *)

Definition RB := Cop field (x2, y2).
Example rb_test : GE_eqb RB (ComputeR crv G rB) = true.
Proof. Time vm_compute. reflexivity. Qed.   (* 34s *)

Definition PA := Cop field (xA, yA).
Definition PB := Cop field (xB, yB).

Definition xA0 := hStoN
  "2079015F 1A2A3C13 2B67CA90 75BB2803 1D6F2239 8DD8331E 72529555 204B495B".
Definition yA0 := hStoN
  "6B3FE6FB 0F5D5664 DCA16128 B5E7FCFD AFA5456C 1E5A914D 1300DB61 F37888ED".
Definition xA1 := hStoN
  "1C006A3B FF97C651 B7F70D0D E0FC09D2 3AA2BE7A 8E9FF7DA F32673B4 16349B92".
Definition yA1 := hStoN
  "5DC74F8A CC114FC6 F1A75CB2 86864F34 7F9B2CF2 9326A270 79B7D37A FC1C145B".
Definition xVbL := hStobL
  "47C82653 4DC2F6F1 FBF28728 DD658F21 E174F481 79ACEF29 00F8B7F5 66E40905".
Definition yVbL := hStobL
  "2AF86EFE 732CF12A D0E09A1F 2556CC65 0D9CCCE3 E249866B BB5C6846 A4C4A295".
Definition xVN := bLtoN xVbL.
Definition yVN := bLtoN yVbL.
Definition xV := wrapper field xVN.
Definition yV := wrapper field yVN.
Definition V := Cop field (xV, yV).
Example Vtest : GE_eqb (ComputeV (pf_mul a) (pf_add a) n h tB x1_tilde PA RA)
  V = true.
Proof. Time vm_compute. reflexivity. Qed. (* 52.815 secs *)

Definition Z := hStobL "47C82653 4DC2F6F1 FBF28728 DD658F21 E174F481 79ACEF29
 00F8B7F5 66E40905 2AF86EFE 732CF12A D0E09A1F 2556CC65 0D9CCCE3 E249866B
 BB5C6846 A4C4A295 E4D1D0C3 CA4C7F11 BC8FF8CB 3F4C02A7 8F108FA0 98E51A66
 8487240F 75E20F31 6B4B6D0E 276691BD 4A11BF72 F4FB501A E309FDAC B72FA6CC
 336E6656 119ABD67".
Example Ztest : Z = xVbL ++ yVbL ++ ZA ++ ZB.
Proof. reflexivity. Qed.

Definition klen := 128%nat.

Definition KB :=
  hStobL "55B0AC62 A6B927BA 23703832 C853DED4".
Example KBtest : KB = KDF SM3_Hash constant_v klen  Z.
Proof. vm_compute. reflexivity. Qed.

Definition SB := hStobL
  "284C8F19 8F141B50 2E81250F 1581C7E9 EEB4CA69 90F9E02D F388B454 71F5BC5C".

Example SBtest : SB = @ComputeS _ field SM3_Hash "02" ZA ZB xV yV x1 y1 x2 y2.
Proof. vm_compute. reflexivity. Qed.

Example rbkbsb_test :
  match ComputeRBKBSB SM3_Hash constant_v klen crv field
    G n h ZA ZB RA PA rB dBN with
  | Error str => Error str
  | Normal (r, k, s) => Normal (GE_uwp r, k, s)
  end = Normal (GE_uwp RB, KB, SB).
Proof. Time vm_compute. reflexivity. Qed.
(*94.608 secs*)

Definition KA := hStobL "55B0AC62 A6B927BA 23703832 C853DED4".
Definition S1 := hStobL
  "284C8F19 8F141B50 2E81250F 1581C7E9 EEB4CA69 90F9E02D F388B454 71F5BC5C".
Definition SA := hStobL
  "23444DAF 8ED75343 66CB901C 84B3BDBB 63504F40 65C1116C 91A4C006 97E6CF7A".

Example kas1sa_test : Normal (KA, S1, SA) = ComputeKAS1SA SM3_Hash constant_v
 klen crv field rA dAN n h PB RA RB ZA ZB SB.
Proof. Time vm_compute. reflexivity. Qed.
(* 67.986 secs *)
Example veris2eqsa_test : @VeriS2eqSA _ field SM3_Hash ZA ZB SA xV yV x1 y1 x2 y2 = true.
Proof. Time vm_compute. reflexivity. Qed.
(*5.392 secs *)
Definition A2_end_description := "Example A.2 on SM2p3 Annex A, page 11, ended. ".
Print A2_end_description.
End test_pf.

(*Module test_bfp.
Definition m := 257%N.
Definition gp := (N.shiftl 1 257) + (N.shiftl 1 12) + 1.
Definition a := 0.
Definition b := hStoN "00 E78BCD09 746C2023 78A7E72B
  12BCE002 66B9627E CB0B5A25 367AD1AD 4CC6242B".
Definition h := 4%N.

Definition n := hStoN "7FFFFFFF FFFFFFFF FFFFFFFF
  FFFFFFFF BC972CF7 E6B6F900 945B3C6A 0CF6161D".

Definition xG := hStoN "00 CDB9CA7F 1E6B0441 F658343F
  4B10297C 0EF9B649 1082400A 62E7A748 5735FADD".
Definition yG := hStoN "01 3DE74DA6 5951C4D7 6DC89220
  D5F7777A 611B1C38 BAE260B1 75951DC8 060C2B3E".
Definition G := Cop (xG, yG).
Definition dA := hStoN "4813903D 254F2C20 A94BC570
  42384969 54BB5279 F861952E F2C5298E 84D2CEAA".
Definition xA := hStoN "00 8E3BDB2E 11F91933 88F1F901
  CCC857BF 49CFC065 FB38B906 9CAAE6D5 AFC3592F".
Definition yA := hStoN "00 4555122A AC0075F4 2E0A8BBD
  2C0665C7 89120DF1 9D77B4E3 EE4712F5 98040415".
Definition PA := Cop (xA, yA).
Definition xB := hStoN "00 34297DD8 3AB14D5B 393B6712
  F32B2F2E 938D4690 B095424B 89DA880C 52D4A7D9".
Definition yB := hStoN "01 99BBF11A C95A0EA3 4BBD00CA
  50B93EC2 4ACB6833 5D20BA5D CFE3B33B DBD2B62D".
Definition PB := Cop (xB, yB).
Definition ZA := hStobL "ECF00802 15977B2E 5D6D61B9
  8A99442F 03E8803D C39E349F 8DCA5621 A9ACDF2B".
Definition ZB := hStobL "557BAD30 E183559A EEC3B225
  6E1C7C11 F870D22B 165D015A CF9465B0 9B87B527".
Definition rA := hStoN "54A3D667 3FF3A6BD 6B02EBB1
  64C2A3AF 6D4A4906 229D9BFC E68CC366 A2E64BA4".
Definition rB := hStoN "1F219333 87BEF781 D0A8F7FD
  708C5AE0 A56EE3F4 23DBC2FE 5BDF6F06 8C53F7AD".
Definition dB := hStoN "08F41BAE 0922F47C 212803FE
  681AD52B 9BF28A35 E1CD0EC2 73A2CF81 3E8FD1DC".
Definition klen := 128%nat.
Definition RA' := bfp_mul m gp a G rA.
Definition RB' := bfp_mul m gp a G rB.
Definition x1 := hStoN "01 81076543 ED19058C 38B313D7
  39921D46 B80094D9 61A13673 D4A5CF8C 7159E304".
Definition y1 := hStoN "01 D8CFFF7C A27A01A2 E88C1867
  3748FDE9 A74C1F9B 45646ECA 0997293C 15C34DD8".
Definition RA := Cop (x1, y1).
Definition x2 := hStoN "00 2A4832B4 DCD399BA AB3FFFE7
  DD6CE6ED 68CC43FF A5F2623B 9BD04E46 8D322A2A".
Definition y2 := hStoN "00 16599BB5 2ED9EAFA D01CFA45
  3CF3052E D60184D2 EECFD42B 52DB7411 0B984C23".
Definition RB := Cop (x2, y2).
Definition xV := hStoN "00 DADD0874 06221D65 7BC3FA79
  FF329BB0 22E9CB7D DFCFCCFE 277BE8CD 4AE9B954".
Definition yV := hStoN "01 F0464B1E 81684E5E D6EF281B
  55624EF4 6CAA3B2D 37484372 D91610B6 98252CC9".
Definition SB := hStobL "4EB47D28 AD3906D6 244D01E0
  F6AEC73B 0B51DE15 74C13798 184E4833 DBAE295A".
(*
Compute bLtohS (ComputeS_bf (N.to_nat m) "02" ZA ZB xV yV
 x1 y1 x2 y2 SM3_Hash).
Correc. Same as SB *)
Definition xU := hStoN "00 DADD0874 06221D65 7BC3FA79
  FF329BB0 22E9CB7D DFCFCCFE 277BE8CD 4AE9B954".
Definition yU := hStoN "01 F0464B1E 81684E5E D6EF281B
  55624EF4 6CAA3B2D 37484372 D91610B6 98252CC9".
Definition KA := hStobL "4E587E5C 66634F22 D973A7D9
  8BF8BE23".
(*
Compute bLtohS
  (ComputeK m SM3_Hash constant_v klen xU yU ZA ZB).
Correct Same as KA*)

(*
Time Compute match RA' with
  |InfO => ("", "")
  |Cop (x, y) => (NtohS x, NtohS y)
end.
Time Compute match RB' with
  |InfO => ("", "")
  |Cop (x, y) => (NtohS x, NtohS y)
end.
*)
(* Same as RA and RB *)
(*     = ("181076543ed19058c38b313d739921d46b80094d961a136
          73d4a5cf8c7159e304",
       "1d8cfff7ca27a01a2e88c18673748fde9a74c1f9b45646eca0
       997293c15c34dd8")
     : string * string
Finished transaction in 1172.412 secs (1168.732u,1.655s)
 (successful)
     = ("2a4832b4dcd399baab3fffe7dd6ce6ed68cc43ffa5f2623b9
         bd04e468d322a2a",
       "16599bb52ed9eafad01cfa453cf3052ed60184d2eecfd42b52
       db74110b984c23")
     : string * string
Finished transaction in 1156.16 secs (1155.32u,0.488s)
(successful)
*)
(*
Time Compute match ComputeRBKBSB_bfp SM3_Hash constant_v klen
  m gp a b G n h ZA ZB RA PA rB dB with
| Error err => Error err
| Normal (rb, kb, sb) => Normal (
    match rb with
    | InfO => ("", "")
    | Cop (xrb, yrb) =>
        (NtohS xrb, NtohS yrb)
    end,
    bLtohS kb, bLtohS sb)
end.
*)
(*= Normal
         ("2a4832b4dcd399baab3fffe7dd6ce6ed68cc43ffa5f2623
          b9bd04e468d322a2a",
         "16599bb52ed9eafad01cfa453cf3052ed60184d2eecfd42b
          52db74110b984c23",
         "4e587e5c66634f22d973a7d98bf8be23",
         "4eb47d28ad3906d6244d01e0f6aec73b0b51de1574c13798
          184e4833dbae295a")
     : optErr (string * string * string * string)
Finished transaction in 2817.141 secs (2815.495u,0.988s)
(successful)
*)
(*Correct *)
(*
Time Compute match ComputeKAS1SA_bfp SM3_Hash constant_v klen
 m gp a b rA dA n h PB RA RB ZA ZB SB with
| Error err => Error err
| Normal (ka, s1, sa) =>
   Normal (bLtohS ka, bLtohS s1, bLtohS sa)
end.
*)
(*
*      = Normal
         ("4e587e5c66634f22d973a7d98bf8be23",
         "4eb47d28ad3906d6244d01e0f6aec73b0b51de1574c13798
          184e4833dbae295a",
         "588aa67064f24dc27ccaa1fab7e27dff811d500ad7ef2fb8
          f69ddf48cc0fecb7")
     : optErr (string * string * string)
Finished transaction in 1691.229 secs (1686.318u,1.809s)
(successful)
Correct *)

End test_bfp.
*)


Require Import Undecidability.Synthetic.Undecidability.
From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts.
Require Import Undecidability.TM.SBTM.
Require Undecidability.TM.Reductions.HaltTM_1_to_SBTM_HALT.
Require Undecidability.TM.Enumerators.SBTM_HALT_enum.

(* ** complement SBTM_HALT is undecidable *)

Lemma complement_SBTM_HALT_undec :
  undecidable (complement SBTM_HALT).
Proof.
  intros H.
  eapply (dec_count_enum H), enumerator_enumerable.
  apply enumerator__T_sigT.
  - now apply (proj2_sig SBTM_HALT_enum.SBTM_enumeration).
  - intros M. now apply (proj2_sig (SBTM_HALT_enum.config_enumeration M)).
Qed.

(* ** SBTM_HALT is undecidable  *)

Lemma SBTM_HALT_undec :
  undecidable SBTM_HALT.
Proof.
  intros H. now apply complement_SBTM_HALT_undec, dec_compl.
Qed.


Set Implicit Arguments.

Class ORDER A := Order {

  LEQ : A -> A -> bool;

  leqRefl: forall x, true = LEQ x x;

  leqTransTrue : forall x y z,
      true = LEQ x y ->
      true = LEQ y z ->
      true = LEQ x z;

  leqTransFalse : forall x y z,
      false = LEQ x y ->
      false = LEQ y z ->
      false = LEQ x z;

  leqSymm : forall x y,
      false = LEQ x y ->
      true = LEQ y x
}.

(*Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].*)


(** H-initiality of Two
        ->
    Simple elimination + computation + uniqueness + coherence for Two
**)

Require Import HoTT.
Require Import two.
Require Import two_alg.

Local Open Scope path_scope.
Local Open Scope fibration_scope.
Local Open Scope equiv_scope.

Section AssumeFunext.
Context `{Funext}.

Theorem twoHinit_impl_twoSimpRules (Two : Type) (zero : Two) (one : Two) :
  twoHinit (Two; (zero, one)) ->
  hasTwoSimpElimCompRules Two zero one *
  hasTwoSimpUniqCohRules Two zero one.
Proof.
set (X := (Two; (zero, one)) : TwoAlg).
intro I.
split.

unfold hasTwoSimpElimCompRules.
intros.
set (Y := (C; (c_0, c_1)) : TwoAlg).
exact (@center _ (I Y)).

unfold hasTwoSimpUniqCohRules.
intros.
set (Y := (C; (c_0, c_1)) : TwoAlg).
set (h_1 := (g; (p_0, p_1)) : TwoHom X Y).
set (h_2 := (h; (q_0, q_1)) : TwoHom X Y).
apply (twoHomPath_to_2Cell X Y h_1 h_2).
apply @path_contr.
exact (I Y).
Defined.

Theorem twoHinit_imp_TwoSimp : TwoHinit -> TwoSimp.
Proof.
intro I.
destruct I as [[Two [zero one]] J].
unfold TwoSimp.
refine (Two; (zero; (one; _))).
apply twoHinit_impl_twoSimpRules.
assumption.
Defined.

End AssumeFunext.


Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.

Inductive MarkedGraph : list Set -> list Set -> list Set -> Type :=
 | empty : MarkedGraph [] [] []
 | inp   : forall i d o x,
           MarkedGraph i d o ->
           MarkedGraph (x :: i) (x :: d) o
 | out   : forall i d o x,
           MarkedGraph i d o ->
           Index d x         ->
           MarkedGraph i d (x :: o)
 | trans : forall i d o a (b : Set),
           MarkedGraph i d o ->
           Index d a         ->
           Transition a b    ->
           MarkedGraph i (b :: d) o
 | join2 : forall i d o (a b : Set),
           MarkedGraph i d o ->
           Index d a         ->
           Index d b         ->
           MarkedGraph i ((a*b)%type :: d) o
 .

Definition plus_left : MarkedGraph [nat] [option nat; nat; nat] [option nat].
 apply out.
 eapply trans.
 eapply trans.
 apply inp.
 apply empty.
 apply here.
 unfold Transition. apply (plus 1).
 apply here.
 unfold Transition. apply Some.
 apply here.
Defined.
Print plus_left.

Inductive Values : list Set -> Type :=
 | v_nil : Values []
 | v_cons (x : Set) xs : list x -> Values xs -> Values (x :: xs).

Fixpoint inputs_to_places i d o
   (m : MarkedGraph i d o)
   (v : Values i) :
   Values d.
 induction m;
 eauto;
  inversion v; subst; eauto;
  try apply IHm in X0;
  try apply IHm in v;
  try solve [constructor; eauto].
  (* trans case. introduces new variables so set them to nil *)
  constructor. apply []. eauto.
  constructor. apply []. eauto.
Defined.

Eval compute in (inputs_to_places plus_left (v_cons [1;2;3] v_nil)).

Fixpoint find_output vs x
   (v : Values vs)
   (i : Index vs x)
      : list x.
 induction i;
 inversion v; eauto.
Defined.

Fixpoint outputs_of_places i d o
   (m : MarkedGraph i d o)
   (v : Values d) :
   Values o.
 induction m; inversion v; subst; eauto.
 inversion i0.
 constructor.
 eapply find_output; eauto.
 eauto.
Defined.

Eval compute in (outputs_of_places plus_left (v_cons [Some 1] (v_cons [] (v_cons [] v_nil)))).

Definition onfirst
  (x y : Set)    (d : list Set)
  (f   : list x -> list y) (v : Values (x::d))
       : Values (y::d).
 inversion v; subst; constructor; eauto.
Defined.

Fixpoint step i d o
   (m : MarkedGraph i d o)
   (v : Values d)
      : Values d.
 induction m.
  * (* empty *) eauto.
  * (* inp   *) inversion v; subst.
                constructor. assumption.
                apply IHm. assumption.
  * (* out   *) apply IHm. assumption.

 :=
 match m with
 | empty
   => v
 | inp i d o x m'
   => onfirst id v
 end.


From discprob.basic Require Import base Series_Ext seq_ext nify.
From discprob.prob Require Import countable rearrange prob.
Require Import Reals Fourier Omega Psatz.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop seq.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.

Definition finite_sum {A: finType} (f: A → R) :=
  λ n: nat, oapp f R0 (nth_error (Finite.enum A) n).

Section finite_sum_facts.

Variable (A: finType).
Implicit Types (a: A → R).

Lemma ex_series_eventually0 (a: nat → R):
  (∃ N, ∀ n, n ≥ N → a n = 0) → ex_series a.
Proof.
  intros (N&Hev0). apply: ex_series_Cauchy.
  rewrite /Cauchy_series => eps. exists N => n m Hlen Hlem.
  assert (Heq: sum_n_m a n m = 0).
  {
    rewrite /sum_n_m.
    rewrite (Iter.iter_nat_ext_loc _ _ _ (λ x, 0)).
    - rewrite /plus/zero//=/Iter.iter_nat Iter.iter_const; nra.
    - intros k (?&?). apply Hev0. lia.
  }
  rewrite /norm//=/abs//=. destruct eps =>//=. rewrite Heq Rabs_right; nra.
Qed.

Lemma ex_series_list_Rabs {B: eqType} (l: list B) (f: B → R):
  ex_series (λ n, Rabs (oapp f R0 (nth_error l n))).
Proof.
  apply ex_series_eventually0.
  exists (length l) => n Hge.
  rewrite /finite_sum (proj2 (nth_error_None _ _)); last omega.
  rewrite Rabs_right => //=; nra.
Qed.

Lemma ex_seriesF_Rabs a:
  ex_series (λ n, Rabs (finite_sum a n)).
Proof.
  apply ex_series_list_Rabs.
Qed.

Lemma ex_seriesF a:
  ex_series (finite_sum a).
Proof.
  apply ex_series_Rabs, ex_seriesF_Rabs.
Qed.

Lemma SeriesF_big_op a:
  Series (finite_sum a) = \big[Rplus/0]_(i in A) (a i).
Proof.
  rewrite /finite_sum/index_enum.
  induction (Finite.enum A) => //=.
  - rewrite big_nil. apply is_series_unique, is_series_0 => n.
    destruct n; auto.
  - rewrite big_cons Series_incr_1 //=.
    * rewrite IHl; f_equal.
    * apply ex_series_Rabs, ex_series_list_Rabs.
Qed.

Lemma SeriesF_is_seriesC a:
  is_series (countable_sum a) (Series (finite_sum a)).
Proof.
  edestruct (ex_seriesF_Rabs); eauto.
  edestruct (series_rearrange_covering (finite_sum a)
                                       (λ n, match @pickle_inv A n with
                                             | Some a => seq.index a (Finite.enum A)
                                             | None => length (Finite.enum A)
                                             end)) as (?&Hconv); eauto.
  - intros n n'. rewrite /finite_sum => //=.
    case_eq (@pickle_inv A n) => //=; last first.
    { rewrite (proj2 (nth_error_None _ _)); last by omega. rewrite //=. }
    intros s Hpickle1.
    case_eq (@pickle_inv A n') => //=; last first.
    { intros ? ? Heq. exfalso.
      cut (length (Finite.enum A) < length (Finite.enum A))%nat;
                         first by (intros; nify; omega).
      rewrite -{1}Heq. rewrite -size_legacy. apply SSR_leq. rewrite seq.index_mem.
      by rewrite -enumT mem_enum.
    }
    intros s' Hpickle2.
    intros Hneq0 Hidxeq.
    assert (s = s').
    {
      rewrite -[a in a = _](@seq.nth_index _ s s (Finite.enum A));
        last by rewrite -enumT mem_enum.
      rewrite -[a in _ = a](@seq.nth_index _ s s' (Finite.enum A));
        last by rewrite -enumT mem_enum.
      auto.
    }
    subst.
    transitivity (pickle s').
    * apply (f_equal (oapp (@pickle A) n)) in Hpickle1.
      rewrite //= pickle_invK in Hpickle1.
      done.
    * apply (f_equal (oapp (@pickle A) n')) in Hpickle2.
      rewrite //= pickle_invK in Hpickle2.
      done.
  - rewrite /finite_sum => n.
    rewrite /oapp.
    case_eq (nth_error (Finite.enum A) n).
    * intros s Heq Hneq0.
      exists (pickle s). rewrite pickleK_inv.
      assert (n < length (Finite.enum A))%nat.
      {  apply nth_error_Some. congruence. }
      eapply nth_error_nth2 with (d := s) in Heq.
      rewrite -Heq. apply seq.index_uniq.
      { nify. rewrite size_legacy. done. }
      rewrite -enumT. apply enum_uniq.
    * rewrite //=.
  - eapply is_series_ext; last apply Hconv.
    intros n. rewrite /finite_sum/countable_sum.
    destruct (@pickle_inv A n) as [s|] => //=.
    * rewrite (nth_error_nth1 s); last first.
      { rewrite -size_legacy.
        apply SSR_leq. rewrite seq.index_mem. by rewrite -enumT mem_enum.
      }
      rewrite seq.nth_index; last by rewrite -enumT mem_enum.
      rewrite //=.
    * rewrite (proj2 (nth_error_None _ _)); last by omega. done.
Qed.

Lemma SeriesC_SeriesF a:
  Series (countable_sum a) = Series (finite_sum a).
Proof. apply is_series_unique, SeriesF_is_seriesC. Qed.

Lemma SeriesC_fin_big a:
  Series (countable_sum a) = \big[Rplus/0]_(i in A) (a i).
Proof. by rewrite SeriesC_SeriesF SeriesF_big_op. Qed.

Lemma SeriesF_is_seriesC' a v:
    \big[Rplus/0]_(i in A) a i = v →
    is_series (countable_sum a) v.
Proof.
  intros <-. rewrite -SeriesC_fin_big //= SeriesC_SeriesF.
  apply SeriesF_is_seriesC.
Qed.

End finite_sum_facts.

Section img_fin.
Variable (A: finType) (B: eqType).
Definition img_fin_enum (f: A → B) : seq (imgT f).
  refine (undup [seq _ | i <- Finite.enum A]).
  rewrite //=. exists (f i). rewrite /img. apply /exCP; eauto.
Defined.

Lemma img_fin_enum_sval (f: A → B):
  map sval (img_fin_enum f) = undup [seq (f i) | i <- Finite.enum A].
Proof.
  rewrite /img_fin_enum //=.
  induction (Finite.enum A) => //=.
  - case: ifP.
    * case: ifP.
      ** intros. eauto.
      ** intros Hnin Hin. exfalso.
         move /mapP in Hin. destruct Hin as [x Hin Hex].
         inversion Hex.
         move /negP in Hnin. apply Hnin.
         apply /mapP. eexists; eauto.
    * case: ifP.
      ** eauto. intros Hin Hnin. eauto. exfalso.
         move /mapP in Hin. destruct Hin as [x Hin Hex].
         move /negP in Hnin. apply Hnin.
         apply /mapP. eexists; eauto.
         apply /eqP. rewrite -(inj_eq val_inj) => //=. apply /eqP. done.
      ** intros. rewrite ?big_cons.
         rewrite //=. f_equal. eauto.
Qed.

Lemma img_fin_uniq (f: A → B) : uniq (img_fin_enum f).
Proof.
  rewrite /img_fin_enum. apply undup_uniq.
Qed.

Lemma img_fin_mem f x : x \in img_fin_enum f.
Proof.
  rewrite /img_fin_enum mem_undup. destruct x as (x&Heq) => //=.
  generalize (Heq). move /exCP in Heq. destruct Heq as (a&Heq) => ?.
  apply /mapP. exists a.
  - rewrite -enumT mem_enum //.
  - move /eqP in Heq. subst. f_equal.
    apply bool_irrelevance.
Qed.

Definition img_finMixin (f: A → B) :=
  Eval hnf in @UniqFinMixin [countType of imgT f] (img_fin_enum f) (img_fin_uniq f) (img_fin_mem f).
Canonical img_finType (f: A → B) :=
  Eval hnf in FinType (imgT f) (img_finMixin f).
End img_fin.

Lemma img_fin_enum_sval_comp {A: finType} {B C: eqType} (f: A → B) (g: B → C):
  map sval (img_fin_enum _ _ (g \o f)) = undup [seq (g (f i)) | i <- Finite.enum A].
Proof.
  rewrite /img_fin_enum. rewrite img_fin_enum_sval; done.
Qed.

Lemma img_fin_big {A: finType} {B: eqType} (f: A → B) (F: B → R) P:
  \big[Rplus/0]_(i in img_finType A B f | P (sval i)) (F (sval i)) =
  \big[Rplus/0]_(i <- undup [seq (f i) | i <- Finite.enum A] | P i) (F i).
Proof.
  rewrite /img_finType /index_enum.
  rewrite {1}[@Finite.enum]unlock //=.
  rewrite /img_fin_enum /imgT/img//=/index_enum.
  rewrite -big_map. rewrite img_fin_enum_sval. done.
Qed.

Lemma img_fin_big' {A: finType} {B: eqType} (f: A → B) (F: B → R) P:
  \big[Rplus/0]_(i <- img_fin_enum A B f | P (sval i)) (F (sval i)) =
  \big[Rplus/0]_(i <- undup [seq (f i) | i <- Finite.enum A] | P i) (F i).
Proof.
 intros. etransitivity; last apply img_fin_big.
 rewrite /index_enum. rewrite [@Finite.enum]unlock //=.
Qed.

  Lemma ex_Ex_fin {A: finType} {Ω: distrib A} (X: rrvar Ω):
    ex_Ex X.
  Proof.
    rewrite /ex_Ex. eexists. apply SeriesF_is_seriesC.
  Qed.

  Hint Resolve ex_Ex_fin.

Section Ex_fin_prop.
  Variable (A: finType).
  Variable (Ω: distrib A).

Lemma Ex_fin_pt  (X: rrvar Ω):
  Ex X = \big[Rplus/0]_(a in A) (X a * (rvar_dist X) a).
Proof.
  rewrite Ex_pt //. rewrite SeriesC_fin_big //.
Qed.

Lemma Ex_fin_comp {B: eqType} (X: rvar Ω B) (f: B → R):
  Ex (rvar_comp X f) = \big[Rplus/0]_(a : imgT X) (pr_eq X (sval a) * f (sval a)).
Proof.
  rewrite Ex_comp_pt.Ex_comp. rewrite SeriesC_fin_big //. apply ex_Ex_fin.
Qed.

Lemma Ex_fin_comp_mono {B: eqType} (X: rvar Ω B) (f: B → R) (g: B → R):
    (∀ x, f x <= g x) →
    Ex (rvar_comp X f) <= Ex (rvar_comp X g).
Proof.
  intros Hle. rewrite ?Ex_fin_comp. apply Rle_bigr => a ?.
  apply Rmult_le_compat_l.
  * apply Rge_le, pr_eq_ge_0.
  * eauto.
Qed.

Lemma pr_sum_all {B: eqType} (X: rvar Ω B):
  \big[Rplus/0]_(i : imgT X) pr_eq X (sval i) = 1.
Proof.
  transitivity (Ex (rvar_comp X (fun _ => 1))).
  - rewrite Ex_fin_comp. apply eq_bigr => ??. field.
  - rewrite Ex_fin_pt //= -big_distrr //= Rmult_1_l -SeriesC_fin_big.
    apply is_series_unique, pmf_sum1.
Qed.

Lemma Ex_comp_ext {B: eqType} (X: rvar Ω B) (f f': B → R):
  (∀ x, f x = f' x) →
  Ex (rvar_comp X f) = Ex (rvar_comp X f').
Proof.
  intros Hext. rewrite ?Ex_fin_pt.
  apply eq_bigr => ?? //=. by rewrite Hext.
Qed.

Lemma Ex_fin_plus_l (X: rrvar Ω) (x: R):
  Ex (rvar_comp X (Rplus x)) = x + Ex X.
Proof. by apply Ex_plus_l. Qed.

Lemma Ex_fin_plus_r (X: rrvar Ω) (x: R):
  Ex (rvar_comp X (λ y, y + x)) = Ex X + x.
Proof. by apply Ex_plus_r. Qed.

Lemma Ex_fin_scal_r (X: rrvar Ω) (c: R):
  Ex (rvar_comp X (λ x, x * c)) = Ex X * c.
Proof. by apply Ex_scal_r. Qed.

Lemma Ex_fin_scal_l (X: rrvar Ω) (c: R):
  Ex (rvar_comp X (λ x, c * x)) = c * Ex X.
Proof. by apply Ex_scal_l. Qed.

Lemma Ex_fin_sum (X Y: rrvar Ω):
  Ex (mkRvar Ω (λ x, X x + Y x)) =
  Ex X + Ex Y.
Proof. by apply Ex_sum. Qed.

Lemma img_rvar_comp {B B': eqType} (r: rvar Ω B) (f: B → B'):
  map sval (Finite.enum [finType of (imgT (rvar_comp r f))])
  = undup ([ seq (f (sval x)) | x <- Finite.enum [finType of (imgT r)]]).
Proof.
  rewrite /img//=. rewrite {1}unlock //=. rewrite img_fin_enum_sval_comp.
  symmetry. rewrite {1}unlock //=. rewrite map_comp img_fin_enum_sval //=.
  rewrite -undup_map -map_comp. done.
Qed.
End Ex_fin_prop.

Arguments Ex_fin_pt {_ _}.
Arguments Ex_fin_comp {_ _ _}.
Arguments Ex_fin_comp_mono {_ _ _}.
Arguments pr_sum_all {_ _ _}.
Arguments Ex_comp_ext {_ _ _}.
Arguments Ex_fin_plus_l {_ _}.
Arguments Ex_fin_plus_r {_ _}.
Arguments Ex_fin_scal_l {_ _}.
Arguments Ex_fin_scal_r {_ _}.
Arguments Ex_fin_sum {_ _}.
Arguments img_rvar_comp {_ _ _ _}.

Lemma img_pair_rv {A A': finType} {B B': eqType} (Ω: distrib A) (Ω' : distrib A')
      (r: rvar Ω B) (r': rvar Ω' B'):
  perm_eq (map sval (Finite.enum [finType of imgT (rvar_pair r r')]))
          [seq (sval x1, sval x2) | x1 <- Finite.enum [finType of (imgT r)],
                          x2 <- Finite.enum [finType of (imgT r')]].
Proof.
  rewrite /img/rvar_pair//= ?unlock /=/prod_enum ?enumT.
  apply uniq_perm.
  - rewrite img_fin_enum_sval. apply undup_uniq.
  - apply allpairs_uniq; try (rewrite /img_fin_enum;  apply undup_uniq).
    intros x y ?? Heq => //=.
    destruct x as (s1&s1'), y as (s2&s2').
    f_equal.
    * destruct s1, s2.  inversion Heq; subst. f_equal; apply bool_irrelevance.
    * destruct s1', s2'.  inversion Heq; subst. f_equal; apply bool_irrelevance.
  - intros (x, y).
    apply /mapP. case: ifP => [HP|HnP].
    * move /allpairsP in HP. destruct HP as [(b&b') [Hb Hb' Heq]].
      rewrite mem_undup in Hb. move /mapP in Hb. destruct Hb as [a ? Hex].
      rewrite mem_undup in Hb'. move /mapP in Hb'. destruct Hb' as [a' ? Hex'].
      assert ((λ y, exC (λ x, (r (fst x), r' (snd x)) == y)) (x, y)) as Hpf.
      {
        apply /exCP. exists (a, a').
        rewrite //= in Heq. inversion Heq. subst.
        rewrite //= in Hex Hex'.
        apply /eqP; f_equal.
        - rewrite Hex => //=.
        - rewrite Hex' => //=.
      }
      exists (exist _ (x, y) Hpf).
      ** apply img_fin_mem.
      ** rewrite //=.
    * intros [((b, b')&Hin0) Hin Heq].
      rewrite //= in Heq. move /negP in  HnP. apply HnP.
      apply /allpairsP.
      rewrite //= in Hin.
      generalize (Hin0). move /exCP => [[a a'] Heq'].
      move /eqP in Heq'. inversion Heq'; subst.
      assert ((λ y, exC (λ x, r x == y)) x) as Hpfx.
      { apply /exCP. exists a. apply /eqP; inversion Heq; done. }
      assert ((λ y, exC (λ x, r' x == y)) y) as Hpfy.
      { apply /exCP. exists a'. apply /eqP; inversion Heq; done. }
      exists (exist _ x Hpfx, exist _ y Hpfy) => //=.
      split; try (apply img_fin_mem).
      done.
Qed.

Lemma Rmult_if_distrib (P : bool) v a b:
  (if P then a else b) * v =
  (if P then a * v else b * v).
Proof.
  destruct P => //=.
Qed.

Lemma pr_eq_rvar_pair {A A': finType} {B B': eqType} {Ω: distrib A} {Ω': distrib A'}
      (r: rvar Ω B) (r': rvar Ω' B') bb:
  pr_eq (rvar_pair r r') bb = pr_eq r (fst bb) * pr_eq r' (snd bb).
Proof.
  rewrite /pr_eq//=/pr ?SeriesC_fin_big.
  rewrite /index_enum -big_mkcondr.
  erewrite (eq_bigl (fun x => (r (fst x) == fst bb) && (r' (snd x) == (snd bb)))); last first.
  { rewrite //= => x. }
  rewrite -(pair_big (λ x, r x == (fst bb)) (λ y, r' y == (snd bb))
                     (fun a b => rvar_dist r a * rvar_dist r' b)%R) //=.
  rewrite big_distrl /=.
  rewrite /index_enum.
  rewrite -big_mkcondr.
  transitivity
    (\big[Rplus/0]_(i <- Finite.enum A | i \in A)
     ((if r i == bb.1 then (rvar_dist r) i *
      \big[Rplus_monoid/0]_(i0 <- Finite.enum A' | (i0 \in A') && (r' i0 == bb.2)) (rvar_dist r') i0
       else 0))); last first.
  { eapply eq_bigr => ??.  rewrite Rmult_if_distrib. case: ifP; auto. intros. field. }
  rewrite //=.
  rewrite -big_mkcondr.
  eapply eq_big.
  { intros x => //=. }
  intros a. move /eqP => Heq.
  rewrite -big_distrr /=.
  f_equal.
Qed.

Lemma rvar_pair_comp {A1 B1 A2 B2} {C1 C2: eqType} (Ω1: distrib A1) (Ω2: distrib A2)
      (r1: rvar Ω1 B1) (r2: rvar Ω2 B2) (f1: B1 → C1) (f2: B2 → C2):
  rvar_pair (rvar_comp r1 f1) (rvar_comp r2 f2) =
  rvar_comp (rvar_pair r1 r2) (λ xy, (f1 (fst xy), f2 (snd xy))).
Proof. by rewrite /=. Qed.


From Coq Require Export Reals.
From Coq Require Import Lra.
From ZornsLemma Require Import EnsemblesImplicit ImageImplicit.

Definition sup := completeness.

Open Scope R_scope.

Definition is_lower_bound (E:R->Prop) (m:R) :=
  forall x:R, E x -> x >= m.
Definition lower_bound (E:R->Prop) :=
  exists m:R, is_lower_bound E m.
Definition is_glb (E:R->Prop) (m:R) :=
  is_lower_bound E m /\ (forall b:R, is_lower_bound E b -> b <= m).

Ltac cut_by_lra H := cut H; [ lra | ].

Definition inf: forall E:R->Prop, lower_bound E -> (exists x:R, E x) ->
  { m:R | is_glb E m }.
unshelve refine (fun E Hlb Hinh =>
  let H:=_ in let H0:=_ in
  exist _ (- (proj1_sig (sup (Im E Ropp) H H0))) _).
- destruct Hlb as [m].
  exists (-m).
  red. intros.
  destruct H0.
  rewrite H1.
  auto with real.
- destruct Hinh as [x].
  now exists (-x), x.
- destruct sup as [m].
  simpl.
  split; red; intros.
  + cut_by_lra (-x <= m).
    apply i.
    now exists x.
  + cut_by_lra (m <= -b).
    apply i.
    red. intros.
    cut_by_lra (-x >= b).
    apply H1.
    destruct H2.
    rewrite H3.
    now replace (--x) with x by ring.
Defined.

Lemma lub_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_lub S m -> eps > 0 -> exists x:R, In S x /\
    m - eps < x <= m.
Proof.
intros.
assert (exists x:R, In S x /\ m - eps < x).
{ apply NNPP.
  intro.
  pose proof (not_ex_all_not _ _ H1). clear H1.
  simpl in H2.
  assert (is_upper_bound S (m-eps)).
  { red. intros.
    assert (~ x > m - eps).
    { intro.
      now contradiction (H2 x). }
    destruct (total_order_T x (m-eps)) as [[?|?]|?];
      auto with real.
  now contradiction H3. }
  destruct H.
  pose proof (H3 _ H1).
  lra. }
destruct H1 as [x [? ?]].
exists x.
repeat split; trivial.
destruct H.
now apply H.
Qed.

Lemma glb_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_glb S m -> eps > 0 -> exists x:R, In S x /\ m <= x < m + eps.
Proof.
intros.
assert (exists x:R, In S x /\ x < m + eps).
{ apply NNPP; intro.
  pose proof (not_ex_all_not _ _ H1). clear H1.
  simpl in H2.
  assert (is_lower_bound S (m+eps)).
  { red. intros.
    assert (~ x < m + eps).
    { intro.
      contradiction (H2 x).
      now split. }
    destruct (total_order_T x (m+eps)) as [[?|?]|?];
      auto with real.
    - now contradiction H3.
    - destruct H.
      lra. }
  destruct H.
  pose proof (H3 _ H1).
  lra. }
destruct H1 as [x [? ?]].
exists x.
repeat split; trivial.
destruct H.
cut_by_lra (x >= m).
auto with real.
Qed.

Lemma lt_plus_epsilon_le: forall x y:R,
  (forall eps:R, eps > 0 -> x < y + eps) -> x <= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?];
  lra || cut_by_lra (x < y + (x - y)).
apply H.
lra.
Qed.

Lemma gt_minus_epsilon_ge: forall x y:R,
  (forall eps:R, eps > 0 -> x > y - eps) -> x >= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?];
  lra || cut_by_lra (x > y - (y - x)).
apply H.
lra.
Qed.


From mathcomp
Require Import all_ssreflect.

From chip
Require Import connect acyclic kosaraju.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section KosarajuAcyclicity.

Variable V : finType.
Variable successors : V -> seq V.

Notation g := (grel successors).

Lemma uniq_flatten_kosaraju : uniq (flatten (kosaraju g)).
Proof.
have H := kosaraju_correct g.
move: H.
rewrite /=.
by case.
Qed.

Lemma all_in_flatten_kosaraju : forall v : V, v \in (flatten (kosaraju g)).
Proof.
have H := kosaraju_correct g.
move: H.
rewrite /=.
by case.
Qed.

Lemma class_diconnected_kosaraju :
  forall c, c \in kosaraju g ->
  exists x, forall y, (y \in c) = diconnect g x y.
Proof.
have H := kosaraju_correct g.
move: H.
rewrite /=.
by case.
Qed.

Definition kosaraju_acyclic := sccs_acyclic (@kosaraju V) g.

Lemma kosaraju_acyclicP :
  reflect (acyclic g) kosaraju_acyclic.
Proof.
apply sccs_acyclicP.
- exact: uniq_flatten_kosaraju.
- exact: all_in_flatten_kosaraju.
- exact: class_diconnected_kosaraju.
Qed.

End KosarajuAcyclicity.


Require Export SpecSyntax.
Require Export BoilerplateFunctions.
Set Implicit Arguments.

(******************************************************************************)
(* Lemmas.                                                                    *)
(******************************************************************************)

Create HintDb interaction.
Ltac isimpl := simpl; autorewrite with interaction; simpl.

Ltac specialize_suc :=
  progress
    match goal with
      | [ H : forall _ : nat, _, k : nat |- _ ] => apply (H (S k))
    end.
Ltac var_case :=
  match goal with
    | [ |- forall v i, _ ] =>
      induction v; simpl; intros; destruct i; auto; isimpl;
      try apply (f_equal (tshiftTy 0)) with (y := tvar _);
      try congruence; auto
  end.
Ltac ty_case T v :=
  induction T; simpl; intros;
  try solve [ try apply f_equal with (f := tvar); apply v
            | apply f_equal2 with (f := tarr); trivial
            | apply f_equal with (f := tall); specialize_suc; trivial
            ].

Lemma shiftIndex_comm_ind :
  forall v i c,
    shiftIndex (v + S c) (shiftIndex (v + O) i) =
    shiftIndex (v + O  ) (shiftIndex (v + c) i).
Proof.
  var_case.
Qed.

Lemma tshiftTy_comm_ind (T : Ty) :
  forall v c,
    tshiftTy (v + S c) (tshiftTy (v + O) T) =
    tshiftTy (v + O  ) (tshiftTy (v + c) T).
Proof.
  ty_case T shiftIndex_comm_ind.
Qed.

Lemma tshiftTy_comm (c : nat) (T : Ty) :
    tshiftTy (S c) (tshiftTy O T)
  = tshiftTy O     (tshiftTy c T).
Proof.
  apply (tshiftTy_comm_ind _ 0).
Qed.
Hint Rewrite tshiftTy_comm : interaction.

Lemma tsubstIndex_shiftIndex_reflection_ind :
  forall (k X : nat) (T : Ty),
    tsubstIndex (k + 0) T (shiftIndex (k + O) X) = tvar X.
Proof.
  var_case.
Qed.

Lemma tsubstTy_tshiftTy_reflection_ind (T : Ty) :
  forall k T',
    tsubstTy (k + 0) T' (tshiftTy (k + O) T) = T.
Proof.
  ty_case T tsubstIndex_shiftIndex_reflection_ind.
Qed.

Lemma tsubstTy_tshiftTy_reflection (T' T : Ty) :
  tsubstTy 0 T' (tshiftTy O T) = T.
Proof.
  apply (tsubstTy_tshiftTy_reflection_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tshiftTy_reflection : interaction.

Lemma tshiftTy_tsubstIndex_comm_ind :
  forall (k X c : nat) (T : Ty),
    tshiftTy (k + c) (tsubstIndex (k + 0) T X) =
    tsubstIndex (k + 0) (tshiftTy c T) (shiftIndex (k + S c) X).
Proof.
  var_case.
Qed.

Lemma tshiftTy_tsubstTy_comm_ind (T : Ty):
  forall (k c : nat) (T' : Ty),
    tshiftTy (k + c) (tsubstTy (k + 0) T' T) =
    tsubstTy (k + 0) (tshiftTy c T') (tshiftTy (k + S c) T).
Proof.
  ty_case T tshiftTy_tsubstIndex_comm_ind.
Qed.

Lemma tshiftTy_tsubstTy_comm c (T T2 : Ty) :
    tshiftTy c (tsubstTy O T T2)
  = tsubstTy O (tshiftTy c T) (tshiftTy (S c) T2).
Proof.
  apply (tshiftTy_tsubstTy_comm_ind _ 0).
Qed.
Hint Rewrite tshiftTy_tsubstTy_comm : interaction.

Lemma tsubstIndex_shiftIndex_comm_ind :
  forall k Y X T',
    tsubstIndex (k + S X) T' (shiftIndex (k + 0) Y) =
    tshiftTy (k + 0) (tsubstIndex (k + X) T' Y).
Proof.
  var_case.
Qed.

Lemma tsubstTy_tshiftTy_comm_ind (T : Ty) :
  forall k X T',
    tsubstTy (k + S X) T' (tshiftTy (k + 0) T) =
    tshiftTy (k + 0) (tsubstTy (k + X) T' T).
Proof.
  ty_case T tsubstIndex_shiftIndex_comm_ind.
Qed.

Lemma tsubstTy_tshiftTy_comm :
  forall X T' T,
    tsubstTy (S X) T' (tshiftTy 0 T) =
    tshiftTy 0 (tsubstTy X T' T).
Proof.
  intros; apply (tsubstTy_tshiftTy_comm_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tshiftTy_comm : interaction.

Lemma tsubstTy_tsubstIndex_comm_ind :
  forall k Y T1 T2 X,
    tsubstTy (k + X) T1 (tsubstIndex (k + 0) T2 Y) =
    tsubstTy (k + 0) (tsubstTy X T1 T2) (tsubstIndex (k + S X) T1 Y).
Proof.
  var_case.
Qed.

Lemma tsubstTy_tsubstTy_comm_ind (T : Ty) :
  forall k X T1 T2,
    tsubstTy (k + X) T1 (tsubstTy (k + 0) T2 T) =
    tsubstTy (k + 0) (tsubstTy X T1 T2) (tsubstTy (k + (S X)) T1 T).
Proof.
  ty_case T tsubstTy_tsubstIndex_comm_ind.
Qed.

Lemma tsubstTy_tsubstTy_comm :
  forall X T1 T2 T,
    tsubstTy X T1 (tsubstTy 0 T2 T) =
    tsubstTy 0 (tsubstTy X T1 T2) (tsubstTy (S X) T1 T).
Proof.
  intros; apply (tsubstTy_tsubstTy_comm_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tsubstTy_comm : interaction.

(******************************************************************************)
(* Context insertions.                                                        *)
(******************************************************************************)

Inductive shift_etvar : nat → Env → Env → Prop :=
  | shift_etvar_here {Γ} :
      shift_etvar 0 Γ (etvar Γ)
  | shift_etvar_there_evar {Γ1 Γ2 c T} :
      shift_etvar c Γ1 Γ2 →
      shift_etvar c (evar Γ1 T) (evar Γ2 (tshiftTy c T))
  | shift_etvar_there_etvar {Γ1 Γ2 c} :
      shift_etvar c Γ1 Γ2 →
      shift_etvar (S c) (etvar Γ1) (etvar Γ2).
Hint Constructors shift_etvar.

Inductive shift_evar : nat → Env → Env → Prop :=
  | shift_evar_here {Γ T} :
      shift_evar 0 Γ (evar Γ T)
  | shift_evar_there_evar {Γ1 Γ2 c T} :
      shift_evar c Γ1 Γ2 →
      shift_evar (S c) (evar Γ1 T) (evar Γ2 T)
  | shift_evar_there_etvar {Γ1 Γ2 c} :
      shift_evar c Γ1 Γ2 →
      shift_evar c (etvar Γ1) (etvar Γ2).
Hint Constructors shift_evar.

(******************************************************************************)
(* Lemmas about shifting and context lookups.                                 *)
(******************************************************************************)

Lemma shift_etvar_lookup_etvar {Γ1 Γ2 c} (ib : shift_etvar c Γ1 Γ2) :
  ∀ X, lookup_etvar Γ1 X →
       lookup_etvar Γ2 (shiftIndex c X).
Proof.
  induction ib; inversion 1; isimpl; eauto.
Qed.
Hint Resolve shift_etvar_lookup_etvar.

Lemma shift_etvar_lookup_evar {Γ1 Γ2 c} (ib : shift_etvar c Γ1 Γ2) :
  ∀ x T, lookup_evar Γ1 x T →
         lookup_evar Γ2 x (tshiftTy c T).
Proof.
  induction ib; inversion 1; isimpl; eauto.
Qed.
Hint Resolve shift_etvar_lookup_evar.

Lemma shift_evar_lookup_etvar {Γ1 Γ2 c} (iv : shift_evar c Γ1 Γ2) :
  ∀ X, lookup_etvar Γ1 X → lookup_etvar Γ2 X.
Proof.
  induction iv; inversion 1; simpl; eauto.
Qed.
Hint Resolve shift_evar_lookup_etvar.

Lemma shift_evar_lookup_evar {Γ1 Γ2 c} (iv : shift_evar c Γ1 Γ2) :
  ∀ x T, lookup_evar Γ1 x T → lookup_evar Γ2 (shiftIndex c x) T.
Proof.
  induction iv; inversion 1; simpl; eauto.
Qed.
Hint Resolve shift_evar_lookup_evar.

(******************************************************************************)
(* Weakening lemmas for well-formedness                                       *)
(******************************************************************************)

Lemma shift_etvar_wftyp {Γ1 T} (wfT: wfTy Γ1 T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → wfTy Γ2 (tshiftTy c T).
Proof.
  induction wfT; simpl; econstructor; eauto.
Qed.
Hint Resolve shift_etvar_wftyp.

Lemma shift_evar_wftyp {Γ1 T} (wfT: wfTy Γ1 T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → wfTy Γ2 T.
Proof.
  induction wfT; simpl; econstructor; eauto.
Qed.
Hint Resolve shift_evar_wftyp.