(************************************************************************)
(* This files introduced basic ingredients of HoTT, most of them already *)
(* presents in https://github.com/HoTT. We have created our own library *)
(* to be independent from their framework which requires a tailored version of Coq  *)
(************************************************************************)

Set Universe Polymorphism.

(* Require Import Program Coq.Classes.RelationClasses. *)

Inductive sigT {A:Type} (P:A -> Type) : Type :=
    existT : forall x:A, P x -> sigT P.

Arguments existT {_} _ _.
Inductive prod (A B : Type) : Type :=  pair : A -> B -> prod A B.

Arguments pair {_ _} _ _.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z): type_scope.

Section projections.
  Context {A : Type} {B : Type}.

  Definition fst (p:prod A B) := prod_rect _ _ (fun _ => A) (fun x y => x) p.

  Definition snd (p:prod A B) := prod_rect _ _ (fun _ => B) (fun x y => y) p.

End projections.

Inductive unit : Type := tt.

Inductive empty : Type :=.

Inductive eq@{i} (A:Type@{i}) (x:A) : A -> Type@{i} :=
    eq_refl : eq A x x.

Notation "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.

Arguments eq_refl {_ _}.

Definition projT1 {A} {P:A -> Type} (p:sigT P) : A :=
  sigT_rect _ _ (fun _ => A) (fun x y => x) p.

Definition projT2  {A} {P:A -> Type} (p:sigT P) : P (projT1 p) :=
  sigT_rect _ _ (fun x => P (projT1 x)) (fun x y => y) p.

Notation id := (fun x => x).

Notation compose := (fun g f x => g (f x)).

Notation "g ∘ f" := (compose g%function f%function) (at level 1): function_scope.
(* Notation "g ∘ f" := (compose f g) (at level 1). *)

Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).

Notation "f == g" := (forall x, f x = g x) (at level 3).

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with eq_refl => eq_refl end.

Definition ap2 {A A' B:Type} (f:A -> A' -> B) {x y:A} (p:x = y)
  {x' y':A'} (q:x' = y') : f x x' = f y y'
  := match p with eq_refl => match q with eq_refl => eq_refl end end.

Definition ap3 {A A' A'' B:Type} (f:A -> A' -> A'' -> B) {x y:A} (p:x = y)
  {x' y':A'} (p':x' = y') {x'' y'':A''} (p'':x'' = y'') : f x x' x''= f y y' y''
  := match p with eq_refl => match p' with eq_refl => match p'' with eq_refl => eq_refl end end end.

Definition ap4 {A A' A'' A''' B:Type} (f:A -> A' -> A'' -> A''' -> B) {x y:A} (p:x = y)
           {x' y':A'} (p':x' = y') {x'' y'':A''} (p'':x'' = y'')
           {x''' y''':A'''} (p''':x''' = y''') : f x x' x'' x'''= f y y' y'' y'''
  := match p with eq_refl =>
     match p' with eq_refl =>
     match p'' with eq_refl =>
     match p''' with eq_refl => eq_refl end end end end.

Definition eq_sym {A} {x y : A} (H : x = y) : y = x :=
  match H with eq_refl => eq_refl end.
(* ET: the [in ... return ...] does not seem needed *)
(* match H in (_ = y0) return (y0 = x) with *)
(* | eq_refl => eq_refl *)
(* end. *)

(* Instance EqSymm A : Symmetric (eq A) := @eq_sym A. *)

(* From HoTT/Coq *)

Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
  : f == g
  := fun x => match h with eq_refl => eq_refl  end.

Definition transport_eq {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with eq_refl => u end.

Notation "p # x" := (transport_eq _ p x) (right associativity, at level 65, only parsing).

Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  destruct p; exact q.
Defined.

Notation "p @ q" := (concat p q) (at level 20).

Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
    := match p with eq_refl => eq_refl end.

Notation "p ^" := (inverse p) (at level 3, format "p '^'").

Definition transportD {A : Type} (B : A -> Type) (C : forall a:A, B a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1 y)
  : C x2 (p # y)
  :=
  match p with eq_refl => z end.

Definition transportD2 {A : Type} (B : A -> Type) (B' : A -> Type) (C : forall a:A, B a -> B' a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1)  (y' : B' x1) (z : C x1 y y')
  : C x2 (p # y) (p # y')
  :=
  match p with eq_refl => z end.

Definition transportD3 {A : Type} (B : A -> Type) (B' : A -> Type) B''
           (C : forall (a:A) (x: B a) (y: B' a), B'' a x y -> Type)
  {x1 x2 : A} (p : x1 = x2) y y' y'' (z : C x1 y y' y'')
  : C x2 (p # y) (p # y') (transportD2 _ _ _ p _ _ y'')
  :=
    match p with eq_refl => z end.

Definition transport_double A (P : A -> A -> Type) x y (e : x = y) (f : forall a, P a a) :
  transport_eq (fun X => P X _ ) e (transport_eq (fun X => P _ X) e (f x)) = f y.
  destruct e. reflexivity.
Defined.

Definition transport_forall A B (f : forall x : A , B x)  y z (e : z = y) :
  (* ET: why not [e # (f z) = f y]. *)
                transport_eq B e (f z) =
                f y.
Proof.
  destruct e. reflexivity.
Defined.

Definition transport_forall2 (P:Type->Type) A A' B (f : P A -> P A') (y z : P A) (H : z = y)
                 (g : forall x , B A x -> B A' (f x))
                 (h : forall x , B A x) :
                 (transport_eq (B _) (ap _ H)
                               (g z (h z))) =
                 g y (h y).
Proof.
  destruct H; reflexivity.
Defined.

Definition transport_pp {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) :
  p @ q # u = q # p # u :=
  match q with eq_refl =>
    match p with eq_refl => eq_refl end
  end.

Definition inverse_left_inverse A (x y : A) (p : x = y) : eq_refl = (p ^ @ p).
Proof. destruct p; reflexivity. Defined.

Definition transport_pV {A : Type} (P : A -> Type) {x y : A} (p : x = y) (z : P y)
  : p # p^ # z = z.
Proof.
  destruct p; reflexivity.
Defined.

Definition transport_Vp {A : Type} (P : A -> Type) {x y : A} (p : y = x) (z : P y)
  : p^ # p # z = z.
Proof.
  destruct p; reflexivity.
Defined.

Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) :
  ap f (p^) = (ap f p)^.
Proof.
  destruct p; reflexivity.
Defined.

Definition concat_refl A (x y :A) (e: x = y) : e @ eq_refl = e.
Proof.
  destruct e; reflexivity.
Defined.

Definition inv_inv A (x y :A) (e: x = y) : e^ @ e = eq_refl.
Proof.
  destruct e; reflexivity.
Defined.

Definition transport_ap {A B : Type} (P : B -> Type) (f : A -> B) {x y : A}
           (p : x = y) (z : P (f x)) : transport_eq P (ap f p) z =
                                       transport_eq (fun x => P (f x)) p z.
Proof.
  destruct p. reflexivity.
Defined.

Definition naturality  {A B} `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B)
           (e' : forall a, Q (f a) -> P a) a b (e : a = b)(z : Q (f a)):
  e' _ (transport_eq (Q ∘ f) e z) = e # (e' _ z).
Proof.
  destruct e. reflexivity.
Defined.

Definition concat_inv {A : Type} {x y z : A} (p : x = y) (q : y = z) :
  (p @ q)^ = q^ @ p^.
             Proof.
  destruct p, q; reflexivity.
Defined.

Definition ap_inv {A B:Type} (f:A -> B) {x y:A} (p:x = y) : ap f p^ = (ap f p)^.
Proof.
  destruct p; reflexivity.
Defined.

Definition transport_inv {A : Type} (P : A -> Type) {x y : A} (p : x = y) u v :
  p # u = v -> u = transport_eq P p^ v.
Proof.
  destruct p. exact id.
Defined.

Definition transport_commute A B (P : A -> B -> Type) x y (e : x = y) x' y' (e' : x' = y') u:
  transport_eq (fun X => P X _ ) e (transport_eq (fun X => P _ X) e' u) =
  transport_eq (fun X => P _ X ) e' (transport_eq (fun X => P X _) e u).
  destruct e, e'. reflexivity.
Defined.

Definition transport_double' A B (P : A -> B -> Type) x y (e : x = y) g (f : forall a, P a (g a)) :
  transport_eq (fun X => P X _ ) e (transport_eq (fun X => P _ (g X)) e (f x)) = f y.
  destruct e. reflexivity.
Defined.

Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
           (pq : {p : u.1 = v.1 & p # u.2 = v.2})
: u = v.
Proof.
  destruct pq as [p q]. destruct u, v. simpl in *. destruct p.
  simpl in q. destruct q. reflexivity.
Defined.

Definition pr1_path {A} `{P : A -> Type} {u v : sigT P} (p : u = v) : u.1 = v.1 := ap projT1 p.

Notation "p ..1" := (pr1_path p) (at level 50).

Definition pr2_path {A} `{P : A -> Type} {u v : sigT P} (p : u = v)
  : p..1 # u.2 =  v.2.
  destruct p. reflexivity.
Defined.

Notation "p ..2" := (pr2_path p) (at level 50).

Definition path_prod_uncurried {A B : Type} (u v : A * B)
           (pq : (fst u = fst v) * (snd u = snd v))
: u = v.
Proof.
  destruct pq as [p q]. destruct u, v. simpl in *. destruct p.
  simpl in q; destruct q; reflexivity.
Defined.

Definition ap_id A (x y:A) (e:x = y) : ap id e = e.
Proof.
  destruct e; reflexivity.
Defined.

Definition refl_V {A : Type} {x : A} (p : x = x) :
  p^ = eq_refl -> p = eq_refl.
Proof.
  pose (ep := inv_inv _ _ _ p).
  intro e; rewrite e in ep. exact ep.
Defined.

Definition unpack_prod {A B} `{P : A * B -> Type} (u : A * B) :
  P (fst u, snd u) -> P u.
  destruct u. exact id.
Defined.

Definition pack_prod {A B} `{P : A * B -> Type} (u : A * B) :
  P u -> P (fst u, snd u).
  destruct u; exact id.
Defined.

Lemma transport_path_prod_uncurried {A B} (P : A * B -> Type) {x y : A * B}
      (H : (fst x = fst y) * (snd x = snd y))
      (Px : P x)
: transport_eq P (path_prod_uncurried _ _ H) Px
  = unpack_prod _ (transport_eq (fun x => P (x, snd y))
              (fst H)
              (transport_eq (fun y => P (fst x, y))
                         (snd H)
                         (pack_prod _ Px))).
Proof.
  destruct x, y, H; simpl in *.
  destruct e, e0.
  reflexivity.
Defined.

Lemma path_prod_uncurried_inv {A B} {x y : A * B}
      (H : (fst x = fst y) * (snd x = snd y))
  : (path_prod_uncurried _ _ H)^
    = path_prod_uncurried _ _ ((fst H)^, (snd H)^).
Proof.
  destruct H, x ,y. cbn in *. destruct e, e0. reflexivity.
Defined.

Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
  (z : P a * Q a)
  : transport_eq (fun a => prod (P a) (Q a)) p z  =  (p # (fst z), p # (snd z)).
  destruct p, z. reflexivity.
Defined.

Definition transport_const {A B : Type} {x1 x2 : A} (p : x1 = x2) (y : B)
  : transport_eq (fun x => B) p y = y.
Proof.
  destruct p.  exact eq_refl.
Defined.

Definition transport_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y)
  : transport_eq (fun x => x = y) p q = p^ @ q.
Proof.
  destruct p, q; reflexivity.
Defined.

Definition transport_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1)
  : transport_eq (fun y => x = y) p q = q @ p.
Proof.
  destruct p, q; reflexivity.
Defined.

Definition transport_paths_Fl {A B : Type} {f : A -> B} {x1 x2 : A} {y : B}
  (p : x1 = x2) (q : f x1 = y)
  : transport_eq (fun x => f x = y) p q = (ap f p)^ @ q.
Proof.
  destruct p, q; reflexivity.
Defined.

Definition transport_paths_Fr {A B : Type} {g : A -> B} {y1 y2 : A} {x : B}
  (p : y1 = y2) (q : x = g y1)
  : transport_eq (fun y => x = g y) p q = q @ (ap g p).
Proof.
  destruct p. symmetry. simpl. apply concat_refl.
Defined.

Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) :
  ap f (p @ q) = (ap f p) @ (ap f q).
  destruct p; reflexivity.
Defined.

Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) :
  (ap f q) @ (p y) = (p x) @ (ap g q).
  destruct q. simpl. apply eq_sym. apply concat_refl.
Defined.

Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
  p @ (q @ r) = (p @ q) @ r.
  destruct p, q; reflexivity.
Defined.

Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  ap (g ∘ f) p = ap g (ap f p).
  destruct p. reflexivity. Defined.

Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) :
  (p x) @ (ap f q) =  q @ (p y).
  destruct q; simpl. apply concat_refl.
Defined.

Definition inv_inv' A (x y :A) (e: x = y) : e @ e^ = eq_refl.
Proof.
  destruct e. reflexivity.
Defined.

Definition transport_switch {A : Type} (P : A -> Type) {x y : A} (p : y = x) (z : P y) z'
  : z = p^ # z' -> p # z = z'.
Proof.
  destruct p; auto.
Defined.

Definition naturality'  {A B} `{P : A -> Type} `{Q : B -> Type}
           (f : A -> B)
           (e' : forall a, P a -> Q (f a)) a b (e : a = b) z:
  transport_eq (Q ∘ f) e (e' _ z) = e' _ (e # z).
Proof.
  destruct e. reflexivity.
Defined.

Definition inv2 A (x y :A) (e: x = y) : e^ ^ = e.
Proof.
  destruct e; reflexivity.
Defined.

(* equivalences *)

Class IsEquiv {A : Type} {B : Type} (f : A -> B) := BuildIsEquiv {
  e_inv :> B -> A ;
  e_sect : forall x, e_inv (f x) = x;
  e_retr : forall y, f (e_inv y) = y;
  e_adj : forall x : A, e_retr (f x) = ap f (e_sect x);
}.

(** A class that includes all the data of an adjoint equivalence. *)
Class Equiv A B := BuildEquiv {
  e_fun :> A -> B ;
  e_isequiv :> IsEquiv e_fun
}.

Notation "A ≃ B" := (Equiv A B) (at level 20).

Arguments e_fun {_ _} _ _.
Arguments e_inv {_ _} _ {_} _.
Arguments e_sect {_ _} _ {_} _.
Arguments e_retr {_ _} _ {_} _.
Arguments e_adj {_ _} _ {_} _.
Arguments e_isequiv {_ _ _}.

Typeclasses Transparent e_fun e_inv.

Coercion e_fun : Equiv >-> Funclass.

Definition univalent_transport {A B : Type} {e: A ≃ B} : A -> B := e_fun e.

Notation "↑" := univalent_transport (at level 65, only parsing).

(* Instance IsEquiv_Equiv A B (e:A ≃ B) : IsEquiv (e_fun e) := e_isequiv (Equiv:=e). *)

Definition e_inv' {A B : Type} (e : A ≃ B) : B -> A := e_inv (e_fun e).
Definition e_sect' {A B : Type} (e : A ≃ B) := e_sect (e_fun e).
Definition e_retr' {A B : Type} (e : A ≃ B) := e_retr (e_fun e).
Definition e_adj' {A B : Type} (e : A ≃ B) := e_adj (e_fun e).

Definition issect'  {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g ∘ f == id) (isretr : f  ∘ g == id) :=
  fun x =>
    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) :
  eq_refl = p^ @ q -> p = q.
Proof.
  destruct p. exact id.
Defined.

Definition concat_1p {A : Type} {x y : A} (p : x = y) :
  eq_refl @ p = p := eq_refl.

Definition moveL_M1 {A : Type} {x y : A} (p q : x = y) :
  eq_refl = q @ p^ -> p = q.
Proof.
  destruct p.
  intro h. exact (h @ (concat_refl _ _ _  _)).
Defined.

Definition moveL_M1' {A : Type} {x y : A} (p q : x = y) :
  q^ @ p = eq_refl -> p = q.
Proof.
  destruct p. intro e. rewrite concat_refl in e.
  rewrite <- inv2. rewrite e. reflexivity.
Defined.

Definition concat_A1p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) :
  (ap f q) @ (p y) = (p x) @ q.
  destruct q. cbn. apply inverse. apply concat_refl.
Defined.

Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) :
  r @ q = p -> r = p @ q ^.
Proof.
  destruct r. cbn in *. destruct 1. destruct q. reflexivity.
Defined.

Definition is_adjoint' {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g∘ f == id) (isretr : f  ∘ g == id) (a : A) : isretr (f a) = ap f (issect' f g issect isretr a).
Proof.
  unfold issect'.
  apply moveL_M1.
  repeat rewrite ap_pp. rewrite <- concat_p_pp; rewrite <- ap_compose.
  pose  (concat_pA1 (fun b => (isretr b)^) (ap f (issect a))).
  eapply concat. 2: { apply ap2. reflexivity. exact e. }
  cbn. clear e.
  pose (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
  rewrite <- concat_p_pp.
  pose (concat_A1p (fun b => (isretr b)) (isretr (f a))).
  apply moveL_Vp in e0.
  rewrite <- concat_p_pp in e0. rewrite inv_inv' in e0.
  rewrite concat_refl in e0.
  rewrite ap_compose in e0.
  eapply concat.
  2: { apply ap2. reflexivity. rewrite concat_p_pp. eapply concat.
       2: { apply ap2. eapply concat.
            2:{ apply ap2. symmetry. apply e0. reflexivity. }
              symmetry. apply inv_inv'. reflexivity. }
              reflexivity. }
  repeat rewrite <- ap_compose.
  cbn. symmetry. eapply concat. refine (ap_pp ((f ∘ g) ∘f) _ _)^.
  rewrite inv_inv. reflexivity.
Qed.

Definition isequiv_adjointify {A B : Type} (f : A -> B) (g : B -> A)
           (issect : g∘ f == id) (isretr : f  ∘ g == id)  : IsEquiv f
  := BuildIsEquiv A B f g (issect' f g issect isretr) isretr
                  (is_adjoint' f g issect isretr).

Definition Equiv_id A : A ≃ A :=
  BuildEquiv _ _ id (BuildIsEquiv _ _ _ id (fun _ => eq_refl) (fun _ => eq_refl) (fun _ => eq_refl)).

Definition isequiv_compose A B C f g `{IsEquiv A B f} `{IsEquiv B C g}
  : IsEquiv (g ∘ f).
Proof.
  unshelve eapply isequiv_adjointify.
  - exact ((e_inv f) ∘ (e_inv g)).
  - exact (fun a => ap (e_inv f) (e_sect g (f a)) @ e_sect f a).
  - exact (fun c => ap g (e_retr f (e_inv g c)) @ e_retr g c).
Defined.

Definition equiv_compose {A B C : Type} (f: A ≃ B) (g : B ≃ C)
  : A ≃ C
  := BuildEquiv A C ((e_fun g) ∘ (e_fun f)) (isequiv_compose _ _ _ _ _).

Notation "g ∘∘ f" := (equiv_compose f g) (at level 50).

Definition concat_Vp {A : Type} {x y : A} (p : x = y) := inv_inv A x y p.

Definition whiskerL {A : Type} {x y z : A} (p : x = y)
           {q r : y = z} (h : q = r) : p @ q = p @ r.
  exact (ap (concat p) h).
Defined.

Definition whiskerR {A : Type} {x y z : A} {p q : x = y}
           (h : p = q) (r : y = z) : p @ r = q @ r.
  exact (ap (fun X => X @ r) h).
Defined.

Definition inverse2 {A : Type} {x y : A} {p q : x = y} (h : p = q)
  : p^ = q^ . apply ap. auto.
Defined.

Definition ap02 {A B : Type} (f:A->B) {x y:A} {p q:x=y} (r:p=q) : ap f p = ap f q.
  apply ap. auto.
Defined.

Definition concat_pp_A1 {A : Type} {g : A -> A} (p : forall x, x = g x)
  {x y : A} (q : x = y)
  {w : A} (r : w = x)
  :
  (r @ p x) @ ap g q = (r @ q) @ p y.
Proof.
  destruct q; simpl.
  repeat rewrite concat_refl.
  reflexivity.
Defined.

Definition concat_pp_A1p {A : Type} {g : A -> A} (p : forall x, x = g x)
  {x y : A} (q : x = y)
  {w z : A} (r : w = x) (s : g y = z)
  :
  (r @ p x) @ (ap g q @ s) = (r @ q) @ (p y @ s).
Proof.
  destruct q, s; simpl.
  repeat rewrite concat_refl.
  reflexivity.
Defined.

Definition ap_compose' {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  ap (fun a => g (f a)) p = ap g (ap f p) := ap_compose f g p.

Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A}
  (r : w = f x) (p : x = y) (q : y = z) :
  r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q).
Proof.
  destruct p, q. simpl. exact (concat_p_pp r eq_refl eq_refl).
Defined.

Definition concat_A1p' {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) :
  (ap f q) @ (p y) = (p x) @ q.
  destruct q; cbn. apply inverse. apply concat_refl.
Defined.

Definition concat_pp_V {A : Type} {x y z : A} (p : x = y) (q : y = z) :
  (p @ q) @ q^ = p.
  destruct p, q.
  reflexivity.
Defined.

Definition concat_p_Vp {A : Type} {x y z : A} (p : x = y) (q : x = z) :
  p @ (p^ @ q) = q.
  destruct p; reflexivity.
Defined.

Definition concat_pA1_p {A : Type} {f : A -> A} (p : forall x, f x = x)
  {x y : A} (q : x = y)
  {w : A} (r : w = f x)
  :
  (r @ ap f q) @ p y = (r @ p x) @ q.
Proof.
  destruct q; simpl.
  repeat rewrite concat_refl.
  reflexivity.
Defined.

Definition concat_pV_p {A : Type} {x y z : A} (p : x = z) (q : y = z) :
  (p @ q^) @ q = p.
  destruct q. cbn. repeat rewrite concat_refl.
  reflexivity.
Defined.

Section EquivInverse.

  Context {A B : Type} (f : A -> B) {feq : IsEquiv f}.

Theorem other_adj (b : B) : e_sect f (e_inv f b) = ap (e_inv f) (e_retr f b).
Proof.
    (* First we set up the mess. *)
    rewrite <- (concat_1p (e_sect _ _)).
    rewrite <- (inv_inv _ _ _ (ap (e_inv f) (e_retr f (f (e_inv f b))))).
    rewrite (whiskerR (inverse2 (ap02 (e_inv f) (e_adj f (e_inv f b)))) _).
    refine (whiskerL _ (concat_1p (e_sect _ _))^ @ _).
    rewrite <- (concat_Vp (e_sect f (e_inv f (f (e_inv f b))))).
    rewrite <- (whiskerL _ (concat_1p (e_sect f (e_inv f (f (e_inv f b)))))).
    rewrite <- (inv_inv' _ _ _ (ap (e_inv f) (e_retr f (f (e_inv f b))))).
    apply moveL_M1'.
    repeat rewrite concat_p_pp.
    (* Now we apply lots of naturality and cancel things. *)

    rewrite <- (concat_pp_A1 (fun a => (e_sect f a)^) _ _).
    rewrite (ap_compose' f (e_inv f)).
    rewrite <- (ap_p_pp _ _ (ap f (ap (e_inv f) (e_retr f (f (e_inv f b))))) _).
    rewrite <- (ap_compose (e_inv f) f).
    rewrite (concat_A1p (e_retr f) _).
    rewrite ap_pp, concat_p_pp.
    rewrite (concat_pp_V _ (ap (e_inv f) (e_retr f (f (e_inv f b))))).
    repeat rewrite <- ap_V.
    rewrite <- ap_pp.
    rewrite <- (concat_pA1 (fun y => (e_sect f y)^) _).
    rewrite (ap_compose'). rewrite <- (ap_compose (e_inv f) f).
    rewrite <- ap_p_pp.
    rewrite (concat_A1p (e_retr f) _).
    rewrite concat_p_Vp.
    rewrite <- ap_compose.
    rewrite (concat_pA1_p (e_sect f) _).
    rewrite concat_pV_p; apply concat_Vp.
Qed.

Definition isequiv_inverse : IsEquiv (e_inv f)
    := BuildIsEquiv _ _ (e_inv f) f (e_retr f) (e_sect f) other_adj.
End EquivInverse.

Definition Equiv_inverse {A B : Type} (e: A ≃ B) : B ≃ A := BuildEquiv _ _ (e_inv (e_fun e)) (isequiv_inverse _).

Definition Move_equiv {A B} (e : A ≃ B) x y : x = e_inv' e y -> e_fun e x = y.
Proof.
  intro X. apply (ap (e_fun e)) in X. exact (X @ e_retr' e _).
Defined.

Definition Move_equiv' {A B} (e : A ≃ B) x y : e_fun e x = y -> x = e_inv' e y.
Proof.
  intro X. apply (ap (e_inv' e)) in X. exact ((e_sect' e _)^ @ X).
Defined.

Definition transport_paths_naturality {A : Type} {g : A -> A} {y1 y2 : A}
  (p : y1 = y2) (q : forall x, x = g x)
  : p @ (q y2) = (q y1) @ (ap g p).
Proof.
  destruct p. symmetry; apply concat_refl.
Defined.

Definition transport_e_fun A B (P : A -> Type) a a' (e : a = a') (e' : P a ≃ B) x
    :
      e_fun e' (transport_eq P e^ x) =
      e_fun (transport_eq (fun X => P X ≃ _) e e') x.
Proof.
  destruct e. reflexivity.
Defined.

Definition transport_e_fun' A B (P : A -> Type) a a' (e : a = a') (e' : B ≃ P a) x
    :
      transport_eq P e (e_fun e' x) =
      e_fun (transport_eq (fun X => _ ≃ P X) e e') x.
Proof.
  destruct e. reflexivity.
Defined.

Definition ap_inv_equiv {A B} (f : A -> B) `{IsEquiv _ _ f} x y : f x = f y -> x = y.
Proof.
  intro X. exact ((e_sect f x)^@ ap (e_inv f) X @ e_sect f y).
Defined.

Definition ap_inv_equiv' {A B} (f : A -> B) `{IsEquiv _ _ f} x y : e_inv f x = e_inv f y -> x = y.
Proof.
  intro X. exact ((e_retr f x)^@ ap f X @ e_retr f y).
Defined.

Definition IsEquiv_ap A (P : A -> Type) {x y : A} (p : x = y) (u v : P x)
  : IsEquiv (@ap _ _ (fun (X : P x) => p # X) u v).
Proof.
  unshelve eapply isequiv_adjointify; cbn.
  - intros. destruct p. exact X.
  - intro e. destruct p. cbn. apply ap_id.
  - intro e. destruct p. cbn. apply ap_id.
Defined.

Definition IsEquiv_transport A (P : A -> Type) {x y : A} (p : x = y)
  : IsEquiv (transport_eq P p).
Proof.
  unshelve econstructor.
  - intros. destruct p. exact X.
  - intro e. destruct p. reflexivity.
  - intro e. destruct p. reflexivity.
  - intro e. destruct p. reflexivity.
Defined.

Definition concat_VpV_p {A : Type} {x z : A} (p : x = z) (q : x = z) :
  q = p -> p^ @ q = eq_refl.
  destruct p. cbn. apply id.
Defined.

Definition ap_1 {A B : Type} (f : A -> B) {x : A} (p : x = x) :
  p = eq_refl -> ap f p = eq_refl.
Proof.
  intro e; rewrite e. reflexivity.
Defined.

Definition concat_Ap1 {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) :
  (p x)^ @ (ap f q) = q @ (p y)^.
  destruct q. apply concat_refl.
Defined.

Definition moveR_pV {A : Type} {x y z : A} (p : x = z) (q : z = y) (r : x = y) :
  p^ @ r = q -> r = p @ q.
Proof.
  destruct r. cbn in *. destruct 1. destruct p.  reflexivity.
Defined.

Definition concat_V_pp {A : Type} {x y z : A} (p : x = y) (q : y = z) :
  p^ @ (p @ q) = q
  :=
  match q with eq_refl =>
    match p with eq_refl => eq_refl end
  end.

Instance isequiv_concat_r {A : Type} y z (p : y = z) (x : A)
  : IsEquiv (fun q:x=y => q @ p) | 0.
Proof.
  refine (BuildIsEquiv _ _ (fun q => q @ p) (fun q => q @ p^)
           (fun q => concat_pp_V q p) (fun q => concat_pV_p q p) _).
  intros q; destruct p; destruct q; reflexivity.
Defined.

Instance isequiv_concat_l {A : Type} x y (p : x = y:>A) (z : A)
  : IsEquiv (@concat A x y z p) | 0.
Proof.
  refine (BuildIsEquiv _ _ _ (concat p^)
                        (concat_V_pp p) (concat_p_Vp p) _).
  intros q; destruct p; destruct q; reflexivity.
Defined.

Instance isequiv_moveL_M1 {A : Type} {x y : A} (p q : x = y)
: IsEquiv (moveL_M1 p q).
Proof.
  destruct p. apply isequiv_concat_r.
Defined.

Definition moveL_M1_eq {A : Type} {x y : A} (p q : x = y) (e : eq_refl = p @ q^):
  ap (concat p) (ap inverse (moveL_M1 q p e)^) =
  inv_inv' _ _ _ p @ e.
Proof.
  destruct q. unfold whiskerL.
  refine (transport_eq (fun X =>  ap (concat p) (ap inverse (moveL_M1 eq_refl p e)^)  = inv_inv' A x x p @ X) (e_sect (moveL_M1 eq_refl p) e) _).
  generalize (moveL_M1 eq_refl p e). clear e; intro e.
  destruct e. reflexivity.
Defined.

(**

Hedberg theorem is a standard theorem of HoTT: it states that if a
type [A] has decle equality, then it is a hSet, i.e. its equality
is proof-irrelevant. See the proof at [https://github.com/HoTT] in
[HoTT/theories/Basics/Decidable.v] *)

Class DecidableEq A := { dec_paths : forall a b : A, (a = b) + (a = b -> False)}.

Class HSet A := {is_hset : forall (x y : A) (e e' : x = y), e = e'}.

Instance Hedberg A `{DecidableEq A} : HSet A.
Proof.
  econstructor.
  intros a b.
  assert (lemma: forall p: a = b,
             match dec_paths a a, dec_paths a b with
             | inl r, inl s => p = r^ @ s
             | _, _ => False
             end).
  {
    destruct p.
    destruct (dec_paths a a) as [pr | f].
    - apply inverse_left_inverse.
    - exact (f eq_refl).
  }

  intros p q.
  assert (p_given_by_dec := lemma p).
  assert (q_given_by_dec := lemma q).
  destruct (dec_paths a b); try contradiction.
  destruct (dec_paths a a); try contradiction.
  apply (p_given_by_dec @ q_given_by_dec ^).
Defined.

Definition logic_eq_is_eq {A} {x y:A} : @Logic.eq A x y -> x = y.
Proof.
  destruct 1. reflexivity.
Defined.

Instance DecidableEq_eq_nat : DecidableEq nat.
constructor. intros x y; revert y.
induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- induction y.
  + right; intro H; inversion H.
  + case (IHx y). intro H. left. exact (ap S H).
    intro H; right. intro e. inversion e. apply (H (logic_eq_is_eq H1)).
Defined.

Instance DecidableEq_eq_bool : DecidableEq bool.
constructor. intros x y; revert y. induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- destruct y.
 + right; intro H; inversion H.
 + left ;reflexivity.
Defined.

Definition isequiv_ap (A B:Type) {H : A ≃ B} a a' :
  (a= a') ≃ (e_fun H a = e_fun H a').
Proof.
  unshelve econstructor.
  apply ap.
  unshelve refine (isequiv_adjointify _ _ _ _ ).
  - intro X. apply (ap (e_inv' H)) in X. exact ((e_sect' H a)^ @ X @ e_sect' H _).
  - intro. cbn. destruct x. cbn. rewrite concat_refl.
    apply inv_inv.
  - intro. cbn.
    repeat rewrite ap_pp.
    rewrite <- ap_compose.
    rewrite ap_V. unfold e_sect'. rewrite <- e_adj.
    eapply concat. apply ap2.
    apply (concat_pA1 (fun b => (e_retr (e_fun H) b)^)).
    reflexivity. rewrite <- concat_p_pp. rewrite e_adj. rewrite inv_inv.
    apply concat_refl.
Defined.

Definition DecidableEq_equiv A B (eB : A ≃ B) `{DecidableEq A} : DecidableEq B.
Proof.
  constructor. pose (eB' := Equiv_inverse eB).
  intros x y. destruct (dec_paths (↑ x) (↑ y)).
  - left. apply (@isequiv_ap _ _ eB'). exact e.
  - right. intro e. apply f. exact (ap _ e).
Defined.

(*** Some Equivalences for types *)

(* sigma types *)
Definition EqSigma {A : Type} {P : A -> Type} (w w' : {a:A & P a}) : Equiv (w = w') {p: w .1 = w' .1 & p # (w .2) = w' .2}.
Proof.
  unshelve econstructor.
  + intro p. unshelve econstructor; destruct p; reflexivity.
  + unshelve eapply isequiv_adjointify.
    - intros [p q]. destruct w as [w1 w2]; destruct w' as [w'1 w'2]; cbn in *.
    destruct p, q; cbn in *. reflexivity.
    - intro p. destruct p. destruct w; cbn in *. reflexivity.
    - destruct w as [w1 w2]; destruct w' as [w'1 w'2].
      intros [p q]; cbn in *. destruct p; destruct q.
      reflexivity.
Defined.

Definition EquivSigmaNoDep {A A' : Type} {B B' : Type}
           (HA : Equiv A A')
           (HB : Equiv B B') :
  Equiv {a:A & B} {a':A' & B'}.
Proof.
  unshelve econstructor.
  * intros [x y]. exact (HA x; HB y).
  * unshelve eapply isequiv_adjointify.
    + intros [x y]. refine (e_inv HA x; HB.(e_inv) y).
    + intros [x y]. apply path_sigma_uncurried. unshelve eexists; cbn.
      exact (e_sect HA x). rewrite transport_const. exact (e_sect HB y).
    + intros [x y]. apply path_sigma_uncurried. unshelve eexists; cbn.
      exact (e_retr HA x). rewrite transport_const. exact (e_retr HB y).
Defined.

Definition EquivSigmaGen {A A' : Type} {B} {B'}
           (HA : Equiv A A')
           (HB : forall a, Equiv (B a) (B' (HA a))) :
  Equiv {a:A & B a} {a':A' & B' a'}.
Proof.
  unshelve econstructor.
  * intros [x y]. exact (HA x; HB x y).
  * unshelve eapply isequiv_adjointify.
  + intros [x y]. refine (e_inv HA x; (HB (e_inv HA x)).(e_inv) _).
    refine (transport_eq B' _ y). apply inverse. exact (e_retr HA x).
  + intros [x y]. apply path_sigma_uncurried. unshelve eexists; cbn.
    exact (e_sect HA x). admit.
  + intros [x y]. apply path_sigma_uncurried. unshelve eexists; cbn.
    exact (e_retr HA x). admit.
Admitted.

Definition EquivSigma {A : Type} {B B' : A -> Type}
  (H : forall a:A, Equiv (B a) (B' a)) : Equiv {a:A & B a} {a:A & B' a}.
Proof.
  unshelve econstructor.
  * intros [x y]. exact (x; H x y).
  * unshelve eapply isequiv_adjointify.
    + intros [x y]. exact (x; (H x).(e_inv) y).
    + intros [x y]. rewrite e_sect. reflexivity.
    + intros [x y]. rewrite e_retr. reflexivity.
Defined.

Definition swap_sigma {A B : Type} {Q : A -> B -> Type} :
    Equiv {a:A & {b:B & Q a b}} {b:B & {a:A & Q a b}}.
Proof.
    unshelve econstructor.
    - intros [a q]. destruct q as [b r]. exact (b; (a; r)).
    - unshelve eapply isequiv_adjointify.
      -- intros [b q]. destruct q as [a r]. exact (a; (b; r)).
      -- intros [a q]. destruct q as [b r]. reflexivity.
      -- intros [b q]. destruct q as [a r]. reflexivity.
Defined.

Definition swap_forall {A B : Type} {Q: A->B->Type} :
  Equiv (forall (a:A) (b:B), Q a b) (forall (b:B) (a:A), Q a b).
Proof.
  unshelve econstructor.
  + intro F. intros b a. exact (F a b).
  + unshelve eapply isequiv_adjointify.
    - intro G. intros a b. exact (G b a).
    - reflexivity.
    - reflexivity.
Defined.

(* Instance DecidableEq_Sigma A (B : A -> Type) `{DecidableEq A} `{forall a, DecidableEq (B a)} : *)
(*   DecidableEq {a : A & B a}. *)
(* Proof. *)
(*   constructor. intros [a b] [a' b' ]. *)
(*   destruct (dec_paths a a'). *)
(*   - destruct e. destruct (dec_paths b b'). *)
(*     + apply inl. apply path_sigma_uncurried. exists eq_refl. exact e. *)
(*     + apply inr; intro Hf; apply f. pose (Hf..2). *)
(*       assert (Hf..1 = eq_refl). apply is_hset. rewrite X in e. exact e. *)
(*   - apply inr; intro Hf; apply f. exact (Hf..1). *)
(* Defined. *)

Definition Move_equiv_equiv {A B} (e : A ≃ B) x y : (x = e_inv' e y) ≃ (e_fun e x = y).
Proof.
  apply (transport_eq (fun X =>  (x = e_inv' e y) ≃ (e x = X)) (e_retr _ y)).
  apply isequiv_ap.
Defined.

Definition isequiv_sym (A:Type) (a a':A) :
  (a = a') ≃ (a' = a).
Proof.
  unshelve econstructor.
  apply inverse.
  unshelve refine (isequiv_adjointify _ _ _ _ ).
  - apply inverse.
  - intro. cbn. apply inv2.
  - intro. cbn. apply inv2.
Defined.

Definition transport_equiv A X (a b:A) Q (e : a = b) (x : Q a) (e' : Q b ≃ X):
  e_fun e' (transport_eq Q e x) =
  e_fun
    (transport_eq (fun X : A => Q X ≃ _) e^
       e') x.
Proof.
  destruct e. reflexivity.
Defined.

Definition transport_paths_naturality' {A : Type} {g : A -> A} {y1 y2 : A}
  (p : y1 = y2) (q : forall x, g x = x)
  : (q _) @ p = (ap g p) @ q _.
Proof.
  destruct p. apply concat_refl.
Defined.

Instance isequiv_moveR_M1 {A : Type} {x y : A} (p q : x = y)
: IsEquiv (moveR_M1 p q).
Proof.
  destruct p. apply (@e_isequiv _ _ (Equiv_id _)).
Defined.

Definition transport_inverse A B (a b : A) (c : B) P (EE : a = b) (XX : Type) (XXX : XX ≃ (P c a)):
      Equiv_inverse (transport_eq (fun X : A => XX ≃ (P c X)) EE XXX) =
      transport_eq (fun X : A => (P c X) ≃ XX) EE (Equiv_inverse XXX).
  destruct EE; reflexivity.
Defined.

Definition transport_inverse' A B (a b : A) (c:B) P (EE : a = b) (XX : Type) (XXX : (P c a) ≃ XX):
      Equiv_inverse (transport_eq (fun X : A => (P c X) ≃ XX) EE XXX) =
      transport_eq (fun X : A => XX ≃ (P c X)) EE (Equiv_inverse XXX).
  destruct EE; reflexivity.
Defined.

Definition transport_fun_eq A (a:A) P (f : forall a', a = a' -> P a') b c (e : b = c) (e' : a = b):
  transport_eq P e (f b e') = f c (e' @ e).
Proof.
  destruct e. cbn. rewrite concat_refl. reflexivity.
Defined.

Definition transport_forall_cst {A B}
           (P : A -> B -> Type) b b' (e: b = b')
           (v : forall x, P x b)
            : (transport_eq (fun y => forall x, P x y) e v)
            = fun x => transport_eq (fun y => P x y) e (v x).
Proof.
  destruct e; reflexivity.
Defined.

Definition transport_sigma {A : Type} {B : A -> Type} {C : forall a:A, B a -> Type}
           {x1 x2 : A} (p : x1 = x2) (yz : { y : B x1 & C x1 y })
: transport_eq (fun x => { y : B x & C x y }) p yz
  = (p # yz.1 ; transportD _ _ p yz.1 yz.2).
Proof.
  destruct p.  destruct yz as [y z]. reflexivity.
Defined.

Definition transport_sigma' {A B : Type} {C : A -> B -> Type}
           {x1 x2 : A} (p : x1 = x2) (yz : { y : B & C x1 y })
: transport_eq (fun x => { y : B & C x y }) p yz =
  (yz.1 ; transport_eq (fun x => C x yz.1) p yz.2).
Proof.
  destruct p. destruct yz. reflexivity.
Defined.

Definition transport_pr1_path A (B:A->Type)
           (X Y : {a:A & B a}) (e : X = Y) :
  transport_eq B (e..1) X.2 = Y .2.
Proof.
  destruct e. reflexivity.
Defined.


(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/05/31.                                             *)
(* Due: 2021/06/04, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment10.v) on CANVAS.        *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment10.vo" file is generated.        *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import PL.RTClosure.
Require Import PL.Lambda.

(* ################################################################# *)
(** * Task 1: Progress And Preservation *)

Module Task1.

Import LambdaIB.
Local Open Scope Z.
Local Open Scope string.

(** In this task, you need to answer some basic questions about lambda
    expressions with integers and booleans involved (references are not
    involved). We have seen the definition of [do_it_three_times] and
    [add_one] in class. *)

Definition do_it_three_times: tm :=
  abs "f" (abs "x" (app "f" (app "f" (app "f" "x")))).

Definition add_one: tm :=
  abs "x" (app (app Oplus "x") 1).

(** Please prove that the following expression is well-typed. Hint: you may use
    [type_of_add_one] and [type_of_do_it_three_times] in this proof. *)

(* type_of_add_one: empty_context |- add_one \in (TInt ~> TInt) *)

(* type_of_do_it_three_times: forall T,
  empty_context |- do_it_three_times \in ((T ~> T) ~> (T ~> T)) *)

(** **** Exercise: 2 stars, standard (power_3_3_well_typed) *)
Lemma power_3_3_well_typed:
  empty_context |- app (app do_it_three_times do_it_three_times) add_one \in
    (TInt ~> TInt).
Proof.
  eapply T_app.
  2: apply type_of_add_one.
  eapply T_app.
  + apply type_of_do_it_three_times.
  + apply type_of_do_it_three_times.
Qed.
(** [] *)

(** Obviously, we can take at least one step to in the process of evaluating
    this expression above. In other words, the following statement is true: *)

Definition step_statement: Prop :=
  exists step_result: tm,
    step (app (app do_it_three_times do_it_three_times) add_one) step_result.

(** On one hand, we can prove this statement above by providing a [step_result]
    explicitly and prove the step relation. What is that step result? *)

(** **** Exercise: 1 star, standard (step_result) *)
Definition step_result: tm :=
  app (abs "x" (app do_it_three_times
    (app do_it_three_times (app do_it_three_times "x")))) add_one.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** On the other hand, we know that step result must exists since lambda
    expression evaluation is type safe. Which type safety property proves this
    existences lemma?

    1. Progress. 2. Preservation. *)

(** **** Exercise: 1 star, standard *)
Definition my_choice1: Z := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** Moreover, from type safety, we know that the [step_result] is also well
    typed. In other words, *)

Definition step_result_type_statement: Prop :=
  empty_context |- step_result \in (TInt ~> TInt).

(** Which type safety property proves this claim?

    1. Progress. 2. Preservation. *)

(** **** Exercise: 1 star, standard *)
Definition my_choice2: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task1.

(* ################################################################# *)
(** * Task 2: Let In Lambda Expressions *)

Module Task2.
Import LambdaIBR.
Local Open Scope Z.
Local Open Scope string.

(** We have seen how to encode "let" expression using normal lambda expressions.
    Please describe the evaluation result of the following lambda expressions.
*)

Module Task2_Example.

Definition expression: tm := \let "x" \be (app Onot true) \in "x".

Definition eval_result: tm := false.

(** Remember, when we write [false] here, it actually means

    - [con (bool_const (false))].

*)

End Task2_Example.

(** **** Exercise: 1 star, standard *)

Module Task2_1.

Definition expression: tm :=
  \let "x" \be 1 \in
  \let "y" \be ("x" + 1)%tm \in
  \let "x" \be ("y" + 1)%tm \in
  "x".

Definition eval_result: tm := 3.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task2_1.

(** **** Exercise: 1 star, standard *)

Module Task2_2.

Definition expression: tm :=
  \let "x" \be app (abs "x" "x") 1 \in
  "x".

Definition eval_result: tm := 1.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task2_2.

(** **** Exercise: 1 star, standard *)

Module Task2_3.

Definition expression: tm :=
  \let "F" \be
     (abs "f" (abs "x"
        (\let "x" \be app "f" "x" \in
         \let "x" \be app "f" "x" \in
         \let "x" \be app "f" "x" \in
         "x"))) \in
  app (app (app "F" "F") (abs "x" ("x" + 1)%tm)) 0.

Definition eval_result: tm := 27.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task2_3.

(** **** Exercise: 1 star, standard *)

Module Task2_4.

Definition expression: tm :=
  \let "swap_arg" \be
     (abs "f" (abs "x" (abs "y" (app (app "f" "y") "x")))) \in
  app "swap_arg" (abs "x" (abs "y" ("x" - "y")%tm)).

Definition eval_result: tm :=
  abs "x" (abs "y" (app (app
    (abs "x" (abs "y" ("x" - "y")%tm)) "y") "x")).
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task2_4.

End Task2.

(* ################################################################# *)
(** * Lambda Expressions With References *)

Module Task3.

Import LambdaIBR.
Local Open Scope Z.
Local Open Scope string.

(** Please describe the evaluation results. *)

(** **** Exercise: 2 stars, standard *)

Module Task3_1.

Definition expression: tm :=
  \let "get_and_add" \be
    (abs "p"
      (\let "x" \be (app Oread "p") \in
       \let "y" \be ("x" + 1)%tm \in
       \let "_" \be (app (app Owrite "p") "y") \in
       "x")) \in
  \let "p" \be app Oalloc 0 \in
  \let "x" \be app "get_and_add" "p" \in
  \let "x" \be app "get_and_add" "p" \in
  \let "x" \be app "get_and_add" "p" \in
  "x".

Definition eval_result: tm := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task3_1.

(** **** Exercise: 2 stars, standard *)

Module Task3_2.

Definition expression: tm :=
  \let "func_add_one" \be
     (abs "f" (abs "x" ((app "f" "x") + 1)%tm)) \in
  \let "f" \be (abs "x" "x") \in
  \let "p" \be (app Oalloc "f") \in
  \let "f" \be (app "func_add_one" (app Oread "p")) \in
  \let "p" \be (app Oalloc "f") \in
  \let "f" \be (app "func_add_one" (app Oread "p")) \in
  app "f" 0.

Definition eval_result: tm := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task3_2.

End Task3.

(* 2021-05-31 21:29 *)


(* Copyright (c) 2008-2009, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* Dependent list types presented in Chapter 9 *)

Require Import Arith List.
Load CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | INil : ilist O
  | ICons : forall n, A -> ilist n -> ilist (S n).

  Definition hd n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S _ => A
                                end with
      | INil => tt
      | ICons _ x _ => x
    end.
  Definition tl n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S n => ilist n
                                end with
      | INil => tt
      | ICons _ _ ls' => ls'
    end.

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | INil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | ICons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.

  Section everywhere.
    Variable x : A.

    Fixpoint everywhere (n : nat) : ilist n :=
      match n with
        | O => INil
        | S n' => ICons x (everywhere n')
      end.
  End everywhere.

  Section singleton.
    Variables x default : A.

    Fixpoint singleton (n m : nat) : ilist n :=
      match n with
        | O => INil
        | S n' =>
          match m with
            | O => ICons x (everywhere default n')
            | S m' => ICons default (singleton n' m')
          end
      end.
  End singleton.

  Section map2.
    Variable f : A -> A -> A.

    Fixpoint map2 n (il1 : ilist n) : ilist n -> ilist n :=
      match il1 in ilist n return ilist n -> ilist n with
        | INil => fun _ => INil
        | ICons _ x il1' => fun il2 => ICons (f x (hd il2)) (map2 il1' (tl il2))
      end.
  End map2.

  Section fold.
    Variable B : Type.
    Variable f : A -> B -> B.
    Variable i : B.

    Fixpoint foldr n (il : ilist n) : B :=
      match il with
        | INil => i
        | ICons _ x il' => f x (foldr il')
      end.
  End fold.
End ilist.

Arguments INil [A].
Arguments First [n].

Section imap.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (il : ilist A n) : ilist B n :=
    match il with
      | INil => INil
      | ICons _ x il' => ICons (f x) (imap il')
    end.
End imap.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Definition hhd ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | x :: _ => B x
                                end with
      | HNil => tt
      | HCons _ _ v _ => v
    end.

  Definition htl ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | _ :: ls' => hlist ls'
                                end with
      | HNil => tt
      | HCons _ _ _ hl' => hl'
    end.

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm) -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.

  Fixpoint happ (ls1 : list A) (hl1 : hlist ls1) : forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) :=
    match hl1 in hlist ls1 return forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) with
      | HNil => fun _ hl2 => hl2
      | HCons _ _ x hl1' => fun _ hl2 => HCons x (happ hl1' hl2)
    end.

  Variable f : forall x, B x.

  Fixpoint hmake (ls : list A) : hlist ls :=
    match ls with
      | nil => HNil
      | x :: ls' => HCons (f x) (hmake ls')
    end.

  Theorem hget_hmake : forall ls (m : member ls),
    hget (hmake ls) m = f elm.
    induction ls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hlist.

Arguments HNil [A B].
Arguments HCons [A B x ls].
Arguments hmake [A B].

Arguments HFirst [A elm ls].
Arguments HNext [A elm x ls].

Infix ":::" := HCons (right associativity, at level 60).
Infix "+++" := happ (right associativity, at level 60).

Section hmap.
  Variable A : Type.
  Variables B1 B2 : A -> Type.

  Variable f : forall x, B1 x -> B2 x.

  Fixpoint hmap (ls : list A) (hl : hlist B1 ls) : hlist B2 ls :=
    match hl with
      | HNil => HNil
      | HCons _ _ x hl' => f x ::: hmap hl'
    end.

  Theorem hmap_happ : forall ls2 (h2 : hlist B1 ls2) ls1 (h1 : hlist B1 ls1),
    hmap h1 +++ hmap h2 = hmap (h1 +++ h2).
    induction h1; crush.
  Qed.

  Theorem hget_hmap : forall elm ls (hls : hlist B1 ls) (m : member elm ls),
    hget (hmap hls) m = f (hget hls m).
    induction hls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hmap.

Arguments hmap [A B1 B2] f [ls].


(************************************************************************)
(* Copyright 2008 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 3                          *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses/lgpl-3.0.html>         *)
(************************************************************************)

(** Module type for extensional functors, and some parametrised
modules for basic functor cosntructs. *)

Module Type Set_Functor.

Parameter F_ : Set -> Set.

Parameter lift_F_ :forall (X Y:Set) (f:X->Y), F_ X -> F_ Y.

Axiom lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.

Axiom lift_F_compose:forall (X Y Z:Set) (g:X->Y) (f:Y->Z) fx,
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.

Axiom lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.

End Set_Functor.

Module Set_Functor_Iter_theory (MF:Set_Functor).

Import MF.

Fixpoint F_iter (j:nat) : Set -> Set :=
   match j with
   |   O  => fun X => X
   | S j' => fun X => (F_iter j' (F_ X))
   end.

Fixpoint lift_F_iter (X Y:Set) (f:X->Y) j  {struct j} : F_iter j X -> F_iter j Y :=
   match j as n return (F_iter n X -> F_iter n Y) with
   |   O  => f
   | S j' =>  lift_F_iter (F_ X) (F_ Y) (lift_F_ _ _ f) j'
   end.

Lemma F_iter_S (X:Set) (j:nat): F_ (F_iter j X)= F_iter (S j) X.
Proof.
 revert X; induction j.
  reflexivity.
  intros X; simpl; rewrite IHj; reflexivity.
Qed.

Lemma lift_F_iter_extensionality: forall (X Y:Set) (f0 f1:X->Y) j s_ix, (forall x, f0 x = f1 x) -> lift_F_iter _ _ f0 j s_ix = lift_F_iter _ _ f1 j s_ix.
Proof.
 intros X Y f0 f1 j; revert X Y f0 f1; induction j; intros X Y f0 f1 s_ix hyp_ext.
  simpl; apply hyp_ext.
  simpl.
  rewrite (IHj (F_ X) (F_ Y) (lift_F_ X Y f0) (lift_F_ X Y f1) s_ix).
   trivial.
   intros sx.
   apply (lift_F_extensionality X Y f0 f1 sx hyp_ext).
Qed.

Lemma lift_F_iter_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) j s_ix:
 lift_F_iter Y Z f j (lift_F_iter X Y g j s_ix) = lift_F_iter X Z (fun x => f (g x)) j s_ix.
Proof.
 revert X Y Z g f s_ix.
 induction j; intros X Y Z g f s_ix.
  simpl; trivial.
  simpl.
  rewrite IHj.
  apply lift_F_iter_extensionality.
  apply (lift_F_compose X Y Z g f).
Qed.

Lemma lift_F_iter_id (X:Set) j (fx:F_iter j X): fx = lift_F_iter X X (fun x0 : X => x0) j fx.
Proof.
 revert X fx.
 induction j; intros X fx.
  simpl; trivial.
  simpl in *.
  transitivity (lift_F_iter (F_ X) (F_ X) (fun x0 : F_ X => x0) j fx).
   apply IHj.
   apply lift_F_iter_extensionality.
   apply lift_F_id.
Qed.

End Set_Functor_Iter_theory.

Close Scope nat_scope.

(* ################################################################################ *)
(** Constant functor: sending every arrow to the identity arrow *)
(* ################################################################################ *)

Module Type Set_module_argument.

Parameter U:Set.

End Set_module_argument.

Module constant_as_Set_Functor (Import U:Set_module_argument) <: Set_Functor.

Export U.

Definition F_ (X:Set) := U.

Definition lift_F_ (X Y:Set) (f:X->Y) (fx:F_ X) : F_ Y := fx.

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X u; unfold lift_F_; reflexivity.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 unfold lift_F_; reflexivity.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f u hyp; unfold lift_F_; reflexivity.
Qed.

End constant_as_Set_Functor.

(* ################################################################################ *)
(** Identity functor *)
(* ################################################################################ *)

Module identity_as_Set_Functor <: Set_Functor.

Definition F_ (X:Set) := X.

Definition lift_F_ (X Y:Set) (f:X->Y) (fx:F_ X) : F_ Y := f fx.

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X u; unfold lift_F_; reflexivity.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 unfold lift_F_; reflexivity.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f u hyp; unfold lift_F_; apply hyp.
Qed.

End identity_as_Set_Functor.

(* ################################################################################ *)
(** Coproduct *)
(* ################################################################################ *)

Module coproduct_as_Set_Functor (FA:Set_Functor) (FB:Set_Functor) <: Set_Functor.

Definition FA_:=FA.F_.
Definition FB_:=FB.F_.

Definition F_ (X:Set) := (FA_ X) + (FB_ X).

Definition lift_F_ (X Y:Set) (f:X->Y) (fx:F_ X) : F_ Y :=
       match fx with
       | inl fa => inl (FB_ Y) (FA.lift_F_ X Y f fa)
       | inr fb => inr (FA_ Y) (FB.lift_F_ X Y f fb)
       end.

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X [fa|fb]; unfold lift_F_;
 [ rewrite <- (FA.lift_F_id X) | rewrite <- (FB.lift_F_id X)]; reflexivity.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 destruct fx as [fa|fb]; unfold lift_F_;
 [ rewrite FA.lift_F_compose | rewrite FB.lift_F_compose] ; reflexivity.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f [fa|fb] hyp; unfold lift_F_; f_equal;
 [ apply FA.lift_F_extensionality | apply FB.lift_F_extensionality]; assumption.
Qed.

End coproduct_as_Set_Functor.

(* ################################################################################ *)
(** Product *)
(* ################################################################################ *)

Module product_as_Set_Functor (FA:Set_Functor) (FB:Set_Functor) <: Set_Functor.

Definition FA_:=FA.F_.
Definition FB_:=FB.F_.

Definition F_ (X:Set) := (FA_ X) * (FB_ X).

Definition lift_F_ (X Y:Set) (f:X->Y) (fx:F_ X) : F_ Y := let (fa, fb) := fx in (FA.lift_F_ X Y f fa, FB.lift_F_ X Y f fb).

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X [fa fb]; unfold lift_F_;
 rewrite <- (FA.lift_F_id X); rewrite <- (FB.lift_F_id X); reflexivity.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 destruct fx as [fa fb]; unfold lift_F_;
 rewrite FA.lift_F_compose; rewrite FB.lift_F_compose; reflexivity.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f [fa fb] hyp; unfold lift_F_; f_equal;
 [ apply FA.lift_F_extensionality | apply FB.lift_F_extensionality]; assumption.
Qed.

End product_as_Set_Functor.

(* ################################################################################ *)
(** Composition *)
(* ################################################################################ *)

Module composition_as_Set_Functor (FA:Set_Functor) (FB:Set_Functor) <: Set_Functor.

Definition FA_:=FA.F_.
Definition FB_:=FB.F_.

Definition F_ (X:Set) := FA_ (FB_ X).

Definition lift_F_ (X Y:Set) (f:X->Y) : F_ X -> F_ Y :=  FA.lift_F_ (FB_ X) (FB_ Y) (FB.lift_F_ X Y f).

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X fx; trivial.
 unfold lift_F_.
 transitivity (FA.lift_F_ (FB_ X) (FB_ X) (fun x0 : FB_ X => x0) fx); [apply FA.lift_F_id|].
 apply FA.lift_F_extensionality.
 apply FB.lift_F_id.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 unfold lift_F_.
 rewrite FA.lift_F_compose.
 apply FA.lift_F_extensionality.
 apply FB.lift_F_compose.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f fx hyp.
 unfold lift_F_.
 apply FA.lift_F_extensionality.
 intros x.
 apply FB.lift_F_extensionality.
 assumption.
Qed.

End composition_as_Set_Functor.

(* ################################################################################ *)
(** Iteration *)
(* ################################################################################ *)

Module Type nat_module_argument.

Parameter n:nat.

End nat_module_argument.

Module iteration_as_Set_Functor (FA:Set_Functor) (Import n:nat_module_argument) <: Set_Functor.

Export n.

Definition FA_:=FA.F_.

Module F_theory:=Set_Functor_Iter_theory FA.

Definition F_ (X:Set) := F_theory.F_iter n X.

Definition lift_F_ (X Y:Set) (f:X->Y) : F_ X -> F_ Y := F_theory.lift_F_iter X Y f n.

Lemma lift_F_id :forall X (fx: F_ X), fx = lift_F_ X X (fun x0 : X => x0) fx.
Proof.
 intros X fx; unfold lift_F_; apply F_theory.lift_F_iter_id.
Qed.

Lemma lift_F_compose (X Y Z:Set) (g:X->Y) (f:Y->Z) fx:
   (fun fx0 => lift_F_ Y Z f (lift_F_ X Y g fx0)) fx = lift_F_ X Z (fun x => f (g x)) fx.
Proof.
 unfold lift_F_; apply F_theory.lift_F_iter_compose.
Qed.

Lemma lift_F_extensionality: forall (X Y:Set) (f0 f1:X->Y) fx, (forall x, f0 x = f1 x) -> lift_F_  _ _ f0 fx = lift_F_ _ _ f1 fx.
Proof.
 intros X Y g f fx hyp;  unfold lift_F_; apply F_theory.lift_F_iter_extensionality; assumption.
Qed.

End iteration_as_Set_Functor.


Load "../std".
Import Nat.

Definition tyid := nat.

Inductive type : Set :=
| tyvar : tyid -> type
| arrow : type -> type -> type
| Π : type -> type.

Inductive exp : Set :=
| var : nat -> exp
| abs : type -> exp -> exp
| app : exp -> exp -> exp
| Λ : exp -> exp
| tapp : exp -> type -> exp.

Definition isval e :=
  match e with
  | abs _ _ => true
  | Λ _ => true
  | _ => false
  end.

Definition context := (list type).

Fixpoint shift_type d c ty :=
  match ty with
  | tyvar n => tyvar (if c <=? n then (n + d) else n)
  | arrow ty1 ty2 => arrow (shift_type d c ty1) (shift_type d c ty2)
  | Π ty1 => Π (shift_type d (S c) ty1)
  end.

Fixpoint subst_type (d: nat) (ty1 ty2: type) :=
  match ty1 with
  | tyvar n =>
    if d =? n then shift_type d 0 ty2
    else if d <? n then tyvar (pred n) else (tyvar n)
  | arrow t1 t2 => arrow (subst_type d t1 ty2) (subst_type d t2 ty2)
  | Π t1 => Π (subst_type (S d) t1 ty2)
  end.

Fixpoint shift_ty_exp (d c: nat) (e: exp) :=
  match e with
  | var _ => e
  | app e1 e2 => app (shift_ty_exp d c e1) (shift_ty_exp d c e2)
  | abs ty e1 => abs (shift_type d c ty) (shift_ty_exp d c e1)
  | tapp e1 ty => tapp (shift_ty_exp d c e1) (shift_type d c ty)
  | Λ e1 => Λ (shift_ty_exp d (S c) e1)
  end.

Definition shift_list n m Γ := (map (shift_type n m) Γ).

Fixpoint subst_ty_exp (d: nat) (ty: type) (e: exp) : exp :=
  match e with
  | var _ => e
  | abs ty1 e1 => abs (subst_type d ty1 ty) (subst_ty_exp d ty e1)
  | app e1 e2 => app (subst_ty_exp d ty e1) (subst_ty_exp d ty e2)
  | Λ e1 => Λ (subst_ty_exp (S d) ty e1)
  | tapp e1 ty2 => tapp (subst_ty_exp d ty e1) (subst_type d ty2 ty)
  end.

Notation " [[ X |-->  T2 ]] t1 " := (subst_ty_exp X T2 t1) (at level 50).

Fixpoint shift_exp (d c : nat) (t : exp) :=
match t with
| var x => var (if c <=? x then x + d else x)
| abs ty e1 => abs (shift_type d c ty) (shift_exp d (S c) e1)
| app e1 e2 => app (shift_exp d c e1) (shift_exp d c e2)
| Λ e1 => Λ (shift_exp d c e1)
| tapp e1 ty1 => tapp (shift_exp d c e1) ty1
end.

Fixpoint subst_exp (d : nat) (s t: exp) : exp :=
match t with
| var x => if d =? x then shift_exp d 0 (shift_ty_exp d 0 s)
           else if d <? x then var (pred x)
                else var x
| abs ty e1 => abs ty (subst_exp (S d) s e1)
| app e1 e2 => app (subst_exp d s e1) (subst_exp d s e2)
| Λ e1 => Λ (subst_exp (S d) s e1)
| tapp e1 ty => tapp (subst_exp d s e1) ty
end.

Notation " [[ X \ t2 ]] t1 " := (subst_exp X t2 t1) (at level 50).

Fixpoint eval_exp e : option exp :=
  match e with
  | app e1 e2 =>
    match isval e1, isval e2 with
    | true, true =>
      match e1 with
      | abs _ t => Some ( [[0 \ e2]]t)
      | _ => None
      end
    | false, _ =>
      match eval_exp e1 with
      | Some e1' => Some (app e1' e2)
      | None => None
      end
    | _, false =>
      match eval_exp e2 with
      | Some e2' => Some (app e1 e2')
      | None => None
      end
    end
  | tapp (Λ e1) ty => Some ( [[ 0 |--> ty ]] e1 )
  | tapp e1 ty =>
    match eval_exp e1 with
    | Some e1' => Some (tapp e1' ty)
    | None => None
    end
  | _ => None
  end.

Fixpoint nth_opt {T: Type} (l: list T) (n: nat) : option T :=
  match n, l with
  | 0, (h:: t) => Some h
  | _, nil => None
  | (S m), (h:: t) => nth_opt t m
  end.

Fixpoint eqb_type ty1 ty2 :=
  match ty1, ty2 with
  | tyvar n1, tyvar n2 => n1 =? n2
  | arrow t1 t2, arrow t1' t2' => (eqb_type t1 t1') && (eqb_type t2 t2')
  | Π t1, Π t2 => eqb_type t1 t2
  | _, _ => false
  end.

Fixpoint type_of (Γ: context) (e: exp) : option type :=
  match e with
  | var n =>
    match nth_opt Γ n with
    | Some ty => Some ty
    | _ => None
    end
  | abs ty e1 =>
    match type_of (ty :: Γ) e1 with
    | Some ty2 => Some (arrow ty ty2)
    | None => None
    end
  | app e1 e2 =>
    match type_of Γ e1, type_of Γ e2 with
    | Some (arrow ty1 ty), Some ty2 =>
      if eqb_type ty1 ty2 then (Some ty) else None
    | _, _ => None
    end
  | Λ e1 =>
    match type_of (shift_list 1 0 Γ) e1 with
    | Some ty => Some (Π ty)
    | None => None
    end
  | tapp e1 T2 =>
    match type_of Γ e1 with
    | Some (Π ty1) => Some ( subst_type 0 ty1 T2)
    | _ => None
    end
  end.

Section exapmle.

Let e1 := (Λ (abs (tyvar 0) (var 0) )).
Compute (type_of [] e1).
Compute (eval_exp (tapp e1 (tyvar 1))).

End exapmle.

Inductive value : exp -> Prop :=
| AbsV : forall ty e, value (abs ty e)
| TAbsV : forall e, value (Λ e).

Reserved Notation "e1 --> e2" (at level 50).
Inductive onestep : exp -> exp -> Prop :=
| E_App1 : forall e1 e2 e,
    e1 --> e -> (app e1 e2) --> (app e e2)
| E_App2: forall v1 e2 e,
    value v1 -> e2 --> e -> (app v1 e2) --> (app v1 e)
| E_AppAbs : forall ty e1 v,
    value v -> (app (abs ty e1) v) --> [[ 0 \ v ]]e1
| E_TApp : forall e1 e2 ty,
    e1 --> e2 -> (tapp e1 ty) --> (tapp e2 ty)
| E_TAppAbs : forall e ty,
    (tapp (Λ e) ty) --> [[ 0 |--> ty]]e
where "e1 --> e2" := (onestep e1 e2).

Reserved Notation "Γ |- e \in ty" (at level 40).
Inductive has_type : context -> exp -> type -> Prop :=
| T_Var : forall n Γ ty,
    nth_opt Γ n = Some ty ->
    Γ |- (var n) \in ty
| T_Abs : forall Γ ty e T,
    (T :: Γ) |- e \in ty ->
    Γ |- (abs T e) \in (arrow T ty)
| T_App : forall e1 e2 Γ ty1 ty2,
    Γ |- e1 \in arrow ty1 ty2 ->
    Γ |- e2 \in ty1 ->
    Γ |- (app e1 e2) \in ty2
| T_TAbs : forall e ty Γ,
    (shift_list 1 0 Γ) |- e \in ty ->
    Γ |- Λ e \in Π ty
| T_TApp : forall Γ e1 ty1 ty2,
    Γ |- e1 \in Π ty1 ->
    Γ |- tapp e1 ty2 \in subst_type 0 ty1 ty2
where "Γ |- e \in ty " := (has_type Γ e ty).

Lemma isval_val : forall e,
    value e <-> isval e = true.
Proof.
  destruct e; split; simpl; intros; try solve_by_invert; auto; constructor.
Qed.

Lemma val_not_eval : forall e,
    value e -> not (exists e', e --> e').
Proof.
  repeat intro.
  destruct H0. destruct H; try solve_by_invert.
Qed.

Lemma eval_step : forall e1 e2,
    e1 --> e2 <-> eval_exp e1 = Some e2.
Proof.
  split; intros.
  -
    induction H; eauto.
    +
      simpl. destruct isval eqn:IH.
      apply isval_val in IH.
      apply val_not_eval in IH. induction IH.
      exists e; auto.
      rewrite IHonestep. reflexivity.
    +
      simpl. apply isval_val in H. rewrite H.
      destruct (isval e2) eqn:IH.
      apply isval_val in IH. apply val_not_eval in IH; induction IH; eauto.
      rewrite IHonestep. reflexivity.
    +
      simpl. rewrite isval_val in H; rewrite H. reflexivity.
    +
      simpl.
      destruct e1; try solve_by_invert;
      rewrite IHonestep; reflexivity.
  -
    generalize dependent e2; induction e1; simpl; intros; try discriminate; eauto.
    +
      destruct isval eqn:IH1. destruct (isval e1_2) eqn:IH2.
      destruct e1_1; try discriminate. inversion H; subst. constructor. apply isval_val; auto.
      destruct (eval_exp e1_2) eqn:IH3; try discriminate.
      inversion H; subst. constructor. apply isval_val; auto.
      apply IHe1_2. reflexivity.
      destruct (eval_exp e1_1) eqn:IH2; try discriminate.
      inversion H; subst; clear H.
      constructor; eauto.
    +
      destruct e1; try discriminate;
      destruct eval_exp eqn:IH; inversion H; subst;
        constructor; eauto.
Qed.

Lemma eqb_type_refl : forall ty,
    eqb_type ty ty = true.
Proof.
  induction ty; simpl; auto.
  rewrite Nat.eqb_refl. reflexivity.
  rewrite IHty1, IHty2; reflexivity.
Qed.

Lemma eqb_type_eq : forall ty1 ty2,
    ty1 = ty2 <-> eqb_type ty1 ty2 = true.
Proof.
  split; intros; try solve [subst; apply eqb_type_refl].
  generalize dependent ty2; induction ty1; simpl; intros; auto;
  destruct ty2; try discriminate.
  -
    destruct eqb eqn:IH; try discriminate. apply eqb_eq in IH. subst; reflexivity.
  -
    apply andb_prop in H. destruct H.
    apply IHty1_1 in H; apply IHty1_2 in H0; subst; reflexivity.
  -
    apply IHty1 in H; subst; reflexivity.
Qed.

Lemma type_of_has : forall e Γ ty,
    Γ |- e \in ty <-> type_of Γ e = Some ty.
Proof.
  split; intros.
  -
    induction H; simpl; eauto.
    +
      rewrite H; reflexivity.
    +
      rewrite IHhas_type; reflexivity.
    +
      rewrite IHhas_type1, IHhas_type2.
      rewrite eqb_type_refl. reflexivity.
    +
      rewrite IHhas_type. reflexivity.
    +
      rewrite IHhas_type. reflexivity.
  -
    revert H. revert Γ. revert ty.
    induction e; simpl; intros.
    +
      constructor. destruct nth_opt eqn:IH; try discriminate; auto.
    +
      destruct type_of eqn:IH; try discriminate.
      inversion H; subst. constructor; eauto.
    +
      destruct type_of eqn:IH1; try discriminate.
      destruct t0; try discriminate. apply IHe1 in IH1.
      destruct type_of eqn:IH2; try discriminate.
      apply IHe2 in IH2. destruct eqb_type eqn:IH3; try discriminate.
      apply eqb_type_eq in IH3; inversion H; subst.
      econstructor; eauto.
    +
      destruct type_of eqn:IH; try discriminate.
      inversion H; subst. constructor; auto.
    +
      destruct type_of eqn:IH1; try discriminate.
      destruct t1; try discriminate.
      inversion H; subst.
      econstructor; eauto.
Qed.

Theorem T22_5_2 : forall e ty,
    [] |- e \in ty ->
    value e \/ (exists e', e --> e').
Proof.
  induction e; intros; inversion H; subst; try solve [left; constructor]; right.
  -
    destruct n; try discriminate.
  -
    generalize H3; intros.
    apply IHe1 in H3. apply IHe2 in H5.
    destruct H3.
    destruct H5.
    inversion H1; subst; try solve_by_invert.
    exists ([[0 \ e2]]e); constructor; auto.
    destruct H2. exists (app e1 x); constructor; auto.
    destruct H1. exists (app x e2); constructor; auto.
  -
    generalize H4; intros.
    apply IHe in H0.
    destruct H0.
    inversion H0; subst; try solve_by_invert.
    exists ([[0 |--> t0]]e0); constructor.
    destruct H0. exists (tapp x t0); constructor; auto.
Qed.

Lemma shift_ty0 : forall ty n,
    shift_type 0 n ty = ty.
Proof.
  induction ty; simpl; intros; eauto.
  -
    destruct leb; auto.
  -
    rewrite IHty1, IHty2; reflexivity.
  -
    rewrite IHty; reflexivity.
Qed.

Lemma shift_exp0 : forall e n,
    shift_exp 0 n e = e.
Proof.
  induction e; simpl; intros; auto.
  -
    destruct leb; auto.
  -
    rewrite IHe, shift_ty0; reflexivity.
  -
    rewrite IHe1, IHe2; reflexivity.
  -
    rewrite IHe; reflexivity.
  -
    rewrite IHe; reflexivity.
Qed.

Lemma appnth : forall (ctx ctx': context) n,
    nth_opt (ctx ++ ctx') (n + (length ctx)) = nth_opt ctx' n.
Proof.
  induction ctx; simpl; intros; auto.
  rewrite <- plus_Snm_nSm. simpl. apply IHctx.
Qed.

Lemma length1_Some : forall n (ctx ctx1 ctx2: context) T,
    n < length ctx ->
    nth_opt (ctx ++ ctx1) n = Some T ->
    nth_opt (ctx ++ ctx2) n = Some T.
Proof.
  induction n; simpl; intros. destruct ctx. inversion H. simpl. simpl in H0. apply H0.
  destruct ctx. inversion H. simpl. destruct ( (t0 :: ctx) ++ ctx1) eqn:IHH. inversion H0. inversion IHH; subst.
  eapply IHn in H0. apply H0. simpl in H. apply lt_S_n in H. apply H.
Qed.

Lemma nth_opt_Some_lt : forall {A: Type} n (Γ: list A) x,
    nth_opt Γ n = Some x -> n < length Γ.
Proof.
  induction n; simpl; intros.
  -
    destruct Γ; simpl in H.
    inversion H.
    inversion H; subst. simpl.
    apply lt_0_succ.
  -
    destruct Γ. inversion H.
    simpl in H.
    apply IHn in H.
    simpl. apply lt_n_S.
    apply H.
Qed.

Lemma nth_opt_non_shift : forall Γ n m x,
    nth_opt Γ x = None ->
    nth_opt (map (shift_type n m) Γ) x = None.
Proof.
  induction Γ; simpl; intros.
  destruct x; auto.
  destruct x; try discriminate H.
  apply IHΓ. apply H.
Qed.

Lemma shift_map_gamma : forall Γ n m x Δ,
  nth_opt Γ x = nth_opt Δ x ->
  nth_opt (map (shift_type n m) Γ) x = nth_opt (map (shift_type n m) Δ) x.
Proof.
  induction Γ; intros.
  simpl in H. simpl.
  destruct Δ.
  destruct x; auto.
  destruct x; simpl in H; auto.
  inversion H. simpl.
  symmetry; apply nth_opt_non_shift. rewrite H. reflexivity.
  destruct x; simpl in H; simpl.
  destruct Δ; simpl in H; inversion H; subst.
  simpl. reflexivity.
  destruct Δ. simpl in H. simpl.
  simpl.
  apply nth_opt_non_shift. apply H.
  simpl. simpl in H.
  apply IHΓ. apply H.
Qed.

Lemma weakend : forall Γ e ty Δ,
    (forall x, x < length Γ -> nth_opt Γ x = nth_opt Δ x) ->
    Γ |- e \in ty -> Δ |- e \in ty.
Proof.
  intros. generalize dependent Δ. induction H0; simpl; intros.
  -
    constructor.
    rewrite <- H0. apply H.
    apply nth_opt_Some_lt in H. apply H.
  -
    constructor. apply IHhas_type; intros.
    clear IHhas_type; clear H0.
    destruct x; simpl. reflexivity.
    apply H. apply lt_S_n. apply H1.
  -
    econstructor; eauto.
  -
    constructor. apply IHhas_type; intros.
    apply shift_map_gamma.
    apply H. unfold shift_list in H1; rewrite map_length in H1. apply H1.
  -
    econstructor; eauto.
Qed.

Lemma shift_type_range : forall ty c c1 d d1,
    c <= c1 <= c + d ->
    shift_type d1 c1 (shift_type d c ty) = shift_type (d1 + d) c ty.
Proof.
  induction ty; intros; eauto.
  -
    simpl. destruct H.
    destruct (c <=? t0) eqn:IH1. apply leb_le in IH1.
    assert (c1 <=? t0 + d = true).
    apply leb_le.
    apply le_trans with (c + d); auto.
    apply plus_le_compat_r. apply IH1.
    rewrite H1. rewrite (add_comm d1). rewrite add_assoc. reflexivity.
    apply leb_gt in IH1.
    assert (c1 <=? t0 = false).
    apply leb_gt.
    apply lt_le_trans with c; auto.
    rewrite H1. reflexivity.
  -
    simpl. rewrite IHty1, IHty2; auto.
  -
    simpl. rewrite IHty; auto.
    destruct H.
    split; apply le_n_S; auto.
Qed.

Lemma shift_ty_exp_range : forall e c c1 d d1,
    c <= c1 <= c + d ->
    shift_ty_exp d1 c1 (shift_ty_exp d c e) = shift_ty_exp (d1 + d) c e.
Proof.
  induction e; simpl; intros; eauto.
  -
    rewrite IHe; auto.
    rewrite shift_type_range; auto.
  -
    rewrite IHe1, IHe2; auto.
  -
    rewrite IHe; auto.
    destruct H; split; apply le_n_S; auto.
  -
    rewrite IHe; auto.
    rewrite shift_type_range; auto.
Qed.

Lemma shift_type_le : forall ty c c1 d d1,
    c1 <= c ->
    shift_type d1 c1 (shift_type d c ty) = shift_type d (d1 + c) (shift_type d1 c1 ty).
Proof.
  induction ty; simpl; intros; eauto.
  -
    destruct (leb c t0) eqn:IH1.
    apply leb_le in IH1.
    assert (leb c1 t0 = true).
    apply leb_le. apply le_trans with c; auto.
    rewrite H0. apply leb_le in H0.
    destruct (leb c1 (t0 + d)) eqn:IH2.
    apply leb_le in IH2.
    assert (leb (d1 + c) (t0 + d1) = true).
    apply leb_le. rewrite add_comm. apply plus_le_compat_r; auto.
    rewrite H1. rewrite <- add_assoc. rewrite (add_comm d d1). rewrite add_assoc. reflexivity.

    apply leb_gt in IH2.
    apply le_lt_trans with (n:= t0) in IH2; try apply le_add_r.
    apply le_not_lt in H0. induction H0; auto.

    apply leb_gt in IH1.
    destruct leb eqn:IH2.

    apply leb_le in IH2.
    assert (d1 + c <=? t0 + d1 = false).
    apply leb_gt. rewrite add_comm. apply plus_lt_compat_l. apply IH1.
    rewrite H0. reflexivity.

    apply leb_gt in IH2. apply lt_lt_add_l with (p:= d1) in IH1.
    apply leb_gt in IH1. rewrite IH1. reflexivity.
  -
    rewrite IHty1, IHty2; auto.
  -
    rewrite IHty; auto.
    rewrite add_succ_r. reflexivity.
    apply le_n_S; apply H.
Qed.

Lemma shift_ty_exp_le : forall e c c1 d d1,
    c1 <= c ->
    shift_ty_exp d1 c1 (shift_ty_exp d c e) = shift_ty_exp d (d1 + c) (shift_ty_exp d1 c1 e).
Proof.
  induction e; simpl; intros; auto.
  -
    rewrite IHe; auto.
    rewrite shift_type_le; auto.
  -
    rewrite IHe1, IHe2; auto.
  -
    rewrite IHe; auto.
    rewrite add_succ_r. reflexivity.
    apply le_n_S; apply H.
  -
    rewrite IHe; auto.
    rewrite shift_type_le; auto.
Qed.

Lemma shift_list_swap : forall Γ n m,
    shift_list 1 0 (shift_list n m Γ)  = shift_list n (S m) (shift_list 1 0 Γ).
Proof.
  induction Γ; auto; intros.
  simpl. rewrite IHΓ.
  rewrite shift_type_le.
  rewrite add_1_l. reflexivity.
  apply Peano.le_0_n.
Qed.

Fixpoint subst_typen (d: nat) (ty1 ty2: type) :=
  match ty1 with
  | tyvar n =>
    if d =? n then ty2
    else if d <? n then tyvar (pred n) else (tyvar n)
  | arrow t1 t2 => arrow (subst_typen d t1 ty2) (subst_typen d t2 ty2)
  | Π t1 => Π (subst_typen (S d) t1 (shift_type 1 0 ty2))
  end.

Lemma subst_substn : forall ty1 ty2 n,
    subst_type n ty1 ty2 = subst_typen n ty1 (shift_type n 0 ty2).
Proof.
  induction ty1; simpl; intros.
  -
    reflexivity.
  -
    rewrite IHty1_1, IHty1_2; auto.
  -
    rewrite IHty1; auto.
    rewrite shift_type_range; auto.
    rewrite add_0_l; split; auto.
    apply le_0_n.
Qed.

Lemma shift_sub_cn : forall ty n c d ty1,
    c <= n ->
    shift_type d c (subst_type n ty ty1) =
       subst_type (n + d) (shift_type d c ty) ty1.
Proof.
  induction ty; simpl; intros; auto.
  -
    destruct eqb eqn:IH.
    +
      apply eqb_eq in IH; subst.
      apply leb_le in H. rewrite H.
      rewrite eqb_refl. rewrite shift_type_range; repeat split; auto.
      rewrite add_comm. reflexivity.
      apply le_0_n. rewrite add_0_l.
      apply leb_le; auto.
    +
      assert (n + d =? t0 + d = false ).
      {
        apply eqb_neq; intro.
        rewrite add_comm in H0.
        rewrite (add_comm t0) in H0.
        apply plus_reg_l in H0. subst.
        rewrite eqb_refl in IH. inversion IH.
      }
      destruct ltb eqn:IH1.
      ++
        apply ltb_lt in IH1.
        assert (c <=? t0 = true).
        { apply leb_le, lt_le_incl.
        apply le_lt_trans with n; auto. }
        rewrite H1.
        rewrite H0.
        destruct t0. inversion IH1.
        apply le_lt_trans with (p:= S t0) in H; auto.
        compute in H. apply le_S_n in H.
        apply plus_lt_compat_r with (p:=d) in IH1.
        apply ltb_lt in IH1. rewrite IH1. simpl.
        apply leb_le in H. rewrite H. reflexivity.
      ++
        destruct leb eqn:IH2.
        +++
          rewrite H0.
          apply ltb_ge in IH1. apply plus_le_compat_r with (p:=d) in IH1.
          apply ltb_ge in IH1. rewrite IH1.
          simpl. rewrite IH2. reflexivity.
        +++
          simpl. rewrite IH2.
          apply ltb_ge in IH1. apply leb_gt in IH2.
          assert (n + d <? t0 = false).
          {
            apply ltb_ge. apply le_plus_trans; auto.
          }
          rewrite H1.
          assert (n + d =? t0 = false).
          {
            apply eqb_neq; intro.
            symmetry in H2; subst.
            destruct d.
            rewrite add_0_r in IH2.
            apply leb_gt in IH2. apply leb_nle in IH2.
            apply IH2; auto.
            apply le_add_le_sub_l in IH1.
            rewrite sub_diag in IH1.
            inversion IH1.
          }
          rewrite H2. reflexivity.
  -
    rewrite IHty1, IHty2; auto.
  -
    rewrite IHty; auto.
    apply le_n_S; auto.
Qed.

Lemma shift_sub_nc : forall ty n c d ty1,
    n <= c ->
    shift_type d c (subst_type n ty ty1) =
       subst_type n (shift_type d (S c) ty) (shift_type d (c - n) ty1).
Proof.
  induction ty; simpl; intros; auto.
  -
    destruct eqb eqn:IH.
    +
      apply eqb_eq in IH; subst.
      destruct t0; simpl.
      repeat rewrite shift_ty0. rewrite sub_0_r. reflexivity.
      assert (leb c t0 = false). apply leb_gt.
      apply lt_le_trans with (S t0); auto.
      rewrite H0. rewrite eqb_refl.
      rewrite (shift_type_le ty1 (c - S t0) 0 ); auto.
      assert (S t0 + (c - S t0) = c).
      { rewrite le_plus_minus_r. reflexivity. apply H. }
      rewrite H1. reflexivity.
      apply le_0_n.
    +
      destruct ltb eqn:IH0.
      ++
        apply ltb_lt in IH0.
        destruct t0. inversion IH0. simpl.
        destruct leb eqn:IH1; simpl.
        +++
          apply leb_le in IH1.
          apply lt_lt_add_r with (p:= d) in IH0.
          rewrite add_succ_l in IH0.
          apply ltb_lt in IH0. rewrite IH0.
          destruct (eqb n (S (t0 + d))) eqn:IH2.
          apply eqb_eq in IH2; subst.
          rewrite ltb_irrefl in IH0. discriminate IH0.
          reflexivity.
        +++
          apply leb_gt in IH1.
          destruct eqb eqn:IH2.
          apply eqb_eq in IH2; subst.
          induction (lt_irrefl (S t0)); auto.
          apply ltb_lt in IH0; rewrite IH0.
          reflexivity.
      ++
        apply ltb_ge in IH0.
        destruct t0; simpl. rewrite IH.
        destruct leb eqn:IH1; auto.
        apply leb_le in IH1. inversion IH1; subst.
        inversion H; subst. simpl in IH; discriminate IH.

        destruct leb eqn:IH1.
        +++
          apply leb_le in IH1.
          apply le_trans with (p:= S t0) in H; auto.
          apply le_lt_or_eq in IH0.
          destruct IH0; subst.
          apply le_not_lt in H. induction H; auto.
          rewrite eqb_refl in IH. discriminate IH.
        +++
          apply leb_gt in IH1.
          apply lt_lt_succ_r in IH1.
          apply lt_S_n in IH1.
          apply leb_gt in IH1.
          rewrite IH1. rewrite IH.
          apply ltb_ge in IH0.
          rewrite IH0. reflexivity.
  -
    rewrite IHty1, IHty2; auto.
  -
    rewrite IHty; auto.
    apply le_n_S; auto.
Qed.

Lemma shift_type_pre : forall e Γ ty n m,
    Γ |- e \in ty ->
    (shift_list n m Γ) |- (shift_ty_exp n m e) \in (shift_type n m ty).
Proof.
  intros. revert n; revert m.
  induction H; simpl; intros; try econstructor; eauto.
  -
    generalize dependent Γ.
    induction n; simpl; intros.
    destruct Γ; try discriminate; auto.
    simpl. simpl in H. inversion H; subst. reflexivity.
    destruct Γ; try discriminate.
    simpl. simpl in H. apply IHn. apply H.
  -
    rewrite shift_list_swap.
    apply IHhas_type.
  -
    rewrite shift_sub_nc.
    rewrite sub_0_r.
    econstructor. simpl in IHhas_type. apply IHhas_type.
    apply le_0_n.
Qed.

Lemma sub_shift_type : forall ty1 n (c: nat) d c ty2,
    c <= n -> S n <= d + c ->
    subst_type n (shift_type d c ty1) ty2
               = shift_type (pred d) c ty1.
Proof.
  induction ty1; simpl; intros.
  -
    destruct leb eqn:IH1.
    +
      apply leb_le in IH1.
      destruct d.

      rewrite add_0_l in H0.
      apply le_lt_n_Sm in H. apply lt_le_trans with (p:= c0) in H; auto.
      apply lt_irrefl in H. inversion H.

      rewrite add_succ_r. simpl.
      assert (n =? S (t0 + d) = false).
      {
        apply eqb_neq; intro. subst.
        apply plus_le_compat_l with (p:= S d) in IH1.
        apply le_trans with (p:= S d + t0) in H0; auto.
        rewrite add_comm in H0.
        apply nle_succ_diag_l in H0. apply H0.
      }
      rewrite H1.
      assert (n <? S (t0 + d) = true).
      {
        apply ltb_lt. rewrite add_succ_l in H0. apply le_S_n in H0.
        apply plus_le_compat_r with (p:= d) in IH1.
        apply le_lt_n_Sm.
        apply le_trans with (d + c0); auto.
        rewrite add_comm; apply IH1.
      }
      rewrite H2. reflexivity.
    +
      assert (n =? t0 = false).
      {
        apply eqb_neq; intro; subst.
        apply leb_nle in IH1. apply IH1.
        apply H.
      }
      rewrite H1.
      apply leb_gt in IH1.
      apply lt_le_trans with (p:= n) in IH1; auto.
      apply lt_le_incl in IH1.
      apply ltb_ge in IH1. rewrite IH1.
      reflexivity.
  -
    rewrite IHty1_1, IHty1_2; auto.
  -
    rewrite IHty1; auto.
    apply le_n_S. apply H.
    rewrite add_succ_r. apply le_n_S. apply H0.
Qed.

Lemma sub_type_pre : forall e Γ ty n T,
    Γ |- e \in ty ->
    (map (fun t' => subst_type n t' T) Γ) |- (subst_ty_exp n T e) \in subst_type n ty T.
Proof.
  intros. revert n; revert T.
  induction H; simpl; intros.
  -
    constructor.
    revert H; revert Γ.
    induction n; intros.
    destruct Γ; simpl in H. inversion H.
    inversion H; subst. simpl. reflexivity.
    destruct Γ; simpl in H. inversion H.
    apply IHn. apply H.
  -
    constructor.
    simpl in IHhas_type.
    apply IHhas_type.
  -
    econstructor; eauto.
  -
    constructor.
    assert (shift_list 1 0 (map (fun t' => subst_type n t' T) Γ) = map (fun t' => subst_type (S n) t' T) (shift_list 1 0 Γ)).
    {
      clear. revert n. revert T.
      induction Γ; simpl; intros; auto.
      rewrite IHΓ.
      rewrite shift_sub_cn. rewrite add_1_r. reflexivity.
      apply le_0_n.
    }
    rewrite H0. apply IHhas_type.
  -
    admit.
Abort.

Lemma shifting : forall e g g1 g2 T,
  (g1 ++ g) |- e \in T ->
  (g1 ++ g2 ++ g) |- (shift_exp (length g2) (length g1) e) \in T.
Proof.
  induction e; simpl; intros; inversion H; subst; try solve [econstructor; eauto].
  -
    apply T_Var. destruct leb eqn:IH. apply leb_le in IH.
    generalize dependent g. generalize dependent T. generalize dependent n.
    induction g1; simpl; intros; eauto. rewrite appnth. apply H2.
    destruct n. inversion IH. simpl.
    apply le_S_n in IH. eapply IHg1 in IH; eauto.
    constructor. apply H2.
    apply leb_gt in IH. eapply length1_Some in IH. apply IH. apply H2.
  -
    admit.
  -
    econstructor; eauto.
    unfold shift_list in H2; rewrite map_app in H2.
    unfold shift_list.
    repeat rewrite map_app.
    rewrite <- map_length with (l:= g1) (f:= shift_type 1 0).
    rewrite <- map_length with (l:= g2) (f:= shift_type 1 0).
    apply IHe. apply H2.
Abort.

Lemma subst_exp_pre : forall e s Ts T ctx ctx',
    (ctx' ++ Ts :: ctx) |- e \in T ->
    ctx |- s \in Ts ->
    (ctx' ++ ctx) |- subst_exp (length ctx') s e \in T.
Proof.
  induction e; simpl; intros.
  -
    inversion H; subst.
    destruct eqb eqn:IH1.
    apply eqb_eq in IH1; subst.
    admit.
    destruct ltb eqn:IH2.
    destruct n; try discriminate; simpl.
    constructor.
    apply ltb_lt in IH2.
    admit.
    constructor.
    admit.
  -
    inversion H; subst.
    constructor; eauto.
    assert (S (length ctx') = (length (t0:: ctx'))). reflexivity.
    rewrite H1.
    apply IHe with (Ts:= Ts) (ctx':= t0::ctx'); auto.
  -
    inversion H; subst.
    econstructor; eauto.
  -
    inversion H; subst.
    constructor.
    unfold shift_list in H3.
    repeat rewrite map_app in H3.
    unfold shift_list. repeat rewrite map_app.
    simpl in H3.
    admit.
  -
    inversion H; subst.
    econstructor; eauto.
Admitted.

Theorem T23_5_1 : forall e Γ ty e',
    Γ |- e \in ty -> e --> e' ->
    Γ |- e' \in ty.
Proof.
  intros. generalize dependent e'.
  induction H; intros; try solve_by_invert.
  - (*case: e = app*)
    inversion H1; subst; try econstructor; eauto.
    inversion H; subst.
    rewrite <- (app_nil_l Γ).
    apply subst_exp_pre with ty1; auto.
  -
    inversion H0; subst; try econstructor; eauto.
    inversion H; subst.
    clear IHhas_type.
    admit.
Abort.


From mathcomp Require Import all_ssreflect.
Require Import Utf8.
Require Import expr label.

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

Module Type EqType.

  Parameter T : eqType.

End EqType.

(*FIXME: impossible to separate proofs from programs using Coq modules*)
Module Type UnionFind.

  Parameter S : eqType.

  Parameter unionfind : Type.

  Parameter empty : unionfind.

  Parameter find : unionfind -> S -> S.

  Parameter union : unionfind -> S -> S -> unionfind.

  Axiom find_empty : forall l , find empty l = l.

  (*Please note this is more specific than a usual UnionFind*)
  Axiom find_union : forall uf lx ly l, find (union uf lx ly) l =
    if (find uf lx == find uf l) then find uf ly else find uf l.

  Axiom find_find : forall uf l, find uf (find uf l) = find uf l.

End UnionFind.

Module NaiveUnionFind(E : EqType) <: UnionFind.

  Definition S : eqType := E.T.

  Definition unionfind_r := seq (S * S).

  Definition is_labeled (T : Type) (l : S) (pl : S * T) := (l == pl.1).

  Definition is_pair (T : eqType) (pl1 pl2 : S * T) := (pl1.1 == pl2.1) && (pl1.2 == pl2.2).

  Definition makeset (uf : unionfind_r) (l : S) :=
    if has (is_labeled l) uf
    then uf
    else (l,l) :: uf.

  Definition empty_r : unionfind_r := [::].

  Definition find_r (uf : unionfind_r) (l : S) :=
    (nth (l,l) uf (seq.find (is_labeled l) uf)).2.

  Definition union_r (uf : unionfind_r) (lx ly : S) :=
    let ufx := makeset uf lx in
    let ufxy := makeset ufx ly in
    let fx := find_r ufxy lx in
    let fy := find_r ufxy ly in
    map (fun pl => (pl.1,if fx == pl.2 then fy else pl.2)) ufxy.

  Definition well_formed (uf : unionfind_r) :=
    uniq (map (fun pl => pl.1) uf) /\
    forall l : S , has (is_labeled l) uf -> has (is_pair (find_r uf l, find_r uf l)) uf.

  Lemma has_makeset uf lh lm :
    has (is_labeled lh) (makeset uf lm) = (lh == lm) || (has (is_labeled lh) uf).
  Proof.
    rewrite /makeset.
    case Hlmuf: (has (is_labeled lm) uf) => //.
    case Hlhuf: (has (is_labeled lh) uf); first by rewrite orbT.
    case Hlhlm: (lh == lm) => //.
    by rewrite (eqP Hlhlm) Hlmuf in Hlhuf.
  Qed.

  Lemma seqhasNfind (T : Type) (a : pred T) s : ~~ has a s -> seq.find a s = size s.
  Proof. by rewrite has_find; case: ltngtP (find_size a s). Qed.

  Lemma hasNfind uf l : ~~ has (is_labeled l) uf -> find_r uf l = l.
  Proof.
    rewrite /find_r /is_labeled.
    move => HNhas.
    rewrite (seqhasNfind HNhas).
    by rewrite nth_default.
  Qed.

  Lemma find_makeset uf lf lm : find_r (makeset uf lm) lf = find_r uf lf.
  Proof.
    rewrite /makeset /find_r.
    case Hlmuf: (has (is_labeled lm) uf) => //=.
    apply negbT in Hlmuf.
    apply hasNfind in Hlmuf.
    move: Hlmuf.
    rewrite /is_labeled /=.
    case Hlmlf: (lf == lm) => //=.
    by rewrite (eqP Hlmlf).
  Qed.

  Lemma find_map uf f l rl : find_r uf l = rl -> find_r (map (fun x => (x.1,f x.2)) uf) l = if has (is_labeled l) uf then f(rl) else l.
  Proof.
    rewrite /find_r.
    case Hhas: (has (is_labeled l) uf).
    + move: Hhas.
      rewrite /is_labeled.
      induction uf as [|hut tuf IHuf] => //=.
      by case Hhutl: (l == hut.1) => //= _ ->.
    move => _.
    have ->: (nth (l, l) [seq (x.1, f x.2) | x <- uf] (seq.find (is_labeled l) [seq (x.1, f x.2) | x <- uf]) = (l,l)) => //=.
    apply nth_default.
    rewrite size_map seq.find_map.
    rewrite /preim //=.
    rewrite seqhasNfind /negb //=.
    by rewrite Hhas.
  Qed.

  Lemma well_formed_empty : well_formed empty_r.
  Proof. by []. Qed.

  Lemma well_formed_makeset uf lm : well_formed uf -> well_formed (makeset uf lm).
  Proof.
    rewrite /well_formed => -[Hu Hwf]; split => [|lf].
    + rewrite /makeset; case: ifP {Hwf} => //= /negP Hhas.
      apply/andP; split => //; apply/negP => /mapP [[l1 l2]] Hin /= ?; subst l1; apply: Hhas.
      by apply/hasP; eexists; eauto; rewrite /is_labeled.
    rewrite has_makeset find_makeset /makeset.
    case Hlflm: (lf == lm); case Hhaslm: (has (is_labeled lm) uf) ; case Hhaslf: (has (is_labeled lf) uf) => //=.
    + by rewrite Hwf // -(eqP Hlflm).
    + by rewrite (eqP Hlflm) Hhaslm in Hhaslf.
    + by rewrite -(eqP Hlflm) Hhaslf in Hhaslm.
    + rewrite hasNfind /is_labeled /=.
      - by rewrite /is_pair Hlflm.
      by rewrite Hhaslf.
    + by rewrite Hwf.
    rewrite /is_labeled /=.
    case Hlmfindlf: ((find_r uf lf == lm)) => //=.
    + by rewrite /is_pair /= Hwf // Hlmfindlf.
    by rewrite /is_pair /= Hwf // Hlmfindlf.
  Qed.

  Lemma well_formed_union uf lx ly : well_formed uf -> well_formed (union_r uf lx ly).
  Proof.
    rewrite /union_r => Hwfuf.
    have:= @well_formed_makeset _ ly (@well_formed_makeset _ lx Hwfuf).
    set ufxy:= makeset (makeset _ _) _ => -[Huxy Hwfufxy]; split => [|l]; first by rewrite -map_comp (@eq_map _ _ _ fst).
    set flx:= find_r ufxy lx; set fly:= find_r ufxy ly; set fl:= find_r ufxy l.
    rewrite has_map (@eq_has _ _ (is_labeled l)); last by move => l'; rewrite /is_labeled.
    have:= has_makeset (makeset uf lx) ly ly; rewrite eq_refl /= -/ufxy => Hhasfly Hhasfl.
    have:= (Hwfufxy _ Hhasfly); rewrite -/fly => /hasP [[? ?]] Hinfly /andP [/=] /eqP ? /eqP ?; subst.
    have:= (Hwfufxy _ Hhasfl); rewrite -/fl => /hasP [[? ?]] Hinfl /andP [/=] /eqP ? /eqP ?; subst.
    apply/hasP; case Heqfind: (flx == fl).
    + exists (fly,fly).
      - by apply/mapP; eexists; first (exact Hinfly); case: ifP.
      by apply/andP; split => //=;
      have ->:= (@find_map ufxy (fun pl2 => if flx == pl2 then fly else pl2) l fl) => //;
      rewrite Hhasfl Heqfind eq_refl.
    exists (fl,fl).
    + by apply/mapP; eexists; first (exact Hinfl); rewrite Heqfind.
    by apply/andP; split => //=;
    have ->:= (@find_map ufxy (fun pl2 => if flx == pl2 then fly else pl2) l fl) => //;
    rewrite Hhasfl Heqfind eq_refl.
  Qed.

  Record unionfind_i : Type := mkUF {
    uf :> seq (S * S); _ : well_formed uf;
  }.

  Definition unionfind := unionfind_i.

  Lemma wf_uf (uf : unionfind) : well_formed uf.
  Proof. by case: uf. Qed.

  Definition empty : unionfind :=
    mkUF well_formed_empty.

  Definition union (uf : unionfind) (x y : S) : unionfind :=
    mkUF (well_formed_union x y (wf_uf uf)).

  Definition find (uf : unionfind) (x : S) :=
    find_r uf x.

  Lemma well_formed_has_has uf :
    well_formed uf ->
    forall l : S , has (is_labeled l) uf -> has (is_labeled (find_r uf l)) uf.
  Proof.
    move => [_ Hwf] l Hhas; have:= (Hwf l Hhas) => {Hwf Hhas}.
    move => /hasP [[? ?]] Hpinuf /andP [/=] /eqP ? /eqP ?; subst.
    by apply/hasP; rewrite /is_labeled; eexists; eauto.
  Qed.

  Lemma find_r_empty l : find_r empty_r l = l.
  Proof. by []. Qed.

  Lemma find_cons uf p l : find_r (p :: uf) l = if (is_labeled l p) then p.2 else find_r uf l.
  Proof.
   by rewrite /find_r /is_labeled /=; case: (l == p.1).
  Qed.

  Lemma find_r_union uf lx ly l :
    well_formed uf -> find_r (union_r uf lx ly) l =
    if (find_r uf lx == find_r uf l) then find_r uf ly else find_r uf l.
  Proof.
    move => Hwfuf.
    have:= (@well_formed_makeset _ ly (@well_formed_makeset _ lx Hwfuf)).
    rewrite -(find_makeset uf l lx) -(find_makeset uf lx lx) -(find_makeset uf ly lx).
    rewrite -(find_makeset (makeset uf lx) l ly) -(find_makeset (makeset uf lx) lx ly) -(find_makeset (makeset uf lx) ly ly).
    set ufxy := makeset (makeset uf lx) ly => Hwfufxy.
    have: has (is_labeled ly) ufxy.
    + by rewrite /ufxy has_makeset eq_refl.
    have: has (is_labeled lx) ufxy.
    + by rewrite /ufxy !has_makeset eq_refl Bool.orb_true_r.
    rewrite (@find_map ufxy (fun l => if find_r ufxy lx == l then find_r ufxy ly else l) l (find_r ufxy l)) => //.
    induction ufxy as [|huf tuf IHtuf] => //=.
    rewrite !find_cons /is_labeled.
    case Hhufl: (l == huf.1);
    case Hhuflx: (lx == huf.1);
    case Hhufly: (ly == huf.1);
    case Hfindtufl: (huf.2 == find_r tuf l);
    case Hhasltuf: (has (is_labeled l) tuf);
    case Hfindlxl: (find_r tuf lx == find_r tuf l) => //=.
    + by rewrite (eqP Hfindtufl) hasNfind // /negb Hhasltuf.
    + by rewrite (eqP Hfindtufl) hasNfind // /negb Hhasltuf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + move => _ Hhaslytuf.
      have Hfindll: (find_r tuf l = l) by apply hasNfind; rewrite /negb Hhasltuf.
      have Hfindlxl': (find_r (huf :: tuf) lx = l) by rewrite find_cons /is_labeled Hhuflx (eqP Hfindtufl).
      have Hhasluf: (has (is_labeled (find_r (huf :: tuf) lx)) (huf :: tuf))
        by apply (well_formed_has_has Hwfufxy); rewrite /is_labeled /= Hhuflx.
      by rewrite Hfindlxl' /is_labeled /= Hhufl Hhasltuf /= in Hhasluf.
    + move => _ Hhaslytuf.
      have Hfindll: (find_r tuf l = l) by apply hasNfind; rewrite /negb Hhasltuf.
      have Hfindlxl': (find_r (huf :: tuf) lx = l) by rewrite find_cons /is_labeled Hhuflx (eqP Hfindtufl).
      have Hhasluf: (has (is_labeled (find_r (huf :: tuf) lx)) (huf :: tuf))
        by apply (well_formed_has_has Hwfufxy); rewrite /is_labeled /= Hhuflx.
      by rewrite Hfindlxl' /is_labeled /= Hhufl Hhasltuf /= in Hhasluf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + by rewrite (eqP Hfindtufl) hasNfind // /negb Hhasltuf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + move => Hhaslxtuf _.
      have Hfindll: (find_r tuf l = l) by apply hasNfind; rewrite /negb Hhasltuf.
      have Hfindlxl': (find_r (huf :: tuf) lx = l) by rewrite find_cons /is_labeled Hhuflx (eqP Hfindlxl).
      have Hhasluf: (has (is_labeled (find_r (huf :: tuf) lx)) (huf :: tuf))
        by apply (well_formed_has_has Hwfufxy); rewrite /is_labeled /= Hhuflx.
      by rewrite Hfindlxl' /is_labeled /= Hhufl Hhasltuf /= in Hhasluf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + move => Hhaslxtuf Hhaslytuf.
      have Hfindll: (find_r tuf l = l) by apply hasNfind; rewrite /negb Hhasltuf.
      have Hhasluf: (has (is_labeled (find_r (huf :: tuf) huf.1)) (huf :: tuf))
        by apply (well_formed_has_has Hwfufxy); rewrite /is_labeled /= eq_refl.
      by rewrite find_cons /is_labeled /= eq_refl (eqP Hfindtufl) /= Hfindll Hhufl Hhasltuf in Hhasluf.
    + by rewrite hasNfind // /negb Hhasltuf.
    + move => Hhaslxtuf Hhaslytuf.
      have Hfindll: (find_r tuf l = l) by apply hasNfind; rewrite /negb Hhasltuf.
      have Hfindlxl': (find_r (huf :: tuf) lx = l) by rewrite find_cons /is_labeled Hhuflx (eqP Hfindlxl).
      have Hhasluf: (has (is_labeled (find_r (huf :: tuf) lx)) (huf :: tuf))
        by apply (well_formed_has_has Hwfufxy); rewrite /is_labeled /= Hhuflx.
      by rewrite Hfindlxl' /is_labeled /= Hhufl Hhasltuf /= in Hhasluf.
    + by rewrite hasNfind // /negb Hhasltuf.
  Qed.

  Lemma find_in uf lx ly :
    well_formed uf ->
    (lx, ly) \in uf ->
    find_r uf lx = ly.
  Proof.
    move => [Huniq _] /assocP Hin; have:= (Hin Huniq).
    elim: uf {Hin Huniq} => // -[lx' ly'] uf IHuf; rewrite find_cons /is_labeled /=.
    by case: ifP => [_ []|_].
  Qed.

  Lemma find_find_r uf l :
    well_formed uf ->
    find_r uf (find_r uf l) = find_r uf l.
  Proof.
    move => Hwf; move: (Hwf) => [_ Himphas].
    case Hhas: (has (is_labeled l) uf); last first.
    + by rewrite {1}(@hasNfind _ l) // Hhas.
    have:= (Himphas _ Hhas) => /hasP [[? ?]] Hfin /andP [/=] /eqP ? /eqP ?; subst.
    by apply: find_in.
  Qed.

  Lemma find_empty l : find empty l = l.
  Proof. apply: find_r_empty. Qed.

  Lemma find_union uf lx ly l : find (union uf lx ly) l =
    if (find uf lx == find uf l) then find uf ly else find uf l.
  Proof. by apply/find_r_union/wf_uf. Qed.

  Lemma find_find uf l : find uf (find uf l) = find uf l.
  Proof. by apply/find_find_r/wf_uf. Qed.

End NaiveUnionFind.

Module LblEqType <: EqType.
  Definition T := [eqType of label].
End LblEqType.

Module LUF := NaiveUnionFind(LblEqType).