From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From Translation
Require Import util SAst SLiftSubst SCommon Equality ITyping ITypingInversions.
Import ListNotations.

(* Lemmata about typing *)

Open Scope type_scope.
Open Scope i_scope.

Section Lemmata.

Context `{Sort_notion : Sorts.notion}.

(* Typing up to equality *)
Lemma meta_ctx_conv :
  forall {Σ Γ Δ t A},
    Σ ;;; Γ |-i t : A ->
    Γ = Δ ->
    Σ ;;; Δ |-i t : A.
Proof.
  intros Σ Γ Δ t A h e.
  rewrite <- e. exact h.
Defined.

Lemma meta_conv :
  forall {Σ Γ t A B},
    Σ ;;; Γ |-i t : A ->
    A = B ->
    Σ ;;; Γ |-i t : B.
Proof.
  intros Σ Γ t A B h e.
  rewrite <- e. exact h.
Defined.

Lemma typing_wf :
  forall {Σ Γ t T},
    Σ ;;; Γ |-i t : T ->
    wf Σ Γ.
Proof.
  intros Σ Γ t T H. induction H ; easy.
Defined.

Fact type_ctx_closed_above :
  forall {Σ Γ t T},
    Σ ;;; Γ |-i t : T ->
    closed_above #|Γ| t = true.
Proof.
  intros Σ Γ t T h.
  dependent induction h.
  all: try (cbn in * ; repeat erewrite_assumption ; reflexivity).
  apply nth_error_Some_length in H0.
  unfold closed_above. case_eq (n <? #|Γ|) ; intro e ; bprop e ; try mylia.
Defined.

Fact type_ctxempty_closed :
  forall {Σ t T},
    Σ ;;; [] |-i t : T ->
    closed t.
Proof.
  intros Σ t T h.
  unfold closed. eapply @type_ctx_closed_above with (Γ := []). eassumption.
Defined.

(* TODO: Move the 6 next constructions away. *)
Fact substl_cons :
  forall {a l t}, substl (a :: l) t = (substl l (t{ 0 := a })).
Proof.
  reflexivity.
Defined.

Inductive closed_list : list sterm -> Type :=
| closed_list_nil : closed_list nil
| closed_list_cons a l :
    closed_above #|l| a = true ->
    closed_list l ->
    closed_list (a :: l).

Derive Signature for closed_list.

Fact closed_substl :
  forall {l},
    closed_list l ->
    forall {t},
      closed_above #|l| t = true ->
      closed (substl l t).
Proof.
  intros l cl. induction cl ; intros t h.
  - cbn in *. assumption.
  - rewrite substl_cons. apply IHcl.
    apply closed_above_subst.
    + mylia.
    + assumption.
    + replace (#|l| - 0) with #|l| by mylia. assumption.
Defined.

Fact rev_cons :
  forall {A} {l} {a : A},
    rev (a :: l) = (rev l ++ [a])%list.
Proof.
  intro A.
  unfold rev.
  match goal with
  | |- forall l a, ?faux _ _ = _ => set (aux := faux)
  end.
  assert (h : forall l acc, aux l acc = (aux l [] ++ acc)%list).
  { intro l. induction l ; intro acc.
    - cbn. reflexivity.
    - cbn. rewrite (IHl [a]). rewrite IHl.
      change (a :: acc) with ([a] ++ acc)%list.
      auto with datatypes.
  }
  intros l a.
  apply h.
Defined.

Fact rev_map_cons :
  forall {A B} {f : A -> B} {l} {a : A},
    rev_map f (a :: l) = (rev_map f l ++ [f a])%list.
Proof.
  intros A B f.
  unfold rev_map.
  match goal with
  | |- forall l a, ?faux _ _ = _ => set (aux := faux)
  end.
  assert (h : forall l acc, aux l acc = (aux l [] ++ acc)%list).
  { intro l. induction l ; intro acc.
    - cbn. reflexivity.
    - cbn. rewrite (IHl [f a]). rewrite IHl.
      change (f a :: acc) with ([f a] ++ acc)%list.
      auto with datatypes.
  }
  intros l a.
  apply h.
Defined.

Fact rev_length :
  forall {A} {l : list A},
    #|rev l| = #|l|.
Proof.
  intro A.
  unfold rev.
  match goal with
  | |- context [ #|?faux _ _| ] => set (aux := faux)
  end.
  assert (h : forall l acc, #|aux l acc| = (#|acc| + #|l|)%nat).
  { intro l. induction l ; intro acc.
    - cbn. mylia.
    - cbn. rewrite IHl. cbn. mylia.
  }
  intro l. apply h.
Defined.

Fact rev_map_length :
  forall {A B} {f : A -> B} {l : list A},
    #|rev_map f l| = #|l|.
Proof.
  intros A B f.
  unfold rev_map.
  match goal with
  | |- context [ #|?faux _ _| ] => set (aux := faux)
  end.
  assert (h : forall l acc, #|aux l acc| = (#|acc| + #|l|)%nat).
  { intro l. induction l ; intro acc.
    - cbn. mylia.
    - cbn. rewrite IHl. cbn. mylia.
  }
  intro l. apply h.
Defined.

Fact xcomp_lift :
  forall {t}, Xcomp t ->
  forall {n k}, Xcomp (lift n k t).
Proof.
  intros t h. induction h ; intros m k.
  all: try (cbn ; constructor ; easy).
  cbn. destruct (k <=? n) ; constructor.
Defined.

Fact xcomp_subst :
  forall {t}, Xcomp t ->
  forall {u}, Xcomp u ->
  forall {n}, Xcomp (t{ n := u}).
Proof.
  intros t ht. induction ht ; intros t' ht' m.
  all: try (cbn ; constructor; easy).
  cbn. case_eq (m ?= n) ; try constructor.
  intro e. apply xcomp_lift. assumption.
Defined.

Lemma ident_eq_spec x y : reflect (x = y) (ident_eq x y).
Proof.
  unfold ident_eq.
  destruct  (string_dec x y); now constructor.
Defined.

Fact ident_neq_fresh :
  forall {Σ id ty d},
    lookup_glob Σ id = Some ty ->
    fresh_glob (dname d) Σ ->
    ident_eq id (dname d) = false.
Proof.
  intro Σ. induction Σ ; intros id ty d h hf.
  - cbn in h. discriminate h.
  - cbn in h. inversion_clear hf.
    unfold ident_eq in *.
    destruct (string_dec id (dname a)).
    destruct (string_dec id (dname d)) ; congruence.
    exact (IHΣ _ _ _ h H).
Defined.

Fixpoint weak_glob_type {Σ Γ t A} (h : Σ ;;; Γ |-i t : A) :
  forall {d},
    fresh_glob (dname d) Σ ->
    (d::Σ) ;;; Γ |-i t : A

with weak_glob_wf {Σ Γ} (h : wf Σ Γ) :
  forall {d},
    fresh_glob (dname d) Σ ->
    wf (d::Σ) Γ.
Proof.
  (* weak_glob_type *)
  - { dependent destruction h ; intros d fd.
      all: try (econstructor ; try apply weak_glob_wf ;
                try apply weak_glob_type ;
                eassumption
               ).
      eapply type_Ax.
      - eapply weak_glob_wf ; eassumption.
      - cbn. erewrite ident_neq_fresh by eassumption.
        assumption.
    }

  (* weak_glob_wf *)
  - { dependent destruction h ; intros fd.
      - constructor.
      - econstructor.
        + apply weak_glob_wf ; assumption.
        + apply weak_glob_type ; eassumption.
    }
Defined.

Corollary weak_glob_isType :
  forall {Σ Γ A} (h : isType Σ Γ A) {d},
    fresh_glob (dname d) Σ ->
    isType (d::Σ) Γ A.
Proof.
  intros Σ Γ A h d hf.
  destruct h as [s h].
  exists s. eapply weak_glob_type ; eassumption.
Defined.

Fact typed_ax_type :
  forall {Σ}, type_glob Σ ->
  forall {id ty},
    lookup_glob Σ id = Some ty ->
    isType Σ [] ty.
Proof.
  intros Σ hg. dependent induction hg ; intros id ty h.
  - cbn in h. discriminate h.
  - cbn in h.
    case_eq (ident_eq id (dname d)).
    + intro e. rewrite e in h. inversion h. subst.
      eapply weak_glob_isType ; eassumption.
    + intro e. rewrite e in h.
      specialize (IHhg _ _ h).
      eapply weak_glob_isType ; eassumption.
Defined.

Fact xcomp_ax_type :
 forall {Σ}, type_glob Σ ->
  forall {id ty},
    lookup_glob Σ id = Some ty ->
    Xcomp ty.
Proof.
  intros Σ hg. dependent induction hg ; intros id ty h.
  - cbn in h. discriminate h.
  - cbn in h.
    case_eq (ident_eq id (dname d)).
    + intro e. rewrite e in h. inversion h. subst.
      assumption.
    + intro e. rewrite e in h.
      specialize (IHhg _ _ h).
      assumption.
Defined.

Fact lift_ax_type :
  forall {Σ},
    type_glob Σ ->
    forall {id ty},
      lookup_glob Σ id = Some ty ->
      forall n k, lift n k ty = ty.
Proof.
  intros Σ hg id ty isd n k.
  destruct (typed_ax_type hg isd).
  eapply closed_lift.
  eapply type_ctxempty_closed. eassumption.
Defined.

Lemma nth_error_lift_context :
  forall Γ k n A,
    nth_error Γ n = Some A ->
    nth_error (lift_context k Γ) n = Some (lift k (#|Γ| - S n) A).
Proof.
  intros Γ k n A e.
  induction Γ in k, n, A, e |- *.
  - destruct n. all: discriminate.
  - destruct n.
    + cbn in e. inversion e. subst. clear e.
      cbn. f_equal. f_equal. mylia.
    + cbn. cbn in e. eapply IHΓ in e. rewrite e. reflexivity.
Defined.

Ltac ih h :=
  lazymatch goal with
  | [ type_lift :
        forall (Σ : sglobal_context) (Γ Δ Ξ : scontext) (t A : sterm),
          Σ;;; Γ ,,, Ξ |-i t : A ->
          type_glob Σ ->
          wf Σ (Γ ,,, Δ) ->
          Σ;;; Γ ,,, Δ ,,, lift_context #|Δ| Ξ
          |-i lift #|Δ| #|Ξ| t : lift #|Δ| #|Ξ| A
    |- _ ] =>
    lazymatch type of h with
    | _ ;;; ?Γ' ,,, ?Ξ' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_lift with (Γ := Γ') (Ξ := Ξ') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Ξ'),, ?d' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_lift with (Γ := Γ') (Ξ := Ξ',, d') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Ξ'),, ?d',, ?d'' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_lift with (Γ := Γ') (Ξ := (Ξ',, d'),, d'') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    end ; try (cbn ; reflexivity)
  | _ => fail "Cannot retrieve type_lift"
  end.

Ltac eih :=
  lazymatch goal with
  | h : _ ;;; _ |-i ?t : _ |- _ ;;; _ |-i lift _ _ ?t : _ => ih h
  | _ => fail "Not handled by eih"
  end.

Fixpoint type_lift {Σ Γ Δ Ξ t A} (h : Σ ;;; Γ ,,, Ξ |-i t : A) {struct h} :
  type_glob Σ ->
  wf Σ (Γ ,,, Δ) ->
  Σ ;;; Γ ,,, Δ ,,, lift_context #|Δ| Ξ |-i lift #|Δ| #|Ξ| t : lift #|Δ| #|Ξ| A

with wf_lift {Σ Γ Δ Ξ} (h : wf Σ (Γ ,,, Ξ)) {struct h} :
  type_glob Σ ->
  wf Σ (Γ ,,, Δ) ->
  wf Σ (Γ ,,, Δ ,,, lift_context #|Δ| Ξ)
.
Proof.
  - { dependent destruction h ; intros hΣ hwf.
      - cbn. case_eq (#|Ξ| <=? n) ; intro e ; bprop e.
        + rewrite liftP3 by mylia.
          replace (#|Δ| + S n)%nat with (S (#|Δ| + n)) by mylia.
          eapply type_Rel.
          * eapply wf_lift ; assumption.
          * unfold ",,,". rewrite nth_error_app2.
            2:{ rewrite lift_context_length. mylia. }
            rewrite lift_context_length.
            rewrite nth_error_app2 by mylia.
            replace (#|Δ| + n - #|Ξ| - #|Δ|) with (n - #|Ξ|) by mylia.
            unfold ",,," in H0. rewrite nth_error_app2 in H0 by auto.
            assumption.
        + eapply meta_conv.
          * eapply type_Rel.
            1: eapply wf_lift ; assumption.
            unfold ",,,". rewrite nth_error_app1.
            2:{ rewrite lift_context_length. auto. }
            eapply nth_error_lift_context.
            unfold ",,," in H0. rewrite nth_error_app1 in H0 by mylia.
            eassumption.
          * rewrite <- liftP2 by mylia. f_equal. mylia.
      - cbn. apply type_Sort. now apply wf_lift.
      - cbn. eapply type_Prod ; eih.
      - cbn. eapply type_Lambda ; eih.
      - cbn.
        change (lift #|Δ| #|Ξ| (B {0 := u}))
          with (lift #|Δ| (0 + #|Ξ|) (B { 0 := u })).
        rewrite substP1.
        eapply type_App ; eih.
      - cbn. eapply type_Sum ; eih.
      - cbn. eapply type_Pair ; eih.
        change (#|Ξ|) with (0 + #|Ξ|)%nat.
        rewrite substP1. reflexivity.
      - cbn. eapply type_Pi1 ; eih.
      - cbn.
        change (#|Ξ|) with (0 + #|Ξ|)%nat.
        rewrite substP1. cbn.
        eapply type_Pi2 ; eih.
      - cbn. apply type_Eq ; eih.
      - cbn. eapply type_Refl ; eih.
      - change (#|Ξ|) with (0 + #|Ξ|)%nat.
        rewrite substP1.
        replace (S (0 + #|Ξ|)) with (1 + #|Ξ|)%nat by mylia.
        rewrite substP1.
        cbn. eapply type_J ; try eih.
        + cbn. unfold ssnoc. cbn.
          f_equal. f_equal.
          * replace (S #|Ξ|) with (1 + #|Ξ|)%nat by mylia.
            apply liftP2. mylia.
          * replace (S #|Ξ|) with (1 + #|Ξ|)%nat by mylia.
            apply liftP2. mylia.
        + replace (S (S #|Ξ|)) with (1 + (S (0 + #|Ξ|)))%nat by mylia.
          rewrite <- substP1.
          replace (1 + (0 + #|Ξ|))%nat with (S (0 + #|Ξ|))%nat by mylia.
          change (sRefl (lift #|Δ| #|Ξ| A0) (lift #|Δ| #|Ξ| u))
            with (lift #|Δ| #|Ξ| (sRefl A0 u)).
          rewrite <- substP1. reflexivity.
      - cbn. eapply type_Transport ; eih.
      - cbn.
        change (lift #|Δ| #|Ξ| (B {0 := u}))
          with (lift #|Δ| (0 + #|Ξ|) (B { 0 := u })).
        change (lift #|Δ| #|Ξ| (t0 {0 := u}))
          with (lift #|Δ| (0 + #|Ξ|) (t0 { 0 := u })).
        rewrite 2!substP1.
        cbn. eapply type_Beta ; eih.
      - cbn. eapply type_Heq ; eih.
      - cbn. eapply type_HeqToEq ; eih.
      - cbn. eapply type_HeqRefl ; eih.
      - cbn. eapply type_HeqSym ; eih.
      - cbn. eapply @type_HeqTrans with (B := lift #|Δ| #|Ξ| B) (b := lift #|Δ| #|Ξ| b) ; eih.
      - cbn. eapply type_HeqTransport ; eih.
      - cbn. eapply type_CongProd ; try eih.
        cbn. f_equal.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
      - cbn. eapply type_CongLambda ; try eih.
        + cbn. f_equal.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
        + cbn. f_equal.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
      - cbn.
        change (lift #|Δ| #|Ξ| (B1 {0 := v1}))
          with (lift #|Δ| (0 + #|Ξ|) (B1 { 0 := v1 })).
        change (lift #|Δ| #|Ξ| (B2 {0 := v2}))
          with (lift #|Δ| (0 + #|Ξ|) (B2 { 0 := v2 })).
        rewrite 2!substP1.
        eapply type_CongApp ; eih.
        cbn. f_equal.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
      - cbn. eapply type_CongSum ; try eih.
        cbn. f_equal.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
      - cbn. eapply type_CongPair ; eih.
        + cbn. f_equal.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
          * rewrite <- liftP2 by mylia.
            change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
            rewrite substP1. cbn. reflexivity.
        + cbn. f_equal.
          * change #|Ξ| with (0 + #|Ξ|)%nat.
            rewrite substP1. reflexivity.
          * change #|Ξ| with (0 + #|Ξ|)%nat.
            rewrite substP1. reflexivity.
        + change #|Ξ| with (0 + #|Ξ|)%nat.
          rewrite substP1. reflexivity.
        + change #|Ξ| with (0 + #|Ξ|)%nat.
          rewrite substP1. reflexivity.
      - cbn. eapply type_CongPi1 ; eih.
        cbn. f_equal.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
      - cbn.
        change #|Ξ| with (0 + #|Ξ|)%nat.
        rewrite 2!substP1.
        eapply type_CongPi2 ; eih.
        cbn. f_equal.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
        + rewrite <- liftP2 by mylia.
          change (S #|Ξ|) with (0 + (S #|Ξ|))%nat at 1.
          rewrite substP1. cbn. reflexivity.
      - cbn. eapply type_CongEq ; eih.
      - cbn. eapply type_CongRefl ; eih.
      - cbn. eapply type_EqToHeq ; eih.
      - cbn. eapply type_HeqTypeEq ; eih.
      - cbn. eapply type_Pack ; eih.
      - cbn. eapply @type_ProjT1 with (A2 := lift #|Δ| #|Ξ| A2) ; eih.
      - cbn. eapply @type_ProjT2 with (A1 := lift #|Δ| #|Ξ| A1) ; eih.
      - cbn. eapply type_ProjTe ; eih.
      - cbn. erewrite lift_ax_type by eassumption.
        eapply type_Ax.
        + now apply wf_lift.
        + assumption.
      - eapply type_rename.
        + eih.
        + eapply nl_lift. assumption.
    }

  (* wf_lift *)
  - { intros hg hwf.
      destruct Ξ.
      - cbn. assumption.
      - dependent destruction h.
        cbn. econstructor.
        + apply wf_lift ; assumption.
        + instantiate (1 := s0). cbn. change (sSort s0) with (lift #|Δ| #|Ξ| (sSort s0)).
          apply type_lift ; assumption.
    }

    Unshelve.
    all: try rewrite !length_cat ; try rewrite length_cat in isdecl ;
      try rewrite lift_context_length ; mylia.
Defined.

Corollary typing_lift01 :
  forall {Σ Γ t A B s},
    type_glob Σ ->
    Σ ;;; Γ |-i t : A ->
    Σ ;;; Γ |-i B : sSort s ->
    Σ ;;; Γ ,, B |-i lift0 1 t : lift0 1 A.
Proof.
  intros Σ Γ t A B s hg ht hB.
  apply (@type_lift _ _ [ B ] nil _ _ ht hg).
  econstructor.
  - eapply typing_wf. eassumption.
  - eassumption.
Defined.

Corollary typing_lift02 :
  forall {Σ Γ t A B s C s'},
    type_glob Σ ->
    Σ ;;; Γ |-i t : A ->
    Σ ;;; Γ |-i B : sSort s ->
    Σ ;;; Γ ,, B |-i C : sSort s' ->
    Σ ;;; Γ ,, B ,, C |-i lift0 2 t : lift0 2 A.
Proof.
  intros Σ Γ t A B s C s' hg ht hB hC.
  assert (eq : forall t, lift0 2 t = lift0 1 (lift0 1 t)).
  { intro u. rewrite lift_lift. reflexivity. }
  rewrite !eq. eapply typing_lift01.
  - assumption.
  - eapply typing_lift01  ; eassumption.
  - eassumption.
Defined.

Fact subst_ax_type :
  forall {Σ},
    type_glob Σ ->
    forall {id ty},
      lookup_glob Σ id = Some ty ->
      forall n u, ty{ n := u } = ty.
Proof.
  intros Σ hg id ty isd n k.
  destruct (typed_ax_type hg isd).
  eapply closed_subst.
  eapply type_ctxempty_closed. eassumption.
Defined.

Lemma nth_error_subst_context :
  forall Γ u n A,
    nth_error Γ n = Some A ->
    nth_error (subst_context u Γ) n = Some (A{ #|Γ| - S n := u }).
Proof.
  intros Γ u n A e.
  induction Γ in u, n, A, e |- *.
  - destruct n. all: discriminate.
  - destruct n.
    + cbn in e. inversion e. subst. clear e.
      cbn. f_equal. f_equal. mylia.
    + cbn. cbn in e. eapply IHΓ in e. rewrite e. reflexivity.
Defined.

Ltac sh h :=
  lazymatch goal with
  | [ type_subst :
        forall (Σ : sglobal_context) (Γ Δ : scontext) (t A : sterm)
          (B u : sterm),
          Σ;;; Γ,, B ,,, Δ |-i t : A ->
          type_glob Σ ->
          Σ;;; Γ |-i u : B -> Σ;;; Γ ,,, subst_context u Δ |-i
          t {#|Δ| := u} : A {#|Δ| := u}
    |- _ ] =>
    lazymatch type of h with
    | _ ;;; ?Γ' ,, ?B' ,,, ?Δ' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_subst with (Γ := Γ') (Δ := Δ') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,, ?B' ,,, ?Δ') ,, ?d' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_subst with (Γ := Γ') (Δ := Δ' ,, d') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,, ?B' ,,, ?Δ') ,, ?d',, ?d'' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_subst with (Γ := Γ') (Δ := (Δ' ,, d') ,, d'') (A := T') ; [
            exact h
          | assumption
          | assumption
          ]
        | .. ]
      | .. ]
    end ; try (cbn ; reflexivity)
  | _ => fail "cannot find type_subst"
  end.

Ltac esh :=
  lazymatch goal with
  | h : _ ;;; _ |-i ?t : _ |- _ ;;; _ |-i ?t{ _ := _ } : _ => sh h
  | _ => fail "not handled by esh"
  end.

Fixpoint type_subst {Σ Γ Δ t A B u}
  (h : Σ ;;; Γ ,, B ,,, Δ |-i t : A) {struct h} :
  type_glob Σ ->
  Σ ;;; Γ |-i u : B ->
  Σ ;;; Γ ,,, subst_context u Δ |-i t{ #|Δ| := u } : A{ #|Δ| := u }

with wf_subst {Σ Γ Δ B u}
  (h : wf Σ (Γ ,, B ,,, Δ)) {struct h} :
  type_glob Σ ->
  Σ ;;; Γ |-i u : B ->
  wf Σ (Γ ,,, subst_context u Δ)
.
Proof.
  (* type_subst *)
  - { intros hg hu.
      dependent destruction h.
      - cbn. case_eq (#|Δ| ?= n) ; intro e ; bprop e.
      + rewrite substP3 by mylia.
        rewrite <- e0.
        replace #|Δ| with #|subst_context u Δ|.
        2:{ rewrite subst_context_length. reflexivity. }
        unfold ",,," in H0. rewrite nth_error_app2 in H0 by mylia.
        replace (n - #|Δ|) with 0 in H0 by mylia.
        cbn in H0. inversion H0. subst.
        eapply @type_lift with (Ξ := []) (Δ := subst_context u Δ).
        * cbn. assumption.
        * assumption.
        * eapply wf_subst ; eassumption.
      + rewrite substP3 by mylia.
        destruct n. 1: lia.
        cbn. unfold ",,," in H0. rewrite nth_error_app2 in H0 by mylia.
        unfold ",," in H0. change (B :: Γ) with ([B] ++ Γ) in H0.
        rewrite nth_error_app2 in H0.
        2:{ unfold length at 1. mylia. }
        unfold length at 2 in H0.
        replace (S n - #|Δ| - 1) with (n - #|Δ|) in H0 by mylia.
        eapply type_Rel.
        * eapply wf_subst. all: eassumption.
        * unfold ",,,". rewrite nth_error_app2.
          2:{ rewrite subst_context_length. mylia. }
          rewrite subst_context_length. assumption.
      + match goal with
        | |- _ ;;; _ |-i _ : ?t{?d := ?u} =>
          replace (subst u d t) with (t{((S n) + (#|Δ| - (S n)))%nat := u})
            by (f_equal ; mylia)
        end.
        rewrite substP2 by mylia.
        eapply type_Rel.
        * eapply wf_subst ; eassumption.
        * unfold ",,,". rewrite nth_error_app1.
          2:{ rewrite subst_context_length. mylia. }
        eapply nth_error_subst_context.
        unfold ",,," in H0. rewrite nth_error_app1 in H0 by mylia.
        assumption.
      - cbn. apply type_Sort. eapply wf_subst ; eassumption.
      - cbn. eapply type_Prod ; esh.
      - cbn. eapply type_Lambda ; esh.
      - cbn.
        change ((B0 {0 := u0}) {#|Δ| := u})
          with ((B0 {0 := u0}) {0 + #|Δ| := u}).
        rewrite substP4. cbn.
        eapply type_App ; esh.
      - cbn. eapply type_Sum ; esh.
      - cbn. eapply type_Pair ; esh.
        change (#|Δ|) with (0 + #|Δ|)%nat.
        rewrite substP4. reflexivity.
      - cbn. eapply type_Pi1 ; esh.
      - cbn.
        change (#|Δ|) with (0 + #|Δ|)%nat.
        rewrite substP4. cbn.
        eapply type_Pi2 ; esh.
      - cbn. eapply type_Eq ; esh.
      - cbn. eapply type_Refl ; esh.
      - cbn.
        change (#|Δ|) with (0 + #|Δ|)%nat.
        rewrite substP4.
        replace (S (0 + #|Δ|)) with (1 + #|Δ|)%nat by mylia.
        rewrite substP4.
        eapply type_J ; esh.
        + cbn. unfold ssnoc. cbn.
          f_equal. f_equal.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            apply substP2. mylia.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            apply substP2. mylia.
        + replace (S (S #|Δ|)) with (1 + (S (0 + #|Δ|)))%nat by mylia.
          rewrite <- substP4.
          replace (1 + (0 + #|Δ|))%nat with (S (0 + #|Δ|))%nat by mylia.
          change (sRefl (A0 {0 + #|Δ| := u}) (u0 {0 + #|Δ| := u}))
            with ((sRefl A0 u0){ 0 + #|Δ| := u}).
          rewrite <- substP4. reflexivity.
      - cbn. eapply type_Transport ; esh.
      - cbn.
        change ((B0 {0 := u0}) {#|Δ| := u})
          with ((B0 {0 := u0}) {0 + #|Δ| := u}).
        change ((t0 {0 := u0}) {#|Δ| := u})
          with ((t0 {0 := u0}) {0 + #|Δ| := u}).
        rewrite 2!substP4. cbn.
        eapply type_Beta ; esh.
      - cbn. eapply type_Heq ; esh.
      - cbn. eapply type_HeqToEq ; esh.
      - cbn. eapply type_HeqRefl ; esh.
      - cbn. eapply type_HeqSym ; esh.
      - cbn.
        eapply type_HeqTrans
          with (B1 := B0{ #|Δ| := u }) (b0 := b{ #|Δ| := u }) ; esh.
      - cbn. eapply type_HeqTransport ; esh.
      - cbn. eapply type_CongProd ; esh.
        cbn. f_equal.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
      - cbn. eapply type_CongLambda ; esh.
        + cbn. f_equal.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
        + cbn. f_equal.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
      - cbn.
        change #|Δ| with (0 + #|Δ|)%nat.
        rewrite 2!substP4. cbn.
        eapply type_CongApp ; esh.
        cbn. f_equal.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
      - cbn. eapply type_CongSum ; esh.
        cbn. f_equal.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
      - cbn. eapply type_CongPair ; esh.
        + cbn. f_equal.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
          * rewrite <- substP2 by mylia.
            change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
            rewrite substP4. cbn. reflexivity.
        + cbn. f_equal.
          * change #|Δ| with (0 + #|Δ|)%nat.
            rewrite substP4. reflexivity.
          * change #|Δ| with (0 + #|Δ|)%nat.
            rewrite substP4. reflexivity.
        + change #|Δ| with (0 + #|Δ|)%nat.
          rewrite substP4. reflexivity.
        + change #|Δ| with (0 + #|Δ|)%nat.
          rewrite substP4. reflexivity.
      - cbn. eapply type_CongPi1 ; esh.
        cbn. f_equal.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
      - cbn.
        change #|Δ| with (0 + #|Δ|)%nat.
        rewrite 2!substP4. cbn.
        eapply type_CongPi2 ; esh.
        cbn. f_equal.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
        + rewrite <- substP2 by mylia.
          change (S #|Δ|) with (0 + (S #|Δ|))%nat at 1.
          rewrite substP4. cbn. reflexivity.
      - cbn. eapply type_CongEq ; esh.
      - cbn. eapply type_CongRefl ; esh.
      - cbn. eapply type_EqToHeq ; esh.
      - cbn. eapply type_HeqTypeEq ; esh.
      - cbn. eapply type_Pack ; esh.
      - cbn. eapply @type_ProjT1 with (A2 := A2{#|Δ| := u}) ; esh.
      - cbn. eapply @type_ProjT2 with (A1 := A1{#|Δ| := u}) ; esh.
      - cbn. eapply type_ProjTe ; esh.
      - cbn. erewrite subst_ax_type by eassumption.
        eapply type_Ax.
        + now eapply wf_subst.
        + assumption.
      - eapply type_rename.
        + esh.
        + eapply nl_subst ; try assumption. reflexivity.
    }

  (* wf_subst *)
  - { intros hg hu.
      destruct Δ.
      - cbn. dependent destruction h. assumption.
      - dependent destruction h. cbn. econstructor.
        + eapply wf_subst ; eassumption.
        + esh.
    }

  Unshelve.
  all: try rewrite !length_cat ; try rewrite !subst_context_length ; mylia.
Defined.

Corollary typing_subst :
  forall {Σ Γ t A B u},
    type_glob Σ ->
    Σ ;;; Γ ,, A |-i t : B ->
    Σ ;;; Γ |-i u : A ->
    Σ ;;; Γ |-i t{ 0 := u } : B{ 0 := u }.
Proof.
  intros Σ Γ t A B u hg ht hu.
  eapply @type_subst with (Δ := []) ; eassumption.
Defined.

Corollary typing_subst2 :
  forall {Σ Γ t A B C u v},
    type_glob Σ ->
    Σ ;;; Γ ,, A ,, B |-i t : C ->
    Σ ;;; Γ |-i u : A ->
    Σ ;;; Γ |-i v : B{ 0 := u } ->
    Σ ;;; Γ |-i t{ 1 := u }{ 0 := v } : C{ 1 := u }{ 0 := v }.
Proof.
  intros Σ Γ t A B C u v hg ht hu hv.
  eapply @type_subst with (Δ := []).
  - eapply @type_subst with (Δ := [ B ]).
    + exact ht.
    + assumption.
    + assumption.
  - assumption.
  - cbn. assumption.
Defined.

Inductive typed_list Σ Γ : list sterm -> scontext -> Type :=
| typed_list_nil : typed_list Σ Γ [] []
| typed_list_cons A l Δ T :
    typed_list Σ Γ l Δ ->
    Σ ;;; Γ ,,, Δ |-i A : T ->
    typed_list Σ Γ (A :: l) (Δ ,, T).

Corollary type_substl :
  forall {Σ l Γ Δ},
    type_glob Σ ->
    typed_list Σ Γ l Δ ->
    forall {t T},
      Σ ;;; Γ ,,, Δ |-i t : T ->
      Σ ;;; Γ |-i substl l t : substl l T.
Proof.
  intros Σ l Γ Δ hg tl.
  induction tl ; intros u C h.
  - cbn. assumption.
  - rewrite !substl_cons. apply IHtl.
    eapply typing_subst.
    + assumption.
    + exact h.
    + assumption.
Defined.

Fact substl_sort :
  forall {l s}, substl l (sSort s) = sSort s.
Proof.
  intro l. induction l ; intro s.
  - cbn. reflexivity.
  - rewrite substl_cons. cbn. apply IHl.
Defined.

Fact nth_error_error :
  forall {A} {l : list A} {n},
    nth_error l n = None ->
    n >= #|l|.
Proof.
  intros A l. induction l.
  - intros. cbn. mylia.
  - intros n h. cbn.
    destruct n.
    + cbn in h. inversion h.
    + inversion h as [e].
      specialize (IHl n e).
      mylia.
Defined.

Fact rev_map_nth_error :
  forall {A B} {f : A -> B} {l n a},
    nth_error l n = Some a ->
    nth_error (rev_map f l) (#|l| - S n) = Some (f a).
Proof.
  intros A B f l. induction l ; intros n x hn.
  - destruct n ; inversion hn.
  - destruct n.
    + cbn in hn. inversion hn.
      rewrite rev_map_cons.
      rewrite nth_error_app2.
      * cbn. rewrite rev_map_length.
        replace (#|l| - 0 - #|l|) with 0 by mylia.
        cbn. reflexivity.
      * rewrite rev_map_length. cbn. mylia.
    + cbn in hn.
      rewrite rev_map_cons.
      rewrite nth_error_app1.
      * cbn. erewrite IHl by eassumption. reflexivity.
      * rewrite rev_map_length. cbn.
        apply nth_error_Some_length in hn.
        mylia.
Defined.

Fixpoint nlctx Γ :=
  match Γ with
  | A :: Γ => nl A :: nlctx Γ
  | nil => nil
  end.

Lemma nlctx_length :
  forall {Γ Δ},
    nlctx Γ = nlctx Δ ->
    #|Γ| = #|Δ|.
Proof.
  intro Γ. induction Γ ; intros Δ e.
  - cbn. destruct Δ ; simpl in e ; try discriminate e.
    reflexivity.
  - destruct Δ ; simpl in e ; try discriminate e.
    cbn. f_equal. eapply IHΓ.
    simpl in e. inversion e. reflexivity.
Defined.

Lemma nth_error_nlctx :
  forall Γ Δ n A,
    nth_error Γ n = Some A ->
    nlctx Γ = nlctx Δ ->
    ∑ B,
      nth_error Δ n = Some B /\
      nl A = nl B.
Proof.
  intros Γ Δ n A h e.
  induction Γ in Δ, A, n, h, e |- *.
  - destruct n. all: discriminate.
  - destruct n.
    + cbn in h. inversion h. subst. clear h.
      destruct Δ. 1: discriminate.
      cbn in e. inversion e.
      cbn. eexists. intuition eauto.
    + cbn in h.
      destruct Δ. 1: discriminate.
      cbn in e. inversion e.
      eapply IHΓ in h as [B [? ?]]. 2: eauto.
      cbn. eexists. intuition eauto.
Defined.

Ltac nleq :=
  repeat (try eapply nl_lift ; try eapply nl_subst) ;
  cbn ; auto ; f_equal ; eauto.

Ltac reih :=
  lazymatch goal with
  | h : _ -> _ -> _ -> nl ?t1 = _ -> _ -> _ ;;; _ |-i _ : _,
    e : nl ?t1 = nl ?t2
    |- _ ;;; _ |-i ?t2 : _ =>
    eapply h ; [
      repeat nleq
    | first [ eassumption | reflexivity ]
    | first [
        eassumption
      | econstructor ; try eassumption ; reih
      ]
    ]
  | h : _ -> _ -> _ -> nl ?t = _ -> _ -> _ ;;; _ |-i _ : _
    |- _ ;;; _ |-i ?t : _ =>
    eapply h ; [
      repeat nleq
    | first [ eassumption | reflexivity ]
    | first [
        eassumption
      | econstructor ; try eassumption ; reih
      ]
    ]
  end.

Ltac lift_sort :=
  match goal with
  | |- _ ;;; _ |-i lift ?n ?k ?t : ?S => change S with (lift n k S)
  | |- _ ;;; _ |-i ?t { ?n := ?u } : ?S => change S with (S {n := u})
  end.

Lemma rename_typed :
  forall {Σ Γ Δ t u A},
    type_glob Σ ->
    Σ ;;; Γ |-i t : A ->
    nlctx Γ = nlctx Δ ->
    nl t = nl u ->
    wf Σ Δ ->
    Σ ;;; Δ |-i u : A.
Proof.
  intros Σ Γ Δ t u A hg h ex e hw. revert Δ ex u e hw.
  induction h ; intros Δ ex t' e hw.
  all: try solve [
    simpl in e ; destruct t' ; try discriminate e ;
    simpl in e ; inversion e ; subst ; clear e ;
    try solve [
          econstructor ; try eassumption ; try reih ;
          try (econstructor ; [ reih | repeat nleq ])
        ] ;
    try solve [
          econstructor ; [
            econstructor ; try eassumption ;
            try reih ;
            try (econstructor ; [ reih | repeat nleq ])
          | repeat nleq
          ]
        ]
  ].
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    eapply nth_error_nlctx in ex as [B [? ?]]. 2: eassumption.
    eapply type_rename.
    + econstructor.
      * assumption.
      * eassumption.
    + eapply nl_lift. auto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      eapply IHh4.
      * repeat nleq.
      * eassumption.
      * repeat eapply wf_snoc ; try eassumption ; try reih.
        econstructor ; try lift_sort ; try eapply typing_lift01 ;
        try eassumption ; try reih ;
        try (econstructor ; [ reih | repeat nleq ]).
        try econstructor ; [ econstructor |].
        -- assumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
        -- cbn. nleq.
    + nleq.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh3 ; try eassumption. reflexivity.
           ++ eapply IHh4 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. f_equal.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh4 ; try eassumption. reflexivity.
           ++ eapply IHh5 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
      * econstructor.
        -- eapply IHh3.
           ++ repeat nleq.
           ++ assumption.
           ++ repeat eapply wf_snoc ; try eassumption ; try reih.
              econstructor.
              ** eapply IHh4 ; try eassumption. reflexivity.
              ** eapply IHh5 ; try eassumption. reflexivity.
        -- cbn. f_equal.
           all: eapply nl_subst.
           all: try eapply nl_lift.
           all: try reflexivity.
           all: eauto.
    + cbn. f_equal.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh5 ; try eassumption. reflexivity.
           ++ eapply IHh6 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. symmetry. f_equal.
      all: try eapply nl_subst.
      all: try assumption.
      all: try reflexivity.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh3 ; try eassumption. reflexivity.
           ++ eapply IHh4 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. f_equal.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh5 ; try eassumption. reflexivity.
           ++ eapply IHh6 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. f_equal.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh4 ; try eassumption. reflexivity.
           ++ eapply IHh5 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. f_equal.
      all: f_equal.
      all: eauto.
  - simpl in e. destruct t' ; try discriminate e.
    simpl in e. inversion e. subst. clear e.
    econstructor.
    + econstructor ; try eassumption ; try reih ;
      try (econstructor ; [ reih | repeat nleq ]).
      econstructor.
      * eapply IHh2.
        -- repeat nleq.
        -- eassumption.
        -- repeat eapply wf_snoc ; try eassumption ; try reih.
           econstructor.
           ++ eapply IHh4 ; try eassumption. reflexivity.
           ++ eapply IHh5 ; try eassumption. reflexivity.
      * cbn. f_equal.
        all: eapply nl_subst.
        all: try eapply nl_lift.
        all: try reflexivity.
        all: assumption.
    + cbn. symmetry. f_equal.
      all: try eapply nl_subst.
      all: try assumption.
      all: cbn.
      all: f_equal.
      all: eauto.
  - econstructor.
    + eapply IHh ; assumption.
    + assumption.
  Unshelve.
  all: try solve [ constructor ].
Defined.

Lemma istype_type :
  forall {Σ Γ t T},
    type_glob Σ ->
    Σ ;;; Γ |-i t : T ->
    exists s, Σ ;;; Γ |-i T : sSort s.
Proof.
  intros Σ Γ t T hg H.
  induction H.
  - induction H in n, A, H0 |- *.
    1:{ destruct n. all: discriminate. }
    destruct n.
    + cbn in H0. inversion H0. subst. clear H0.
      exists s. change (sSort s) with (lift0 1 (sSort s)).
      eapply typing_lift01. all: eassumption.
    + cbn in H0. eapply IHwf in H0 as [s' ?].
      exists s'. change (sSort s') with (lift0 1 (sSort s')).
      assert (eq : forall t, lift0 (S (S n)) t = lift0 1 (lift0 (S n) t)).
      { intro t'. rewrite lift_lift. reflexivity. }
      rewrite eq. clear eq.
      eapply typing_lift01.
      all: eassumption.
  - exists (Sorts.succ (Sorts.succ s)). now apply type_Sort.
  - eexists. apply type_Sort. apply (typing_wf H).
  - eexists. apply type_Prod ; eassumption.
  - exists s2. change (sSort s2) with ((sSort s2){ 0 := u }).
    eapply typing_subst ; eassumption.
  - eexists. econstructor. eapply typing_wf. eassumption.
  - eexists. econstructor ; eassumption.
  - eexists. eassumption.
  - exists s2. change (sSort s2) with ((sSort s2){ 0 := sPi1 A B p }).
    eapply typing_subst ; try eassumption.
    econstructor ; eassumption.
  - eexists. apply type_Sort. apply (typing_wf H).
  - eexists. now apply type_Eq.
  - exists s2.
    change (sSort s2) with ((sSort s2){1 := v}{0 := p}).
    eapply typing_subst2.
    + assumption.
    + eassumption.
    + assumption.
    + cbn. rewrite !lift_subst, lift00.
      assumption.
  - eexists. eassumption.
  - destruct IHtyping1 as [z h].
    exists (Sorts.eq_sort z). eapply type_Eq.
    + change (sSort z) with ((sSort z){ 0 := u }).
      eapply typing_subst ; eassumption.
    + eapply type_App ; try eassumption.
      eapply type_Lambda ; eassumption.
    + eapply typing_subst ; eassumption.
  - eexists. apply type_Sort. apply (typing_wf H).
  - eexists. apply type_Eq ; eassumption.
  - eexists. eapply type_Heq ; eassumption.
  - eexists. eapply type_Heq ; eassumption.
  - eexists. eapply type_Heq ; eassumption.
  - eexists. apply type_Heq. all: try eassumption.
    eapply type_Transport ; eassumption.
  - eexists.
    apply type_Heq.
    + eapply type_Sort. apply (typing_wf H).
    + eapply type_Sort. apply (typing_wf H).
    + apply type_Prod ; assumption.
    + apply type_Prod ; assumption.
  - eexists. apply type_Heq.
    + apply type_Prod ; eassumption.
    + apply type_Prod ; assumption.
    + eapply type_Lambda ; eassumption.
    + eapply type_Lambda ; eassumption.
  - eexists. apply type_Heq.
    + lift_sort.
      eapply typing_subst ; eassumption.
    + lift_sort.
      eapply typing_subst ; eassumption.
    + eapply type_App ; eassumption.
    + eapply type_App ; eassumption.
  - eexists.
    apply type_Heq.
    + eapply type_Sort. apply (typing_wf H).
    + eapply type_Sort. apply (typing_wf H).
    + apply type_Sum ; assumption.
    + apply type_Sum ; assumption.
  - eexists. econstructor.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - eexists. econstructor ; try eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - eexists. econstructor ; try eassumption.
    + match goal with
      | |- _ ;;; _ |-i _ { 0 := ?t } : ?S =>
        change S with (S{ 0 := t })
      end.
      eapply typing_subst ; try eassumption.
      econstructor ; eassumption.
    + match goal with
      | |- _ ;;; _ |-i _ { 0 := ?t } : ?S =>
        change S with (S{ 0 := t })
      end.
      eapply typing_subst ; try eassumption.
      econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - eexists. apply type_Heq.
    + apply type_Sort ; apply (typing_wf H).
    + apply type_Sort ; apply (typing_wf H).
    + apply type_Eq ; assumption.
    + apply type_Eq ; assumption.
  - eexists. apply type_Heq.
    + apply type_Eq ; eassumption.
    + apply type_Eq ; assumption.
    + eapply type_Refl ; eassumption.
    + eapply type_Refl ; eassumption.
  - eexists. eapply type_Heq ; eassumption.
  - eexists. eapply type_Eq ; try assumption.
    apply type_Sort. apply (typing_wf H).
  - eexists. apply type_Sort. apply (typing_wf H).
  - exists s. assumption.
  - exists s. assumption.
  - eexists. apply type_Heq ; try eassumption.
    + eapply type_ProjT1 ; eassumption.
    + eapply @type_ProjT2 with (A1 := A1) ; eassumption.
  - destruct (typed_ax_type hg H0) as [s hh].
    exists s. change (sSort s) with (lift #|Γ| #|@nil sterm| (sSort s)).
    replace ty with (lift #|Γ| #|@nil sterm| ty)
      by (erewrite lift_ax_type by eassumption ; reflexivity).
    eapply meta_ctx_conv.
    + eapply @type_lift with (Γ := []) (Ξ := []) (Δ := Γ).
      * assumption.
      * assumption.
      * rewrite nil_cat. assumption.
    + cbn. apply nil_cat.
  - destruct IHtyping. eexists.
    eapply rename_typed ; try eassumption.
    + reflexivity.
    + eapply typing_wf. eassumption.
  Unshelve. all: exact nAnon.
Defined.

End Lemmata.


(** * Definition and Notations for [do { body }] *)
Require Import Coq.ZArith.BinInt.
Require Import Coq.Classes.Morphisms.
Require Import Coq.micromega.Lia.
Require Import Coq.omega.Omega.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.ZUtil.Z2Nat.
Require Import Crypto.Util.Notations Crypto.Util.CPSNotations.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.UniquePose.

Section with_state.
  Import CPSNotations.
  Context {state : Type}.

  Definition loop_cps_step
             (loop_cps
              : forall (max_iter : nat)
                       (initial : state)
                       (body : state -> forall {T} (continue : state -> T) (break : state -> T), T),
                 ~> state)
             (max_iter : nat)
    : forall (initial : state)
             (body : state -> forall {T} (continue : state -> T) (break : state -> T), T),
      ~> state
    := fun st body
       => match max_iter with
          | 0
            => (return st)
          | S max_iter'
            => fun T ret
               => body st T (fun st' => @loop_cps max_iter' st' body _ ret) ret
          end.

  Fixpoint loop_cps (max_iter : nat)
    : forall (initial : state)
             (body : state -> forall {T} (continue : state -> T) (break : state -> T), T),
      ~> state
    := loop_cps_step loop_cps max_iter.

  Lemma unfold_loop_cps
        (max_iter : nat)
    : loop_cps max_iter
      = loop_cps_step loop_cps max_iter.
  Proof.
    destruct max_iter; reflexivity.
  Qed.

  Theorem loop_cps_def (max_iter : nat)
          (initial : state)
          (body : state -> forall {T} (continue : state -> T) (break : state -> T), T)
          T ret
    : loop_cps (S max_iter) initial body T ret =
      body initial (fun st' => @loop_cps max_iter st' body _ ret) ret.
  Proof.
    reflexivity.
  Qed.

  Theorem loop_cps_ind
          (invariant : state -> Prop)
          T (P : T -> Prop) n v0 body rest
    : invariant v0
      -> (forall v continue break,
             (forall v, invariant v -> P (continue v))
             -> (forall v, invariant v -> P (break v))
             -> invariant v
             -> P (body v T continue break))
      -> (forall v, invariant v -> P (rest v))
      -> P (loop_cps n v0 body T rest).
  Proof.
    revert v0 rest.
    induction n as [|n IHn]; intros v0 rest Hinv Hbody HP; simpl; cbv [cpsreturn]; auto.
  Qed.

  Local Hint Extern 2 => omega.

  (** TODO(REDACTED): Remove this if we don't need it *)
  Theorem loop_cps_wf_ind_break
          (measure : state -> nat)
          (invariant : state -> Prop)
          T (P : T -> Prop) n v0 body rest
    : invariant v0
      -> (forall v continue,
             invariant v
             -> (forall break,
                    (forall v', measure v' < measure v -> invariant v' -> P (continue v'))
                    -> P (body v T continue break))
                \/ P (body v T continue rest))
      -> measure v0 < n
      -> P (loop_cps n v0 body T rest).
  Proof.
    revert v0 rest.
    induction n as [|n IHn]; intros v0 rest Hinv Hbody Hmeasure; simpl; try omega.
    edestruct Hbody as [Hbody'|Hbody']; eauto.
  Qed.

  Theorem loop_cps_wf_ind
          (measure : state -> nat)
          (invariant : state -> Prop)
          T (P : T -> Prop) n v0 body rest
    : invariant v0
      -> (forall v continue,
             invariant v
             -> ((forall v', measure v' < measure v -> invariant v' -> P (continue v'))
                 -> P (body v T continue rest)))
      -> measure v0 < n
      -> P (loop_cps n v0 body T rest).
  Proof.
    revert v0.
    induction n as [|n IHn]; intros v0 Hinv Hbody Hmeasure; simpl; try omega.
    eauto.
  Qed.

  Theorem eq_loop_cps_large_n
          (measure : state -> nat)
          n n' v0 body T rest
    : measure v0 < n
      -> measure v0 < n'
      -> (forall v continue continue',
             (forall v', measure v' < measure v -> continue v' = continue' v')
             -> measure v <= measure v0
             -> body v T continue rest = body v T continue' rest)
      -> loop_cps n v0 body T rest = loop_cps n' v0 body T rest.
  Proof.
    revert n n'.
    match goal with
    | [ |- forall n n', ?P ] => cut (forall n n', n <= n' -> P)
    end.
    { intros H n n' ???.
      destruct (le_lt_dec n n'); [ | symmetry ]; auto. }
    { intros n n' Hle Hn _.
      revert n' Hle v0 Hn.
      induction n as [|n IHn], n' as [|n']; simpl;
        auto with omega. }
  Qed.
End with_state.

(** N.B. If the body is polymorphic (that is, if the type argument
    shows up in the body), then we need to bind the name of the type
    parameter somewhere in the notation for it to show up; we have a
    separate notation for this case. *)
(** TODO: When these notations are finalized, reserve them in Notations.v and moving the level and formatting rules there *)
Notation "'loop' _{ fuel } ( state1 .. staten = initial ) 'labels' ( continue , break , @ T ) {{ body }} ; rest"
  := (@loop_cps _ fuel initial
                (fun state1 => .. (fun staten => id (fun T continue break => body)) .. )
                _ (fun state1 => .. (fun staten => rest) .. ))
       (at level 200, state1 binder, staten binder,
        format "'[v  ' 'loop' _{ fuel }  ( state1 .. staten  =  initial )  'labels'  ( continue ,  break ,  @ T )  {{ '//' body ']' '//' }} ; '//' rest").
Notation "'loop' _{ fuel } ( state1 .. staten = initial ) 'labels' ( continue , break ) {{ body }} ; rest"
  := (@loop_cps _ fuel initial
                (fun state1 => .. (fun staten => id (fun T continue break => body)) .. )
                _ (fun state1 => .. (fun staten => rest) .. ))
       (at level 200, state1 binder, staten binder,
        format "'[v  ' 'loop' _{ fuel }  ( state1 .. staten  =  initial )  'labels'  ( continue ,  break )  {{ '//' body ']' '//' }} ; '//' rest").
Notation "'loop' _{ fuel } ( state1 .. staten = initial ) 'labels' ( continue ) {{ body }} ; rest"
  := (@loop_cps _ fuel initial
                (fun state1 => .. (fun staten => id (fun T continue _ => body)) .. )
                _ (fun state1 => .. (fun staten => rest) .. ))
       (at level 200, state1 binder, staten binder,
        format "'[v  ' 'loop' _{ fuel }  ( state1 .. staten  =  initial )  'labels'  ( continue )  {{ '//' body ']' '//' }} ; '//' rest").

Section with_for_state.
  Import CPSNotations.
  Section with_loop_params.
    Context {state : Type}.
    Context (test : Z -> Z -> bool) (i_final : Z) (upd_i : Z -> Z)
            (body : state -> Z -> forall {T} (continue : state -> T) (break : state -> T), T).

    (* we assume that [upd_i] is linear to compute the fuel *)
    Definition for_cps (i0 : Z) (initial : state)
      : ~> state
      := fun T ret
         => @loop_cps
              (Z * state)
              (S (S (Z.to_nat ((i_final - i0) / (upd_i 0%Z)))))
              (i0, initial)
              (fun '(i, st) T continue break
               => if test i i_final
                  then @body st i T
                             (fun st' => continue (upd_i i, st')%Z)
                             (fun st' => break (i, st'))
                  else break (i, st))
              T (fun '(i, st) => ret st).

    Section lemmas.
      Local Open Scope Z_scope.
      Context (upd_linear : forall x, upd_i x = upd_i 0 + x)
              (upd_nonzero : upd_i 0 <> 0)
              (upd_signed : forall i0, test i0 i_final = true -> 0 <= (i_final - i0) / (upd_i 0)).

      (** TODO: Strengthen this to take into account the value of
                  the loop counter at the end of the loop; based on
                  [ForLoop.v], it should be something like [(finish -
                  Z.sgn (finish - i0 + step - Z.sgn step) * (Z.abs
                  (finish - i0 + step - Z.sgn step) mod Z.abs step) +
                  step - Z.sgn step)] *)
      Theorem for_cps_ind
              (invariant : Z -> state -> Prop)
              T (P : (*Z ->*) T -> Prop) i0 v0 rest
        : invariant i0 v0
          -> (forall i v continue,
                 test i i_final = true
                 -> (forall v, invariant (upd_i i) v -> P (continue v))
                 -> invariant i v
                 -> P (@body v i T continue rest))
          -> (forall i v, test i i_final = false -> invariant i v -> P (rest v))
          -> P (for_cps i0 v0 T rest).
      Proof.
        unfold for_cps, cpscall, cpsreturn.
        intros Hinv IH Hrest.
        eapply @loop_cps_wf_ind with (T:=T)
                                       (invariant := fun '(i, s) => invariant i s)
                                       (measure := fun '(i, s) => Z.to_nat (1 + (i_final - i) / upd_i 0));
          [ assumption
          |
          | solve [ destruct (Z_le_gt_dec 0 ((i_final - i0) / upd_i 0));
                    [ rewrite Z2Nat.inj_add by omega; simpl; omega
                    | rewrite Z2Nat.inj_nonpos by omega; omega ] ] ].
        intros [i st] continue Hinv' IH'.
        destruct (test i i_final) eqn:Hi; [ | solve [ eauto ] ].
        pose proof (upd_signed _ Hi) as upd_signed'.
        assert (upd_i 0 <> 0)
          by (intro H'; rewrite H' in upd_signed'; autorewrite with zsimplify in upd_signed';
              omega).
        specialize (IH i st (fun st' => continue (upd_i i, st')) Hi).
        specialize (fun v pf => IH' (upd_i i, v) pf).
        cbv beta iota in *.
        specialize (fun pf v => IH' v pf).
        rewrite upd_linear in IH'.
        replace ((i_final - (upd_i 0 + i)) / upd_i 0)
        with ((i_final - i) / upd_i 0 - 1)
          in IH'
          by (Z.div_mod_to_quot_rem; nia).
        rewrite <- upd_linear, Zplus_minus, Z2Nat.inj_add in IH' by omega.
        auto with omega.
      Qed.

      Theorem for_cps_unroll1
              T i0 v0 rest
              (body_Proper : Proper (eq ==> eq ==> forall_relation (fun T => (pointwise_relation _ eq) ==> eq ==> eq)) body)
        : for_cps i0 v0 T rest
          = if test i0 i_final
            then @body v0 i0 T
                       (fun v => for_cps (upd_i i0) v T rest)
                       rest
            else rest v0.
      Proof.
        unfold for_cps at 1.
        rewrite loop_cps_def.
        destruct (test i0 i_final) eqn:Hi; [ | reflexivity ].
        apply body_Proper; [ reflexivity | reflexivity | intro st | reflexivity ].
        assert (Hto0 : forall x, x <= 0 -> Z.to_nat x = 0%nat)
          by (intros []; intros; simpl; lia).
        apply eq_loop_cps_large_n with (measure := fun '(i, st) => Z.to_nat (1 + (i_final - i) / upd_i 0));
          repeat first [ progress intros
                       | reflexivity
                       | progress destruct_head'_prod
                       | progress unfold pointwise_relation
                       | break_innermost_match_step
                       | apply body_Proper
                       | omega
                       | rewrite Zdiv.Zdiv_0_r in *
                       | rewrite ?(Z.add_opp_r _ 1), Zplus_minus, <- ?(Z.add_opp_r _ 1) in *
                       | match goal with
                         | [ H : forall v, _ -> ?continue _ = ?continue' _ |- ?continue _ = ?continue' _ ] => apply H
                         | [ |- context[upd_i ?x] ]
                           => lazymatch x with
                              | 0 => fail
                              | _ => rewrite (upd_linear x)
                              end
                         | [ H : ?x = 0 |- context[?x] ] => rewrite H
                         | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
                         | [ H : forall i, ?f i ?y = true -> ?R (_ / 0), H' : ?f _ ?y = true |- _ ]
                           => specialize (H _ H')
                         | [ |- context[?i_final - (upd_i 0 + ?i0)] ]
                           => replace (i_final - (upd_i 0 + i0)) with ((i_final - i0) + (-1) * upd_i 0) by omega;
                              rewrite Zdiv.Z_div_plus_full by assumption
                         end
                       | lazymatch goal with
                         | [ H : upd_i 0 = 0 |- _ ] => fail
                         | [ H : upd_i 0 <> 0 |- _ ] => fail
                         | _ => destruct (Z_zerop (upd_i 0))
                         end
                       | match goal with
                         | [ |- context[S (Z.to_nat ?x)] ]
                           => destruct (Z_lt_le_dec 0 x);
                              [ rewrite <- (Z2Nat.inj_succ x) by omega
                              | rewrite !(Hto0 x) by omega ]
                         | [ |- (Z.to_nat _ < Z.to_nat _)%nat ]
                           => apply Z2Nat.inj_lt
                         | [ |- (Z.to_nat ?x < ?n)%nat ]
                           => apply (Z2Nat.inj_lt x (Z.of_nat n)); simpl
                         | [ H : forall i, ?f i ?y = true -> 0 <= _ / _, H' : ?f _ ?y = true |- _ ]
                           => specialize (H _ H')
                         end ].
      Qed.
    End lemmas.
  End with_loop_params.
End with_for_state.

Delimit Scope for_upd_scope with for_upd.
Delimit Scope for_test_scope with for_test.
Notation "i += k" := (Z.add i k) : for_upd_scope.
Notation "i -= k" := (Z.sub i k) : for_upd_scope.
Notation "i ++" := (i += 1)%for_upd : for_upd_scope.
Notation "i --" := (i -= 1)%for_upd : for_upd_scope.
Notation "<" := Z.ltb (at level 71) : for_test_scope.
Notation ">" := Z.gtb (at level 71) : for_test_scope.
Notation "<=" := Z.leb (at level 71) : for_test_scope.
Notation ">=" := Z.geb (at level 71) : for_test_scope.
Notation "≤" := Z.leb (at level 71) : for_test_scope.
Notation "≥" := Z.geb (at level 71) : for_test_scope.
Global Close Scope for_test_scope. (* TODO: make these notations not print all over the place *)

Definition force_idZ (f : Z -> Z) (pf : f = id) {T} (v : T) := v.
(** [lhs] and [cmp_expr] go at level 9 so that they bind more tightly
    than application (so that [i (<)] sticks [i] in [lhs] and [(<)] in
    [cmp_expr], rather than sticking [i (<)] in [lhs] and then
    complaining about a missing value for [cmp_expr].  Unfortunately,
    because the comparison operators need to be at level > 70 to not
    conflict with their infix versions, putting [cmp_expr] at level 9
    forces us to wrap parentheses around the comparison operator. *)
(** TODO(REDACTED): If it's worth it, duplicate these notations for
      each value of [cmp_expr] so that we don't need to wrap the
      comparison operator in parentheses. *)
(** TODO: When these notations are finalized, reserve them in Notations.v and moving the level and formatting rules there *)
Notation "'for' ( i1 .. i2 = i0 ; lhs cmp_expr final ; upd_expr ) 'updating' ( state1 .. staten = initial ) 'labels' ( continue , break , @ T ) {{ body }} ; rest"
  := (force_idZ
        (fun i1 => .. (fun i2 => lhs) ..)
        eq_refl
        (@for_cps _ cmp_expr%for_test
                  final
                  (fun i1 => .. (fun i2 => upd_expr%for_upd) .. )
                  (fun state1 => .. (fun staten => id (fun i1 => .. (fun i2 => id (fun T continue break => body)) .. )) .. )
                  i0
                  initial
                  _ (fun state1 => .. (fun staten => rest) .. )))
       (at level 200, state1 binder, staten binder, i1 binder, i2 binder, lhs at level 9, cmp_expr at level 9,
        format "'[v  ' 'for'  ( i1 .. i2  =  i0 ;  lhs  cmp_expr  final ;  upd_expr )  'updating'  ( state1 .. staten  =  initial )  'labels'  ( continue ,  break ,  @ T )  {{ '//' body ']' '//' }} ; '//' rest").
Notation "'for' ( i1 .. i2 = i0 ; lhs cmp_expr final ; upd_expr ) 'updating' ( state1 .. staten = initial ) 'labels' ( continue , break ) {{ body }} ; rest"
  := (force_idZ
        (fun i1 => .. (fun i2 => lhs) ..)
        eq_refl
        (@for_cps _ cmp_expr%for_test
                  final
                  (fun i1 => .. (fun i2 => upd_expr%for_upd) .. )
                  (fun state1 => .. (fun staten => id (fun i1 => .. (fun i2 => id (fun T continue break => body)) .. )) .. )
                  i0
                  initial
                  _ (fun state1 => .. (fun staten => rest) .. )))
       (at level 200, state1 binder, staten binder, i1 binder, i2 binder, lhs at level 9, cmp_expr at level 9,
        format "'[v  ' 'for'  ( i1 .. i2  =  i0 ;  lhs  cmp_expr  final ;  upd_expr )  'updating'  ( state1 .. staten  =  initial )  'labels'  ( continue ,  break )  {{ '//' body ']' '//' }} ; '//' rest").
Notation "'for' ( i1 .. i2 = i0 ; lhs cmp_expr final ; upd_expr ) 'updating' ( state1 .. staten = initial ) 'labels' ( continue ) {{ body }} ; rest"
  := (force_idZ
        (fun i1 => .. (fun i2 => lhs) ..)
        eq_refl
        (@for_cps _ cmp_expr%for_test
                  final
                  (fun i1 => .. (fun i2 => upd_expr%for_upd) .. )
                  (fun state1 => .. (fun staten => id (fun i1 => .. (fun i2 => id (fun T continue break => body)) .. )) .. )
                  i0
                  initial
                  _ (fun state1 => .. (fun staten => rest) .. )))
       (at level 200, state1 binder, staten binder, i1 binder, i2 binder, lhs at level 9, cmp_expr at level 9,
        format "'[v  ' 'for'  ( i1 .. i2  =  i0 ;  lhs  cmp_expr  final ;  upd_expr )  'updating'  ( state1 .. staten  =  initial )  'labels'  ( continue )  {{ '//' body ']' '//' }} ; '//' rest").

Section LoopTest.
  Import CPSNotations.
  Check loop _{ 10 } (x = 0) labels (continue, break) {{ continue (x + 1) }} ; x.

  Check
    loop _{ 1234 } ('(i, a) = (0, 0)) labels (continue, break)
    {{
        if i <? 10
        then
          continue (i + 1, a+1)
        else
          break (0, a)
    }};
    a.

  Context (f:nat~>nat).

  Check x <- f 0 ; return x + x.
  Check x <- f 0 ; y <- f x; z <- f y; return (x,y,z).

 Check loop _{ 10 } (x = 0) labels (continue, break) {{ continue (x + 1) }} ;
   return x.

 Check loop _{ 10 } (x = 0) labels (continue, break) {{ continue (x + 1) }} ;
   x <- f x;
   return x.

  Check loop _{ 10 } (x = 0) labels (continue, break) {{ x <- f x ; continue (x) }} ; x.

  Context (s F : Z) (zero : nat).
  Check for ( i = s; i (<) F; i++) updating (P = zero) labels (continue, break)
  {{
      continue (P+P)
  }};
  P.

  Check for ( i = s; i (<) F; i++) updating (P = zero) labels (continue)
  {{
      P <- f P;
      continue (P+P)
  }};
  P.
End LoopTest.

Module CPSBoilerplate.
  Import CPSNotations.
  Definition valid {R} (f:~>R) :=
    forall {T} (continuation:R->T),
      (x <- f; continuation x) = (continuation (f _ id)).
  Existing Class valid.
End CPSBoilerplate.

Require Import Coq.Classes.Morphisms.
Require Import Crypto.Algebra.ScalarMult.
Section ScalarMult.
  Import CPSNotations.

  Context {G} (zero:G) (k w : Z) (add_tbl : G -> Z -> Z ~> G) (nth_limb : Z ~> Z). (* k w-bit limbs *)

  Definition ScalarMultBase :=
    for ( i = 0; i (<) k; i++) updating (P = zero) labels (continue, break)
    {{
      x <- nth_limb i;
      P <- add_tbl P i x;
      continue P
    }};
    P.

  Context {Geq add opp} {Hmonoid:@Algebra.Hierarchy.group G Geq add zero opp}.
  Local Notation smul := (@scalarmult_ref G add zero opp).
  Context {nth_limb_valid : forall a, CPSBoilerplate.valid (nth_limb a)}.
  Context {add_tbl_valid : forall a b c, CPSBoilerplate.valid (add_tbl a b c)}.
  Context {Proper_add_tbl : Proper (Geq ==> eq ==> eq ==> Geq) (fun a b c => add_tbl a b c _ id)}.
  Context (B:G).
  Context {limb_good}
          {nth_limb_good: forall i, (0 <= i < k)%Z -> limb_good i (nth_limb i _ id)}
          {add_tbl_correct : forall P i limb,
              limb_good i limb -> Geq (add_tbl P i limb G id) (add P (smul (2 ^ i * limb) B))}.

  Definition n_upto t : Z :=
    for ( i = 0; i (<) t; i++) updating (n = 0%Z) labels (continue)
    {{
            x <- nth_limb i;
            continue (n + (2^i)*x)%Z
    }};
    n.

  Lemma ScalarMultBase_correct : Geq ScalarMultBase (smul (n_upto k) B).
    cbv [ScalarMultBase].
    eapply for_cps_ind with (invariant := fun i P => Geq P (smul (n_upto i) B )%Z).
    - intros; omega.
    - omega.
    - intros; rewrite Z.ltb_lt in H; autorewrite with zsimplify; omega.
    - autorewrite with zsimplify. symmetry; eapply (scalarmult_0_l(add:=add)).
    - cbv [force_idZ id]; intros. clear H.
      setoid_rewrite nth_limb_valid; setoid_rewrite add_tbl_valid.
      setoid_rewrite <-H0; [reflexivity|]; clear H0.

      etransitivity.
      eapply Proper_add_tbl; [eapply H1|reflexivity|reflexivity].
      clear H1.
      replace (n_upto (i+1))%Z with (n_upto i + (2^i)*(nth_limb i _ id))%Z by admit.
      rewrite scalarmult_add_l.
      rewrite add_tbl_correct; [reflexivity|].
      apply nth_limb_good.
      admit.
  Admitted.
End ScalarMult.


From Usuba Require Import usuba_AST.
Require Import String.
Require Import List.

Declare Scope Usuba.
Delimit Scope Usuba with usuba.
Declare Scope Usuba_var_decl.
Delimit Scope Usuba_var_decl with ua_var_decl.
Declare Scope Usuba_type.
Delimit Scope Usuba_type with ua_type.
Declare Scope Usuba_eqn.
Delimit Scope Usuba_eqn with ua_eqn.
Declare Scope Usuba_expr.
Delimit Scope Usuba_expr with ua_expr.
Declare Scope Usuba_arith_expr.
Delimit Scope Usuba_arith_expr with ua_aexpr.
Declare Scope Usuba_var.
Delimit Scope Usuba_var with ua_var.

Coercion ExpVar : var >-> expr.
Coercion Const_e : nat >-> arith_expr.
Coercion Var : ident >-> var.

Notation "x '&' y" := (Log And (x)%ua_expr (y)%ua_expr) (at level 87, left associativity) : Usuba_expr.
Notation "x 'xor' y" := (Log Xor (x)%ua_expr (y)%ua_expr) (at level 87, left associativity) : Usuba_expr.
Notation "x '<<' y" := (Shift Lshift (x)%ua_expr (y)%ua_aexpr) (at level 87, left associativity) : Usuba_expr.
Notation "x '>>' y" := (Shift Rshift (x)%ua_expr (y)%ua_aexpr) (at level 87, left associativity) : Usuba_expr.
Notation "x '<<<' y" := (Shift Lrotate (x)%ua_expr (y)%ua_aexpr) (at level 87, left associativity) : Usuba_expr.
Notation "x '>>>' y" := (Shift Rrotate (x)%ua_expr (y)%ua_aexpr) (at level 87, left associativity) : Usuba_expr.

Notation "v '[' e ']'" := (Index (v)%ua_var (e)%ua_aexpr) (at level 88, left associativity) : Usuba_var.

Notation "a '<=' b ';' tl" := (Dcons (Eqn (a)%ua_var (b)%ua_expr false) tl)
    (at level 90, right associativity) : Usuba_eqn.

Notation "a '<:=' b ';' tl" := (Dcons (Eqn (a)%ua_var (b)%ua_expr true) tl)
    (at level 90, right associativity) : Usuba_eqn.

Notation "a '<:=' b ';'" := (a <:= b ; Dnil)%ua_eqn
    (at level 89, no associativity) : Usuba_eqn.
(* Notation "a '<=' b ';'" := (a <= b ; Dnil)%ua_eqn
    (at level 89, no associativity) : Usuba_eqn. *)

Notation "hd ',' tl" :=
    ((hd)%ua_var_decl ++ (tl)%ua_var_decl)
        (at level 90, right associativity) : Usuba_var_decl.

Notation " var ':' typ" :=
    ({| VD_ID := (var)%string; VD_TYP := (typ)%ua_type ; VD_OPTS := nil |}::nil)
        (at level 89, no associativity) : Usuba_var_decl.

Notation "'node' name 'args' var_decl 'returns' var_decl2 'vars' var_decl3 'let' eqns 'tel'" :=
    {|
        ID := name;
        P_IN := (var_decl)%ua_var_decl;
        P_OUT := (var_decl2)%ua_var_decl;
        OPT := No_opt;
        NODE := Single (var_decl3)%ua_var_decl (eqns)%ua_eqn
    |} (at level 90).

Definition test : string := "test".
Definition a : string := "a".
Definition b : string := "b".

Definition node1 := node test args (a : Nat) returns (b : Nat) vars nil
    let (Var b [ Const_e 1 ])%ua_var :: nil <:= ExpVar (Var a); tel.

Definition f : ident := "f"%string.
Definition x : ident := "x"%string.
Definition y : ident := "y"%string.

Definition refresh : ident := "refresh"%string.

Definition f_node := node f args (x : Uint Vslice (Mint 32) 1) returns (y: Uint Vslice (Mint 32) 1) vars nil
    let
        Var y :: nil <:= ((x <<< 5) & Fun refresh (ECons x Enil)) xor (x <<< 1);
    tel.

Print f_node.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal11.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero)         (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))).
Definition lfind_example_2  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_3  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_4  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_5  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_6  := ( Cons (Succ Zero) Nil).
Definition lfind_example_7  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_8  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_9  := ( Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil).
Definition lfind_example_10  := ( Cons (Succ (Succ (Succ (Succ Zero))))         (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_11  := ( Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))))).
Definition lfind_example_12  := ( Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil)).
Definition lfind_example_13  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_14  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_15  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_16  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_17  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_18  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_19  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_20  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal11_lem2_41_lem/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 .


Require Import Lang.Syntax Lang.Bindings_map Lang.BindingsFacts_map_0.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_EV_map_map.

Definition
  EV_map_map_ef (EV1 EV2 EV3 HV L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (ε : ef EV1 HV L) :
  EV_map_ef f₂ (EV_map_ef f₁ ε) = EV_map_ef g ε
.
Proof.
destruct ε ; simpl ;
crush.
Qed.

Fixpoint
  EV_map_map_eff (EV1 EV2 EV3 HV L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (𝓔 : eff EV1 HV L) :
  EV_map_eff f₂ (EV_map_eff f₁ 𝓔) = EV_map_eff g 𝓔
.
Proof.
destruct 𝓔 ; simpl ;
repeat erewrite EV_map_map_ef ;
repeat erewrite EV_map_map_eff ;
crush.
Qed.

Fixpoint
  EV_map_map_ty (EV1 EV2 EV3 HV L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (T : ty EV1 HV L) {struct T} :
  EV_map_ty f₂ (EV_map_ty f₁ T) = EV_map_ty g T.
Proof.
+ destruct T ; simpl ;
  repeat erewrite EV_map_map_ty ;
  repeat erewrite EV_map_map_eff ;
  crush.
Qed.

Fixpoint
  EV_map_map_hd (EV1 EV2 EV3 HV V L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (h : hd EV1 HV V L) {struct h} :
  EV_map_hd f₂ (EV_map_hd f₁ h) = EV_map_hd g h
with
  EV_map_map_val (EV1 EV2 EV3 HV V L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (v : val EV1 HV V L) {struct v} :
  EV_map_val f₂ (EV_map_val f₁ v) = EV_map_val g v
with
  EV_map_map_tm (EV1 EV2 EV3 HV V L : Set)
  (f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (t : tm EV1 HV V L) {struct t} :
  EV_map_tm f₂ (EV_map_tm f₁ t) = EV_map_tm g t.
Proof.
+ destruct h ; simpl ;
  repeat erewrite EV_map_map_hd ;
  repeat erewrite EV_map_map_tm ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite EV_map_map_hd ;
  repeat erewrite EV_map_map_ty ;
  repeat erewrite EV_map_map_tm ;
  repeat erewrite EV_map_map_eff ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite EV_map_map_ty ;
  repeat erewrite EV_map_map_eff ;
  repeat erewrite EV_map_map_val ;
  repeat erewrite EV_map_map_tm ;
  repeat erewrite EV_map_map_hd ;
  crush.
Qed.

Lemma EV_map_map_XEnv
(EV1 EV2 EV3 HV : Set)
(f₁ : EV1 → EV2) (f₂ : EV2 → EV3) (g : EV1 → EV3)
(Hf : ∀ x, f₂ (f₁ x) = g x)
(Ξ : XEnv EV1 HV) :
EV_map_XEnv f₂ (EV_map_XEnv f₁ Ξ) = EV_map_XEnv g Ξ.
Proof.
induction Ξ as [ | ? ? [] ] using env_ind.
+ repeat rewrite EV_map_XEnv_empty ; reflexivity.
+ repeat rewrite EV_map_XEnv_concat, EV_map_XEnv_single.
  erewrite EV_map_map_ty, EV_map_map_eff, IHΞ ; crush.
Qed.

End section_EV_map_map.

Section section_HV_map_map.

Definition
  HV_map_map_lbl (HV1 HV2 HV3 L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (ℓ : lbl HV1 L) :
  HV_map_lbl f₂ (HV_map_lbl f₁ ℓ) = HV_map_lbl g ℓ
.
Proof.
destruct ℓ ; simpl ;
crush.
Qed.

Definition
  HV_map_map_ef (EV HV1 HV2 HV3 L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (ε : ef EV HV1 L) :
  HV_map_ef f₂ (HV_map_ef f₁ ε) = HV_map_ef g ε
.
Proof.
destruct ε ; simpl ;
repeat erewrite HV_map_map_lbl ;
crush.
Qed.

Fixpoint
  HV_map_map_eff (EV HV1 HV2 HV3 L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (𝓔 : eff EV HV1 L) :
  HV_map_eff f₂ (HV_map_eff f₁ 𝓔) = HV_map_eff g 𝓔
.
Proof.
destruct 𝓔 ; simpl ;
repeat erewrite HV_map_map_ef ;
repeat erewrite HV_map_map_eff ;
crush.
Qed.

Fixpoint
  HV_map_map_ty (EV HV1 HV2 HV3 L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (T : ty EV HV1 L) {struct T} :
  HV_map_ty f₂ (HV_map_ty f₁ T) = HV_map_ty g T.
Proof.
+ destruct T ; simpl ;
  repeat erewrite HV_map_map_ty ;
  repeat erewrite HV_map_map_eff ;
  repeat erewrite HV_map_map_lbl ;
  crush.
Qed.

Fixpoint
  HV_map_map_hd (EV HV1 HV2 HV3 V L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (h : hd EV HV1 V L) {struct h} :
  HV_map_hd f₂ (HV_map_hd f₁ h) = HV_map_hd g h
with
  HV_map_map_val (EV HV1 HV2 HV3 V L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (v : val EV HV1 V L) {struct v} :
  HV_map_val f₂ (HV_map_val f₁ v) = HV_map_val g v
with
  HV_map_map_tm (EV HV1 HV2 HV3 V L : Set)
  (f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (t : tm EV HV1 V L) {struct t} :
  HV_map_tm f₂ (HV_map_tm f₁ t) = HV_map_tm g t.
Proof.
+ destruct h ; simpl ;
  repeat erewrite HV_map_map_hd ;
  repeat erewrite HV_map_map_tm ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite HV_map_map_hd ;
  repeat erewrite HV_map_map_ty ;
  repeat erewrite HV_map_map_tm ;
  repeat erewrite HV_map_map_eff ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite HV_map_map_ty ;
  repeat erewrite HV_map_map_eff ;
  repeat erewrite HV_map_map_val ;
  repeat erewrite HV_map_map_tm ;
  repeat erewrite HV_map_map_hd ;
  crush.
Qed.

Lemma HV_map_map_XEnv
(EV HV1 HV2 HV3 : Set)
(f₁ : HV1 → HV2) (f₂ : HV2 → HV3) (g : HV1 → HV3)
(Hf : ∀ x, f₂ (f₁ x) = g x)
(Ξ : XEnv EV HV1) :
HV_map_XEnv f₂ (HV_map_XEnv f₁ Ξ) = HV_map_XEnv g Ξ.
Proof.
induction Ξ as [ | ? ? [] ] using env_ind.
+ repeat rewrite HV_map_XEnv_empty ; reflexivity.
+ repeat rewrite HV_map_XEnv_concat, HV_map_XEnv_single.
  erewrite HV_map_map_ty, HV_map_map_eff, IHΞ ; crush.
Qed.

End section_HV_map_map.

Section section_L_map_map.

Definition
  L_map_map_lid (L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (id : lid L1) :
  L_map_lid f₂ (L_map_lid f₁ id) = L_map_lid g id
.
Proof.
destruct id ; simpl ; crush.
Qed.

Definition
  L_map_map_lbl (HV L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (ℓ : lbl HV L1) :
  L_map_lbl f₂ (L_map_lbl f₁ ℓ) = L_map_lbl g ℓ
.
Proof.
destruct ℓ ; simpl ;
repeat erewrite L_map_map_lid ;
crush.
Qed.

Definition
  L_map_map_ef (EV HV L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (ε : ef EV HV L1) :
  L_map_ef f₂ (L_map_ef f₁ ε) = L_map_ef g ε
.
Proof.
destruct ε ; simpl ;
repeat erewrite L_map_map_lbl ;
crush.
Qed.

Fixpoint
  L_map_map_eff (EV HV L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (𝓔 : eff EV HV L1) :
  L_map_eff f₂ (L_map_eff f₁ 𝓔) = L_map_eff g 𝓔
.
Proof.
destruct 𝓔 ; simpl ;
repeat erewrite L_map_map_ef ;
repeat erewrite L_map_map_eff ;
crush.
Qed.

Fixpoint
  L_map_map_ty (EV HV L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (T : ty EV HV L1) {struct T} :
  L_map_ty f₂ (L_map_ty f₁ T) = L_map_ty g T.
Proof.
+ destruct T ; simpl ;
  repeat erewrite L_map_map_ty ;
  repeat erewrite L_map_map_eff ;
  repeat erewrite L_map_map_lbl ;
  crush.
Qed.

Fixpoint
  L_map_map_hd (EV HV V L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (h : hd EV HV V L1) {struct h} :
  L_map_hd f₂ (L_map_hd f₁ h) = L_map_hd g h
with
  L_map_map_val (EV HV V L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (v : val EV HV V L1) {struct v} :
  L_map_val f₂ (L_map_val f₁ v) = L_map_val g v
with
  L_map_map_tm (EV HV V L1 L2 L3 : Set)
  (f₁ : L1 → L2) (f₂ : L2 → L3) (g : L1 → L3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (t : tm EV HV V L1) {struct t} :
  L_map_tm f₂ (L_map_tm f₁ t) = L_map_tm g t.
Proof.
+ destruct h ; simpl ;
  repeat erewrite L_map_map_hd ;
  repeat erewrite L_map_map_tm ;
  repeat erewrite L_map_map_lid ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite L_map_map_hd ;
  repeat erewrite L_map_map_lid ;
  repeat erewrite L_map_map_ty ;
  repeat erewrite L_map_map_eff ;
  repeat erewrite L_map_map_tm ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite L_map_map_ty ;
  repeat erewrite L_map_map_eff ;
  repeat erewrite L_map_map_val ;
  repeat erewrite L_map_map_tm ;
  repeat erewrite L_map_map_hd ;
  crush.
Qed.

End section_L_map_map.

Fixpoint
  V_map_map_hd (EV HV V1 V2 V3 L : Set)
  (f₁ : V1 → V2) (f₂ : V2 → V3) (g : V1 → V3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (h : hd EV HV V1 L) {struct h} :
  V_map_hd f₂ (V_map_hd f₁ h) = V_map_hd g h
with
  V_map_map_val (EV HV V1 V2 V3 L : Set)
  (f₁ : V1 → V2) (f₂ : V2 → V3) (g : V1 → V3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (v : val EV HV V1 L) {struct v} :
  V_map_val f₂ (V_map_val f₁ v) = V_map_val g v
with
  V_map_map_tm (EV HV V1 V2 V3 L : Set)
  (f₁ : V1 → V2) (f₂ : V2 → V3) (g : V1 → V3)
  (Hf : ∀ x, f₂ (f₁ x) = g x)
  (t : tm EV HV V1 L) {struct t} :
  V_map_tm f₂ (V_map_tm f₁ t) = V_map_tm g t.
Proof.
+ destruct h ; simpl ;
  repeat erewrite V_map_map_hd ;
  repeat erewrite V_map_map_tm ;
  crush.
+ destruct v ; simpl ;
  repeat erewrite V_map_map_hd ;
  repeat erewrite V_map_map_tm ;
  crush.
+ destruct t ; simpl ;
  repeat erewrite V_map_map_ty ;
  repeat erewrite V_map_map_eff ;
  repeat erewrite V_map_map_val ;
  repeat erewrite V_map_map_tm ;
  repeat erewrite V_map_map_hd ;
  crush.
Qed.