Require Import List.
Require Import String.
Open Scope string_scope.

Definition var := string.

Inductive Expr : Set :=
| Var : var -> Expr
| App : Expr -> Expr -> Expr
| Lam : var -> Expr -> Expr.

Notation "'V' x" := (Var x) (at level 48).
Notation "e1 @ e2" := (App e1 e2) (at level 49).
Notation "\ x , t" := (Lam x t) (at level 50).

Check (\"x", \"y", V"x").
Check (\"x", \"y", V"y").
Check ((\"x", V"x" @ V"x") @ (\"x", V"x" @ V"x")).

(* e1[e2/x] = e3 *)
Inductive Subst : Expr -> Expr -> var ->
                  Expr -> Prop :=
| SubstVar_same : forall e x,
  Subst (V x) e x e
| SubstVar_diff : forall e x1 x2,
  x1 <> x2 ->
  Subst (V x1) e x2 (V x1)
| SubstApp : forall eA eB e x eA' eB',
  Subst eA e x eA' ->
  Subst eB e x eB' ->
  Subst (eA @ eB) e x (eA' @ eB')
| SubstLam_same : forall eA e x,
  Subst (\x, eA) e x (\x, eA)
| SubstLam_diff : forall eA e x1 x2 eA',
  x1 <> x2 ->
  Subst eA e x2 eA' ->
  Subst (\x1, eA) e x2 (\x1, eA').

Lemma subst_test_1:
  Subst (\"x", V"y") (V"z") "y" (\"x", V"z").
Proof.
  constructor.
  { discriminate. }
  { constructor. }
Qed.

Lemma subst_test_2:
  Subst (\"x", V"x") (V"z") "x"
        (\"x", V"x").
Proof.
  constructor.
Qed.

(**
Small Step:
<<
       e1 --> e1'
  ---------------------
    e1 e2 --> e1' e2

  -----------------------------
    (\x. e1) e2 --> e1[e2/x]
>>
*)

Inductive SStep : Expr -> Expr -> Prop :=
| Scrunch : forall e1 e1' e2,
  SStep e1 e1' ->
  SStep (e1 @ e2) (e1' @ e2)
| Ssubst : forall x e1 e2 e1',
  Subst e1 e2 x e1' ->
  SStep ((\x, e1) @ e2) e1'.

Notation "e1 --> e2" := (SStep e1 e2) (at level 51).

Lemma sstep_test_1:
  (\"x", V"x") @ V"z" --> V"z".
Proof.
  apply Ssubst.
  apply SubstVar_same.
Qed.

Lemma Lam_nostep:
  forall x e1 e2,
  ~ (\x, e1 --> e2).
Proof.
  intros. intro. inversion H.
Qed.

(*

Lemma Subst_det:
  forall e1 e2 x e3 e3',
  Subst e1 e2 x e3 ->
  Subst e1 e2 x e3' ->
  e3 = e3'.
Proof.
  intros. induction H.
  - inversion H0; subst.
    + reflexivity.
    + congruence.
  - inversion H0; subst.
    + congruence.
    + reflexivity.
  - inversion H0; subst.
    (* stuck, IH not strong enough... *)
Abort.

*)

Lemma Subst_det:
  forall e1 e2 x e3,
  Subst e1 e2 x e3 ->
  forall e3',
  Subst e1 e2 x e3' ->
  e3 = e3'.
Proof.
  induction 1; intros.
  { inversion H; subst; auto.
    congruence.
  }
  { inversion H0; subst; auto.
    congruence.
  }
  { inversion H1; subst; auto.
    f_equal; auto.
  }
  { inversion H; subst; auto.
    congruence.
  }
  { inversion H1; subst; auto.
    { congruence. }
    { f_equal; auto. }
  }
Qed.

Lemma SStep_det:
  forall e e1,
  e --> e1 ->
  forall e2,
  e --> e2 ->
  e1 = e2.
Proof.
  intro. intro. intro. induction H.
  { intros. inversion H0.
    { subst. f_equal. auto. }
    { subst. apply Lam_nostep in H. contradiction. }
  }
  { intros. inversion H0.
    { subst. apply Lam_nostep in H4. contradiction. }
    { subst. eapply Subst_det in H5.
      { eassumption. }
      { assumption. }
    }
  }
Qed.

(**
Big Step:
<<

  ---------------------
    \x. e ==> \x. e

    e1 ==> \x.e1'   e1'[e2/x] ==> v
  ------------------------------------
            e1 e2 ==> v
>>
*)

Inductive BStep : Expr -> Expr -> Prop :=
| BSval : forall x e,
  BStep (\x, e) (\x, e)
| BSsubst : forall e1 e2 x e1' e2' v,
  BStep e1 (\x, e1') ->
  Subst e1' e2 x e2' ->
  BStep e2' v ->
  BStep (e1 @ e2) v.

Notation "e1 ==> e2" := (BStep e1 e2) (at level 51).

Lemma bstep_test_1:
  (\"x", V"x") @ (\"y", V"y") ==> (\"y", V"y").
Proof.
  econstructor.
  { left. }
  { constructor. }
  { left. }
Qed.

Lemma bstep_test_2:
  forall e,
  ~ (V"x" ==> e).
Proof.
  intro. intro. inversion H.
Qed.

Lemma bstep_lam_inv:
  forall x1 e1 x2 e2,
  \x1, e1 ==> \x2, e2 ->
  x1 = x2 /\ e1 = e2.
Proof.
  intros. inversion H. auto.
Qed.

Lemma bstep_test_3:
  forall e1,
  e1 = (\"x", V"x" @ V"x") @ (\"x", V"x" @ V"x") ->
  forall e2,
  ~ (e1 ==> e2).
Proof.
  intros. intro. induction H0.
  { discriminate. }
  { inversion H. subst. inversion H0_. subst. inversion H0. subst. inversion H3.
    { subst. inversion H7.
      { subst. auto. }
      { auto. }
    }
    { auto. }
  }
Qed.

Lemma bstep_det:
  forall e e1,
  e ==> e1 ->
  forall e2,
  e ==> e2 ->
  e1 = e2.
Proof.
  intro. intro. intro. induction H.
  { intros. inversion H. reflexivity. }
  { intros. inversion H2. subst.
    apply IHBStep1 in H5. inversion H5. subst.
    replace e2'0 with e2' in *.
    { auto. }
    { eapply Subst_det.
      { eassumption. }
      { assumption. }
    }
  }
Qed.

Inductive SSstar : Expr -> Expr -> Prop :=
| SSrefl : forall e,
  SSstar e e
| SSstep : forall e e' e'',
  SStep e e' ->
  SSstar e' e'' ->
  SSstar e e''.

Notation "e1 -->* e2" := (SSstar e1 e2) (at level 51).

Lemma SStar_trans:
  forall e1 e2 e3,
  e1 -->* e2 ->
  e2 -->* e3 ->
  e1 -->* e3.
Proof.
  intros. induction H.
  { assumption. }
  { econstructor.
    { eassumption. }
    { auto. }
  }
Qed.

Lemma SStar_crunch_left:
  forall e1 e1',
  e1 -->* e1' ->
  forall e2,
  e1 @ e2 -->* e1' @ e2.
Proof.
  intro. intro. intro. induction H.
  { left. }
  { intro. econstructor.
    { left. eassumption. }
    { auto. }
  }
Qed.

Lemma BStep_SSstar:
  forall e1 e2,
  e1 ==> e2 ->
  e1 -->* e2.
Proof.
  intros. induction H.
  { left. }
  { eapply SStar_trans with (e2 := (\x, e1') @ e2).
    { apply SStar_crunch_left. assumption. }
    { econstructor.
      { right. eassumption. }
      { assumption. }
    }
  }
Qed.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     general_category.

Section IdentityTransformation.
  Context {C D : BiCategory}
          `{Univalence}.
  Variable (F : LaxFunctor C D).

  Definition identity_transformation_d : PseudoTransformation_d F F.
  Proof.
    make_pseudo_transformation.
    - exact (fun X => id₁ (F X)).
    - intros X Y f ; simpl in *.
      exact (left_unit_inv (F ₁ f) ∘ right_unit (F ₁ f)).
    - intros X Y f ; simpl in *.
      exact (right_unit_inv (F ₁ f) ∘ left_unit (F ₁ f)).
  Defined.

  Definition is_lax_identity_transformation
    : is_pseudo_transformation_p identity_transformation_d.
  Proof.
    make_is_pseudo_transformation.
    - intros X Y f g α ; simpl in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite !vcomp_assoc.
      reflexivity.
    - intros X ; simpl in *.
      rewrite <- right_unit_id_is_left_unit_id.
      rewrite !vcomp_assoc.
      rewrite right_unit_right.
      rewrite vcomp_right_identity.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite right_unit_id_is_left_unit_id.
      rewrite vcomp_assoc.
      rewrite left_unit_right.
      apply vcomp_right_identity.
    - intros X Y Z f g ; simpl in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      symmetry.
      rewrite <- (vcomp_left_identity (id₂ (F ₁ f))).
      rewrite <- (vcomp_left_identity (id₂ (F ₁ g))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ z))) (vcomp_assoc _ _ _)^).
      rewrite triangle_l.
      rewrite <- interchange.
      rewrite left_unit_left.
      rewrite vcomp_left_identity, hcomp_id₂.
      rewrite !vcomp_left_identity.
      f_ap.
      rewrite <- right_unit_assoc.
      rewrite <- !vcomp_assoc.
      f_ap.
      pose (left_unit_inv_assoc (F ₁ g) (F ₁ f)) as p.
      unfold bc_whisker_r in p.
      rewrite p ; clear p.
      rewrite <- vcomp_assoc.
      rewrite assoc_left.
      apply vcomp_left_identity.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite right_unit_left, vcomp_left_identity.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite left_unit_left, vcomp_left_identity.
      apply right_unit_right.
  Qed.

  Definition identity_transformation
    : PseudoTransformation F F
    := Build_PseudoTransformation identity_transformation_d is_lax_identity_transformation.
End IdentityTransformation.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Require Import maps.
Require Import smallstep.
Require Import morestlc.

(* 構文 *)
Inductive ty : Type :=

  | Top : ty
  | Base : string -> ty
  | Arrow : ty -> ty -> ty

  | RNil : ty
  | RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=

  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | rproj : tm -> string -> tm

  | rnil : tm
  | rcons : string -> tm -> tm -> tm.

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty RNil
  | RTcons : forall i T1 T2,
        record_ty (RCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm rnil
  | rtcons : forall i t1 t2,
        record_tm (rcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTop :
        well_formed_ty Top
  | wfBase : forall i,
        well_formed_ty (Base i)
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (Arrow T1 T2)
  | wfRNil :
        well_formed_ty RNil
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (RCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* 置換 *)
Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 => abs y T (if eqb_string x y then t1
                             else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | rproj t1 i => rproj (subst x s t1) i
  | rnil => rnil
  | rcons i t1 tr2 => rcons i (subst x s t1) (subst x s tr2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* 簡約 *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (abs x T t)
  | v_rnil : value rnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (rcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | RCons i' T Tr' =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | rcons i' t tr' =>
      if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  | ST_Proj1 : forall tr tr' i,
        tr --> tr' ->
        (rproj tr i) --> (rproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
       (rproj tr i) --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        (rcons i t1 tr2) --> (rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        (rcons i v1 tr2) --> (rcons i v1 tr2')

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

(* サブタイプ *)
Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=

  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: Top
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    Arrow S1 S2 <: Arrow T1 T2

  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (RCons i T1 T2) ->
    RCons i T1 T2 <: RNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    RCons i S1 Sr2 <: RCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (RCons i1 T1 (RCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       RCons i1 T1 (RCons i2 T2 Tr3)
    <: RCons i2 T2 (RCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(*サブタイプの性質*)
Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  -
    split... inversion H. subst. inversion H5... Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  -
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)... inversion H0; subst... Qed.

(*
フィールド参照
  サブタイプがあることで、レコードマッチング補題はいくらか複雑になります。
  それには2つの理由があります。
  1つはレコード型が対応する項の正確な構造を記述する必要がなくなることです。
  2つ目は、has_typeの導出に関する帰納法を使う推論が一般には難しくなることです。 なぜなら、has_typeが構文指向ではなくなるからです。
 *)
Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  -
    exists Ti...
  -
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  -
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eqb_string i k)...
    +
      inversion Hget. subst. exists S1...
  -
    exists Ti. split.
    +
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eqb_stringP i i1)...
      *
        destruct (eqb_stringP i i2)...
        destruct H0.
        subst...
    +
      inversion H. subst. inversion H5. subst... Qed.

Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (Arrow V1 V2) ->
     exists U1 U2,
       (U=(Arrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (Arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1. induction Hs; intros; subst; try solve_by_invert.
  -
    inversion H; subst. exists V1, V2...
  -
    inversion Hs2.
    +
      inversion H; subst; apply IHHs1...
    +
      subst. specialize (IHHs2 V1 V2). destruct IHHs2...
      inversion H1. inversion H2. inversion H4; subst.
      specialize (IHHs1 x x0). destruct IHHs1...
      inversion H3. inversion H7; subst. inversion H9.
      exists x1, x2...
    +
      symmetry in H1. apply IHHs1 in H1. inversion H1. inversion H4.
      inversion H5. inversion H7; subst. exists x, x0. split...
  -
    inversion HeqV. subst. exists S1, S2...
Qed.

(* --------型付け------- *)
Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- var x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- abs x T11 t12 \in Arrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in Arrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- app t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- rproj t i \in Ti

  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T

  | T_RNil : forall Gamma,
      Gamma |- rnil \in RNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- rcons i t tr \in RCons i T Tr

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Module Examples.
Open Scope string_scope.

Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation j := "j".
Notation k := "k".
Notation i := "i".
Notation A := (Base "A").
Notation B := (Base "B").
Notation C := (Base "C").

Definition TRcd_j :=
  (RCons j (Arrow B B) RNil). Definition TRcd_kj :=
  RCons k (Arrow A A) TRcd_j.

Definition trcd_kj :=
  (rcons k (abs z A (var z))
           (rcons j (abs z B (var z))
                      rnil)).

Example typing_example_0 :
  has_type empty
           (rcons k (abs z A (var z))
                     (rcons j (abs z B (var z))
                               rnil))
           TRcd_kj.
Proof with eauto.
  unfold TRcd_kj, TRcd_j.
  apply T_RCons. apply T_Abs. apply wfBase.
  apply T_Var. reflexivity. apply wfBase.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase.
  apply T_RNil. apply RTnil. apply rtnil. apply RTcons. apply rtcons.
Qed.

Example subtyping_example_0 :
  subtype (Arrow C TRcd_kj)
          (Arrow C RNil).
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
Proof with eauto.
  unfold TRcd_kj, TRcd_j.
  eapply S_Trans.
  apply S_RcdPerm...
  intros H; inversion H.
  apply S_RcdDepth...
Qed.

Example typing_example_1 :
  has_type empty
           (app (abs x TRcd_j (rproj (var x) j))
                   (trcd_kj))
           (Arrow B B).
Proof with eauto.
  unfold TRcd_kj, TRcd_j.
  eapply T_App. apply T_Abs. apply wfRCons. apply wfArrow. apply wfBase. apply wfBase. apply wfRNil. apply RTnil.
  econstructor. apply T_Var. reflexivity. apply wfRCons. apply wfArrow; apply wfBase. apply wfRNil. apply RTnil.
  reflexivity.
  unfold trcd_kj. econstructor. apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase. apply T_RNil. apply RTnil. apply rtnil.
  apply RTcons. apply rtcons.
  apply subtyping_example_1.
Qed.

Example typing_example_2 :
  has_type empty
           (app (abs z (Arrow (Arrow C C) TRcd_j)
                           (rproj (app (var z)
                                            (abs x C (var x)))
                                    j))
                   (abs z (Arrow C C) trcd_kj))
           (Arrow B B).
Proof with eauto.
  unfold trcd_kj, TRcd_j.
  eapply T_App. apply T_Abs. apply wfArrow. apply wfArrow; apply wfBase. apply wfRCons.
  apply wfArrow; apply wfBase. apply wfRNil. apply RTnil.
  econstructor. eapply T_App.
  apply T_Var. reflexivity. apply wfArrow. apply wfArrow; apply wfBase. apply wfRCons.
  apply wfArrow; apply wfBase. apply wfRNil. apply RTnil.
  apply T_Abs. apply wfBase.
  apply T_Var. reflexivity. apply wfBase. reflexivity.
  apply T_Abs. apply wfArrow; apply wfBase.
  econstructor.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase.
  apply T_RNil. apply RTnil. apply rtnil. apply RTcons. apply rtcons.
  apply subtyping_example_1.
Qed.

End Examples.

(* 型付けの性質 *)

(* Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  -
    inversion IHHtyp1...
  -
    eapply wf_rcd_lookup...
  -
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* フィールド参照 *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve_by_invert.
  -
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  -
    simpl in H0. simpl. simpl in H1.
    destruct (eqb_string i i0).
    +
      inversion H1. subst. exists t...
    +
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval... Qed.

Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (Arrow T1 T2) ->
     value s ->
     exists x S1 s2,
        s = abs x S1 s2.
Proof with eauto.
  intros.

  destruct s; intros; eauto; try solve_by_invert.
  inversion H. subst.
  remember (Arrow T1 T2) as SS.
  revert HeqSS. generalize dependent S.
  induction H; intros; try solve_by_invert.
  inversion HeqSS; subst...
  subst... admit.
  admit.
Admitted.

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  -
    inversion H.
  -
    right.
    destruct IHHt1; subst...
    +
      destruct IHHt2; subst...
      *
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      *
        destruct H0 as [t2' Hstp]. exists (app t1 t2')...
    +
      destruct H as [t1' Hstp]. exists (app t1' t2)...
  -
    right. destruct IHHt...
    +
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    +
      destruct H0 as [t' Hstp]. exists (rproj t' i)...
  -
    destruct IHHt1...
    +
      destruct IHHt2...
      *
        right. destruct H2 as [tr' Hstp].
        exists (rcons i t tr')...
    +
      right. destruct H1 as [t' Hstp].
      exists (rcons i t' tr)... Qed.

(* 反転補題 *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (var x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (var x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  -
    exists T...
  -
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (app t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (Arrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (app t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  -
    exists T1...
  -
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1... Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (abs x S1 t2) T ->
     (exists S2, subtype (Arrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (abs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  -
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  -
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (rproj t1 i) Ti ->
  exists T Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (rproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  -
    assert (well_formed_ty Ti) as Hwf.
    {
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T, Ti...
  -
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U, Ui... Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (rcons i ti tr) T ->
  exists Si Sr,
    subtype (RCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (rcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  -
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri, Rr...
  -
    assert (well_formed_ty (RCons i T Tr)) as Hwf.
    {
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T, Tr... Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (abs x S1 s2) (Arrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst... Qed.

(* コンテキスト不変性 *)

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (rproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (rcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (rcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  -
    apply T_Var... rewrite <- Heqv...
  -
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (eqb_stringP x x0)...
  -
    apply T_App with T1...
  -
    apply T_RCons... Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  -
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx... Qed.

(* 保存 *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S ->
     has_type empty v U ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  -
    rename s into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (eqb_stringP x y)...
    +
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    +
      destruct (subtype__wf _ _ Hsub)...
  -
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  -
    rename s into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (Arrow T1 T2)... apply T_Abs...
    destruct (eqb_stringP x y).
    +
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    +
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst. rewrite false_eqb_string...
  -
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  -
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  -
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (RCons s Ti Tr)...
    apply T_RCons...
    +
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    +
      inversion Hrcdt2; subst; simpl... Qed.

Theorem preservation : forall t t' T,
     has_type empty t T ->
     t --> t' ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  -
    inversion HE; subst...
    +
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  -
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  -
    eauto using step_preserves_record_tm. Qed.


(** Coq coding by choukh, July 2022 **)
Require Import Notions NatEmbed PartialFunc Discrete.

Section 可判定性.
Context {M : 偏函数模型} {A : Type} {p : A → Prop}.

Lemma 可判定_余可判定 : 可判定 p → 可判定 p⁻.
Proof.
  intros [f Hf]. exists (λ x, negb (f x)).
  intros x. pose proof (Hf x).
  destruct (f x); simpl; rewrite H; intuition.
Qed.

Lemma 余不可判定_不可判定 : ¬ 可判定 p⁻ → ¬ 可判定 p.
Proof. intros H1 H2. apply H1, 可判定_余可判定, H2. Qed.

Lemma 可判定_半可判定 : 可判定 p → 半可判定 p.
Proof.
  intros [f Hf]. exists (λ x _, f x). intros x.
  unfold 判定器 in Hf. rewrite Hf. firstorder. econstructor.
Qed.

Lemma 半可判定_可枚举 : 可枚举ᵀ A → 半可判定 p → 可枚举 p.
Proof.
  unfold 半可判定, 半判定器. intros [f Hf] [g Hg].
  exists (λ' ⟨n, m⟩, if f n is Some x then
    if g x m then Some x else None
  else None ).
  intros x. rewrite Hg. split.
  - intros [m gxm]. destruct (Hf x) as [[n fn] _]. easy.
    exists ⟨n, m⟩. rewrite GF, fn, gxm. easy.
  - intros [nm hnm]. destruct ⎞nm⎛ as (n, m).
    destruct (f n) as [x'|]. 2:discriminate.
    destruct (g x' m) eqn:E. 2:discriminate.
    inv hnm. eauto.
Qed.

Lemma 可枚举_半可判定 : 离散 A → 可枚举 p → 半可判定 p.
Proof.
  unfold 可枚举, 枚举器. intros [f Hf] [g Hg].
  exists (λ x n, if g n is Some y then f (x, y) else false).
  intros x. rewrite Hg. split.
  - intros [n Hn]. exists n. rewrite Hn. now apply Hf.
  - intros [n Hn]. exists n. destruct (g n).
    apply Hf in Hn. now subst. discriminate.
Qed.

Lemma 可判定_可枚举 : 可枚举ᵀ A → 可判定 p → 可枚举 p.
Proof.
  intros. apply 半可判定_可枚举. easy.
  apply 可判定_半可判定. easy.
Qed.

Lemma 半可判定的偏函数表述 : 半可判定 p ↔ ∃ B (f : A ⇀ B), ∀ x, p x ↔ 有值 (f x).
Proof.
  split.
  - intros [f Hf].
    exists ℕ, (λ x, μ (f x)). intros x.
    rewrite (Hf x). split; intros [n H].
    + eapply μ有值. eauto.
    + eapply μ规则 in H as [H _]. eauto.
  - intros (B & f & Hf).
    exists (λ x n, if 求值 (f x) n is Some _ then true else false).
    intros x. rewrite Hf. split.
    + intros [y H]. apply 求值规则 in H as [n H].
      exists n. rewrite H. easy.
    + intros [n H]. destruct 求值 eqn:E.
      eexists. eapply 求值规则. eauto. discriminate.
Qed.

End 可判定性.

Lemma 自然数_可枚举_iff_半可判定 (p : ℕ → Prop) : 可枚举 p ↔ 半可判定 p.
Proof.
  split. apply 可枚举_半可判定. auto.
  apply 半可判定_可枚举. auto.
Qed.

Lemma 自然数_可判定_可枚举 (p : ℕ → Prop) : 可判定 p → 可枚举 p.
Proof. intros. apply 可判定_可枚举; auto. Qed.


Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
Proof.
  unfold not.
  intros.
  apply H.
  right.
  intro.
  apply (H (or_introl H0)).
Qed.


From Lambda Require Export Util.Basic STLC.SimpleTypes.

(** Note: many of the helper lemmas
          and proof techniques
          are inspired by those of
          Kazuhiko Sakaguchi:
          [https://github.com/pi8027/lambda-calculus]
*)

(** * De Bruijn Syntax *)

Inductive expr : Set :=
| Var (n : nat)
| Lam (t : type) (e : expr)
| App (e1 e2 : expr).
(**[]*)

Declare Scope expr_scope.
Delimit Scope expr_scope with expr.
Notation "'λ' t '⇒' e" := (Lam t e) (at level 10) : expr_scope.
Notation "e1 ⋅ e2"
  := (App e1 e2) (at level 8, left associativity) : expr_scope.
Notation "! n" := (Var n) (at level 0) : expr_scope.
Open Scope expr_scope.

(** * Static Semantics *)

Reserved Notation "Γ '⊢' e '∈' τ" (at level 40).

Inductive typing (Γ : list type) : expr -> type -> Prop :=
| typ_var n τ :
    nth_error Γ n = Some τ ->
    Γ ⊢ !n ∈ τ
| typ_lam τ τ' e :
    (τ :: Γ) ⊢ e ∈ τ' ->
    Γ ⊢ λ τ ⇒ e ∈ τ → τ'
| typ_app τ τ' e1 e2 :
    Γ ⊢ e1 ∈ τ → τ' ->
    Γ ⊢ e2 ∈ τ ->
    Γ ⊢ e1 ⋅ e2 ∈ τ'
where "Γ '⊢' e '∈' τ" := (typing Γ e τ).
(**[]*)

Theorem type_unique : forall Γ e τ1 τ2,
    Γ ⊢ e ∈ τ1 -> Γ ⊢ e ∈ τ2 -> τ1 = τ2.
Proof.
  intros g e; generalize dependent g;
    induction e; intros ? ? ? Ht1 Ht2; inv Ht1; inv Ht2.
  - rewrite H0 in H1; inv H1; reflexivity.
  - f_equal; eauto 2.
  - pose proof IHe1 _ _ _ H1 H2 as IH1;
      pose proof IHe2 _ _ _ H3 H5 as IH2.
    inv IH1; reflexivity.
Qed.

Section TypingLemmas.
  Local Hint Constructors typing : core.
  Local Hint Resolve nth_error_app1 : core.
  Local Hint Resolve nth_error_length : core.

  Lemma typing_prefix G e t :
      G ⊢ e ∈ t -> forall g, (G ++ g) ⊢ e ∈ t.
  Proof.
    intros H; induction H;
      intros g; eauto.
    constructor. rewrite nth_error_app1; eauto.
  Qed.
End TypingLemmas.

(** * Dynamic Semantics *)

(** Shifts free variables above a cutoff [c] up by [i]. *)
Fixpoint shift (c i : nat) (e : expr) : expr :=
  match e with
  | !n => ! if le_lt_dec c n then n + i else n
  | λ τ ⇒ e => λ τ ⇒ (shift (S c) i e)
  | e1 ⋅ e2 => (shift c i e1) ⋅ (shift c i e2)
  end.
(**[]*)

Section ShiftLemmas.
  Lemma shift0 : forall e k, shift k 0 e = e.
  Proof. induction e; destroy_arith. Qed.

  Lemma shift_add : forall e d d' c c',
    c <= c' <= c + d -> shift c' d' (shift c d e) = shift c (d' + d) e.
  Proof.
    induction e as [n | t e IHe | e1 IHe1 e2 IHe2];
      intros; simpl.
    - destroy_arith.
    - rewrite IHe by lia. reflexivity.
    - f_equal; auto.
  Qed.

  Lemma shift_shift_distr : forall e d c d' c',
      c' <= c -> shift c' d' (shift c d e) = shift (d' + c) d (shift c' d' e).
  Proof.
    induction e as [n | t e IHe | e1 IHe1 e2 IHe2];
      intros; simpl; f_equal; auto.
    - destroy_arith.
    - rewrite IHe by lia. f_equal; lia.
  Qed.

  Local Hint Constructors typing : core.

  Lemma typing_shift : forall e G g g' t,
      (G ++ g) ⊢ e ∈ t ->
      (G ++ g' ++ g) ⊢ (shift (length G) (length g') e) ∈ t.
  Proof.
    intro e;
      induction e as [n | t e IHe | e1 IHe1 e2 IHe2];
      intros G g g' τ Het; inv Het; simpl; eauto.
    - constructor. destroy_arith.
      + rewrite Nat.add_comm.
        rewrite nth_error_app2 in * by lia.
        replace (length g' + n - length G)
          with (length g' + (n - length G)) by lia.
        rewrite nth_error_app_plus. assumption.
      + rewrite nth_error_app1 in * by lia.
        assumption.
    - constructor.
      replace (S (length G))
        with (length (t :: G)) by reflexivity.
      rewrite app_comm_cons. eauto.
  Qed.

  Lemma typ_weak_weak : forall e A Γ' Γ T,
      (Γ' ++ Γ) ⊢ e ∈ T ->
      (Γ' ++ A :: Γ) ⊢ shift (length Γ') 1 e ∈ T.
  Proof.
    intros e A G g t Het.
    replace 1 with (length [A]) by reflexivity.
    replace (G ++ A :: g)
      with (G ++ [A] ++ g) by reflexivity.
    apply typing_shift. assumption.
  Qed.

  Lemma thinning : forall e Γ T A,
      Γ ⊢ e ∈ T ->
      (A :: Γ) ⊢ shift 0 1 e ∈ T.
  Proof.
    intros e g T A Het.
    replace (A :: g) with ([] ++ A :: g) by reflexivity.
    replace 0 with (@length type []) at 1 by reflexivity.
    apply typ_weak_weak. assumption.
  Qed.

  Lemma thinning_n : forall Γ' Γ e T,
      Γ ⊢ e ∈ T ->
      (Γ' ++ Γ) ⊢ shift 0 (length Γ') e ∈ T.
  Proof.
    intros g' g e t Het.
    replace (g' ++ g) with ([] ++ g' ++ g) by reflexivity.
    replace 0 with (@length type nil) by reflexivity.
    apply typing_shift. assumption.
  Qed.
End ShiftLemmas.

Fixpoint sub (n: nat) (es: list expr) (e: expr) : expr :=
  match e with
  | !m => if le_lt_dec n m then
           shift 0 n (nth (m - n) es !(m - n - length es))
         else !m
  | λ τ ⇒ e => λ τ ⇒ (sub (S n) es e)
  | e1 ⋅ e2 => (sub n es e1) ⋅ (sub n es e2)
  end.
(**[]*)

Section SubShiftLemmas.
  Lemma sub_nil : forall e n,
      sub n [] e = e.
  Proof.
    induction e as [m | t e IHe | e1 IHe1 e2 IHe2]; intros; simpl;
      try (f_equal; eauto; assumption).
    destroy_arith.
  Qed.

  Lemma sub_shift_cancel : forall e n d c ts,
    c <= n -> length ts + n <= d + c ->
    sub n ts (shift c d e) = shift c (d - length ts) e.
  Proof.
    induction e as [m | t e IHe | e1 IHe1 e2 IHe2]; intros; simpl.
    - destroy_arith. rewrite nth_overflow by lia.
      simpl. f_equal. lia.
    - rewrite IHe by lia. reflexivity.
    - f_equal; auto.
  Qed.

  Lemma shift_sub_distr : forall e n d c ts,
      c <= n -> shift c d (sub n ts e) = sub (d + n) ts (shift c d e).
  Proof.
    induction e as [j | t e IHe | e1 IHe1 e2 IHe2]; intros; simpl.
    - destroy_arith. rewrite shift_add by lia.
      repeat (f_equal; try lia).
    - rewrite IHe by lia.
      do 2 f_equal. lia.
    - f_equal; auto.
  Qed.

  Lemma sub_shift_distr :  forall e ts n c d,
      n <= c ->
      shift c d (sub n ts e) =
      sub n (map (shift (c - n) d) ts) (shift (length ts + c) d e).
  Proof.
    induction e as [m | t e IHe | e1 IHe1 e2 IHe2];
      intros; simpl.
    - destroy_arith; rewrite map_length.
      + rewrite nth_overflow by lia.
        replace !(m + d - n - length ts)
          with (shift (c - n) d !(m - n - length ts)).
        * rewrite map_nth; simpl. destroy_arith.
          rewrite nth_overflow by lia; simpl.
          destroy_arith.
        * simpl. destroy_arith.
      + destruct (le_lt_dec (length ts) (m - n)) as [Hmnts | Hmnts].
        * rewrite nth_overflow by lia.
          rewrite nth_overflow
            by (try rewrite map_length; lia).
          simpl. destroy_arith.
        * rewrite nth_map with (a := !(m - n - length ts)) by lia.
          rewrite shift_shift_distr with (c' := 0) by lia.
          f_equal; try lia.
    - f_equal. rewrite IHe by lia.
      f_equal; try lia.
      f_equal; try lia.
    - f_equal; auto.
  Qed.

  Lemma sub_sub_distr : forall e n m xs ys,
      m <= n ->
      sub n xs (sub m ys e) =
      sub m (map (sub (n - m) xs) ys) (sub (length ys + n) xs e).
  Proof.
    induction e as [j | t e IHe | e1 IHe1 e2 IHe2]; intros; simpl.
    - destroy_arith.
      + rewrite nth_overflow by lia; simpl. destroy_arith.
        rewrite sub_shift_cancel
          by (try rewrite map_length; lia).
        rewrite map_length. do 3 (f_equal; try lia).
      + rewrite map_length.
        destruct (le_lt_dec (length ys) (j - m)) as [Hjmys | Hjmys].
        * rewrite nth_overflow by lia.
          rewrite nth_overflow
            by (try rewrite map_length; lia).
          simpl. destroy_arith.
        * rewrite nth_map with (a := !(j - m - length ys)) by lia.
          rewrite shift_sub_distr by lia.
          f_equal; lia.
    - f_equal. rewrite IHe by lia.
      f_equal; try lia.
      f_equal; try lia.
    - f_equal; auto.
  Qed.

  Lemma sub_append : forall e xs ys n,
      sub n (xs ++ ys) e = sub n xs (sub (length xs + n) ys e).
  Proof.
    induction e as [m | t e IHe | e1 IHe1 e2 IHe2];
      intros; simpl.
    - destroy_arith.
      + rewrite app_nth2 by lia.
        rewrite sub_shift_cancel by lia.
        rewrite app_length.
        repeat (f_equal; try lia).
      + rewrite app_nth1 by lia.
        rewrite app_length.
        repeat (f_equal; try lia).
    - f_equal. rewrite IHe by lia.
      repeat (f_equal; try lia).
    - f_equal; auto.
  Qed.

  Local Hint Constructors typing : core.

  Lemma typing_sub : forall e G ts g T es,
      Forall2 (typing g) es ts ->
      (G ++ ts ++ g) ⊢ e ∈ T ->
      (G ++ g) ⊢ sub (length G) es e ∈ T.
  Proof.
    intro e;
      induction e as [n | t e IHe | e1 IHe1 e2 IHe2];
      intros G ts g T es HF2 Het; inv Het; simpl; eauto.
    - assert (Hlen : length es = length ts)
        by eauto using Forall2_length.
      destroy_arith.
      + apply thinning_n.
        destruct (le_lt_dec (length es) (n - length G))
          as [Hesng | Hesng].
        * rewrite nth_overflow by lia.
          constructor. rewrite Hlen.
          repeat rewrite nth_error_app2 in H0 by lia.
          assumption.
        * rewrite nth_error_app2 in H0 by lia.
          rewrite nth_error_app1 in H0 by lia.
          apply length_nth_error in Hesng as [e Hnth].
          erewrite nth_error_nth by eauto.
          eapply Forall2_nth_error; eauto.
      + rewrite nth_error_app1 in H0 by lia.
        constructor. rewrite nth_error_app1 by lia.
        assumption.
    - replace (S (length G))
        with (length (t :: G)) by reflexivity.
      constructor. rewrite app_comm_cons. eauto.
  Qed.
End SubShiftLemmas.

(** Beta-reduction [(λx.e1) e2 -> e1{e2/x}]. *)
Definition beta_reduce (e1 e2 : expr) : expr := sub 0 [e2] e1.
(**[]*)

Lemma typing_beta_reduce : forall g e E t T,
    g ⊢ e ∈ t ->
    (t :: g) ⊢ E ∈ T ->
    g ⊢ (beta_reduce E e) ∈ T.
Proof.
  intros g e E t T He HE. unfold beta_reduce.
  replace g with ([] ++ g) by reflexivity.
  replace 0 with (@length type []) by reflexivity.
  eapply typing_sub; eauto.
Qed.

Reserved Notation "e1 '-->' e2" (at level 40).

(** Beta-reduction. *)
Inductive bred : expr -> expr -> Prop :=
| bred_bred t e1 e2 :
    (λ t ⇒ e1) ⋅ e2 -->  beta_reduce e1 e2
| bred_abs t e e' :
    e -->  e' ->
    λ t ⇒ e -->  λ t ⇒ e'
| bred_app_l el el' er :
    el -->  el' ->
    el ⋅ er -->  el' ⋅ er
| bred_app_r el er er' :
    er -->  er' ->
    el ⋅ er -->  el ⋅ er'
where "e1 '-->' e2" := (bred e1 e2).

Section Bred_exm.
  Local Hint Constructors bred : core.

  Lemma bred_exm : forall e,
      (exists e', e -->  e') \/ forall e', ~ e -->  e'.
  Proof.
    intro e;
      induction e as
        [n
        | t e [[e' IHe]| IHe]
        | e1 [[e1' IHe1] | IHe1] e2 [[e2' IHe2] | IHe2]]; eauto;
        try (right; intros e' He'; inv He';
             intuition; eauto; contradiction).
    destruct e1 as [m | t1 e1 | e11 e12]; eauto;
      try (right; intros e' He'; inv He';
           intuition; eauto; contradiction).
  Qed.
End Bred_exm.

Section BredSub.
  Local Hint Constructors bred : core.
  Local Hint Unfold beta_reduce : core.

  Lemma sub_bred : forall e e',
      e -->  e' -> forall n es, sub n es e -->  sub n es e'.
  Proof.
    intros e e' Hred; induction Hred;
      intros n es; simpl; auto.
    unfold beta_reduce.
    rewrite sub_sub_distr by lia; simpl.
    replace (n - 0) with n by lia.
    replace (sub 0 [sub n es e2] (sub (S n) es e1))
      with (beta_reduce (sub (S n) es e1) (sub n es e2))
      by reflexivity; auto.
  Qed.

  Local Hint Resolve sub_bred : core.

  Lemma beta_reduce_bred : forall e1 e1' e2,
      e1 -->  e1' -> beta_reduce e1 e2 -->  beta_reduce e1' e2.
  Proof. autounfold with core; auto. Qed.
End BredSub.

Section Preservation.
  Local Hint Constructors typing : core.
  Local Hint Resolve typing_beta_reduce : core.

  Theorem preservation : forall e e',
      e -->  e' -> forall g t, g ⊢ e ∈ t -> g ⊢ e' ∈ t.
  Proof.
    intros e e' He; induction He;
      intros g T Ht; inv Ht; eauto.
    inv H1; eauto.
  Qed.
End Preservation.

Section CanonicalForms.
  Local Hint Constructors bred : core.

  Lemma canonical_forms_lambda : forall e T t,
    [] ⊢ e ∈ T → t ->
    (forall e', ~ e -->  e') ->
    exists body, e = λ T ⇒ body.
  Proof.
    intro e;
      induction e as [n | T' e IHe | e1 IHe1 e2 IHe2];
      intros T t HeTt He; inv HeTt; simpl in *; eauto.
    - rewrite nth_error_nil in H0; discriminate.
    - exfalso. apply IHe1 in H1; eauto.
      + destruct H1 as [e1' He1]; subst.
        specialize He with (e' := beta_reduce e1' e2); auto.
      + intros e1' He1.
        specialize He with (e' := e1' ⋅ e2); auto.
  Qed.
End CanonicalForms.

Section Progress.
  Local Hint Constructors bred : core.

  Theorem progress_thm : forall e t,
      [] ⊢ e ∈ t ->
      (exists e', e -->  e') \/ exists T v, e = λ T ⇒ v.
  Proof.
    intro e;
      induction e as
        [ n
        | T e IHe
        | e1 IHe1 e2 IHe2 ];
      intros t Het; inv Het; eauto.
    - rewrite nth_error_nil in H0; discriminate.
    - pose proof IHe1 _ H1 as IH1; clear IHe1.
      pose proof IHe2 _ H3 as IH2; clear IHe2.
      destruct IH1 as [[e1' IH1] | [T1 [v1 IH1]]];
        destruct IH2 as [[e2' IH2] | [T2 [v2 IH2]]];
        subst; eauto.
  Qed.
End Progress.

Notation "e '-->*' e'"
  := (refl_trans_closure bred e e')
       (at level 40, no associativity).

(** Termination predicate. *)
Definition halts (e : expr) : Prop :=
  exists e', e -->* e' /\ forall e'', ~ e' -->  e''.

(** Strongly Normalizing. *)
Definition SN : expr -> Prop := Acc (fun e' e => e -->  e').

Section HaltsSN.
  Local Hint Constructors refl_trans_closure : core.

  Lemma SN_halts : forall e, SN e -> halts e.
  Proof.
    intros e Hsn; unfold halts; induction Hsn.
    destruct (bred_exm x) as [[e He] | He]; eauto.
    apply H0 in He as He_. destruct He_ as [e' [He' He'']]; eauto.
  Qed.
End HaltsSN.

Section SNProp.
  Local Hint Unfold SN : core.

  Lemma SN_var : forall n, SN !n.
  Proof.
    intros n. constructor.
    intros e' Hred. inv Hred.
  Qed.

  Lemma bred_SN : forall e e',
    e -->  e' -> SN e -> SN e'.
  Proof.
    intros e e' Hbred Hsn; inv Hsn; auto.
  Qed.

  Local Hint Resolve bred_SN : core.

  Lemma multi_bred_SN : forall e e',
      e -->* e' -> SN e -> SN e'.
  Proof.
    intros e e' Hms; induction Hms; eauto.
  Qed.

  Local Hint Constructors Acc : core.
  Local Hint Resolve multi_bred_SN : core.

  Lemma not_bred_SN : forall e,
      (forall e', ~ e -->  e') -> SN e.
  Proof.
    intros e H; constructor.
    intros e' H'. apply H in H'. contradiction.
  Qed.
End SNProp.

Module StrongNorm.

  Fixpoint types (g : list type) (e : expr) : option type :=
    match e with
    | !n => nth_error g n
    | λ t ⇒ e =>
      match types (t :: g) e with
      | None => None
      | Some T => Some (t → T)
      end
    | e1 ⋅ e2 =>
      match types g e1, types g e2 with
      | Some (T → t), Some T'
        => if teqb T T' then Some t else None
      | _, _ => None
      end
    end.
  (**[]*)

  Section TypingIff.
    Hint Rewrite teqb_refl : core.

    Lemma typing_types : forall g e t,
      g ⊢ e ∈ t -> types g e = Some t.
    Proof.
      intros g e t H;
        induction H; simpl in *;
          repeat match goal with
                 | H: types ?g ?t = Some _
                   |- context [types ?g ?t] => rewrite H; simpl
                 end; autorewrite with core; auto.
    Qed.

    Local Hint Constructors typing : core.
    Hint Rewrite teqb_eq : core.

    Lemma types_typing : forall e g t,
        types g e = Some t -> g ⊢ e ∈ t.
    Proof.
      intro e;
        induction e as [n | T e IHe | e1 IHe1 e2 IHe2];
        intros g t H; simpl in *; eauto.
      - destruct (types (T :: g) e) as [t' |] eqn:Heq;
          simpl in *; inv H; auto.
      - destruct (types g e1) as [[| T T'] |] eqn:Heq1;
          try discriminate.
        destruct (types g e2) as [t' |] eqn:Heq2;
          try discriminate.
        destruct (teqb T t') eqn:Heqt; inv H.
        autorewrite with core in *; subst; eauto.
    Qed.

    Local Hint Resolve typing_types : core.
    Local Hint Resolve types_typing : core.

    Lemma types_iff : forall g e t,
        types g e = Some t <-> g ⊢ e ∈ t.
    Proof. intuition. Qed.

    Local Hint Resolve types_iff : core.
    Local Hint Resolve typing_prefix : core.

    Lemma types_prefix : forall G g e t,
        types G e = Some t -> types (G ++ g) e = Some t.
    Proof. auto. Qed.

    Local Hint Resolve types_prefix : core.
    Hint Rewrite types_iff : core.

    Lemma types_append : forall G g e t,
        G ⊢ e ∈ t -> types (G ++ g) e = types G e.
    Proof.
      intros G g e t HG.
      assert (Hg: (G ++ g) ⊢ e ∈ t) by auto.
      rewrite <- types_iff in *.
      rewrite HG; rewrite Hg; reflexivity.
    Qed.
  End TypingIff.

  Section ListHyp.
    Fixpoint list_type (t : type) : list type :=
      match t with
      | ⊥ => []
      | T → t => T :: list_type T ++ list_type t
      end.
    (**[]*)

    Fixpoint list_expr (g : list type) (e : expr) : list type :=
      match types g e with
      | None => []
      | Some t => list_type t
      end ++
          match e with
          | !_ => []
          | λ t ⇒ e => list_expr (t :: g) e
          | e1 ⋅ e2 => list_expr g e1 ++ list_expr g e2
          end.
    (**[]*)

    Lemma list_expr_eq : forall g e,
        list_expr g e =
        match types g e with
        | None => []
        | Some t => list_type t
        end ++
            match e with
            | !_ => []
            | λ t ⇒ e => list_expr (t :: g) e
            | e1 ⋅ e2 => list_expr g e1 ++ list_expr g e2
            end.
    Proof.
      intros g []; reflexivity.
    Qed.

    Local Hint Resolve nth_error_length : core.
    Local Hint Resolve types_append : core.

    Lemma list_expr_append : forall e G g t,
        G ⊢ e ∈ t -> list_expr (G ++ g) e = list_expr G e.
    Proof.
      intro e;
        induction e as [n | T e IHe | e1 IHe1 e2 IHe2];
        intros G g t Het; inv Het; simpl.
      - assert (n < length G) by eauto.
        rewrite nth_error_app1 by lia. reflexivity.
      - rewrite app_comm_cons. erewrite IHe by eauto.
        erewrite types_append by eauto. reflexivity.
      - erewrite IHe1 by eauto. erewrite IHe2 by eauto.
        repeat erewrite types_append by eauto. reflexivity.
    Qed.
  End ListHyp.

  Definition neutral (e : expr) : Prop :=
    match e with
    | ! _ | _ ⋅ _ => True
    | λ _ ⇒ _ => False
    end.
  (**[]*)

  Fixpoint R (g : list type) (e : expr) (t : type) : Prop :=
    match t with
    | ⊥ => SN e
    | T → t => forall E, g ⊢ E ∈ T -> R g E T -> R g (e ⋅ E) t
    end.
  (**[]*)

  Section RProp.
    Local Hint Constructors typing : core.
    Local Hint Constructors bred : core.
    Local Hint Resolve bred_SN : core.
    Local Hint Resolve multi_bred_SN : core.
    Local Hint Resolve preservation : core.

    Lemma CR2 : forall t g e e',
        e -->  e' -> R g e t -> R g e' t.
    Proof.
      intro t;
        induction t as [| t1 IHt1 t2 IHt2];
        intros g e e' Hred HR; simpl in *;
          intuition; eauto.
    Qed.

    Local Hint Resolve CR2 : core.
    Local Hint Constructors Acc : core.
    Local Hint Unfold SN : core.
    Local Hint Unfold neutral : core.

    Lemma CR1_CR3 : forall t,
        (forall e g,
            Forall (fun t => In t g) (list_type t) ->
            g ⊢ e ∈ t -> R g e t -> SN e) /\
        (forall e g,
            Forall (fun t => In t g) (list_type t) ->
            g ⊢ e ∈ t -> neutral e ->
            (forall e', e -->  e' -> R g e' t) -> R g e t).
    Proof.
      intro t;
        induction t as
          [| t1 [IHt1_CR1 IHt1_CR3] t2 [IHt2_CR1 IHt2_CR3]];
        split; simpl; try (intuition; eauto; assumption).
      - intros e g HF Het HR. inv HF.
        rewrite Forall_app in H2; intuition.
        apply In_nth_error in H1 as [n Hnth].
        assert (g ⊢ e ⋅ !n ∈ t2) by eauto.
        assert (SN ((fun e => e ⋅ !n) e)).
        { eapply IHt2_CR1; eauto.
          apply HR; eauto.
          apply IHt1_CR3; eauto.
          intros ? Hn. inv Hn. }
        eapply acc_pres with (f := fun e => e ⋅ !n); eauto; simpl.
        intuition.
      - intros e g HF Het Hneut HR. inv HF.
        rewrite Forall_app in H2; intuition.
        assert (g ⊢ e ⋅ E ∈ t2) by eauto.
        assert (Hsn: SN E) by eauto. induction Hsn.
        eapply IHt2_CR3; eauto.
        intros e' He'; inv He'; simpl in *;
          try contradiction; eauto 6.
    Qed.

    Lemma CR1 : forall g e t,
        Forall (fun t => In t g) (list_type t) ->
        g ⊢ e ∈ t -> R g e t -> SN e.
    Proof.
      intros ? ? t.
      pose proof CR1_CR3 t as [HCR1 _]. eauto 2.
    Qed.

    Lemma CR3 : forall g e t,
        Forall (fun t => In t g) (list_type t) ->
        g ⊢ e ∈ t -> neutral e ->
        (forall e', e -->  e' -> R g e' t) -> R g e t.
    Proof.
      intros ? ? t.
      pose proof CR1_CR3 t as [_ HCR3]. eauto 2.
    Qed.

    Local Hint Resolve CR1 : core.
    Local Hint Resolve CR3 : core.
    Local Hint Resolve Forall_impl : core.
    Local Hint Resolve in_cons : core.
    Local Hint Resolve beta_reduce_bred : core.
    Local Hint Resolve sub_bred : core.

    Lemma abs_red : forall g e T t,
        Forall (fun t => In t g) (list_type (T → t)) ->
        g ⊢ λ T ⇒ e ∈ T → t ->
        (forall E, g ⊢ E ∈ T -> R g E T -> R g (beta_reduce e E) t) ->
        R g (λ T ⇒ e) (T → t).
    Proof.
      intros g e T t HF Het HR;
        inv HF; inv Het; simpl in *.
      rewrite Forall_app in H2. intuition.
      assert (Hbr: g ⊢ beta_reduce e E ∈ t) by eauto.
      assert (Hsn: SN e).
      { pose proof CR1 _ _ _ H3 Hbr (HR _ H2 H4) as Hsnbr.
        unfold beta_reduce in *.
        eapply acc_pres with (f := sub 0 [E]); eauto.
        intuition. }
      assert (HSN: SN E) by eauto.
      revert e E Hsn HSN H2 H4 HR Hbr H0.
      refine (Acc_ind2 _ _ _ _ _ _); intros.
      eapply CR3; eauto.
      intros e' He'; inv He'; eauto 8.
      inv H10. eauto 8.
    Qed.

    Local Hint Resolve typing_sub : core.

    Lemma R_var : forall g n t,
        Forall (fun t => In t g) (list_type t) ->
        nth_error g n = Some t ->
        R g !n t.
    Proof.
      intros g n t HF Hnth.
      apply CR3; auto.
      intros ? H'. inv H'.
    Qed.

    Local Hint Resolve R_var : core.

    Lemma reduce_lemma : forall e t g ts es,
        Forall (fun t => In t g) (list_expr (ts ++ g) e) ->
        Forall2 (typing g) es ts ->
        Forall2 (R g) es ts ->
        (ts ++ g) ⊢ e ∈ t ->
        R g (sub 0 es e) t.
    Proof.
      intro e;
        induction e as [n | T e IHe | e1 IHe1 e2 IHe2];
        intros t g ts es Hl Htyps HRs Het; inv Het.
      - simpl in *.
        assert (length es = length ts)
          by eauto using Forall2_length.
        rewrite shift0. rewrite H0 in Hl. rewrite app_nil_r in Hl.
        replace (n - 0) with n by lia.
        destruct (le_lt_dec (length es) n) as [Hesn | Hesn].
        + rewrite nth_overflow by lia.
          rewrite nth_error_app2 in H0 by lia.
          rewrite H. auto.
        + rewrite nth_error_app1 in H0 by lia.
          apply length_nth_error in Hesn as [e He].
          erewrite nth_error_nth by eauto.
          eapply Forall2_nth_error; eauto.
      - simpl in Hl.
        erewrite typing_types in Hl by eauto.
        simpl in Hl. inv Hl.
        rewrite Forall_app in H3.
        unfold sub; fold sub.
        apply abs_red; simpl; intuition.
        + constructor.
          replace 1 with (length [T]) by reflexivity.
          replace (T :: g) with ([T] ++ g) by reflexivity. eauto.
        + unfold beta_reduce.
          rewrite <- sub_append.
          apply IHe with (ts := T :: ts); simpl; intuition.
      - simpl in *.
        repeat erewrite typing_types in Hl by eauto.
        rewrite teqb_refl in Hl.
        repeat rewrite Forall_app in Hl.
        destruct Hl as [Ht [He1 He2]].
        pose proof IHe1 _ _ _ _ He1 Htyps HRs H1 as IH1; clear IHe1.
        pose proof IHe2 _ _ _ _ He2 Htyps HRs H3 as IH2; clear IHe2.
        simpl in IH1. apply IH1; eauto.
        replace g with ([] ++ g) by reflexivity.
        replace 0 with (@length type []) by reflexivity. eauto.
    Qed.

    Local Hint Resolve reduce_lemma : core.
    Local Hint Resolve typing_prefix : core.

    Theorem typing_SN : forall g e t, g ⊢ e ∈ t -> SN e.
    Proof.
      intros g e t Hget.
      assert (Happget: (g ++ list_expr g e) ⊢ e ∈ t) by eauto.
      rewrite <- sub_nil with (n := 0).
      pose proof reduce_lemma
           e t (g ++ list_expr g e) [] [] as H.
      assert (HF:
                Forall (fun t : type => In t (g ++ list_expr g e))
                       (list_expr ([] ++ g ++ list_expr g e) e)).
      { apply Forall_forall; simpl.
        erewrite list_expr_append by eauto.
        intuition. }
      pose proof H HF (Forall2_nil _) (Forall2_nil _) Happget as HR; clear H HF.
      pose proof CR1 (g ++ list_expr g e) (sub 0 [] e) t as Hcr1.
      assert (HF':
                Forall
                  (fun t : type => In t (g ++ list_expr g e)) (list_type t)).
      { rewrite list_expr_eq.
        erewrite typing_types by eauto.
        apply Forall_forall. intuition. }
      replace e with (sub 0 [] e) in Happget at 2 by eauto using sub_nil. eauto.
    Qed.
  End RProp.

  Fixpoint normal_order (e : expr) : option expr :=
    match e with
    | (λ _ ⇒ e1) ⋅ e2 => Some (beta_reduce e1 e2)
    | λ t ⇒ e => match normal_order e with
                | None => None
                | Some e' => Some (λ t ⇒ e')
                end
    | e1 ⋅ e2 => match normal_order e1 with
                | None => match normal_order e2 with
                         | None => None
                         | Some e2' => Some (e1 ⋅ e2')
                         end
                | Some e1' => Some (e1' ⋅ e2)
                end
    | ! _ => None
    end.

  Definition typed_expr (g : list type) (t : type) : Type :=
    {e : expr | g ⊢ e ∈ t }.
  (**[]*)

  Section NormalOrder.
    Local Hint Constructors bred : core.

    Lemma normal_order_bred : forall e e',
      normal_order e = Some e' -> e -->  e'.
    Proof.
      intro e;
        induction e as [? | t e IHe | e1 IHe1 e2 IHe2];
        intros e' Hno; simpl in *; try discriminate.
      - destruct (normal_order e) as [? |] eqn:Heq;
          try discriminate. inv Hno. eauto.
      - destruct (normal_order e1) as [e1' |] eqn:Heq1.
        + destruct e1; inv Hno; eauto.
        + destruct (normal_order e2)
            as [e2' |] eqn:Heq2;
            destruct e1; inv Hno; eauto.
    Qed.

    Local Hint Resolve normal_order_bred : core.
    Local Hint Resolve preservation : core.

    Lemma normal_order_preservation : forall e e',
        normal_order e = Some e' ->
        forall g t, g ⊢ e ∈ t -> g ⊢ e' ∈ t.
    Proof.
      eauto.
    Qed.

    Local Hint Resolve normal_order_preservation : core.

    Definition normal_order_typed
               g t (et : typed_expr g t) :
      sumor {et' : typed_expr g t | proj1_sig et -->  proj1_sig et'}
            (normal_order (proj1_sig et) = None).
    Proof.
      destruct (normal_order (proj1_sig et)) as [e' |] eqn:Heq.
      - left. destruct et as [e He]; simpl in *.
        assert (e -->  e') by eauto.
        assert (He': g ⊢ e' ∈ t) by eauto.
        refine (exist _ (exist _ e' He') _); auto.
      - right; trivial.
    Defined.
  End NormalOrder.

  Section Lemmas.
    Lemma typed_expr_acc : forall g t (et : typed_expr g t),
      Acc (fun (e' e : typed_expr g t) => proj1_sig e -->  proj1_sig e') et.
    Proof.
      intros g t [e Hget].
      apply typing_SN in Hget as HSN.
      unfold SN in HSN.
      pose proof @acc_pres
           (typed_expr g t) expr
           (@proj1_sig expr (fun e => g ⊢ e ∈ t)) as H.
      eapply H; eauto. intuition.
    Qed.

    Local Hint Resolve typed_expr_acc : core.

    Lemma typed_expr_wf : forall g t,
        well_founded
          (fun (et' et : typed_expr g t) =>
             proj1_sig et -->   proj1_sig et').
    Proof.
      unfold well_founded; auto.
    Qed.

    Definition multi_normal_order_typed g t :
      typed_expr g t -> typed_expr g t.
    Proof.
      refine
        (Fix
           (typed_expr_wf g t) (fun _ => typed_expr g t)
           (fun (et: typed_expr g t)
              (f: forall et': typed_expr g t,
                  (proj1_sig et -->  proj1_sig et') -> typed_expr g t) =>
              match normal_order_typed _ _ et with
              | inleft obj => f (proj1_sig obj) _
              | inright _ => et
              end)).
      destruct obj as [et' Heq]; auto.
    Defined.
  End Lemmas.

  Definition multi_normal_order g e t :
    g ⊢ e ∈ t -> expr :=
    fun H => proj1_sig (multi_normal_order_typed _ _ (exist _ e H)).
  (**[]*)

  Module Examples.
    Section Examples.
      Local Hint Constructors typing : core.

      Let basic := λ ⊥ ⇒ !0.

      Example basic_typing : [] ⊢ basic ∈ ⊥ → ⊥.
      Proof.
        subst basic; auto.
      Qed.

      (** WTF? *)
      (*Compute multi_normal_order _ _ _ basic_typing.*)
      (** If I replace all [Qed]s with [Defined],
          this command does not terminate. *)
    End Examples.
  End Examples.
End StrongNorm.

(* From Coq Require Extraction. *)
(* Recursive Extraction StrongNorm.multi_normal_order. *)


Require Export Arith.
Require Export Compare_dec.
Require Export ArithRing.
Require Export Omega.
Require Export ZArith.
Require Export ZArithRing.

Ltac CaseEq f := generalize (refl_equal f); pattern f at -1 in |- *; case f.

Inductive Qpositive : Set :=
  | nR : Qpositive -> Qpositive
  | dL : Qpositive -> Qpositive
  | One : Qpositive.

Fixpoint Qpositive_i (w : Qpositive) : nat * nat :=
  match w with
  | One => (1, 1)
  | nR w' => match Qpositive_i w' with
             | (p, q) => (p + q, q)
             end
  | dL w' => match Qpositive_i w' with
             | (p, q) => (p, p + q)
             end
  end.
Coercion Z_of_nat : nat >-> Z.

Theorem interp_reduced_fraction :
 forall w : Qpositive,
 exists a : Z,
   (exists b : Z, (a * fst (Qpositive_i w) + b * snd (Qpositive_i w))%Z = 1%Z).
intros w; elim w; clear w.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists a; exists (b - a)%Z.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists (a - b)%Z; exists b.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
exists 1%Z; exists 0%Z; simpl in |- *; omega.
Qed.

Fixpoint Qpositive_inv (w : Qpositive) : Qpositive :=
  match w with
  | One => One
  | nR w' => dL (Qpositive_inv w')
  | dL w' => nR (Qpositive_inv w')
  end.

Theorem inv_correct :
 forall (w : Qpositive) (p q : nat),
 Qpositive_i w = (p, q) -> Qpositive_i (Qpositive_inv w) = (q, p).
 let T_local :=
  (intros w'; simpl in |- *; case (Qpositive_i w'); intros p' q' Hrec p q Heq;
    rewrite (Hrec p' q'); auto; injection Heq; intros H1 H2;
    rewrite <- H1; rewrite <- H2; rewrite plus_comm;
    auto) in
 (intros w; elim w; clear w;
   [ T_local
   | T_local
   | simpl in |- *; intros p q Heq; injection Heq; intros H1 H2;
      rewrite <- H1; rewrite <- H2; auto with * ]).
Qed.

Theorem interp_non_zero :
 forall w : Qpositive,
 exists p : nat, (exists q : nat, Qpositive_i w = (S p, S q)).
simple induction w; simpl in |- *;
 (repeat exists 0; auto; fail) ||
   (intros w' Hrec; elim Hrec; intros p' Hex; elim Hex; intros q' Heq;
     rewrite Heq).
exists (p' + S q'); exists q'; auto.
exists p'; exists (p' + S q'); auto.
Qed.

Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive :=
  match n with
  | O => One
  | S n' =>
      match p - q with
      | O => match q - p with
             | O => One
             | v => dL (Qpositive_c p v n')
             end
      | v => nR (Qpositive_c v q n')
      end
  end.

Theorem minus_O_le : forall n m : nat, n - m = 0 -> n <= m.
intros n; elim n; clear n.
auto with arith.
intros n Hrec m; case m; clear m.
simpl in |- *; intros Heq; discriminate Heq.
simpl in |- *; intros; apply le_n_S; apply Hrec; auto.
Qed.

Theorem le_minus_O : forall n m : nat, n <= m -> n - m = 0.
intros n; elim n; clear n.
simpl in |- *; auto.
intros n Hrec m; case m; clear m.
intros Hle; inversion Hle.
intros m' Hle; simpl in |- *; apply Hrec; auto with arith.
Qed.

Theorem minus_le : forall m n : nat, m - n <= m.
intros m; elim m.
simpl in |- *; auto.
intros m' Hrec n; case n; simpl in |- *; auto.
Qed.

Theorem mult_reg_l : forall n m p : nat, S n * m = S n * p -> m = p.
intros n m; elim m; clear m.
intros p; case p; simpl in |- *.
auto.
intros p'; rewrite <- mult_n_O.
intros H; discriminate H.
intros m' Hrec p; case p.
rewrite <- mult_n_O; simpl in |- *; intros H; discriminate H.
intros p'; repeat rewrite (mult_comm (S n)); simpl in |- *.
intros H; injection H.
intros H'; apply f_equal with (f := S).
apply Hrec.
repeat rewrite (mult_comm (S n)).
apply plus_reg_l with n.
exact H'.
Qed.

Theorem absolu_inj_nat : forall x : nat, Zabs_nat (Z_of_nat x) = x.
intros x; case x.
auto.
simpl in |- *.
exact nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

Theorem absolu_mult :
 forall x y : Z, Zabs_nat (x * y) = Zabs_nat x * Zabs_nat y.
intros x; case x; auto; intros p y; case y; auto; simpl in |- *; intros;
 apply nat_of_P_mult_morphism.
Qed.

Theorem Qpositive_c_unfold1 :
 forall p q n : nat,
 S p + S q + S q <= S n ->
 Qpositive_c (S p + S q) (S q) (S n) = nR (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite <- (plus_n_Sm p q).
rewrite <- (minus_Sn_m (p + q) q).
rewrite (plus_comm p); rewrite minus_plus; auto with *.
auto with arith.
Qed.

Theorem Qpositive_c_unfold2 :
 forall p q n : nat,
 S p + (S p + S q) <= S n ->
 Qpositive_c (S p) (S p + S q) (S n) = dL (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite le_minus_O.
rewrite minus_plus.
auto.
auto with arith.
Qed.

Theorem construct_correct :
 forall (w : Qpositive) (p q n : nat),
 Qpositive_i w = (p, q) -> p + q <= n -> Qpositive_c p q n = w.
intros w; elim w; clear w.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S (p' + S q')) (S q') (S n)) with
  (nR (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := nR).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold1. auto with *.
auto with *.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S p') (S (p' + S q')) (S n)) with
  (dL (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := dL).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold2; auto with *.

simpl in |- *; intros p q n Heq; injection Heq; intros Heq2 Heq1; case n.
rewrite <- Heq1; simpl in |- *; intros Hle; inversion Hle.
rewrite <- Heq1; rewrite <- Heq2; simpl in |- *; auto with *.

Qed.

Theorem construct_correct2 :
 forall n p q : nat,
 S p + S q <= n ->
 exists d : nat,
   S p = fst (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d /\
   S q = snd (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d.
intros n; elim n.
intros p q Hle; inversion Hle.
clear n; intros n.
intros Hrec p q Hle; case (le_gt_dec (S p) (S q)).
simpl in |- *.
intros Hle'; rewrite (le_minus_O p q).
CaseEq (q - p).
intros Heq_minus; exists p.
simpl in |- *; split; auto with arith.
rewrite <- plus_n_O.
apply le_antisym; auto with arith.
apply minus_O_le.
auto.
intros q' Heq_minus; elim (Hrec p q').
intros d; simpl in |- *; case (Qpositive_i (Qpositive_c (S p) (S q') n));
 repeat rewrite <- (mult_comm (S d)); intros p'' q'' (Heq1, Heq2).
exists d; split.
exact Heq1.
rewrite (le_plus_minus (S p) (S q)).
simpl in |- *.
rewrite Heq_minus; rewrite Heq2.
simpl in |- *.
replace (S (p + q'' * S d)) with (S p + q'' * S d).
rewrite Heq1.
simpl in |- *.
ring.
simpl in |- *; auto.
auto with arith.
apply le_S_n.
rewrite plus_n_Sm.
apply le_trans with (S p + S q).
apply plus_le_compat_l.
apply le_n_S.
rewrite <- Heq_minus; apply minus_le.
exact Hle.
auto with arith.
intros Hgt; simpl in |- *; CaseEq (p - q).
intros H; elim (gt_not_le _ _ Hgt).
apply le_n_S.
apply minus_O_le.
exact H.
intros p'.
intros Heq_minus; simpl in |- *; elim (Hrec p' q).
intros d; case (Qpositive_i (Qpositive_c (S p') (S q) n)).
simpl in |- *; intros p'' q'' (Heq1, Heq2).
exists d; split; auto.
rewrite (le_plus_minus (S q) (S p)); simpl in |- *.
rewrite Heq_minus.
replace (S (q + S p')) with (S q + S p').
rewrite Heq2; rewrite Heq1; ring.
simpl in |- *; auto.
auto with arith.
rewrite <- Heq_minus.
replace (p - q) with (S p - S q).
rewrite <- (plus_comm (S q)).
rewrite <- (le_plus_minus (S q) (S p)).
apply le_trans with (S p + q).
auto with arith.
apply le_S_n; rewrite plus_n_Sm.
exact Hle.
auto with arith.
auto.
Qed.

Theorem construct_correct2' :
 forall n p q : nat,
 1 <= p ->
 1 <= q ->
 p + q <= n ->
 exists d : nat,
   p = fst (Qpositive_i (Qpositive_c p q n)) * S d /\
   q = snd (Qpositive_i (Qpositive_c p q n)) * S d.
intros n p; case p.
intros q H; inversion H.
intros p' q; case q.
intros Hle H; inversion H.
intros q' Hle Hle2; exact (construct_correct2 n p' q').
Qed.

Theorem construct_correct3 :
 forall n n' p q p' q' d : nat,
 S p = S d * p' ->
 S q = S d * q' ->
 S p + S q <= S n ->
 p' + q' <= S n' -> Qpositive_c (S p) (S q) (S n) = Qpositive_c p' q' (S n').
intros n; elim n; clear n.
intros n' p q p' q' d; rewrite <- plus_n_Sm.
simpl in |- *.
intros H1 H2 H3; inversion H3.
inversion H0.
intros n0 Hrec n' p q p' q' d Heqd1 Heqd2 Hle1 Hle2.
simpl in |- *.
CaseEq (p - q).
CaseEq (q - p).
intros H H0.
cut (p' = q').
intros Heq'; rewrite Heq'; rewrite <- (minus_n_n q').
auto.
apply mult_reg_l with d.
rewrite <- Heqd2; rewrite <- Heqd1.
apply le_antisym; apply minus_O_le; assumption.
intros q2 Heq2 Heqp.
cut (p' <= q').
intros H; generalize (le_minus_O _ _ H).
intros Heq3; rewrite Heq3.
CaseEq (q' - p').
intros Heq4; cut (q' = p').
intros Heq5; generalize Heq2; replace (q - p) with (S q - S p).
rewrite Heqd2; rewrite Heqd1; rewrite Heq5.
rewrite <- minus_n_n; intros Heq6; discriminate Heq6.
auto.
apply le_antisym; apply minus_O_le; assumption.
intros q'2.
generalize Hle2; case n'.
generalize Heqd1 Heqd2; case p'; case q'.
simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy;
 discriminate Dummy.
simpl in |- *; intros x H'1 H'2 H'3 H'4; discriminate H'4.
simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
 inversion H'3.
inversion H1.
intros n''.
intros Hle3 Heq4.
simpl in |- *.
CaseEq p'.
intros Heqp'; generalize Heqd1; rewrite Heqp'.
rewrite <- (mult_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
intros p'2 Heqp'2.
change
  (dL (Qpositive_c (S p) (S q2) (S n0)) =
   dL (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
apply f_equal with (f := dL).
apply Hrec with d; auto with *.
rewrite <- Heqp'2; assumption.
rewrite <- Heq4; rewrite <- Heq2; rewrite (mult_comm (S d)).
rewrite mult_minus_distr_r.
repeat rewrite <- (mult_comm (S d)).
rewrite <- Heqd2; rewrite <- Heqd1.
simpl in |- *; auto.
apply mult_S_le_reg_l with d.
rewrite <- Heqd2; rewrite <- Heqd1.
apply le_n_S.
apply minus_O_le; assumption.
intros p2 Heqp2.
CaseEq (p' - q').
intros Heqm'; cut (S p - S q = 0).
simpl in |- *; rewrite Heqp2; intros Dummy; discriminate Dummy.
rewrite Heqd2; rewrite Heqd1.
repeat rewrite (mult_comm (S d)).
rewrite <- mult_minus_distr_r.
rewrite Heqm'; simpl in |- *; auto.
intros p'2.
generalize Hle2; case n'.
generalize Heqd1 Heqd2; case p'; case q'.
simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy;
 discriminate Dummy.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy1 Dummy2;
 discriminate Dummy2.
simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
 inversion H'3.
inversion H0.
intros n''.
intros Hle3 Heq4.
CaseEq q'.
intros Heq5; generalize Heqd2; rewrite Heq5; simpl in |- *.
rewrite <- (mult_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
intros q'2 Heqq'2.
change
  (nR (Qpositive_c (S p2) (S q) (S n0)) =
   nR (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
apply f_equal with (f := nR).
apply Hrec with d; auto with *.
rewrite <- Heq4; rewrite <- Heqp2; rewrite (mult_comm (S d)).
rewrite mult_minus_distr_r.
repeat rewrite <- (mult_comm (S d)).
rewrite <- Heqd2; rewrite <- Heqd1.
simpl in |- *; auto.
rewrite <- Heqq'2; assumption.
Qed.

Theorem construct_correct4 :
 forall p q p' q' n n' : nat,
 S p + S q <= S n ->
 S p' + S q' <= S n' ->
 S p * S q' = S p' * S q ->
 Qpositive_c (S p) (S q) (S n) = Qpositive_c (S p') (S q') (S n').
intros p q p' q' n n' H H0 H1.
elim (construct_correct2 _ _ _ H).
intros d (Heq1, Heq2).
elim (construct_correct2 _ _ _ H0).
intros d' (Heq3, Heq4).
elim (interp_non_zero (Qpositive_c (S p) (S q) (S n))).
intros p0 Hex1; elim Hex1; intros q0 Heq5; clear Hex1.
elim (interp_non_zero (Qpositive_c (S p') (S q') (S n'))).
intros p'0 Hex1; elim Hex1; intros q'0 Heq6; clear Hex1.
elim (interp_reduced_fraction (Qpositive_c (S p) (S q) (S n))); intros a Hex1;
 elim Hex1; intros b; clear Hex1.
rewrite Heq6 in Heq4; rewrite Heq6 in Heq3; rewrite Heq5 in Heq2;
 rewrite Heq5 in Heq1; rewrite Heq5; unfold fst, snd in |- *;
 intros Heq7.
generalize H1; rewrite Heq1; rewrite Heq2; rewrite Heq3; rewrite Heq4;
 unfold fst, snd in |- *; clear H1; intros H1.
unfold fst, snd in Heq1, Heq2, Heq3, Heq4.
cut (S p0 * S q'0 = S p'0 * S q0).
intros Heq8.
cut (S p'0 = Zabs_nat (a * S p'0 + b * S q'0) * S p0).
intros Heq9.
cut (S q'0 = Zabs_nat (a * S p'0 + b * S q'0) * S q0).
intros Heq10.
cut (exists d'' : nat, Zabs_nat (a * S p'0 + b * S q'0) = S d'').
intros Hex; elim Hex; intros d'' Heq11; rewrite Heq11 in Heq9;
 rewrite Heq11 in Heq10.
replace (S p0 * S d) with (S (d + p0 * S d)).
replace (S q0 * S d) with (S (d + q0 * S d)).
rewrite
 (construct_correct3 n n (d + p0 * S d) (d + q0 * S d) (S p0) (S q0) d)
 .
replace (S p'0 * S d') with (S (d' + p'0 * S d')).
replace (S q'0 * S d') with (S (d' + q'0 * S d')).
symmetry in |- *.
apply construct_correct3 with (d := d' + d'' * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite Heq9; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
rewrite Heq10; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite <- Heq3; rewrite <- Heq4.
exact H0.
auto.
auto.
apply le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- mult_plus_distr_r.
rewrite mult_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
rewrite (mult_comm (S d)); auto.
rewrite (mult_comm (S d)); auto.
replace (S (d + q0 * S d)) with (S q0 * S d).
replace (S (d + p0 * S d)) with (S p0 * S d).
rewrite <- Heq1; rewrite <- Heq2.
exact H.
auto.
auto.
apply le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- mult_plus_distr_r.
rewrite mult_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
CaseEq (Zabs_nat (a * S p'0 + b * S q'0)).
intros Dummy; rewrite Dummy in Heq10; simpl in Heq10; discriminate Heq10.
intros d'' Heq; exists d''; auto.
rewrite <- (absolu_inj_nat (S q0)).
pattern (S q'0) at 1 in |- *; rewrite <- (absolu_inj_nat (S q'0)).
rewrite <- absolu_mult.
apply f_equal with (f := Zabs_nat).
pattern (Z_of_nat (S q'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S q'0 * (a * S p0 + b * S q0))%Z with
 (S p0 * S q'0 * a + S q'0 * (b * S q0))%Z.
rewrite <- (Znat.inj_mult (S p0)).
rewrite Heq8.
rewrite Znat.inj_mult; ring.
ring.
rewrite <- (absolu_inj_nat (S p0)).
pattern (S p'0) at 1 in |- *; rewrite <- absolu_inj_nat.
rewrite <- absolu_mult.
apply f_equal with (f := Zabs_nat).
pattern (Z_of_nat (S p'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S p'0 * (a * S p0 + b * S q0))%Z with
 (S p'0 * S q0 * b + S p'0 * (a * S p0))%Z.
rewrite <- (Znat.inj_mult (S p'0)).
rewrite <- Heq8.
rewrite Znat.inj_mult; ring.
ring.
apply mult_reg_l with (d' + d * S d').
replace (S (d' + d * S d')) with (S d * S d').
transitivity (S p0 * S d * (S q'0 * S d')).
ring.
rewrite H1.
ring.
auto.
Qed.

Theorem construct_correct4' :
 forall p q p' q' n n' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> p * q' = p' * q -> Qpositive_c p q n = Qpositive_c p' q' n'.
intros p; case p.
intros q p' q' n n' H; inversion H.
intros p0 q; case q.
intros p' q' n n' H H1; inversion H1.
intros q0 p'; case p'.
intros q' n n' H H1 H2; inversion H2.
intros p'0 q'; case q'.
intros n n' H H1 H2 H3; inversion H3.
intros q'0 n; case n.
simpl in |- *; intros n' H H1 H2 H3 H4; inversion H4.
intros n0 n'; case n'.
simpl in |- *; intros H H1 H2 H3 H4 H5; inversion H5.
intros; apply construct_correct4; auto.
Qed.

Theorem interp_inject :
 forall w w' : Qpositive, Qpositive_i w = Qpositive_i w' -> w = w'.
intros w w' H; CaseEq (Qpositive_i w).
intros p q Heq.
rewrite <- construct_correct with (1 := Heq) (n := p + q).
apply construct_correct; auto.
rewrite <- H; auto.
auto.
Qed.

Theorem minus_decompose :
 forall a b c d : nat, a = b -> c = d -> a - c = b - d.
intros a b c d H H1; rewrite H; rewrite H1; auto.
Qed.

Theorem Qpositive_c_equiv :
 forall n p q n' p' q' : nat,
 S p + S q <= n ->
 S p' + S q' <= n' ->
 Qpositive_c (S p) (S q) n = Qpositive_c (S p') (S q') n' ->
 S p * S q' = S p' * S q.
intros n; elim n.
simpl in |- *; intros p q n' p' q' H; inversion H.
intros n0 Hrec p q n'.
case n'.
simpl in |- *; intros p' q' H H1; inversion H1.
unfold Qpositive_c in |- *.
CaseEq (S p - S q).
CaseEq (S q - S p).
intros Heq1 Heq2 n1 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Heq3 Heq4; cut (p = q).
intros Heq5; rewrite Heq5.
cut (p' = q').
intros Heq6; rewrite Heq6.
intros; apply mult_comm.
apply eq_add_S; apply le_antisym; apply minus_O_le; auto with *.
apply eq_add_S; apply le_antisym; apply minus_O_le; auto with *.
intros p2 H H1 H2 H3 H4; discriminate H4.
intros n2 H H1 H2 H4; discriminate H4.
intros q2 Heq1 Heq2 n2 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros H3 H4 H H1 H2; discriminate H2.
intros q'2 H H1 H2 H3 H4; injection H4; intros H5.
rewrite (le_plus_minus (S p) (S q)).
rewrite (le_plus_minus (S p') (S q')).
rewrite (mult_comm (S p)); rewrite (mult_comm (S p')).
repeat rewrite mult_plus_distr_r; repeat rewrite <- (mult_comm (S p)).
apply f_equal with (f := fun x : nat => S p * S p' + x).
rewrite Heq1; rewrite H.
rewrite <- (mult_comm (S p')).
apply Hrec with n2.
rewrite <- Heq1.
rewrite <- le_plus_minus.
apply le_trans with (p + S q).
auto with arith.
apply le_S_n; exact H2.
apply minus_O_le; auto.
rewrite <- H.
rewrite <- le_plus_minus.
apply le_trans with (p' + S q').
auto with arith; fail.
apply le_S_n; exact H3.
apply minus_O_le; auto.
exact H5.
apply minus_O_le; auto.
apply minus_O_le; auto.
intros n1 dummy1 Dummy2 Dummy3 Dummy; discriminate Dummy.
intros n1 Heq1 n2 p' q' Hle1 Hle2; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Dummy3 Dummy1 Dummy2; discriminate Dummy2.
intros n3 Dummy Dummy1 Dummy2; discriminate Dummy2.
intros p'2 Heq2 Heq3.
injection Heq3; clear Heq3; intros Heq3.
rewrite (le_plus_minus (S q) (S p)).
rewrite Heq1.
rewrite (le_plus_minus (S q') (S p')).
rewrite Heq2.
repeat rewrite mult_plus_distr_r; repeat rewrite (mult_comm (S q')).
apply f_equal with (f := fun x : nat => S q * S q' + x).
apply Hrec with n2.
rewrite plus_comm; rewrite <- Heq1.
rewrite <- le_plus_minus.
apply le_trans with (p + S q).
rewrite <- plus_n_Sm.
auto with arith.
apply le_S_n; assumption.
omega.
rewrite <- Heq2.
rewrite plus_comm; rewrite <- le_plus_minus.
apply le_trans with (p' + S q').
rewrite <- plus_n_Sm; auto with arith.
apply le_S_n; exact Hle2.
omega.
exact Heq3.
omega.
omega.
Qed.

Theorem Qpositive_c_equiv' :
 forall n p q n' p' q' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> Qpositive_c p q n = Qpositive_c p' q' n' -> p * q' = p' * q.
intros n p q n' p' q'; case p.
intros H; inversion H.
clear p; intros p Hlp.
case q; [ intros H; inversion H | clear q; intros q Dummy; clear Dummy ].
case p'; [ intros H; inversion H | clear p'; intros p' Dummy; clear Dummy ].
case q'; [ intros H; inversion H | clear q'; intros q' Dummy; clear Dummy ].
intros; apply Qpositive_c_equiv with n n'; auto.
Qed.