(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about the unit type *)

Require Import HoTT.Basics.
Local Open Scope path_scope.

Generalizable Variables A.

(** ** Eta conversion *)

Definition eta_unit (z : Unit) : tt = z
  := match z with tt => 1 end.

(** ** Paths *)

(* This is all kind of ridiculous, but it fits the pattern. *)

Definition path_unit_uncurried (z z' : Unit) : Unit -> z = z'
  := fun _ => match z, z' with tt, tt => 1 end.

Definition path_unit (z z' : Unit) : z = z'
  := path_unit_uncurried z z' tt.

Definition eta_path_unit {z z' : Unit} (p : z = z') :
  path_unit z z' = p.
Proof.
  destruct p. destruct z. reflexivity.
Defined.

Global Instance isequiv_path_unit (z z' : Unit) : IsEquiv (path_unit_uncurried z z') | 0.
  refine (Build_IsEquiv _ _ (path_unit_uncurried z z') (fun _ => tt)
    (fun p:z=z' =>
      match p in (_ = z') return (path_unit_uncurried z z' tt = p) with
        | idpath => match z as z return (path_unit_uncurried z z tt = 1) with
                    | tt => 1
                  end
      end)
    (fun x => match x with tt => 1 end) _).
  intros []; destruct z, z'; reflexivity.
Defined.

Definition equiv_path_unit (z z' : Unit) : Unit <~> (z = z')
  := Build_Equiv _ _ (path_unit_uncurried z z') _.

(** ** Transport *)

(** Is a special case of transporting in a constant fibration. *)

(** ** Universal mapping properties *)

(* The positive universal property *)
Arguments Unit_ind [A] a u : rename.

Global Instance isequiv_unit_ind `{Funext} (A : Unit -> Type)
: IsEquiv (@Unit_ind A) | 0
  := isequiv_adjointify _
  (fun f : forall u:Unit, A u => f tt)
  (fun f : forall u:Unit, A u => path_forall (@Unit_ind A (f tt)) f
                                             (fun x => match x with tt => 1 end))
  (fun _ => 1).

Global Instance isequiv_unit_rec `{Funext} (A : Type)
: IsEquiv (@Unit_ind (fun _ => A)) | 0
  := isequiv_unit_ind (fun _ => A).

Definition equiv_unit_rec `{Funext} (A : Type)
  : A <~> (Unit -> A)
  := (Build_Equiv _ _ (@Unit_ind (fun _ => A)) _).

(* For various reasons, it is typically more convenient to define functions out of the unit as constant maps, rather than [Unit_ind]. *)
Notation unit_name x := (fun (_ : Unit) => x).

Global Instance isequiv_unit_name@{i j} `{Funext} (A : Type@{i})
: @IsEquiv@{i j} _ (Unit -> _) (fun (a:A) => unit_name a).
Proof.
  refine (isequiv_adjointify _ (fun f : Unit -> _ => f tt) _ _).
  - intros f; apply path_forall@{i i j}; intros x.
    apply ap@{i i}, path_unit.
  - intros a; reflexivity.
Defined.

(* The negative universal property *)
Definition unit_coind {A : Type} : Unit -> (A -> Unit)
  := fun _ _ => tt.

Global Instance isequiv_unit_coind `{Funext} (A : Type) : IsEquiv (@unit_coind A) | 0.
Proof.
  refine (isequiv_adjointify _ (fun f => tt) _ _).
  - intro f. apply path_forall; intros x; apply path_unit.
  - intro x; destruct x; reflexivity.
Defined.

Definition equiv_unit_coind `{Funext} (A : Type)
  : Unit <~> (A -> Unit)
  := Build_Equiv _ _ (@unit_coind A) _.

(** ** Truncation *)

(* The Unit type is contractible *)
(** Because [Contr] is a notation, and [Contr_internal] is the record, we need to iota expand to fool Coq's typeclass machinery into accepting supposedly "mismatched" contexts. *)
Global Instance contr_unit : Contr Unit | 0 := let x := {|
  center := tt;
  contr := fun t : Unit => match t with tt => 1 end
|} in x.

(** ** Equivalences *)

(** A contractible type is equivalent to [Unit]. *)
Definition equiv_contr_unit `{Contr A} : A <~> Unit.
Proof.
  refine (Build_Equiv _ _
    (fun (_ : A) => tt)
    (Build_IsEquiv _ _ _
      (fun (_ : Unit) => center A)
      (fun t : Unit => match t with tt => 1 end)
      (fun x : A => contr x) _)).
  intro x. symmetry; apply ap_const.
Defined.

(* Conversely, a type equivalent to [Unit] is contractible. *)
Global Instance contr_equiv_unit (A : Type) (f : A <~> Unit) : Contr A | 10000
  := Build_Contr A (f^-1 tt)
  (fun a => ap f^-1 (contr (f a)) @ eissect f a).


Set Implicit Arguments.

Require Import Coq.Structures.DecidableTypeEx.
Require Import Coq.FSets.FSetInterface.
Require Coq.FSets.FSetProperties.
Require Bedrock.Platform.Cito.GeneralTactics.
Require Bedrock.Platform.Cito.SetoidListFacts.
Require Bedrock.Platform.Cito.ListFacts1.

Module UWFacts_fun (E : UsualDecidableType) (Import M : WSfun E).

  Import Coq.FSets.FSetProperties.
  Module Import P := WProperties_fun E M.
  Import FM.

  Module FSetNotations.
    Infix "+" := union : fset_scope.
    Infix "-" := diff : fset_scope.
    Infix "*" := inter : fset_scope.
    Infix "<=" := Subset : fset_scope.
    Delimit Scope fset_scope with fset.
    Module FSetNotationsTrial.
      Notation " [ ] " := empty : fset_scope.
      Notation "m %- k" := (remove k m) (at level 60) : fset_scope.
    End FSetNotationsTrial.
  End FSetNotations.

  Definition Disjoint a b := forall x, ~ (In x a /\ In x b).

  Import ListNotations.
  Import Bedrock.Platform.Cito.GeneralTactics.

  Import Bedrock.Platform.Cito.SetoidListFacts.

  Lemma NoDup_elements : forall s, List.NoDup (elements s).
    intros.
    apply NoDupA_NoDup.
    apply elements_3w.
  Qed.

  Lemma of_list_fwd : forall e ls,
    In e (of_list ls)
    -> List.In e ls.
    intros.
    eapply of_list_1 in H.
    eapply InA_eq_In_iff; eauto.
  Qed.

  Lemma of_list_bwd : forall e ls,
    List.In e ls
    -> In e (of_list ls).
    intros.
    eapply of_list_1.
    eapply InA_eq_In_iff; eauto.
  Qed.

  Local Hint Resolve of_list_fwd of_list_bwd.

  Lemma of_list_spec : forall e ls, In e (of_list ls) <-> List.In e ls.
    generalize of_list_fwd, of_list_bwd; firstorder.
  Qed.

  Lemma of_list_singleton : forall e, Equal (of_list [e]) (singleton e).
    intros.
    unfold of_list.
    simpl.
    unfold Equal.
    split; intros.
    eapply singleton_iff.
    eapply add_iff in H.
    openhyp.
    eauto.
    eapply empty_iff in H.
    intuition.
    eapply singleton_iff in H.
    eapply add_iff; eauto.
  Qed.

  Lemma of_list_cons : forall e ls, Equal (of_list (e :: ls)) (union (singleton e) (of_list ls)).
    unfold Equal; intuition.
    simpl in *.
    apply add_iff in H; intuition (subst; eauto).
    apply union_iff; left; apply singleton_iff; auto.
    eapply union_iff; eauto.
    simpl.
    apply union_iff in H.
    openhyp.
    eapply singleton_iff in H.
    eapply add_iff; eauto.
    eapply add_iff; eauto.
  Qed.

  Global Add Morphism Disjoint with signature Equal ==> Equal ==> iff as Disjoint_m.
    unfold Equal, Disjoint; firstorder.
  Qed.

  Local Hint Resolve union_2 union_3.

  Lemma Disjoint_union : forall s1 s2 s3, Disjoint s1 (union s2 s3) <-> (Disjoint s1 s2 /\ Disjoint s1 s3).
    unfold Disjoint; intuition eauto.
    apply union_iff in H3; intuition eauto.
  Qed.

  Local Hint Resolve singleton_2.

  Lemma Disjoint_singletons : forall e1 e2, Disjoint (singleton e1) (singleton e2) <-> e1 <> e2.
    unfold Disjoint; intuition eauto.
    apply singleton_iff in H1; apply singleton_iff in H2.
    congruence.
  Qed.

  Lemma Disjoint_singleton : forall e s, Disjoint (singleton e) s <-> ~ In e s.
    unfold Disjoint; intuition eauto.
    apply singleton_iff in H1.
    congruence.
  Qed.

  Local Hint Resolve inter_1 inter_2 inter_3.

  Lemma inter_is_empty_iff : forall s1 s2, is_empty (inter s1 s2) = true <-> Disjoint s1 s2.
    unfold Disjoint; intuition eauto.
    apply is_empty_2 in H.
    eapply H; eauto.
    apply is_empty_1.
    hnf; intuition.
    eauto.
  Qed.

  Lemma Equal_Subset_iff : forall s1 s2, Equal s1 s2 <-> (Subset s1 s2 /\ Subset s2 s1).
    unfold Equal, Subset; firstorder.
  Qed.

  Require Import IffFacts.
  Export IffFacts.

  Lemma singleton_not_iff x x' : ~ In x' (singleton x) <-> x <> x'.
  Proof.
    eapply iff_not_iff.
    eapply singleton_iff.
  Qed.

  Lemma union_not_iff a b x : ~ In x (union a b) <-> (~ In x a /\ ~ In x b).
  Proof.
    etransitivity.
    - eapply iff_not_iff.
      eapply union_iff.
    - intuition.
  Qed.

  Lemma of_list_not_iff x ls : ~ In x (of_list ls) <-> ~ List.In x ls.
    eapply iff_not_iff.
    eapply of_list_spec.
  Qed.

  Lemma set_disjoint_list_disjoint ls1 ls2 : Disjoint (of_list ls1) (of_list ls2) -> ListFacts1.Disjoint ls1 ls2.
    unfold ListFacts1.Disjoint, Disjoint.
    intros Hdisj e [Hin1 Hin2].
    eapply Hdisj; split; eapply of_list_spec; eauto.
  Qed.

  Lemma list_disjoint_set_disjoint ls1 ls2 : ListFacts1.Disjoint ls1 ls2 -> Disjoint (of_list ls1) (of_list ls2).
    unfold ListFacts1.Disjoint, Disjoint.
    intros Hdisj e [Hin1 Hin2].
    eapply Hdisj; split; eapply of_list_spec; eauto.
  Qed.

  Lemma compat_bool_f A (f : A -> bool) : SetoidList.compat_bool Logic.eq f.
    unfold SetoidList.compat_bool.
    intuition.
  Qed.

  Lemma for_all_elim p s : for_all p s = true -> forall x, In x s -> p x = true.
  Proof.
    intros H x Hin.
    eapply for_all_iff in H; eauto.
    eapply compat_bool_f; eauto.
  Qed.

  Global Arguments for_all_elim [p s] _ _ _.

  Lemma for_all_intro p s : (forall x, In x s -> p x = true) -> for_all p s = true.
  Proof.
    intros H.
    eapply for_all_iff; eauto.
    eapply compat_bool_f; eauto.
  Qed.

  Lemma for_all_singleton_elim p x : for_all p (singleton x) = true -> p x = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    eapply HH.
    eapply singleton_iff; eauto.
  Qed.

  Lemma for_all_union_elim p a b : for_all p (union a b) = true -> for_all p a = true /\ for_all p b = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    split.
    - eapply for_all_intro.
      intros; eapply HH.
      eapply union_iff; intuition.
    - eapply for_all_intro.
      intros; eapply HH.
      eapply union_iff; intuition.
  Qed.

  Lemma for_all_of_list_elim p ls : for_all p (of_list ls) = true -> List.forallb p ls = true.
  Proof.
    intros H.
    specialize (for_all_elim H); intros HH.
    eapply List.forallb_forall.
    intros x Hin.
    eapply HH.
    eapply of_list_spec; eauto.
  Qed.

End UWFacts_fun.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Arith.
Require Export Divides.
Require Export Binomials.

Lemma div_fact :
 forall p k : nat,
 prime p ->
 0 < k ->
 divides p (factorial k) -> exists j : nat, 0 < j /\ j <= k /\ divides p j.
Proof.
simple induction k.
simpl in |- *; intros H' H'0; absurd (0 < 0); auto with arith.
intros k' H' H'0 H'1 H'2; case (L_Euclides2 p (S k') (factorial k')); auto.
intros H'3; exists (S k'); auto.
intros H'3.
elim H';
 [ intros j E; elim E; intros H'7 H'8; elim H'8; intros H'9 H'10;
    try exact H'10
 | clear H'
 | clear H'
 | clear H' ]; auto.
exists j; split; auto.
generalize H'3; case k'; simpl in |- *; auto with arith.
intros H'4; absurd (prime 1); auto.
rewrite (divides_antisym 1 p); auto.
Qed.

Lemma p_div_bin :
 forall k p : nat, prime p -> 0 < k -> k < p -> divides p (binomial p k).
Proof.
intros k p; case p; auto.
intros H'; absurd (prime 0); auto.
intros p' H' H'0 H'1.
apply L_Euclides1 with (factorial k); auto.
apply L_Euclides1 with (factorial (S p' - k)); auto.
rewrite mult_assoc.
rewrite mult_comm.
pattern (S p') at 2 in |- *; rewrite (le_plus_minus k (S p'));
 auto with arith.
rewrite mult_comm with (m := factorial k); auto.
rewrite binomial_fact; auto.
rewrite <- le_plus_minus; auto with arith.
apply dividesDef with (q := factorial p'); rewrite mult_comm; auto.
red in |- *; intros H'2; elim (div_fact (S p') (S p' - k));
 [ intros j E; elim E; intros H'7 H'8; elim H'8; intros H'9 H'10; clear H'8 E
 | idtac
 | idtac
 | idtac ]; auto with arith.
absurd (divides (S p') j); auto.
apply not_lt_div; auto.
apply le_lt_trans with (m := S p' - k); auto with arith.
apply lt_minus_O_lt; auto.
red in |- *; intros H'2.
elim (div_fact (S p') k);
 [ intros j E; elim E; intros H'8 H'9; elim H'9; intros H'10 H'11;
    clear H'9 E
 | idtac
 | idtac
 | idtac ]; auto.
absurd (divides (S p') j); auto.
apply not_lt_div; auto.
apply le_lt_trans with (m := k); auto with arith.
Qed.

Lemma Fermat1 :
 forall x p : nat, prime p -> congruent p (power (x + 1) p) (power x p + 1).
Proof.
intros x p; case p; auto.
intros H'; absurd (prime 0); auto.
intros n; case n.
intros H'; absurd (prime 1); auto.
intros n0 H'.
rewrite (exp_Pascal x 1).
rewrite sum_nm_i.
rewrite sum_nm_f.
replace (binomial (S (S n0)) 0 * (power x (S (S n0) - 0) * power 1 0)) with
 (power x (S (S n0))).
replace
 (binomial (S (S n0)) (1 + S n0) *
  (power x (S (S n0) - (1 + S n0)) * power 1 (1 + S n0))) with 1.
rewrite plus_comm with (m := 1).
replace (power x (S (S n0)) + 1) with (power x (S (S n0)) + 1 + 0);
 auto with arith.
rewrite plus_assoc.
apply cong_plus; auto.
apply cong_ref; auto.
apply inv_sum_nm.
replace 0 with (0 + 0); auto.
intros; apply cong_plus; auto.
intros.
apply cong_mult_O.
apply cong_sym.
apply divides_cong.
apply p_div_bin; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; rewrite binomial_def3; simpl in |- *; auto.
repeat (rewrite binomial_def2; simpl in |- *; auto with arith).
rewrite <- minus_n_n; auto.
rewrite power_SO.
simpl in |- *; auto.
simpl in |- *; auto.
rewrite <- plus_n_O.
rewrite mult_1_r; auto.
Qed.

Lemma Fermat2 : forall x p : nat, prime p -> congruent p (power x p) x.
Proof.
intros x; elim x; auto.
intros p; case p; simpl in |- *; auto.
intros H'; absurd (prime 0); auto.
intros n H'; apply cong_ref; auto.
intros n H' p H'0.
apply (cong_trans p) with (b := power n p + 1).
replace (S n) with (n + 1); auto with arith.
apply Fermat1; auto.
rewrite plus_comm; simpl in |- *; auto.
replace (S n) with (n + 1).
apply cong_plus; auto.
apply cong_ref.
rewrite plus_comm; simpl in |- *; auto.
Qed.

Theorem Fermat :
 forall x p : nat,
 prime p -> ~ divides p x -> congruent p (power x (p - 1)) 1.
Proof.
intros x p H' H'0.
cut (x <= power x p); [ intros Lex | idtac ].
cut (divides p (power x p - x)); [ intros H'1; inversion_clear H'1 | idtac ].
cut (power x p = x * power x (p - 1)); [ intros Eqp | idtac ].
cut (x <> 0); [ intros nx | idtac ].
cut (divides x q); [ intros H2; inversion_clear H2 | idtac ].
apply congruentDef with (u := 0) (v := q0); simpl in |- *; auto.
rewrite <- plus_n_O.
apply eq_mult with x; auto.
rewrite <- Eqp; auto.
rewrite mult_comm; simpl in |- *.
rewrite mult_comm with (m := x).
rewrite mult_assoc.
rewrite (mult_comm x).
rewrite <- H0.
rewrite <- H.
apply le_plus_minus; auto.
apply L_Euclides with (a := p); auto.
apply prime_gcd; auto.
rewrite mult_comm; rewrite <- H.
apply dividesDef with (q := power x (p - 1) - 1); auto.
rewrite mult_minus_distr_r.
apply f_equal2 with (A1 := nat) (A2 := nat); simpl in |- *; auto.
rewrite mult_comm; auto.
red in |- *; intros H'1; case H'0; rewrite H'1; auto.
generalize H'; case p; simpl in |- *; auto with arith.
intros H'1; absurd (prime 0); auto.
apply cong_divides; auto.
apply Fermat2; auto.
generalize H'; case p; auto.
intros H'1; absurd (prime 0); auto.
intros n H'1.
apply power_le; auto with arith.
Qed.


Require Import FP.CoreClasses.
Require Import FP.Classes.
Require Import FP.DerivingEverything.
Require Import FP.Data.Type.
Require Import FP.Data.Sum.

Import ClassesNotation.
Import CoreClassesNotation.

Inductive error E A :=
  | Failure : E -> error E A
  | Success : A -> error E A.
Arguments Failure {E A} _.
Arguments Success {E A} _.

Section error_Bijection.
  Context {E A:Type}.

  Definition error_to_sum (aM:error E A) : E + A :=
    match aM with
    | Failure e => inl e
    | Success a => inr a
    end.
  Global Instance IR_error_to_sum_eq
    : InjectionRespect (error E A) (E+A) error_to_sum eq eq.
  Proof.
    constructor ; unfold Proper ; simpl in * ; intros ; try congruence.
    destruct x,y ; simpl in * ; congruence.
  Qed.

  Definition sum_to_error (aM:E+A) : error E A :=
    match aM with
    | inl e => Failure e
    | inr a => Success a
    end.
  Global Instance II_sum_to_error_eq
    : InjectionInverse (E+A) (error E A) sum_to_error error_to_sum eq.
  Proof.
    constructor ; intros.
    destruct x ; simpl in * ; auto.
  Qed.
End error_Bijection.

Module error_DE_Arg <: DE_IdxFunctor_Arg.
  Definition T := error.
  Definition U := sum.
  Definition to : forall {E A}, T E A -> U E A := @error_to_sum.
  Definition from : forall {E A}, U E A -> T E A := @sum_to_error.
  Definition IR_to {E A} : InjectionRespect (T E A) (U E A) to eq eq := _.
  Definition II_from {E A} : InjectionInverse (U E A) (T E A) from to eq := _.
  Definition _DE_IdxFunctorI : DE_IdxFunctorI' U.
  Proof. econstructor ; econstructor ; eauto with typeclass_instances. Defined.
End error_DE_Arg.
Module error_DE := DE_IdxFunctor error_DE_Arg.
Import error_DE.

Section IR.
  Context {E A C} `{! Eqv E ,! PER_WF E ,! Eqv A ,! PER_WF A ,! Eqv C ,! PER_WF C }.

  Global Instance IR_Failure_eqv : InjectionRespect E (error E A) Failure eqv eqv.
  Proof.
    constructor ; unfold Proper,"==>","<==" ; intros ; simpl.
    - apply InjectionRespect_beta ; simpl.
      apply InjectionRespect_eta ; auto.
    - apply InjectionRespect_eta in H ; simpl in H.
      apply InjectionRespect_beta in H ; auto.
  Qed.

  Global Instance Failure_Proper : Proper eqv (@Failure E A) := Proper_inj.

  Global Instance IR_Success_eqv : InjectionRespect A (error E A) Success eqv eqv.
    constructor ; unfold Proper,"==>","<==" ; intros ; simpl.
    - apply InjectionRespect_beta ; simpl.
      apply InjectionRespect_eta ; auto.
    - apply InjectionRespect_eta in H ; simpl in H.
      apply InjectionRespect_beta in H ; auto.
  Qed.

  Global Instance Success_Proper : Proper eqv (@Success E A) := Proper_inj.
End IR.

Definition error_elim {E A C} (aM:error E A) (ef:E -> C) (af:A -> C) : C :=
  match aM with
  | Failure e => ef e
  | Success a => af a
  end.
Section error_elim_Proper.
  Context {E A C} `{! Eqv E ,! PER_WF E ,! Eqv A ,! PER_WF A ,! Eqv C ,! PER_WF C }.
  Global Instance error_elim_Proper : Proper eqv (@error_elim E A C).
  Proof.
    unfold Proper ; logical_eqv_intro.
    destruct x,y ; simpl ; logical_eqv.
    - apply InjectionRespect_beta in H ; auto.
    - inversion H.
    - inversion H.
    - apply InjectionRespect_beta in H ; auto.
  Qed.
End error_elim_Proper.
Definition from_elim {E A} (ef:E -> A) (aM:error E A) : A := error_elim aM ef id.

Ltac fold_error :=
  match goal with
  | [ |- context
         [ match ?aM with
           | Failure e => (@?ef e)
           | Success a => (@?af a)
           end
         ]
    ] => fold (error_elim aM ef af)
  end.


From ASUB Require Import core unscoped.

Require Import Setoid Morphisms Relation_Definitions.

Inductive ty : Type :=
  | var_ty : nat -> ty
  | arr : ty -> ty -> ty
  | all : ty -> ty.

Lemma congr_arr {s0 : ty} {s1 : ty} {t0 : ty} {t1 : ty} (H0 : s0 = t0)
  (H1 : s1 = t1) : arr s0 s1 = arr t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => arr x s1) H0))
         (ap (fun x => arr t0 x) H1)).
Qed.

Lemma congr_all {s0 : ty} {t0 : ty} (H0 : s0 = t0) : all s0 = all t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => all x) H0)).
Qed.

Lemma upRen_ty_ty (xi : nat -> nat) : nat -> nat.
Proof.
exact (up_ren xi).
Defined.

Fixpoint ren_ty (xi_ty : nat -> nat) (s : ty) {struct s} : ty :=
  match s with
  | var_ty s0 => var_ty (xi_ty s0)
  | arr s0 s1 => arr (ren_ty xi_ty s0) (ren_ty xi_ty s1)
  | all s0 => all (ren_ty (upRen_ty_ty xi_ty) s0)
  end.

Lemma up_ty_ty (sigma : nat -> ty) : nat -> ty.
Proof.
exact (scons (var_ty var_zero) (funcomp (ren_ty shift) sigma)).
Defined.

Fixpoint subst_ty (sigma_ty : nat -> ty) (s : ty) {struct s} : ty :=
  match s with
  | var_ty s0 => sigma_ty s0
  | arr s0 s1 => arr (subst_ty sigma_ty s0) (subst_ty sigma_ty s1)
  | all s0 => all (subst_ty (up_ty_ty sigma_ty) s0)
  end.

Lemma upId_ty_ty (sigma : nat -> ty) (Eq : forall x, sigma x = var_ty x) :
  forall x, up_ty_ty sigma x = var_ty x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint idSubst_ty (sigma_ty : nat -> ty)
(Eq_ty : forall x, sigma_ty x = var_ty x) (s : ty) {struct s} :
subst_ty sigma_ty s = s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (idSubst_ty sigma_ty Eq_ty s0) (idSubst_ty sigma_ty Eq_ty s1)
  | all s0 =>
      congr_all (idSubst_ty (up_ty_ty sigma_ty) (upId_ty_ty _ Eq_ty) s0)
  end.

Lemma upExtRen_ty_ty (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_ty_ty xi x = upRen_ty_ty zeta x.
Proof.
exact (fun n => match n with
                | S n' => ap shift (Eq n')
                | O => eq_refl
                end).
Qed.

Fixpoint extRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat)
(Eq_ty : forall x, xi_ty x = zeta_ty x) (s : ty) {struct s} :
ren_ty xi_ty s = ren_ty zeta_ty s :=
  match s with
  | var_ty s0 => ap var_ty (Eq_ty s0)
  | arr s0 s1 =>
      congr_arr (extRen_ty xi_ty zeta_ty Eq_ty s0)
        (extRen_ty xi_ty zeta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (extRen_ty (upRen_ty_ty xi_ty) (upRen_ty_ty zeta_ty)
           (upExtRen_ty_ty _ _ Eq_ty) s0)
  end.

Lemma upExt_ty_ty (sigma : nat -> ty) (tau : nat -> ty)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_ty_ty sigma x = up_ty_ty tau x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint ext_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty)
(Eq_ty : forall x, sigma_ty x = tau_ty x) (s : ty) {struct s} :
subst_ty sigma_ty s = subst_ty tau_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (ext_ty sigma_ty tau_ty Eq_ty s0)
        (ext_ty sigma_ty tau_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (ext_ty (up_ty_ty sigma_ty) (up_ty_ty tau_ty) (upExt_ty_ty _ _ Eq_ty)
           s0)
  end.

Lemma up_ren_ren_ty_ty (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_ty_ty zeta) (upRen_ty_ty xi) x = upRen_ty_ty rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Fixpoint compRenRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat)
(rho_ty : nat -> nat) (Eq_ty : forall x, funcomp zeta_ty xi_ty x = rho_ty x)
(s : ty) {struct s} : ren_ty zeta_ty (ren_ty xi_ty s) = ren_ty rho_ty s :=
  match s with
  | var_ty s0 => ap var_ty (Eq_ty s0)
  | arr s0 s1 =>
      congr_arr (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s0)
        (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compRenRen_ty (upRen_ty_ty xi_ty) (upRen_ty_ty zeta_ty)
           (upRen_ty_ty rho_ty) (up_ren_ren _ _ _ Eq_ty) s0)
  end.

Lemma up_ren_subst_ty_ty (xi : nat -> nat) (tau : nat -> ty)
  (theta : nat -> ty) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_ty_ty tau) (upRen_ty_ty xi) x = up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint compRenSubst_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp tau_ty xi_ty x = theta_ty x) (s : ty) {struct s} :
subst_ty tau_ty (ren_ty xi_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s0)
        (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compRenSubst_ty (upRen_ty_ty xi_ty) (up_ty_ty tau_ty)
           (up_ty_ty theta_ty) (up_ren_subst_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma up_subst_ren_ty_ty (sigma : nat -> ty) (zeta_ty : nat -> nat)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (ren_ty zeta_ty) sigma x = theta x) :
  forall x,
  funcomp (ren_ty (upRen_ty_ty zeta_ty)) (up_ty_ty sigma) x =
  up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenRen_ty shift (upRen_ty_ty zeta_ty)
                (funcomp shift zeta_ty) (fun x => eq_refl) (sigma n'))
             (eq_trans
                (eq_sym
                   (compRenRen_ty zeta_ty shift (funcomp shift zeta_ty)
                      (fun x => eq_refl) (sigma n')))
                (ap (ren_ty shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstRen_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp (ren_ty zeta_ty) sigma_ty x = theta_ty x)
(s : ty) {struct s} :
ren_ty zeta_ty (subst_ty sigma_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s0)
        (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compSubstRen_ty (up_ty_ty sigma_ty) (upRen_ty_ty zeta_ty)
           (up_ty_ty theta_ty) (up_subst_ren_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma up_subst_subst_ty_ty (sigma : nat -> ty) (tau_ty : nat -> ty)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (subst_ty tau_ty) sigma x = theta x) :
  forall x,
  funcomp (subst_ty (up_ty_ty tau_ty)) (up_ty_ty sigma) x = up_ty_ty theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenSubst_ty shift (up_ty_ty tau_ty)
                (funcomp (up_ty_ty tau_ty) shift) (fun x => eq_refl)
                (sigma n'))
             (eq_trans
                (eq_sym
                   (compSubstRen_ty tau_ty shift
                      (funcomp (ren_ty shift) tau_ty) (fun x => eq_refl)
                      (sigma n'))) (ap (ren_ty shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstSubst_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty)
(theta_ty : nat -> ty)
(Eq_ty : forall x, funcomp (subst_ty tau_ty) sigma_ty x = theta_ty x)
(s : ty) {struct s} :
subst_ty tau_ty (subst_ty sigma_ty s) = subst_ty theta_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s0)
        (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (compSubstSubst_ty (up_ty_ty sigma_ty) (up_ty_ty tau_ty)
           (up_ty_ty theta_ty) (up_subst_subst_ty_ty _ _ _ Eq_ty) s0)
  end.

Lemma rinstInst_up_ty_ty (xi : nat -> nat) (sigma : nat -> ty)
  (Eq : forall x, funcomp var_ty xi x = sigma x) :
  forall x, funcomp var_ty (upRen_ty_ty xi) x = up_ty_ty sigma x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_ty shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint rinst_inst_ty (xi_ty : nat -> nat) (sigma_ty : nat -> ty)
(Eq_ty : forall x, funcomp var_ty xi_ty x = sigma_ty x) (s : ty) {struct s} :
ren_ty xi_ty s = subst_ty sigma_ty s :=
  match s with
  | var_ty s0 => Eq_ty s0
  | arr s0 s1 =>
      congr_arr (rinst_inst_ty xi_ty sigma_ty Eq_ty s0)
        (rinst_inst_ty xi_ty sigma_ty Eq_ty s1)
  | all s0 =>
      congr_all
        (rinst_inst_ty (upRen_ty_ty xi_ty) (up_ty_ty sigma_ty)
           (rinstInst_up_ty_ty _ _ Eq_ty) s0)
  end.

Lemma renRen_ty (xi_ty : nat -> nat) (zeta_ty : nat -> nat) (s : ty) :
  ren_ty zeta_ty (ren_ty xi_ty s) = ren_ty (funcomp zeta_ty xi_ty) s.
Proof.
exact (compRenRen_ty xi_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma compRen_ty (sigma_ty : nat -> ty) (zeta_ty : nat -> nat) (s : ty) :
  ren_ty zeta_ty (subst_ty sigma_ty s) =
  subst_ty (funcomp (ren_ty zeta_ty) sigma_ty) s.
Proof.
exact (compSubstRen_ty sigma_ty zeta_ty _ (fun n => eq_refl) s).
Qed.

Lemma renComp_ty (xi_ty : nat -> nat) (tau_ty : nat -> ty) (s : ty) :
  subst_ty tau_ty (ren_ty xi_ty s) = subst_ty (funcomp tau_ty xi_ty) s.
Proof.
exact (compRenSubst_ty xi_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma compComp_ty (sigma_ty : nat -> ty) (tau_ty : nat -> ty) (s : ty) :
  subst_ty tau_ty (subst_ty sigma_ty s) =
  subst_ty (funcomp (subst_ty tau_ty) sigma_ty) s.
Proof.
exact (compSubstSubst_ty sigma_ty tau_ty _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_ty (xi_ty : nat -> nat) (s : ty) :
  ren_ty xi_ty s = subst_ty (funcomp var_ty xi_ty) s.
Proof.
exact (rinst_inst_ty xi_ty _ (fun n => eq_refl) s).
Qed.

Lemma instId'_ty (s : ty) : subst_ty var_ty s = s.
Proof.
exact (idSubst_ty var_ty (fun n => eq_refl) s).
Qed.

Lemma rinstId'_ty (s : ty) : ren_ty id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_ty s) (rinstInst'_ty id s)).
Qed.

Lemma varL'_ty (sigma_ty : nat -> ty) (x : nat) :
  subst_ty sigma_ty (var_ty x) = sigma_ty x.
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_ty (xi_ty : nat -> nat) (x : nat) :
  ren_ty xi_ty (var_ty x) = var_ty (xi_ty x).
Proof.
exact (eq_refl).
Qed.

Inductive tm : Type :=
  | app : tm -> tm -> tm
  | tapp : tm -> ty -> tm
  | vt : vl -> tm
with vl : Type :=
  | var_vl : nat -> vl
  | lam : ty -> tm -> vl
  | tlam : tm -> vl.

Lemma congr_app {s0 : tm} {s1 : tm} {t0 : tm} {t1 : tm} (H0 : s0 = t0)
  (H1 : s1 = t1) : app s0 s1 = app t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app x s1) H0))
         (ap (fun x => app t0 x) H1)).
Qed.

Lemma congr_tapp {s0 : tm} {s1 : ty} {t0 : tm} {t1 : ty} (H0 : s0 = t0)
  (H1 : s1 = t1) : tapp s0 s1 = tapp t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => tapp x s1) H0))
         (ap (fun x => tapp t0 x) H1)).
Qed.

Lemma congr_vt {s0 : vl} {t0 : vl} (H0 : s0 = t0) : vt s0 = vt t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => vt x) H0)).
Qed.

Lemma congr_lam {s0 : ty} {s1 : tm} {t0 : ty} {t1 : tm} (H0 : s0 = t0)
  (H1 : s1 = t1) : lam s0 s1 = lam t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => lam x s1) H0))
         (ap (fun x => lam t0 x) H1)).
Qed.

Lemma congr_tlam {s0 : tm} {t0 : tm} (H0 : s0 = t0) : tlam s0 = tlam t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => tlam x) H0)).
Qed.

Lemma upRen_ty_vl (xi : nat -> nat) : nat -> nat.
Proof.
exact (xi).
Defined.

Lemma upRen_vl_ty (xi : nat -> nat) : nat -> nat.
Proof.
exact (xi).
Defined.

Lemma upRen_vl_vl (xi : nat -> nat) : nat -> nat.
Proof.
exact (up_ren xi).
Defined.

Fixpoint ren_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat) (s : tm) {struct s}
   : tm :=
  match s with
  | app s0 s1 => app (ren_tm xi_ty xi_vl s0) (ren_tm xi_ty xi_vl s1)
  | tapp s0 s1 => tapp (ren_tm xi_ty xi_vl s0) (ren_ty xi_ty s1)
  | vt s0 => vt (ren_vl xi_ty xi_vl s0)
  end
with ren_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat) (s : vl) {struct s} :
vl :=
  match s with
  | var_vl s0 => var_vl (xi_vl s0)
  | lam s0 s1 =>
      lam (ren_ty xi_ty s0)
        (ren_tm (upRen_vl_ty xi_ty) (upRen_vl_vl xi_vl) s1)
  | tlam s0 => tlam (ren_tm (upRen_ty_ty xi_ty) (upRen_ty_vl xi_vl) s0)
  end.

Lemma up_ty_vl (sigma : nat -> vl) : nat -> vl.
Proof.
exact (funcomp (ren_vl shift id) sigma).
Defined.

Lemma up_vl_ty (sigma : nat -> ty) : nat -> ty.
Proof.
exact (funcomp (ren_ty id) sigma).
Defined.

Lemma up_vl_vl (sigma : nat -> vl) : nat -> vl.
Proof.
exact (scons (var_vl var_zero) (funcomp (ren_vl id shift) sigma)).
Defined.

Fixpoint subst_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl) (s : tm)
{struct s} : tm :=
  match s with
  | app s0 s1 =>
      app (subst_tm sigma_ty sigma_vl s0) (subst_tm sigma_ty sigma_vl s1)
  | tapp s0 s1 => tapp (subst_tm sigma_ty sigma_vl s0) (subst_ty sigma_ty s1)
  | vt s0 => vt (subst_vl sigma_ty sigma_vl s0)
  end
with subst_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl) (s : vl) {struct
 s} : vl :=
  match s with
  | var_vl s0 => sigma_vl s0
  | lam s0 s1 =>
      lam (subst_ty sigma_ty s0)
        (subst_tm (up_vl_ty sigma_ty) (up_vl_vl sigma_vl) s1)
  | tlam s0 => tlam (subst_tm (up_ty_ty sigma_ty) (up_ty_vl sigma_vl) s0)
  end.

Lemma upId_ty_vl (sigma : nat -> vl) (Eq : forall x, sigma x = var_vl x) :
  forall x, up_ty_vl sigma x = var_vl x.
Proof.
exact (fun n => ap (ren_vl shift id) (Eq n)).
Qed.

Lemma upId_vl_ty (sigma : nat -> ty) (Eq : forall x, sigma x = var_ty x) :
  forall x, up_vl_ty sigma x = var_ty x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma upId_vl_vl (sigma : nat -> vl) (Eq : forall x, sigma x = var_vl x) :
  forall x, up_vl_vl sigma x = var_vl x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_vl id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint idSubst_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(Eq_ty : forall x, sigma_ty x = var_ty x)
(Eq_vl : forall x, sigma_vl x = var_vl x) (s : tm) {struct s} :
subst_tm sigma_ty sigma_vl s = s :=
  match s with
  | app s0 s1 =>
      congr_app (idSubst_tm sigma_ty sigma_vl Eq_ty Eq_vl s0)
        (idSubst_tm sigma_ty sigma_vl Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp (idSubst_tm sigma_ty sigma_vl Eq_ty Eq_vl s0)
        (idSubst_ty sigma_ty Eq_ty s1)
  | vt s0 => congr_vt (idSubst_vl sigma_ty sigma_vl Eq_ty Eq_vl s0)
  end
with idSubst_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(Eq_ty : forall x, sigma_ty x = var_ty x)
(Eq_vl : forall x, sigma_vl x = var_vl x) (s : vl) {struct s} :
subst_vl sigma_ty sigma_vl s = s :=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (idSubst_ty sigma_ty Eq_ty s0)
        (idSubst_tm (up_vl_ty sigma_ty) (up_vl_vl sigma_vl)
           (upId_vl_ty _ Eq_ty) (upId_vl_vl _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (idSubst_tm (up_ty_ty sigma_ty) (up_ty_vl sigma_vl)
           (upId_ty_ty _ Eq_ty) (upId_ty_vl _ Eq_vl) s0)
  end.

Lemma upExtRen_ty_vl (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_ty_vl xi x = upRen_ty_vl zeta x.
Proof.
exact (fun n => Eq n).
Qed.

Lemma upExtRen_vl_ty (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_vl_ty xi x = upRen_vl_ty zeta x.
Proof.
exact (fun n => Eq n).
Qed.

Lemma upExtRen_vl_vl (xi : nat -> nat) (zeta : nat -> nat)
  (Eq : forall x, xi x = zeta x) :
  forall x, upRen_vl_vl xi x = upRen_vl_vl zeta x.
Proof.
exact (fun n => match n with
                | S n' => ap shift (Eq n')
                | O => eq_refl
                end).
Qed.

Fixpoint extRen_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat)
(Eq_ty : forall x, xi_ty x = zeta_ty x)
(Eq_vl : forall x, xi_vl x = zeta_vl x) (s : tm) {struct s} :
ren_tm xi_ty xi_vl s = ren_tm zeta_ty zeta_vl s :=
  match s with
  | app s0 s1 =>
      congr_app (extRen_tm xi_ty xi_vl zeta_ty zeta_vl Eq_ty Eq_vl s0)
        (extRen_tm xi_ty xi_vl zeta_ty zeta_vl Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp (extRen_tm xi_ty xi_vl zeta_ty zeta_vl Eq_ty Eq_vl s0)
        (extRen_ty xi_ty zeta_ty Eq_ty s1)
  | vt s0 => congr_vt (extRen_vl xi_ty xi_vl zeta_ty zeta_vl Eq_ty Eq_vl s0)
  end
with extRen_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat)
(Eq_ty : forall x, xi_ty x = zeta_ty x)
(Eq_vl : forall x, xi_vl x = zeta_vl x) (s : vl) {struct s} :
ren_vl xi_ty xi_vl s = ren_vl zeta_ty zeta_vl s :=
  match s with
  | var_vl s0 => ap var_vl (Eq_vl s0)
  | lam s0 s1 =>
      congr_lam (extRen_ty xi_ty zeta_ty Eq_ty s0)
        (extRen_tm (upRen_vl_ty xi_ty) (upRen_vl_vl xi_vl)
           (upRen_vl_ty zeta_ty) (upRen_vl_vl zeta_vl)
           (upExtRen_vl_ty _ _ Eq_ty) (upExtRen_vl_vl _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (extRen_tm (upRen_ty_ty xi_ty) (upRen_ty_vl xi_vl)
           (upRen_ty_ty zeta_ty) (upRen_ty_vl zeta_vl)
           (upExtRen_ty_ty _ _ Eq_ty) (upExtRen_ty_vl _ _ Eq_vl) s0)
  end.

Lemma upExt_ty_vl (sigma : nat -> vl) (tau : nat -> vl)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_ty_vl sigma x = up_ty_vl tau x.
Proof.
exact (fun n => ap (ren_vl shift id) (Eq n)).
Qed.

Lemma upExt_vl_ty (sigma : nat -> ty) (tau : nat -> ty)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_vl_ty sigma x = up_vl_ty tau x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma upExt_vl_vl (sigma : nat -> vl) (tau : nat -> vl)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_vl_vl sigma x = up_vl_vl tau x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_vl id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint ext_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(tau_ty : nat -> ty) (tau_vl : nat -> vl)
(Eq_ty : forall x, sigma_ty x = tau_ty x)
(Eq_vl : forall x, sigma_vl x = tau_vl x) (s : tm) {struct s} :
subst_tm sigma_ty sigma_vl s = subst_tm tau_ty tau_vl s :=
  match s with
  | app s0 s1 =>
      congr_app (ext_tm sigma_ty sigma_vl tau_ty tau_vl Eq_ty Eq_vl s0)
        (ext_tm sigma_ty sigma_vl tau_ty tau_vl Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp (ext_tm sigma_ty sigma_vl tau_ty tau_vl Eq_ty Eq_vl s0)
        (ext_ty sigma_ty tau_ty Eq_ty s1)
  | vt s0 => congr_vt (ext_vl sigma_ty sigma_vl tau_ty tau_vl Eq_ty Eq_vl s0)
  end
with ext_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(tau_ty : nat -> ty) (tau_vl : nat -> vl)
(Eq_ty : forall x, sigma_ty x = tau_ty x)
(Eq_vl : forall x, sigma_vl x = tau_vl x) (s : vl) {struct s} :
subst_vl sigma_ty sigma_vl s = subst_vl tau_ty tau_vl s :=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (ext_ty sigma_ty tau_ty Eq_ty s0)
        (ext_tm (up_vl_ty sigma_ty) (up_vl_vl sigma_vl) (up_vl_ty tau_ty)
           (up_vl_vl tau_vl) (upExt_vl_ty _ _ Eq_ty) (upExt_vl_vl _ _ Eq_vl)
           s1)
  | tlam s0 =>
      congr_tlam
        (ext_tm (up_ty_ty sigma_ty) (up_ty_vl sigma_vl) (up_ty_ty tau_ty)
           (up_ty_vl tau_vl) (upExt_ty_ty _ _ Eq_ty) (upExt_ty_vl _ _ Eq_vl)
           s0)
  end.

Lemma up_ren_ren_ty_vl (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_ty_vl zeta) (upRen_ty_vl xi) x = upRen_ty_vl rho x.
Proof.
exact (Eq).
Qed.

Lemma up_ren_ren_vl_ty (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_vl_ty zeta) (upRen_vl_ty xi) x = upRen_vl_ty rho x.
Proof.
exact (Eq).
Qed.

Lemma up_ren_ren_vl_vl (xi : nat -> nat) (zeta : nat -> nat)
  (rho : nat -> nat) (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_vl_vl zeta) (upRen_vl_vl xi) x = upRen_vl_vl rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Fixpoint compRenRen_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (rho_ty : nat -> nat)
(rho_vl : nat -> nat) (Eq_ty : forall x, funcomp zeta_ty xi_ty x = rho_ty x)
(Eq_vl : forall x, funcomp zeta_vl xi_vl x = rho_vl x) (s : tm) {struct s} :
ren_tm zeta_ty zeta_vl (ren_tm xi_ty xi_vl s) = ren_tm rho_ty rho_vl s :=
  match s with
  | app s0 s1 =>
      congr_app
        (compRenRen_tm xi_ty xi_vl zeta_ty zeta_vl rho_ty rho_vl Eq_ty Eq_vl
           s0)
        (compRenRen_tm xi_ty xi_vl zeta_ty zeta_vl rho_ty rho_vl Eq_ty Eq_vl
           s1)
  | tapp s0 s1 =>
      congr_tapp
        (compRenRen_tm xi_ty xi_vl zeta_ty zeta_vl rho_ty rho_vl Eq_ty Eq_vl
           s0) (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s1)
  | vt s0 =>
      congr_vt
        (compRenRen_vl xi_ty xi_vl zeta_ty zeta_vl rho_ty rho_vl Eq_ty Eq_vl
           s0)
  end
with compRenRen_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (rho_ty : nat -> nat)
(rho_vl : nat -> nat) (Eq_ty : forall x, funcomp zeta_ty xi_ty x = rho_ty x)
(Eq_vl : forall x, funcomp zeta_vl xi_vl x = rho_vl x) (s : vl) {struct s} :
ren_vl zeta_ty zeta_vl (ren_vl xi_ty xi_vl s) = ren_vl rho_ty rho_vl s :=
  match s with
  | var_vl s0 => ap var_vl (Eq_vl s0)
  | lam s0 s1 =>
      congr_lam (compRenRen_ty xi_ty zeta_ty rho_ty Eq_ty s0)
        (compRenRen_tm (upRen_vl_ty xi_ty) (upRen_vl_vl xi_vl)
           (upRen_vl_ty zeta_ty) (upRen_vl_vl zeta_vl) (upRen_vl_ty rho_ty)
           (upRen_vl_vl rho_vl) Eq_ty (up_ren_ren _ _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (compRenRen_tm (upRen_ty_ty xi_ty) (upRen_ty_vl xi_vl)
           (upRen_ty_ty zeta_ty) (upRen_ty_vl zeta_vl) (upRen_ty_ty rho_ty)
           (upRen_ty_vl rho_vl) (up_ren_ren _ _ _ Eq_ty) Eq_vl s0)
  end.

Lemma up_ren_subst_ty_vl (xi : nat -> nat) (tau : nat -> vl)
  (theta : nat -> vl) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_ty_vl tau) (upRen_ty_vl xi) x = up_ty_vl theta x.
Proof.
exact (fun n => ap (ren_vl shift id) (Eq n)).
Qed.

Lemma up_ren_subst_vl_ty (xi : nat -> nat) (tau : nat -> ty)
  (theta : nat -> ty) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_vl_ty tau) (upRen_vl_ty xi) x = up_vl_ty theta x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma up_ren_subst_vl_vl (xi : nat -> nat) (tau : nat -> vl)
  (theta : nat -> vl) (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_vl_vl tau) (upRen_vl_vl xi) x = up_vl_vl theta x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_vl id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint compRenSubst_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(tau_ty : nat -> ty) (tau_vl : nat -> vl) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp tau_ty xi_ty x = theta_ty x)
(Eq_vl : forall x, funcomp tau_vl xi_vl x = theta_vl x) (s : tm) {struct s} :
subst_tm tau_ty tau_vl (ren_tm xi_ty xi_vl s) = subst_tm theta_ty theta_vl s
:=
  match s with
  | app s0 s1 =>
      congr_app
        (compRenSubst_tm xi_ty xi_vl tau_ty tau_vl theta_ty theta_vl Eq_ty
           Eq_vl s0)
        (compRenSubst_tm xi_ty xi_vl tau_ty tau_vl theta_ty theta_vl Eq_ty
           Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp
        (compRenSubst_tm xi_ty xi_vl tau_ty tau_vl theta_ty theta_vl Eq_ty
           Eq_vl s0) (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s1)
  | vt s0 =>
      congr_vt
        (compRenSubst_vl xi_ty xi_vl tau_ty tau_vl theta_ty theta_vl Eq_ty
           Eq_vl s0)
  end
with compRenSubst_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(tau_ty : nat -> ty) (tau_vl : nat -> vl) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp tau_ty xi_ty x = theta_ty x)
(Eq_vl : forall x, funcomp tau_vl xi_vl x = theta_vl x) (s : vl) {struct s} :
subst_vl tau_ty tau_vl (ren_vl xi_ty xi_vl s) = subst_vl theta_ty theta_vl s
:=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (compRenSubst_ty xi_ty tau_ty theta_ty Eq_ty s0)
        (compRenSubst_tm (upRen_vl_ty xi_ty) (upRen_vl_vl xi_vl)
           (up_vl_ty tau_ty) (up_vl_vl tau_vl) (up_vl_ty theta_ty)
           (up_vl_vl theta_vl) (up_ren_subst_vl_ty _ _ _ Eq_ty)
           (up_ren_subst_vl_vl _ _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (compRenSubst_tm (upRen_ty_ty xi_ty) (upRen_ty_vl xi_vl)
           (up_ty_ty tau_ty) (up_ty_vl tau_vl) (up_ty_ty theta_ty)
           (up_ty_vl theta_vl) (up_ren_subst_ty_ty _ _ _ Eq_ty)
           (up_ren_subst_ty_vl _ _ _ Eq_vl) s0)
  end.

Lemma up_subst_ren_ty_vl (sigma : nat -> vl) (zeta_ty : nat -> nat)
  (zeta_vl : nat -> nat) (theta : nat -> vl)
  (Eq : forall x, funcomp (ren_vl zeta_ty zeta_vl) sigma x = theta x) :
  forall x,
  funcomp (ren_vl (upRen_ty_ty zeta_ty) (upRen_ty_vl zeta_vl))
    (up_ty_vl sigma) x = up_ty_vl theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenRen_vl shift id (upRen_ty_ty zeta_ty) (upRen_ty_vl zeta_vl)
            (funcomp shift zeta_ty) (funcomp id zeta_vl) (fun x => eq_refl)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compRenRen_vl zeta_ty zeta_vl shift id
                  (funcomp shift zeta_ty) (funcomp id zeta_vl)
                  (fun x => eq_refl) (fun x => eq_refl) (sigma n)))
            (ap (ren_vl shift id) (Eq n)))).
Qed.

Lemma up_subst_ren_vl_ty (sigma : nat -> ty) (zeta_ty : nat -> nat)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (ren_ty zeta_ty) sigma x = theta x) :
  forall x,
  funcomp (ren_ty (upRen_vl_ty zeta_ty)) (up_vl_ty sigma) x =
  up_vl_ty theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenRen_ty id (upRen_vl_ty zeta_ty) (funcomp id zeta_ty)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compRenRen_ty zeta_ty id (funcomp id zeta_ty)
                  (fun x => eq_refl) (sigma n))) (ap (ren_ty id) (Eq n)))).
Qed.

Lemma up_subst_ren_vl_vl (sigma : nat -> vl) (zeta_ty : nat -> nat)
  (zeta_vl : nat -> nat) (theta : nat -> vl)
  (Eq : forall x, funcomp (ren_vl zeta_ty zeta_vl) sigma x = theta x) :
  forall x,
  funcomp (ren_vl (upRen_vl_ty zeta_ty) (upRen_vl_vl zeta_vl))
    (up_vl_vl sigma) x = up_vl_vl theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenRen_vl id shift (upRen_vl_ty zeta_ty)
                (upRen_vl_vl zeta_vl) (funcomp id zeta_ty)
                (funcomp shift zeta_vl) (fun x => eq_refl) (fun x => eq_refl)
                (sigma n'))
             (eq_trans
                (eq_sym
                   (compRenRen_vl zeta_ty zeta_vl id shift
                      (funcomp id zeta_ty) (funcomp shift zeta_vl)
                      (fun x => eq_refl) (fun x => eq_refl) (sigma n')))
                (ap (ren_vl id shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstRen_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp (ren_ty zeta_ty) sigma_ty x = theta_ty x)
(Eq_vl : forall x, funcomp (ren_vl zeta_ty zeta_vl) sigma_vl x = theta_vl x)
(s : tm) {struct s} :
ren_tm zeta_ty zeta_vl (subst_tm sigma_ty sigma_vl s) =
subst_tm theta_ty theta_vl s :=
  match s with
  | app s0 s1 =>
      congr_app
        (compSubstRen_tm sigma_ty sigma_vl zeta_ty zeta_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
        (compSubstRen_tm sigma_ty sigma_vl zeta_ty zeta_vl theta_ty theta_vl
           Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp
        (compSubstRen_tm sigma_ty sigma_vl zeta_ty zeta_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
        (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s1)
  | vt s0 =>
      congr_vt
        (compSubstRen_vl sigma_ty sigma_vl zeta_ty zeta_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
  end
with compSubstRen_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp (ren_ty zeta_ty) sigma_ty x = theta_ty x)
(Eq_vl : forall x, funcomp (ren_vl zeta_ty zeta_vl) sigma_vl x = theta_vl x)
(s : vl) {struct s} :
ren_vl zeta_ty zeta_vl (subst_vl sigma_ty sigma_vl s) =
subst_vl theta_ty theta_vl s :=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (compSubstRen_ty sigma_ty zeta_ty theta_ty Eq_ty s0)
        (compSubstRen_tm (up_vl_ty sigma_ty) (up_vl_vl sigma_vl)
           (upRen_vl_ty zeta_ty) (upRen_vl_vl zeta_vl) (up_vl_ty theta_ty)
           (up_vl_vl theta_vl) (up_subst_ren_vl_ty _ _ _ Eq_ty)
           (up_subst_ren_vl_vl _ _ _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (compSubstRen_tm (up_ty_ty sigma_ty) (up_ty_vl sigma_vl)
           (upRen_ty_ty zeta_ty) (upRen_ty_vl zeta_vl) (up_ty_ty theta_ty)
           (up_ty_vl theta_vl) (up_subst_ren_ty_ty _ _ _ Eq_ty)
           (up_subst_ren_ty_vl _ _ _ _ Eq_vl) s0)
  end.

Lemma up_subst_subst_ty_vl (sigma : nat -> vl) (tau_ty : nat -> ty)
  (tau_vl : nat -> vl) (theta : nat -> vl)
  (Eq : forall x, funcomp (subst_vl tau_ty tau_vl) sigma x = theta x) :
  forall x,
  funcomp (subst_vl (up_ty_ty tau_ty) (up_ty_vl tau_vl)) (up_ty_vl sigma) x =
  up_ty_vl theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenSubst_vl shift id (up_ty_ty tau_ty) (up_ty_vl tau_vl)
            (funcomp (up_ty_ty tau_ty) shift) (funcomp (up_ty_vl tau_vl) id)
            (fun x => eq_refl) (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compSubstRen_vl tau_ty tau_vl shift id
                  (funcomp (ren_ty shift) tau_ty)
                  (funcomp (ren_vl shift id) tau_vl) (fun x => eq_refl)
                  (fun x => eq_refl) (sigma n)))
            (ap (ren_vl shift id) (Eq n)))).
Qed.

Lemma up_subst_subst_vl_ty (sigma : nat -> ty) (tau_ty : nat -> ty)
  (theta : nat -> ty)
  (Eq : forall x, funcomp (subst_ty tau_ty) sigma x = theta x) :
  forall x,
  funcomp (subst_ty (up_vl_ty tau_ty)) (up_vl_ty sigma) x = up_vl_ty theta x.
Proof.
exact (fun n =>
       eq_trans
         (compRenSubst_ty id (up_vl_ty tau_ty) (funcomp (up_vl_ty tau_ty) id)
            (fun x => eq_refl) (sigma n))
         (eq_trans
            (eq_sym
               (compSubstRen_ty tau_ty id (funcomp (ren_ty id) tau_ty)
                  (fun x => eq_refl) (sigma n))) (ap (ren_ty id) (Eq n)))).
Qed.

Lemma up_subst_subst_vl_vl (sigma : nat -> vl) (tau_ty : nat -> ty)
  (tau_vl : nat -> vl) (theta : nat -> vl)
  (Eq : forall x, funcomp (subst_vl tau_ty tau_vl) sigma x = theta x) :
  forall x,
  funcomp (subst_vl (up_vl_ty tau_ty) (up_vl_vl tau_vl)) (up_vl_vl sigma) x =
  up_vl_vl theta x.
Proof.
exact (fun n =>
       match n with
       | S n' =>
           eq_trans
             (compRenSubst_vl id shift (up_vl_ty tau_ty) (up_vl_vl tau_vl)
                (funcomp (up_vl_ty tau_ty) id)
                (funcomp (up_vl_vl tau_vl) shift) (fun x => eq_refl)
                (fun x => eq_refl) (sigma n'))
             (eq_trans
                (eq_sym
                   (compSubstRen_vl tau_ty tau_vl id shift
                      (funcomp (ren_ty id) tau_ty)
                      (funcomp (ren_vl id shift) tau_vl) (fun x => eq_refl)
                      (fun x => eq_refl) (sigma n')))
                (ap (ren_vl id shift) (Eq n')))
       | O => eq_refl
       end).
Qed.

Fixpoint compSubstSubst_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(tau_ty : nat -> ty) (tau_vl : nat -> vl) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp (subst_ty tau_ty) sigma_ty x = theta_ty x)
(Eq_vl : forall x, funcomp (subst_vl tau_ty tau_vl) sigma_vl x = theta_vl x)
(s : tm) {struct s} :
subst_tm tau_ty tau_vl (subst_tm sigma_ty sigma_vl s) =
subst_tm theta_ty theta_vl s :=
  match s with
  | app s0 s1 =>
      congr_app
        (compSubstSubst_tm sigma_ty sigma_vl tau_ty tau_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
        (compSubstSubst_tm sigma_ty sigma_vl tau_ty tau_vl theta_ty theta_vl
           Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp
        (compSubstSubst_tm sigma_ty sigma_vl tau_ty tau_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
        (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s1)
  | vt s0 =>
      congr_vt
        (compSubstSubst_vl sigma_ty sigma_vl tau_ty tau_vl theta_ty theta_vl
           Eq_ty Eq_vl s0)
  end
with compSubstSubst_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(tau_ty : nat -> ty) (tau_vl : nat -> vl) (theta_ty : nat -> ty)
(theta_vl : nat -> vl)
(Eq_ty : forall x, funcomp (subst_ty tau_ty) sigma_ty x = theta_ty x)
(Eq_vl : forall x, funcomp (subst_vl tau_ty tau_vl) sigma_vl x = theta_vl x)
(s : vl) {struct s} :
subst_vl tau_ty tau_vl (subst_vl sigma_ty sigma_vl s) =
subst_vl theta_ty theta_vl s :=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (compSubstSubst_ty sigma_ty tau_ty theta_ty Eq_ty s0)
        (compSubstSubst_tm (up_vl_ty sigma_ty) (up_vl_vl sigma_vl)
           (up_vl_ty tau_ty) (up_vl_vl tau_vl) (up_vl_ty theta_ty)
           (up_vl_vl theta_vl) (up_subst_subst_vl_ty _ _ _ Eq_ty)
           (up_subst_subst_vl_vl _ _ _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (compSubstSubst_tm (up_ty_ty sigma_ty) (up_ty_vl sigma_vl)
           (up_ty_ty tau_ty) (up_ty_vl tau_vl) (up_ty_ty theta_ty)
           (up_ty_vl theta_vl) (up_subst_subst_ty_ty _ _ _ Eq_ty)
           (up_subst_subst_ty_vl _ _ _ _ Eq_vl) s0)
  end.

Lemma rinstInst_up_ty_vl (xi : nat -> nat) (sigma : nat -> vl)
  (Eq : forall x, funcomp var_vl xi x = sigma x) :
  forall x, funcomp var_vl (upRen_ty_vl xi) x = up_ty_vl sigma x.
Proof.
exact (fun n => ap (ren_vl shift id) (Eq n)).
Qed.

Lemma rinstInst_up_vl_ty (xi : nat -> nat) (sigma : nat -> ty)
  (Eq : forall x, funcomp var_ty xi x = sigma x) :
  forall x, funcomp var_ty (upRen_vl_ty xi) x = up_vl_ty sigma x.
Proof.
exact (fun n => ap (ren_ty id) (Eq n)).
Qed.

Lemma rinstInst_up_vl_vl (xi : nat -> nat) (sigma : nat -> vl)
  (Eq : forall x, funcomp var_vl xi x = sigma x) :
  forall x, funcomp var_vl (upRen_vl_vl xi) x = up_vl_vl sigma x.
Proof.
exact (fun n =>
       match n with
       | S n' => ap (ren_vl id shift) (Eq n')
       | O => eq_refl
       end).
Qed.

Fixpoint rinst_inst_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(Eq_ty : forall x, funcomp var_ty xi_ty x = sigma_ty x)
(Eq_vl : forall x, funcomp var_vl xi_vl x = sigma_vl x) (s : tm) {struct s} :
ren_tm xi_ty xi_vl s = subst_tm sigma_ty sigma_vl s :=
  match s with
  | app s0 s1 =>
      congr_app (rinst_inst_tm xi_ty xi_vl sigma_ty sigma_vl Eq_ty Eq_vl s0)
        (rinst_inst_tm xi_ty xi_vl sigma_ty sigma_vl Eq_ty Eq_vl s1)
  | tapp s0 s1 =>
      congr_tapp (rinst_inst_tm xi_ty xi_vl sigma_ty sigma_vl Eq_ty Eq_vl s0)
        (rinst_inst_ty xi_ty sigma_ty Eq_ty s1)
  | vt s0 =>
      congr_vt (rinst_inst_vl xi_ty xi_vl sigma_ty sigma_vl Eq_ty Eq_vl s0)
  end
with rinst_inst_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
(sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
(Eq_ty : forall x, funcomp var_ty xi_ty x = sigma_ty x)
(Eq_vl : forall x, funcomp var_vl xi_vl x = sigma_vl x) (s : vl) {struct s} :
ren_vl xi_ty xi_vl s = subst_vl sigma_ty sigma_vl s :=
  match s with
  | var_vl s0 => Eq_vl s0
  | lam s0 s1 =>
      congr_lam (rinst_inst_ty xi_ty sigma_ty Eq_ty s0)
        (rinst_inst_tm (upRen_vl_ty xi_ty) (upRen_vl_vl xi_vl)
           (up_vl_ty sigma_ty) (up_vl_vl sigma_vl)
           (rinstInst_up_vl_ty _ _ Eq_ty) (rinstInst_up_vl_vl _ _ Eq_vl) s1)
  | tlam s0 =>
      congr_tlam
        (rinst_inst_tm (upRen_ty_ty xi_ty) (upRen_ty_vl xi_vl)
           (up_ty_ty sigma_ty) (up_ty_vl sigma_vl)
           (rinstInst_up_ty_ty _ _ Eq_ty) (rinstInst_up_ty_vl _ _ Eq_vl) s0)
  end.

Lemma renRen_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (s : tm) :
  ren_tm zeta_ty zeta_vl (ren_tm xi_ty xi_vl s) =
  ren_tm (funcomp zeta_ty xi_ty) (funcomp zeta_vl xi_vl) s.
Proof.
exact (compRenRen_tm xi_ty xi_vl zeta_ty zeta_vl _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma renRen_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
  (zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (s : vl) :
  ren_vl zeta_ty zeta_vl (ren_vl xi_ty xi_vl s) =
  ren_vl (funcomp zeta_ty xi_ty) (funcomp zeta_vl xi_vl) s.
Proof.
exact (compRenRen_vl xi_ty xi_vl zeta_ty zeta_vl _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma compRen_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
  (zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (s : tm) :
  ren_tm zeta_ty zeta_vl (subst_tm sigma_ty sigma_vl s) =
  subst_tm (funcomp (ren_ty zeta_ty) sigma_ty)
    (funcomp (ren_vl zeta_ty zeta_vl) sigma_vl) s.
Proof.
exact (compSubstRen_tm sigma_ty sigma_vl zeta_ty zeta_vl _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma compRen_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
  (zeta_ty : nat -> nat) (zeta_vl : nat -> nat) (s : vl) :
  ren_vl zeta_ty zeta_vl (subst_vl sigma_ty sigma_vl s) =
  subst_vl (funcomp (ren_ty zeta_ty) sigma_ty)
    (funcomp (ren_vl zeta_ty zeta_vl) sigma_vl) s.
Proof.
exact (compSubstRen_vl sigma_ty sigma_vl zeta_ty zeta_vl _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma renComp_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat)
  (tau_ty : nat -> ty) (tau_vl : nat -> vl) (s : tm) :
  subst_tm tau_ty tau_vl (ren_tm xi_ty xi_vl s) =
  subst_tm (funcomp tau_ty xi_ty) (funcomp tau_vl xi_vl) s.
Proof.
exact (compRenSubst_tm xi_ty xi_vl tau_ty tau_vl _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma renComp_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat)
  (tau_ty : nat -> ty) (tau_vl : nat -> vl) (s : vl) :
  subst_vl tau_ty tau_vl (ren_vl xi_ty xi_vl s) =
  subst_vl (funcomp tau_ty xi_ty) (funcomp tau_vl xi_vl) s.
Proof.
exact (compRenSubst_vl xi_ty xi_vl tau_ty tau_vl _ _ (fun n => eq_refl)
         (fun n => eq_refl) s).
Qed.

Lemma compComp_tm (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
  (tau_ty : nat -> ty) (tau_vl : nat -> vl) (s : tm) :
  subst_tm tau_ty tau_vl (subst_tm sigma_ty sigma_vl s) =
  subst_tm (funcomp (subst_ty tau_ty) sigma_ty)
    (funcomp (subst_vl tau_ty tau_vl) sigma_vl) s.
Proof.
exact (compSubstSubst_tm sigma_ty sigma_vl tau_ty tau_vl _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma compComp_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl)
  (tau_ty : nat -> ty) (tau_vl : nat -> vl) (s : vl) :
  subst_vl tau_ty tau_vl (subst_vl sigma_ty sigma_vl s) =
  subst_vl (funcomp (subst_ty tau_ty) sigma_ty)
    (funcomp (subst_vl tau_ty tau_vl) sigma_vl) s.
Proof.
exact (compSubstSubst_vl sigma_ty sigma_vl tau_ty tau_vl _ _
         (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm (xi_ty : nat -> nat) (xi_vl : nat -> nat) (s : tm) :
  ren_tm xi_ty xi_vl s =
  subst_tm (funcomp var_ty xi_ty) (funcomp var_vl xi_vl) s.
Proof.
exact (rinst_inst_tm xi_ty xi_vl _ _ (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat) (s : vl) :
  ren_vl xi_ty xi_vl s =
  subst_vl (funcomp var_ty xi_ty) (funcomp var_vl xi_vl) s.
Proof.
exact (rinst_inst_vl xi_ty xi_vl _ _ (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma instId'_tm (s : tm) : subst_tm var_ty var_vl s = s.
Proof.
exact (idSubst_tm var_ty var_vl (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma instId'_vl (s : vl) : subst_vl var_ty var_vl s = s.
Proof.
exact (idSubst_vl var_ty var_vl (fun n => eq_refl) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm (s : tm) : ren_tm id id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id id s)).
Qed.

Lemma rinstId'_vl (s : vl) : ren_vl id id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_vl s) (rinstInst'_vl id id s)).
Qed.

Lemma varL'_vl (sigma_ty : nat -> ty) (sigma_vl : nat -> vl) (x : nat) :
  subst_vl sigma_ty sigma_vl (var_vl x) = sigma_vl x.
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_vl (xi_ty : nat -> nat) (xi_vl : nat -> nat) (x : nat) :
  ren_vl xi_ty xi_vl (var_vl x) = var_vl (xi_vl x).
Proof.
exact (eq_refl).
Qed.

Class Up_vl X Y :=
    up_vl : X -> Y.

Class Up_tm X Y :=
    up_tm : X -> Y.

Class Up_ty X Y :=
    up_ty : X -> Y.

Instance Subst_vl : (Subst2 _ _ _ _) := @subst_vl.

Instance Subst_tm : (Subst2 _ _ _ _) := @subst_tm.

Instance Up_vl_vl : (Up_vl _ _) := @up_vl_vl.

Instance Up_vl_ty : (Up_ty _ _) := @up_vl_ty.

Instance Up_ty_vl : (Up_vl _ _) := @up_ty_vl.

Instance Ren_vl : (Ren2 _ _ _ _) := @ren_vl.

Instance Ren_tm : (Ren2 _ _ _ _) := @ren_tm.

Instance VarInstance_vl : (Var _ _) := @var_vl.

Instance Subst_ty : (Subst1 _ _ _) := @subst_ty.

Instance Up_ty_ty : (Up_ty _ _) := @up_ty_ty.

Instance Ren_ty : (Ren1 _ _ _) := @ren_ty.

Instance VarInstance_ty : (Var _ _) := @var_ty.

Notation "[ sigma_ty ; sigma_vl ]" := (subst_vl sigma_ty sigma_vl)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_ty ; sigma_vl ]" := (subst_vl sigma_ty sigma_vl s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__vl" := up_vl (only printing) : subst_scope.

Notation "[ sigma_ty ; sigma_vl ]" := (subst_tm sigma_ty sigma_vl)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_ty ; sigma_vl ]" := (subst_tm sigma_ty sigma_vl s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__tm" := up_tm (only printing) : subst_scope.

Notation "↑__vl" := up_vl_vl (only printing) : subst_scope.

Notation "↑__ty" := up_vl_ty (only printing) : subst_scope.

Notation "↑__vl" := up_ty_vl (only printing) : subst_scope.

Notation "⟨ xi_ty ; xi_vl ⟩" := (ren_vl xi_ty xi_vl)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_ty ; xi_vl ⟩" := (ren_vl xi_ty xi_vl s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "⟨ xi_ty ; xi_vl ⟩" := (ren_tm xi_ty xi_vl)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_ty ; xi_vl ⟩" := (ren_tm xi_ty xi_vl s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_vl ( at level 1, only printing) : subst_scope.

Notation "x '__vl'" := (@ids _ _ VarInstance_vl x)
  ( at level 5, format "x __vl", only printing) : subst_scope.

Notation "x '__vl'" := (var_vl x) ( at level 5, format "x __vl") :
  subst_scope.

Notation "[ sigma_ty ]" := (subst_ty sigma_ty)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_ty ]" := (subst_ty sigma_ty s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__ty" := up_ty (only printing) : subst_scope.

Notation "↑__ty" := up_ty_ty (only printing) : subst_scope.

Notation "⟨ xi_ty ⟩" := (ren_ty xi_ty)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_ty ⟩" := (ren_ty xi_ty s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_ty ( at level 1, only printing) : subst_scope.

Notation "x '__ty'" := (@ids _ _ VarInstance_ty x)
  ( at level 5, format "x __ty", only printing) : subst_scope.

Notation "x '__ty'" := (var_ty x) ( at level 5, format "x __ty") :
  subst_scope.

Instance subst_vl_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@subst_vl)).
Proof.
exact (fun f_ty g_ty Eq_ty f_vl g_vl Eq_vl s t Eq_st =>
       eq_ind s (fun t' => subst_vl f_ty f_vl s = subst_vl g_ty g_vl t')
         (ext_vl f_ty f_vl g_ty g_vl Eq_ty Eq_vl s) t Eq_st).
Qed.

Instance subst_tm_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@subst_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_vl g_vl Eq_vl s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_ty f_vl s = subst_tm g_ty g_vl t')
         (ext_tm f_ty f_vl g_ty g_vl Eq_ty Eq_vl s) t Eq_st).
Qed.

Instance ren_vl_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@ren_vl)).
Proof.
exact (fun f_ty g_ty Eq_ty f_vl g_vl Eq_vl s t Eq_st =>
       eq_ind s (fun t' => ren_vl f_ty f_vl s = ren_vl g_ty g_vl t')
         (extRen_vl f_ty f_vl g_ty g_vl Eq_ty Eq_vl s) t Eq_st).
Qed.

Instance ren_tm_morphism :
 (Proper
    (respectful (pointwise_relation _ eq)
       (respectful (pointwise_relation _ eq) (respectful eq eq))) (@ren_tm)).
Proof.
exact (fun f_ty g_ty Eq_ty f_vl g_vl Eq_vl s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_ty f_vl s = ren_tm g_ty g_vl t')
         (extRen_tm f_ty f_vl g_ty g_vl Eq_ty Eq_vl s) t Eq_st).
Qed.

Instance subst_ty_morphism :
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s t Eq_st =>
       eq_ind s (fun t' => subst_ty f_ty s = subst_ty g_ty t')
         (ext_ty f_ty g_ty Eq_ty s) t Eq_st).
Qed.

Instance ren_ty_morphism :
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq)) (@ren_ty)).
Proof.
exact (fun f_ty g_ty Eq_ty s t Eq_st =>
       eq_ind s (fun t' => ren_ty f_ty s = ren_ty g_ty t')
         (extRen_ty f_ty g_ty Eq_ty s) t Eq_st).
Qed.

Ltac auto_unfold := repeat
                     unfold VarInstance_ty, Var, ids, Ren_ty, Ren1, ren1,
                      Up_ty_ty, Up_ty, up_ty, Subst_ty, Subst1, subst1,
                      VarInstance_vl, Var, ids, Ren_tm, Ren2, ren2, Ren_vl,
                      Ren2, ren2, Up_ty_vl, Up_vl, up_vl, Up_vl_ty, Up_ty,
                      up_ty, Up_vl_vl, Up_vl, up_vl, Subst_tm, Subst2,
                      subst2, Subst_vl, Subst2, subst2.

Tactic Notation "auto_unfold" "in" "*" := repeat
                                           unfold VarInstance_ty, Var, ids,
                                            Ren_ty, Ren1, ren1, Up_ty_ty,
                                            Up_ty, up_ty, Subst_ty, Subst1,
                                            subst1, VarInstance_vl, Var, ids,
                                            Ren_tm, Ren2, ren2, Ren_vl, Ren2,
                                            ren2, Up_ty_vl, Up_vl, up_vl,
                                            Up_vl_ty, Up_ty, up_ty, Up_vl_vl,
                                            Up_vl, up_vl, Subst_tm, Subst2,
                                            subst2, Subst_vl, Subst2, subst2
                                            in *.

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite compComp_vl
                 | progress rewrite ?compComp_vl
                 | progress setoid_rewrite compComp_tm
                 | progress rewrite ?compComp_tm
                 | progress setoid_rewrite renComp_vl
                 | progress rewrite ?renComp_vl
                 | progress setoid_rewrite renComp_tm
                 | progress rewrite ?renComp_tm
                 | progress setoid_rewrite compRen_vl
                 | progress rewrite ?compRen_vl
                 | progress setoid_rewrite compRen_tm
                 | progress rewrite ?compRen_tm
                 | progress setoid_rewrite renRen_vl
                 | progress rewrite ?renRen_vl
                 | progress setoid_rewrite renRen_tm
                 | progress rewrite ?renRen_tm
                 | progress setoid_rewrite compComp_ty
                 | progress rewrite ?compComp_ty
                 | progress setoid_rewrite renComp_ty
                 | progress rewrite ?renComp_ty
                 | progress setoid_rewrite compRen_ty
                 | progress rewrite ?compRen_ty
                 | progress setoid_rewrite renRen_ty
                 | progress rewrite ?renRen_ty
                 | progress setoid_rewrite varLRen'_vl
                 | progress rewrite ?varLRen'_vl
                 | progress setoid_rewrite varL'_vl
                 | progress rewrite ?varL'_vl
                 | progress setoid_rewrite rinstId'_vl
                 | progress rewrite ?rinstId'_vl
                 | progress setoid_rewrite rinstId'_tm
                 | progress rewrite ?rinstId'_tm
                 | progress setoid_rewrite instId'_vl
                 | progress rewrite ?instId'_vl
                 | progress setoid_rewrite instId'_tm
                 | progress rewrite ?instId'_tm
                 | progress setoid_rewrite varLRen'_ty
                 | progress rewrite ?varLRen'_ty
                 | progress setoid_rewrite varL'_ty
                 | progress rewrite ?varL'_ty
                 | progress setoid_rewrite rinstId'_ty
                 | progress rewrite ?rinstId'_ty
                 | progress setoid_rewrite instId'_ty
                 | progress rewrite ?instId'_ty
                 | progress
                    unfold up_vl_vl, up_vl_ty, up_ty_vl, upRen_vl_vl,
                     upRen_vl_ty, upRen_ty_vl, up_ty_ty, upRen_ty_ty, up_ren
                 | progress
                    cbn[subst_vl subst_tm ren_vl ren_tm subst_ty ren_ty]
                 | progress fsimpl
                 | repeat unfold funcomp ]).

Ltac asimpl := repeat try unfold_funcomp;
                repeat
                 unfold VarInstance_ty, Var, ids, Ren_ty, Ren1, ren1,
                  Up_ty_ty, Up_ty, up_ty, Subst_ty, Subst1, subst1,
                  VarInstance_vl, Var, ids, Ren_tm, Ren2, ren2, Ren_vl, Ren2,
                  ren2, Up_ty_vl, Up_vl, up_vl, Up_vl_ty, Up_ty, up_ty,
                  Up_vl_vl, Up_vl, up_vl, Subst_tm, Subst2, subst2, Subst_vl,
                  Subst2, subst2 in *; asimpl'; minimize.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case ltac:(asimpl; cbn; eauto).

Ltac substify := auto_unfold; try repeat erewrite ?rinstInst'_vl;
                  try repeat erewrite ?rinstInst'_tm;
                  try repeat erewrite ?rinstInst'_ty.

Ltac renamify := auto_unfold; try repeat erewrite <- ?rinstInst'_vl;
                  try repeat erewrite <- ?rinstInst'_tm;
                  try repeat erewrite <- ?rinstInst'_ty.


From stdpp Require Import countable numbers gmap.
From iris.algebra Require Import base.

Record loc := { loc_car : Z }.

Instance loc_eq_decision : EqDecision loc.
Proof. solve_decision. Qed.

Instance loc_inhabited : Inhabited loc := populate {|loc_car := 0 |}.

Instance loc_countable : Countable loc.
Proof. by apply (inj_countable' loc_car (λ i, {| loc_car := i |})); intros []. Qed.

Program Instance loc_infinite : Infinite loc :=
  inj_infinite (λ p, {| loc_car := p |}) (λ l, Some (loc_car l)) _.
Next Obligation. done. Qed.

Definition loc_add (l : loc) (off : Z) : loc :=
  {| loc_car := loc_car l + off|}.

Notation "l +ₗ off" :=
  (loc_add l off) (at level 50, left associativity) : stdpp_scope.

Lemma loc_add_assoc l i j : l +ₗ i +ₗ j = l +ₗ (i + j).
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Lemma loc_add_0 l : l +ₗ 0 = l.
Proof. destruct l; rewrite /loc_add /=; f_equal; lia. Qed.

Instance loc_add_inj l : Inj eq eq (loc_add l).
Proof. destruct l; rewrite /Inj /loc_add /=; intros; simplify_eq; lia. Qed.

Definition fresh_locs (ls : gset loc) : loc :=
  {| loc_car := set_fold (λ k r, (1 + loc_car k) `max` r)%Z 1%Z ls |}.

Lemma fresh_locs_fresh ls i :
  (0 ≤ i)%Z → fresh_locs ls +ₗ i ∉ ls.
Proof.
  intros Hi. cut (∀ l, l ∈ ls → loc_car l < loc_car (fresh_locs ls) + i)%Z.
  { intros help Hf%help. simpl in *. lia. }
  apply (set_fold_ind_L (λ r ls, ∀ l, l ∈ ls → (loc_car l < r + i)%Z));
    set_solver by eauto with lia.
Qed.

Global Opaque fresh_locs.


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 5 *)

Require Import Frap AbstractInterpret Pset5Sig.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

Theorem constant_sound : absint_sound constant_absint.
Proof.
Admitted.

Theorem constfold_cmd_fwd : forall ss v c v' c',
    (forall v' c', step^* (v, c) (v', c')
                   -> exists s, ss $? c' = Some s
                                /\ compatible s v')
    -> step^* (v, c) (v', c')
    -> step^* (v, constfold_cmd c ss (fun c1 => c1))
           (v', constfold_cmd c' ss (fun c1 => c1)).
Proof.
Admitted.

Theorem constfold_cmd_fwd_big : forall ss v c v',
    (forall v' c', step^* (v, c) (v', c')
                   -> exists s, ss $? c' = Some s
                                /\ compatible s v')
    -> eval v c v'
    -> eval v (constfold_cmd c ss (fun c1 => c1)) v'.
Proof.
Admitted.

(** * An example, analyzing one program *)

Theorem optimize_program_ok : forall v c v' ss,
  eval v c v'
  -> invariantFor (absint_trsys constant_absint c)
                  (fun p => exists s, ss $? snd p = Some s
                                      /\ subsumed (fst p) s)
  -> eval v (constfold_cmd c ss (fun c1 => c1)) v'.
Proof.
  simplify.
  apply constfold_cmd_fwd_big; auto.
  eapply invariant_simulates with (sys1 := trsys_of v c) in H0;
    try (apply absint_simulates with (a := constant_absint); apply constant_sound).
  simplify.
  eapply use_invariant in H0; simplify; eauto.
  invert H0.
  invert H2.
  simplify.
  first_order.
  eauto.
Qed.

Example loopsy :=
  "a" <- 7;;
  "b" <- 0;;
  while "n" loop
    "b" <- "b" + "a";;
    "n" <- "n" - 1
  done.

Example loopsy_optimized :=
  "a" <- 7;;
  "b" <- 0;;
  while "n" loop
    "b" <- "b" + 7;;
    "n" <- "n" - 1
  done.

Theorem loopsy_optimized_properly : forall v v',
  eval v loopsy v'
  -> eval v loopsy_optimized v'.
Proof.
  simplify.
  assert (exists ss, invariantFor (absint_trsys constant_absint loopsy)
                                  (fun p => exists s, ss $? snd p = Some s
                                                      /\ subsumed (fst p) s)
                     /\ loopsy_optimized = constfold_cmd loopsy ss (fun c1 => c1)).

  eexists; propositional.

  apply interpret_sound.
  apply constant_sound.

  unfold loopsy.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret_done.

  simplify.
  equality.

  first_order.
  rewrite H1.
  apply optimize_program_ok.
  assumption.
  assumption.
Qed.


Require Import Basics.
Require Import WildCat.Core.

(** Unit category *)

Global Instance is01cat_unit : Is01Cat Unit.
Proof.
  srapply Build_Is01Cat.
  1: intros; exact Unit.
  all: intros; exact tt.
Defined.

Global Instance is0gpd_unit : Is0Gpd Unit.
Proof.
  constructor; intros; exact tt.
Defined.

Global Instance is1cat_unit : Is1Cat Unit.
Proof.
  econstructor.
  1,2:econstructor.
  all:intros; exact tt.
Defined.


Require Import String.
Require Import Names.
Require Import Arith.
Require Import Lambda.
Require Import Arith_Lambda.
Require Import Functors.
Require Import PNames.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := AType :+: LType.

End Type_Test_Section.

Section Test_Section.

  Definition E (A : Set) := Arith :+: (Lambda D A).

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto 150 with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: BotValue :+: NatValue :+: (ClosValue E).

  Instance V_eval : FAlgebra EvalName (Names.Exp (E nat)) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

  Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E nat) SV))) (E nat).
    eauto 200 with typeclass_instances.
  Defined.

  Definition eval_continuous : forall m,
    forall (e : Names.Exp (E nat)) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven!").

  Definition Eqv (A B : Set) := (NP_Functor_eqv E Arith A B) ::+:: (Lambda_eqv D E A B).
  Definition WFV := (WFValue_Clos D E V Eqv (fun e => typeof _ _ (proj1_sig e))) ::+::
    (WFValue_Bot D V) ::+:: (WFValue_VI D V).

Instance eq_DType_eq_alg : (PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D).
  eauto 250 with typeclass_instances.
Defined.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 350 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Arith :+: Lambda Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)