Require Coq.extraction.Extraction.
Require Import Ascii String Coq.Strings.Byte.
Require Export ExtrOcamlChar.
Extract Inductive bool => "bool" ["true" "false"].
Extract Inductive string => "char list" [ "[]" "(::)" ].
From Coq Require Import Lists.List.
Extract Inductive list => "list" [ "[]" "(::)" ].
Extraction Language OCaml.
Import ListNotations.
Load "../std".

Module deBruijin.

Module E11_1.
Require Import Nat.

Inductive ty : Type :=
| Bool
| Arrow (T1 T2: ty)
| Unit.
Notation "t1 '|-->' t2" := (Arrow t1 t2) (at level 40).

Inductive term : Type :=
(*純粋λ計算*)
| var (n: nat)
| abs (name: string) (typ: ty) (t: term)
| app (t1 t2: term)

(*ぶーる*)
| tru
| fls
| If (t1 t2 t3: term)
(*拡張*)
| unit
| seq (t1 t2: term).

Inductive value : term -> Prop :=
  | v_abs : forall x T t, value (abs x T t)
  | v_tru : value tru
  | v_fls : value fls
  | v_unit: value unit.

Definition isval t :=
  match t with
  | tru => true
  | fls => true
  | abs _ _ _ => true
  | unit => true
  | _ => false
  end.

Fixpoint eqb_ty (T1 T2: ty) : bool :=
  match (T1, T2) with
  | (Bool, Bool) => true
  | (Unit, Unit) => true
  | (T11 |--> T12, T21 |--> T22) =>
    andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | _ => false
  end.

Lemma eq_type_refl : forall T,
    eqb_ty T T = true.
Proof.
  induction T; simpl; auto. rewrite IHT1, IHT2; auto.
Qed.

Fixpoint shift (d : nat) (t : term) : term :=
match t with
| var x => var (if leb d x then (S x) else x)
| abs x T t' => abs x T (shift (S d) t')
| app t1 t2 => app (shift d t1) (shift d t2)
| tru => tru
| fls => fls
| If t1 t2 t3 =>
  If (shift d t1) (shift d t2) (shift d t3)
| unit => unit
| seq t1 t2 =>
  seq (shift d t1) (shift d t2)
end.

Fixpoint subst (d : nat) (s t: term) : term :=
match t with
| var x =>
  if eqb d x then s
  else if ltb d x then var (pred x) else var x
| abs x T t' => abs x T (subst (S d) (shift 0 s) t')
| app t1 t2 => app (subst d s t1) (subst d s t2)
| tru => tru
| fls => fls
| unit => unit
| If t1 t2 t3 =>
  If (subst d s t1) (subst d s t2) (subst d s t3)
| seq t1 t2 =>
  seq (subst d s t1) (subst d s t2)
end.

Reserved Notation " t '-->i' t' " (at level 40).
Inductive internal_step :term -> term -> Prop :=
| Ei_IfTrue : forall t2 t3,
    If tru t2 t3 -->i t2
| Ei_IfFalse : forall t2 t3,
    If fls t2 t3 -->i t3
| Ei_If : forall t1 t1' t2 t3,
    t1 -->i t1' ->
    If t1 t2 t3 -->i If t1' t2 t3
| Ei_App1 : forall t1 t2 t1',
    t1 -->i t1' ->
    app t1 t2 -->i app t1' t2
| Ei_App2 : forall v1 t2 t2',
    value v1 ->
    t2 -->i t2' ->
    app v1 t2 -->i app v1 t2'
| Ei_AppAbs : forall typ str t12 t2,
    value t2 ->
    app (abs str typ t12) t2 -->i subst 0 t2 t12

where " t '-->i' t' " := (internal_step t t').

Reserved Notation " t '-->e' t' " (at level 40).
Inductive external_step : term -> term -> Prop :=
| E_IfTrue : forall t2 t3,
    If tru t2 t3 -->e t2
| E_IfFalse : forall t2 t3,
    If fls t2 t3 -->e t3
| E_If : forall t1 t1' t2 t3,
    t1 -->e t1' ->
    If t1 t2 t3 -->e If t1' t2 t3
| E_App1 : forall t1 t2 t1',
    t1 -->e t1' ->
    app t1 t2 -->e app t1' t2
| E_App2 : forall v1 t2 t2',
    value v1 ->
    t2 -->e t2' ->
    app v1 t2 -->e app v1 t2'
| E_AppAbs : forall typ str t12 t2,
    value t2 ->
    app (abs str typ t12) t2 -->e subst 0 t2 t12
| E_seq : forall t1 t1' t2,
    t1 -->e t1' ->
    seq t1 t2 -->e seq t1' t2
| E_SeqNext : forall v1 t2,
    value v1 ->
    seq v1 t2 -->e t2
where " t '-->e' t' " := (external_step t t').

Lemma leb_S_l : forall m n,
  leb (n + S m) n = false.
Proof.
  induction n; simpl; intros; auto.
Qed.

Require Import PeanoNat.

Lemma sub_shift : forall t1 t2 n,
    subst n t2 (shift n t1) = t1.
Proof.
  induction t1; intros; simpl; auto.
  -
    destruct leb eqn:IH1; destruct eqb eqn:IH2; try apply Nat.eqb_eq in IH2; subst.
    apply Nat.leb_le in IH1. apply Nat.nle_succ_diag_l in IH1. inversion IH1.
    apply Nat.leb_le in IH1. apply Lt.le_lt_n_Sm in IH1. apply Nat.ltb_lt in IH1. rewrite IH1. simpl. reflexivity.
    rewrite Nat.leb_refl in IH1. inversion IH1.
    assert (n0 <? n = false).
    apply Nat.ltb_ge, Nat.lt_le_incl, Nat.leb_gt. apply IH1.
    rewrite H. reflexivity.
  -
    rewrite IHt1. reflexivity.
  -
    rewrite IHt1_1, IHt1_2; reflexivity.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; reflexivity.
  -
    rewrite IHt1_2, IHt1_1; reflexivity.
Qed.

Notation "t1 ';' t2" := (seq t1 t2) (at level 50).

Fixpoint e2t t :=
  match t with
  | var x => var x
  | abs x T t' => abs x T (e2t t')
  | app t1 t2 => app (e2t t1) (e2t t2)
  | If t1 t2 t3 => If (e2t t1) (e2t t2) (e2t t3)
  | t1; t2 => app (abs "x" Unit (shift 0 (e2t t2 ))) (e2t t1)
  | _ => t
  end.

Lemma shift_shift : forall t1 i k,
    i < (S k) ->
    shift (S k) (shift i t1 ) = shift i (shift k t1).
Proof.
  induction t1; simpl; intros; auto.
  -
    destruct leb eqn:IH1; destruct (leb k n) eqn:IH2.
    apply Nat.leb_le in IH1. apply le_S in IH1. apply Nat.leb_le in IH1. rewrite IH1. reflexivity.
    rewrite IH1. reflexivity.

    destruct n. apply Nat.leb_le in IH2. inversion IH2; subst. compute in H. apply le_S_n in H.
    inversion H; subst. simpl in IH1. inversion IH1.

    compute in H. apply le_S_n in H. apply Nat.leb_le in IH2. apply Nat.le_trans with (p:= (S n)) in H; auto.
    apply Nat.leb_nle in IH1. apply IH1 in H. inversion H.
    rewrite IH1.
    destruct n; auto.
    assert (k <=? n = false).
    +
      apply Nat.leb_nle. intro. apply le_S in H0. apply Nat.leb_nle in IH2. apply IH2. apply H0.
    +
    rewrite H0. reflexivity.
  -
    rewrite IHt1; auto. apply Lt.lt_n_S. apply H.
  -
    rewrite IHt1_1, IHt1_2; auto.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; auto.
  -
    rewrite IHt1_1, IHt1_2; auto.
Qed.

Notation "t1 '[[' n ':=' t2 ']]' " := (subst n t2 t1) (at level 20).
Lemma shift_sub : forall t1 i j s,
    j < (S i) ->
    shift i (t1 [[ j := s]] ) = (shift (i + 1 ) t1) [[j := (shift i s) ]].
Proof.
  induction t1; simpl; intros; auto.
  -
    rewrite Nat.add_1_r.
    destruct eqb eqn:IH1.
    +
      apply Nat.eqb_eq in IH1; subst.
      apply Nat.nle_gt in H. apply Nat.leb_nle in H. rewrite H.
      rewrite Nat.eqb_refl. reflexivity.
    +
      destruct ((S i) <=? n) eqn:IH2; simpl.
      ++
        apply Nat.leb_le in IH2. apply Nat.lt_le_trans with (p:= n) in H; auto. apply Nat.ltb_lt in H.
        rewrite H; simpl.
        destruct n. inversion H. simpl.
        apply le_S_n in IH2. apply Nat.leb_le in IH2. rewrite IH2.
        destruct (j =? (S(S n))) eqn:IH3. apply Nat.eqb_eq in IH3; subst.
        apply Nat.ltb_lt in H. apply Nat.nlt_succ_diag_l in H. inversion H.
        apply Nat.ltb_lt, Nat.lt_lt_succ_r, Nat.ltb_lt in H. rewrite H.
        reflexivity.
      ++
        destruct (j <? n) eqn:IH3.
        +++
          rewrite IH1. simpl. destruct n; simpl. compute in H. apply le_S_n in H. destruct i; simpl; auto.
          inversion H; subst. simpl in IH1. inversion IH1.
          apply Nat.leb_nle, Nat.nle_gt, Lt.lt_S_n, Nat.nle_gt, Nat.leb_nle in IH2.
          rewrite IH2. reflexivity.
        +++
          simpl. rewrite IH1.
          apply Nat.leb_nle, Nat.nle_gt in IH2. compute in IH2.
          apply le_S_n, Lt.le_lt_or_eq in IH2. destruct IH2.
          apply Nat.nle_gt in H0. apply Nat.leb_nle in H0. rewrite H0; reflexivity.
          subst. compute in H. apply le_S_n, Lt.le_lt_or_eq in H. destruct H.
          apply Nat.ltb_lt in H. rewrite H in IH3. inversion IH3.
          subst. rewrite Nat.eqb_refl in IH1. inversion IH1.
  -
    rewrite IHt1. rewrite shift_shift; auto.
    apply Nat.lt_0_succ.
    apply Lt.lt_n_S; auto.
  -
    rewrite IHt1_1, IHt1_2; auto.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; auto.
  -
    rewrite IHt1_1, IHt1_2; auto.
Qed.

Lemma shift_sub_lt : forall t1 s i j,
    i < (S j) ->
    shift i (t1 [[j := s]]) = (shift i t1) [[(S j) := shift i s]].
Proof.
 induction t1; simpl; intros; auto.
   -
    destruct eqb eqn:IH1.
    +
      apply Nat.eqb_eq in IH1; subst.
      destruct leb eqn:IH2.
      *
        simpl. rewrite Nat.eqb_refl. reflexivity.
      *
        apply Nat.leb_nle in IH2. compute in H. apply le_S_n in H. induction IH2; auto.
    +
      destruct (j <? n) eqn:IH2.
      *
        destruct (i <=? n) eqn:IH3.
        **
          rewrite IH1. apply Nat.ltb_lt in IH2. apply Lt.lt_n_S in IH2. apply Nat.ltb_lt in IH2.
          rewrite IH2. simpl. destruct n; try discriminate; simpl.
          apply Nat.leb_le in IH3. apply Lt.le_lt_or_eq in IH3. destruct IH3; subst.
          compute in H0. apply le_S_n in H0. apply Nat.leb_le in H0; rewrite H0. reflexivity.
          apply Nat.ltb_lt in IH2. apply Lt.lt_S_n in IH2. apply Lt.lt_S_n in H.
          apply Nat.nle_gt in IH2. compute in H. induction IH2. apply H.
        **
          destruct n; try discriminate; simpl.
          apply Nat.leb_nle in IH3. apply Nat.nle_gt in IH3. apply Nat.lt_succ_l in IH3. apply Nat.nle_gt in IH3. apply Nat.leb_nle in IH3. rewrite IH3.
          destruct (j =? n) eqn:IH4. apply Nat.eqb_eq in IH4; subst. compute in H. apply Nat.leb_nle in IH3. apply le_S_n in H. induction IH3; apply H.
          destruct (S j <? S n) eqn:IH5; auto.
          apply Nat.ltb_lt in IH2. compute in IH2. apply Lt.le_lt_or_eq in IH2. destruct IH2; subst; try discriminate.
          apply Nat.ltb_lt in H0. rewrite H0 in IH5. inversion IH5. inversion H0; subst. rewrite Nat.eqb_refl in IH4. inversion IH4.
      *
        destruct leb eqn:IH3.
        **
          rewrite IH1. simpl. rewrite IH3. destruct (S j <? S n) eqn:IH4; auto.
          apply Nat.ltb_lt, Lt.lt_S_n, Nat.ltb_lt in IH4. rewrite IH4 in IH2. inversion IH2.
        **
          destruct n; simpl. rewrite IH3. reflexivity.
          rewrite IH3. destruct (j =? n) eqn:IH4.
          apply Nat.eqb_eq in IH4; subst. apply Nat.ltb_nlt in IH2. apply Nat.nlt_ge in IH2. einduction Nat.nle_succ_diag_l. apply IH2.
          destruct (S j <? S n) eqn:IH5; auto.
          apply Nat.ltb_lt in IH5. compute in IH5. repeat apply Le.le_Sn_le in IH5.
          apply Lt.le_lt_or_eq in IH5; destruct IH5; subst. apply Nat.ltb_lt in H0. rewrite H0 in IH2. inversion IH2.
          rewrite Nat.eqb_refl in IH1. inversion IH1.
  -
    rewrite IHt1; auto. rewrite shift_shift; auto.
    apply Nat.lt_0_succ.
    apply Lt.lt_n_S; auto.
  -
    rewrite IHt1_1; try rewrite IHt1_2; auto.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; auto.
  -
    rewrite IHt1_1, IHt1_2; auto.
Qed.

Lemma subsub :forall t1 j i v u,
    i < (S j) ->
    t1[[ S j := shift i v ]] [[i := u[[j := v ]] ]] = t1 [[i := u ]] [[j := v]].
Proof.
  induction t1; simpl; intros; auto.
  -
    destruct n.
    +
      destruct ltb eqn:IH1. inversion IH1.
      simpl. destruct i. reflexivity.
      simpl. apply Lt.lt_S_n in H. destruct j. inversion H. simpl. reflexivity.
    +
      simpl.
      destruct eqb eqn:IH1.
      ++
        apply Nat.eqb_eq in IH1; subst. generalize H; intros. compute in H. destruct eqb eqn:IH1; try apply Nat.eqb_eq in IH1; subst.
        einduction Nat.nle_succ_diag_l; eauto. apply Nat.ltb_lt in H0. rewrite H0. simpl. rewrite Nat.eqb_refl.
        rewrite sub_shift. reflexivity.
      ++
        destruct ltb eqn:IH2; simpl.
        destruct (eqb i n) eqn:IH3. apply Nat.eqb_eq in IH3; subst.
        apply Nat.ltb_lt in IH2.
        apply Nat.nle_gt in IH2. compute in H. induction IH2. apply H.
      --
        destruct (ltb i n) eqn:IH4.
        destruct (i =? S n) eqn:IH5; try apply Nat.eqb_eq in IH5; subst. apply Nat.ltb_lt in IH4.
        induction (Nat.nlt_succ_diag_l n); apply IH4.
        apply Nat.ltb_lt in IH2. apply Nat.lt_trans with (p:= S n) in H; auto. apply Nat.ltb_lt in H. rewrite H.
        simpl. rewrite IH1. apply Lt.lt_S_n in IH2. apply Nat.ltb_lt in IH2. rewrite IH2. reflexivity.
        destruct (i =? S n) eqn:IH5; try apply Nat.eqb_eq in IH5; subst.
        apply Nat.ltb_lt in IH2. apply Nat.nle_gt in IH2. apply Nat.lt_le_incl in H. induction IH2. apply H.
        apply Nat.ltb_lt in IH2. apply Nat.lt_trans with (p:= S n) in H; auto. compute in H.
        apply le_S_n in H. apply Lt.le_lt_or_eq in H. destruct H.
        apply Nat.ltb_lt in H. rewrite H in IH4. inversion IH4.
        subst. rewrite Nat.eqb_refl in IH3. inversion IH3.
      --
        destruct (i =? S n) eqn:IH3; try apply Nat.eqb_eq in IH3; subst; auto.
        apply Nat.ltb_nlt in IH2. apply Nat.nlt_ge in IH2.
        destruct (i <? S n) eqn:IH4. simpl.
        rewrite IH1. apply le_S_n in IH2. apply Nat.nlt_ge in IH2. apply Nat.ltb_nlt in IH2. rewrite IH2. reflexivity.
        simpl.
        destruct (eqb j (S n)) eqn:IH5; try apply Nat.eqb_eq in IH5; subst.
        ***
          compute in H. apply le_S_n in H. apply Lt.le_lt_or_eq in H. destruct H; subst.
          apply Nat.ltb_nlt in IH4. induction IH4; apply H.
          rewrite Nat.eqb_refl in IH3. inversion IH3.
        ***
          destruct (ltb j (S n)) eqn:IH6; auto.
          apply Nat.ltb_lt in IH6. compute in IH6.
          apply Nat.lt_le_trans with (p:= S n) in H; auto. apply Nat.ltb_lt in H. rewrite H in IH4.
          inversion IH4.
  -
    generalize Nat.lt_0_succ; intros.
    generalize H; intros.
    apply Lt.lt_n_S in H. apply IHt1 with (v:= v) (u:= u) in H.
    rewrite shift_sub_lt; auto. rewrite <- shift_shift; auto. rewrite IHt1. reflexivity. apply Lt.lt_n_S.
    apply H1.
  -
    rewrite IHt1_2, IHt1_1; auto.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; auto.
  -
    rewrite IHt1_2, IHt1_1; auto.
Qed.

Lemma shift_e2t : forall t1 n,
    e2t (shift n t1) = shift n (e2t t1).
Proof.
  induction t1; simpl; intros; auto.
  -
    rewrite IHt1; reflexivity.
  -
    rewrite IHt1_1, IHt1_2; reflexivity.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; reflexivity.
  -
    rewrite shift_shift; auto.
    rewrite IHt1_1. rewrite IHt1_2. reflexivity.
    compute. apply le_n_S. apply le_0_n.
Qed.

Lemma subst_e2t : forall t1 t2 n,
   e2t (t1[[n := t2]] ) = (e2t t1)[[n:= (e2t t2)]].
Proof.
  induction t1; simpl; intros; auto.
  -
    destruct eqb; destruct ltb; auto.
  -
    rewrite IHt1, shift_e2t. reflexivity.
  -
    rewrite IHt1_1, IHt1_2; auto.
  -
    rewrite IHt1_1, IHt1_2, IHt1_3; reflexivity.
  -
    rewrite IHt1_1, IHt1_2.
    rewrite shift_sub_lt. reflexivity.
    compute. apply le_n_S. apply le_0_n.
Qed.

Theorem T11_3_1_1_1 : forall t' t'',
  t' -->e t'' ->
  (e2t t') -->i (e2t t'').
Proof.
  induction t'; intros; simpl; try solve_by_inverts 2.
  -
    inversion H; subst; simpl; try solve [constructor; auto].
    +
      apply IHt'2 in H4. apply Ei_App2; auto. destruct t'1; simpl; try constructor; solve_by_invert; auto.
    +
      rewrite subst_e2t; auto.
      constructor.
      destruct t'2; try constructor; solve_by_invert.
  -
    inversion H; subst; simpl; try constructor; auto.
  -
    inversion H; subst; simpl; try constructor; auto; try solve_by_invert.
    +
      constructor.
    +
      erewrite <- sub_shift. constructor. destruct t'1; try solve_by_invert; constructor.
Qed.

Theorem T11_3_1_1_2 : forall t u,
  (e2t t) -->i u ->
  exists t', u = e2t t' /\ t -->e t'.
Proof.
  induction t; simpl; intros; try solve_by_invert.
  -
    inversion H; subst; simpl; try constructor.
    +
      apply IHt1 in H3; destruct H3; destruct H0; subst. exists (app x t2); split; try constructor; auto.
    +
      apply IHt2 in H4; destruct H4; destruct H0; subst. exists (app t1 x); split; try constructor; auto.
      destruct t1; try solve_by_invert; constructor.
    +
      destruct t1; try solve_by_invert. simpl in H0. inversion H0; subst.
      exists (subst 0 t2 t1). split. symmetry. apply subst_e2t.
      constructor.
      destruct t2; try solve_by_invert; constructor.
  -
    inversion H; subst.
    +
      destruct t1; try solve_by_invert. simpl in H1. exists t2. split; auto; constructor.
    +
      destruct t1; try solve_by_invert. simpl in H1. exists t3; split; auto; constructor.
    +
      apply IHt1 in H4. destruct H4; destruct H0; subst.
      exists (If x t2 t3); split; try constructor; auto.
  -
    inversion H; subst.
    +
      subst. inversion H3.
    +
      apply IHt1 in H4. destruct H4; destruct H0; subst. exists (seq x t2); split; try constructor; auto.
    +
      exists t2. split; try constructor; auto. apply sub_shift. destruct t1; try solve_by_invert; constructor.
Qed.

Definition context := list (string * ty).
Definition eqb_string s1 s2:= String.eqb s1 s2.

Fixpoint getbinding (n : nat) (ctx: context) :=
  match n with
  | 0 =>
    match ctx with
    | [] => None
    | (x, t) :: ctx' => Some t
    end
  | S n' =>
    match ctx with
    | [] => None
    | x :: ctx' => getbinding n' ctx'
    end
  end.

Reserved Notation "ctx '|-' t '\in' T" (at level 40).
Inductive has_type : context -> term -> ty -> Prop :=
| T_True: forall ctx,
      ctx |- tru \in Bool
| T_False: forall ctx,
      ctx |- fls \in Bool
| T_If: forall ctx t1 t2 t3 T',
      ctx |- t1 \in Bool ->
      ctx |- t2 \in T' ->
      ctx |- t3 \in T' ->
      ctx |- (If t1 t2 t3) \in T'
| T_Var: forall ctx n1 t,
      getbinding n1 ctx = Some t ->
      ctx |- (var n1) \in t
| T_Abs: forall ctx x T1 t2 T2,
      ((x, T1) :: ctx) |- t2 \in T2 ->
      ctx |- (abs x T1 t2) \in (T1 |--> T2)
| T_App: forall ctx t1 T11 T12 t2,
      ctx |- t1 \in (T11 |--> T12) ->
      ctx |- t2 \in T11 ->
      ctx |- app t1 t2 \in T12
| T_Unit: forall ctx,
    ctx |- unit \in Unit
| T_Seq : forall ctx t1 t2 T2,
    ctx |- t1 \in Unit ->
    ctx |- t2 \in T2 ->
    ctx |- (seq t1 t2) \in T2

where " ctx '|-' x '\in' t " := (has_type ctx x t).

Lemma appGetbind : forall ctx ctx' n,
    getbinding (n + (length ctx)) (ctx ++ ctx') = getbinding n ctx'.
Proof.
  induction ctx; simpl; intros; auto.
  rewrite <- plus_n_O; reflexivity.
  rewrite Nat.add_succ_r. simpl. apply IHctx.
Qed.

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

Lemma shifting : forall t g g1 a T,
  (g1 ++ g) |- t \in T ->
  (g1 ++ (a :: g)) |- (shift (length g1) t) \in T.
Proof.
  induction t; intros; inversion H; subst; clear H; try solve [econstructor; eauto]; simpl.

  apply T_Var. destruct (leb) eqn:IH. apply Nat.leb_le in IH.
  generalize dependent g. generalize dependent T. generalize dependent n.
  induction g1; simpl; intros; eauto.

  destruct n. inversion IH. simpl.
  apply le_S_n in IH. simpl in H2. eapply IHg1 in IH; eauto.

  apply Nat.leb_gt in IH. eapply length1_Some in IH. apply IH. apply H2.

  apply T_Abs.
  assert (S (length g1) = length ((name, typ) :: g1)). reflexivity.
  rewrite H. apply IHt with (g1:= ((name, typ) :: g1)). apply H5.
Qed.

Lemma shifting_rev : forall t g g1 a T,
  (g1 ++ (a :: g)) |- (shift (length g1) t) \in T ->
  (g1 ++ g) |- t \in T.
Proof.
  induction t; intros; inversion H; subst; clear H; try solve [econstructor; eauto]; simpl.
  -
    destruct leb eqn:IH1. apply Nat.leb_le in IH1.
    apply T_Var.
    generalize dependent g. generalize dependent T. generalize dependent n.
    induction g1; simpl; intros; eauto.

    destruct n. inversion IH1. simpl. apply IHg1; auto. apply le_S_n. apply IH1.

    apply Nat.leb_gt in IH1.
    apply length1_Some with (ctx := g1) (ctx1 := a:: g) (ctx2 :=g) in H2; auto. apply T_Var.
    apply H2.
  -
    apply T_Abs. apply IHt with (g1:= (name,typ) :: g1) in H5. simpl in H5.
    apply H5.
Qed.

Theorem T11_3_1_2 : forall t1 T ctx,
    ctx |- t1 \in T <->
    ctx |- (e2t t1) \in T.
Proof.
  split; generalize dependent T; generalize dependent ctx.
  -
    induction t1; simpl; intros; auto; inversion H; subst; try solve [econstructor; eauto].
    +
      econstructor; eauto. constructor; auto.
      apply shifting with (g1 := []).
      simpl. apply IHt1_2. apply H5.
  -
    induction t1; simpl; intros; auto; inversion H; subst; try solve [econstructor; eauto].
    inversion H3; subst.
    constructor; eauto.
    apply IHt1_2.
    apply shifting_rev with (g1:= nil) in H2. simpl in H2. apply H2.
Qed.

Lemma type_app_r : forall e Γ1 Γ2 typ,
    Γ1 |- e \in typ ->
    (Γ1 ++ Γ2) |- e \in typ.
Proof.
  intros. revert Γ2.
  induction H; intros; econstructor; eauto.
  revert H. revert n1.
  induction ctx; simpl; intros.
  destruct n1; try discriminate.
  destruct n1; simpl in H; simpl; auto.
Qed.

Lemma getbind_length_le : forall Γ1 Γ2 n ,
    length Γ1 <= n ->
    getbinding n (Γ1 ++ Γ2) = getbinding (n - length Γ1) Γ2.
Proof.
  induction Γ1; simpl; intros.
  rewrite Nat.sub_0_r. reflexivity.
  destruct n. inversion H.
  apply le_S_n in H. apply IHΓ1. apply H.
Qed.

Lemma subst_type: forall t s x Ts T ctx ctx',
    (ctx' ++ (x, Ts) :: ctx) |- t \in T ->
    ctx' |- s \in Ts ->
    (ctx' ++ ctx) |- subst (length ctx') s t \in T.
Proof.
  induction t; intros; inversion H; subst; clear H; try solve [econstructor; eauto]; simpl.
  -
    destruct eqb eqn:IH.
    rewrite Nat.eqb_eq in IH; subst.
    assert (H: getbinding (Datatypes.length ctx') (ctx' ++ (x, Ts) :: ctx) = Some Ts).
    { clear. induction ctx'; eauto. }
    rewrite H in H3. inversion H3; subst.
    apply type_app_r. apply H0.
    apply Nat.eqb_neq in IH.
    destruct ltb eqn:IH0.
    apply Nat.ltb_lt in IH0.
    destruct n; try solve_by_invert.
    simpl. constructor.
    unfold lt in IH0. apply le_S_n in IH0.
    rewrite getbind_length_le; auto.
    rewrite getbind_length_le in H3; auto.
    rewrite <- minus_Sn_m in H3; auto.
    apply Nat.ltb_ge in IH0.
    constructor.
    apply length1_Some with ((x, Ts)::ctx); auto.
    apply le_lt_or_eq in IH0. destruct IH0; auto.
    symmetry in H. apply IH in H. inversion H.
  -
    apply T_Abs.
    assert (length ((name, typ) :: ctx') = S (length ctx')).
    reflexivity.
    rewrite <- H.
    assert ((name, typ):: ctx' ++ ctx = ( (name, typ) :: ctx') ++ ctx). reflexivity.
    rewrite H1.
    apply IHt with (x:= x) (Ts:= Ts). apply H6.
    rewrite <- (app_nil_l ( (name, typ)::ctx' ) ).
    apply shifting. simpl. apply H0.
Qed.

Theorem T9_3_9 : forall t t' T ctx,
    ctx |- t \in T ->
    t -->i t' ->
    ctx |- t' \in T.
Proof.
  intros. generalize dependent t'. induction H; intros; try solve_by_invert.
  -
    inversion H2; subst; auto.
    apply IHhas_type1 in H7. constructor; auto.
  -
    inversion H1; subst.
    +
      apply IHhas_type1 in H5. econstructor; eauto.
    +
      apply IHhas_type2 in H6. econstructor; eauto.
    +
      inversion H; subst.
      clear IHhas_type1. clear IHhas_type2.
      rewrite <- (app_nil_l ctx).
      eapply subst_type; eauto.
Abort.

End E11_1.

End deBruijin.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From LCAC Require Import Relations_ext seq_ext_base ssrnat_ext seq_ext.

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

Inductive typ := tyvar of nat | tyfun of typ & typ.
Inductive term := var of nat | app of term & term | abs of typ & term.

Coercion tyvar : nat >-> typ.
Coercion var : nat >-> term.

Notation "ty ->t ty'" := (tyfun ty ty') (at level 55, right associativity).
Notation "t @ t'" := (app t t') (at level 65, left associativity).

Fixpoint eqtyp t1 t2 :=
  match t1, t2 with
    | tyvar n, tyvar m => eqn n m
    | t1l ->t t1r, t2l ->t t2r => eqtyp t1l t2l && eqtyp t1r t2r
    | _, _ => false
  end.

Lemma eqnP' : Equality.axiom eqn.
Proof.
elim => [| n IH] [| m] //=; try by constructor.
by case: (IH m) => H; constructor; [f_equal | case].
Defined.

Lemma eqtypP : Equality.axiom eqtyp.
Proof.
elim => [n | t1l IHl t1r IHr] [m | t2l t2r] /=; try by constructor.
- by case: eqnP'; constructor; [f_equal | case].
- move: (IHl t2l) (IHr t2r) => [] Hl [] Hr;
    constructor; by [f_equal | case].
Defined.

Canonical typ_eqMixin := EqMixin eqtypP.
Canonical typ_eqType := Eval hnf in EqType typ typ_eqMixin.

Fixpoint eqterm t1 t2 :=
  match t1, t2 with
    | var n, var m => n == m
    | t1l @ t1r, t2l @ t2r => eqterm t1l t2l && eqterm t1r t2r
    | abs ty1 t1, abs ty2 t2 => (ty1 == ty2) && eqterm t1 t2
    | _, _ => false
  end.

Lemma eqtermP : Equality.axiom eqterm.
Proof.
move => t1 t2; apply: (iffP idP) => [| <-];
  last by elim: t1 => //= [t1l -> | ty1 t1 ->] //; rewrite andbT.
by elim: t1 t2 => [n | t1l IHl t1r IHr | ty1 t1 IH]
  [// m /eqP -> | //= t2l t2r /andP [] /IHl -> /IHr -> |
   //= ty2 t2 /andP [] /eqP -> /IH ->].
Defined.

Canonical term_eqMixin := EqMixin eqtermP.
Canonical term_eqType := Eval hnf in EqType term term_eqMixin.

Fixpoint shift d c t : term :=
  match t with
    | var n => var (if c <= n then n + d else n)
    | t1 @ t2 => shift d c t1 @ shift d c t2
    | abs ty t1 => abs ty (shift d c.+1 t1)
  end.

Notation substitutev ts m n :=
  (shift n 0 (nth (var (m - n - size ts)) ts (m - n))) (only parsing).

Fixpoint substitute n ts t : term :=
  match t with
    | var m => if n <= m then substitutev ts m n else m
    | t1 @ t2 => substitute n ts t1 @ substitute n ts t2
    | abs ty t' => abs ty (substitute n.+1 ts t')
  end.

Reserved Notation "t ~>b1 t'" (at level 70, no associativity).

Inductive betared1 : relation term :=
  | betared1beta ty t1 t2 : abs ty t1 @ t2 ~>b1 substitute 0 [:: t2] t1
  | betared1appl t1 t1' t2 : t1 ~>b1 t1' -> t1 @ t2 ~>b1 t1' @ t2
  | betared1appr t1 t2 t2' : t2 ~>b1 t2' -> t1 @ t2 ~>b1 t1 @ t2'
  | betared1abs ty t t' : t ~>b1 t' -> abs ty t ~>b1 abs ty t'
  where "t ~>b1 t'" := (betared1 t t').

Notation betared := [* betared1].
Notation betaeq  := [= betared1].
Infix "~>b"      := betared (at level 70, no associativity).
Infix "==b"      := betaeq  (at level 70, no associativity).

Hint Constructors betared1.

Fixpoint typing_rec (ctx : context typ) (t : term) : option typ :=
  match t with
    | var n => nth None ctx n
    | tl @ tr =>
      if typing_rec ctx tl is Some (tyl ->t tyr)
        then (if typing_rec ctx tr == Some tyl then Some tyr else None)
        else None
    | abs ty t => omap (tyfun ty) (typing_rec (Some ty :: ctx) t)
  end.

Definition typing := nosimpl typing_rec.

Notation "ctx \|- t \: ty" := (Some ty == typing ctx t)
  (at level 69, no associativity).
Notation "ctx \|- t \: ty" := (Some (ty : typ) == typing ctx t)
  (at level 69, no associativity, only parsing).

Lemma typing_varE ctx (n : nat) ty : ctx \|- n \: ty = ctxindex ctx n ty.
Proof. by rewrite /typing /=. Qed.

Lemma typing_appP ctx t1 t2 ty :
  reflect (exists2 tyl, ctx \|- t1 \: tyl ->t ty & ctx \|- t2 \: tyl)
          (ctx \|- t1 @ t2 \: ty).
Proof.
apply: (iffP idP); rewrite /typing /=.
- by move: (typing_rec ctx t1) => [] // [] // tyl tyr;
    case: ifP => // /eqP -> /eqP [] ->; exists tyl.
- by case => tyl /eqP <- /eqP <-; rewrite eqxx.
Qed.

Lemma typing_absP ctx t tyl ty :
  reflect (exists2 tyr, ty = tyl ->t tyr & Some tyl :: ctx \|- t \: tyr)
          (ctx \|- abs tyl t \: ty).
Proof.
apply: (iffP idP); rewrite /typing /=.
- by case: typing_rec => //= tyr /eqP [] ->; exists tyr.
- by case => tyr ->; case: typing_rec => // tyr' /eqP [] <-.
Qed.

Lemma typing_absE ctx t tyl tyr :
  ctx \|- abs tyl t \: tyl ->t tyr = Some tyl :: ctx \|- t \: tyr.
Proof.
by rewrite /typing /=; case: typing_rec => //= tyr';
  rewrite /eq_op /= /eq_op /= -/eq_op eqxx.
Qed.

Notation SN := (Acc (fun x y => betared1 y x)).

Definition neutral t := if t is abs _ _ then false else true.

Lemma shiftzero n t : shift 0 n t = t.
Proof. by elim: t n; congruence' => m n; rewrite addn0 if_same. Qed.

Lemma shift_add d d' c c' t :
  c <= c' <= c + d -> shift d' c' (shift d c t) = shift (d' + d) c t.
Proof. case/andP; do 2 elimleq; elim: t c; congruence' => *; elimif_omega. Qed.

Lemma shift_shift_distr d c d' c' t :
  c' <= c -> shift d' c' (shift d c t) = shift d (d' + c) (shift d' c' t).
Proof. elimleq; elim: t c'; congruence' => *; elimif_omega. Qed.

Lemma shift_subst_distr n d c ts t :
  c <= n -> shift d c (substitute n ts t) = substitute (d + n) ts (shift d c t).
Proof.
elimleq; elim: t c => /=; congruence' => v c;
  elimif_omega; rewrite shift_add; elimif_omega.
Qed.

Lemma subst_shift_distr n d c ts t :
  n <= c ->
  shift d c (substitute n ts t) =
  substitute n (map (shift d (c - n)) ts) (shift d (size ts + c) t).
Proof.
elimleq; elim: t n; congruence' => v n; elimif_omega.
- rewrite !nth_default ?size_map /=; elimif_omega.
- rewrite -shift_shift_distr // nth_map' /=.
    congr shift; apply nth_equal; rewrite size_map; elimif_omega.
Qed.

Lemma subst_shift_cancel n d c ts t :
  c <= n -> size ts + n <= d + c ->
  substitute n ts (shift d c t) = shift (d - size ts) c t.
Proof.
do 2 elimleq; elim: t c; congruence' => v c;
  elimif_omega; rewrite nth_default /=; elimif_omega.
Qed.

Lemma subst_subst_distr n m xs ys t :
  m <= n ->
  substitute n xs (substitute m ys t) =
  substitute m (map (substitute (n - m) xs) ys) (substitute (size ys + n) xs t).
Proof.
elimleq; elim: t m; congruence' => v m /=; elimif_omega.
- rewrite (@subst_shift_cancel m) // size_map 1?nth_default /=; elimif_omega.
- rewrite size_map -shift_subst_distr // nth_map' /=;
    congr shift; apply nth_equal; rewrite size_map; elimif_omega.
Qed.

Lemma subst_app n xs ys t :
  substitute n xs (substitute (size xs + n) ys t) = substitute n (xs ++ ys) t.
Proof.
elim: t n; congruence' => v n; rewrite nth_cat size_cat;
  elimif_omega; rewrite subst_shift_cancel; elimif_omega.
Qed.

Lemma subst_nil n t : substitute n [::] t = t.
Proof. elim: t n; congruence' => v n; rewrite nth_nil /=; elimif_omega. Qed.

Lemma subst_betared1 n ts t t' :
  t ~>b1 t' -> substitute n ts t ~>b1 substitute n ts t'.
Proof.
move => H; elim/betared1_ind: t t' / H n => /=; auto => t t' ty n.
by rewrite subst_subst_distr //= add1n subn0.
Qed.

Module subject_reduction_proof.

Lemma ctxleq_preserves_typing ctx1 ctx2 t ty :
  ctx1 <=c ctx2 -> ctx1 \|- t \: ty -> ctx2 \|- t \: ty.
Proof.
elim: t ty ctx1 ctx2 => /= [n | tl IHl tr IHr | tyl t IH] ty ctx1 ctx2.
- move/ctxleqP; apply.
- by move => H /typing_appP [tyl H0 H1]; apply/typing_appP;
    exists tyl; [apply (IHl _ ctx1) | apply (IHr _ ctx1)].
- by move => H /typing_absP [tyr -> H0]; rewrite typing_absE;
    move: H0; apply IH; rewrite ctxleqE eqxx.
Qed.

Lemma typing_shift t c ctx1 ctx2 :
  typing (ctxinsert ctx2 ctx1 c) (shift (size ctx2) c t) = typing ctx1 t.
Proof.
rewrite /typing.
elim: t c ctx1 => /= [n | tl IHl tr IHr | tyl t IH] c ctx1.
- by rewrite nth_insert; elimif_omega.
- by rewrite IHl IHr.
- by rewrite -(IH c.+1).
Qed.

Lemma subject_subst t ty n ctx ctx' :
  all (fun p => drop n ctx \|- p.1 \: p.2) ctx' ->
  ctxinsert [seq Some p.2 | p <- ctx'] ctx n \|- t \: ty ->
  ctx \|- substitute n (unzip1 ctx') t \: ty.
Proof.
elim: t ty n ctx => /= [m | tl IHl tr IHr | tyl t IH] ty n ctx H.
- rewrite /typing /= nth_insert !size_map => /eqP ->; elimif.
  + apply/eqP/esym; rewrite nth_default ?size_map /=; elimif_omega.
  + rewrite -/typing !(nth_map (var 0, tyvar 0)) //.
    move: {H H0} (all_nthP (var 0, tyvar 0) H m H0).
    rewrite -(typing_shift _ 0 _ (ctxinsert [::] (take n ctx) n))
            size_insert /= add0n size_take minnC minKn /insert take0
            sub0n take_minn minnn size_take minnE subKn ?leq_subr //=
            drop_take_nil drop0 cats0 -catA -{4}(cat_take_drop n ctx).
    apply ctxleq_preserves_typing; rewrite ctxleq_appl.
    by case: (leqP' n (size ctx)) =>
      //= /ltnW /drop_oversize ->; rewrite cats0;
      apply/ctxleqP => /= n' ty' /eqP; rewrite nth_nseq if_same.
- by case/typing_appP => tyl H0 H1; apply/typing_appP; exists tyl; auto.
- by case/typing_absP => tyr -> H0; rewrite typing_absE; apply IH.
Qed.

Lemma subject_subst0 t ty ctx ctx' :
  all (fun p => ctx \|- p.1 \: p.2) ctx' ->
  [seq Some p.2 | p <- ctx'] ++ ctx \|- t \: ty ->
  ctx \|- substitute 0 (unzip1 ctx') t \: ty.
Proof.
by move: (@subject_subst t ty 0 ctx ctx'); rewrite /insert take0 sub0n drop0.
Qed.

Arguments subject_subst [t ty n ctx] _ _ _.
Arguments subject_subst0 [t ty ctx] _ _ _.

Theorem subject_reduction ctx t1 t2 ty :
  t1 ~>b1 t2 -> ctx \|- t1 \: ty -> ctx \|- t2 \: ty.
Proof.
move => H; elim/betared1_ind: t1 t2 / H ctx ty => /=.
- move => ty t1 t2 ctx ty2 /typing_appP [tyl] /typing_absP [tyr [-> ->]] H H0.
  by apply (subject_subst0 [:: (t2, ty)]) => //=; rewrite H0.
- by move => t1 t1' t2 H H0 ctx ty /typing_appP [tyl H1 H2];
    apply/typing_appP; exists tyl; [apply H0 | apply H2].
- by move => t1 t2 t2' H H0 ctx ty /typing_appP [tyl H1 H2];
    apply/typing_appP; exists tyl; [apply H1 | apply H0].
- by move => tyl t t' H H0 ctx ty /typing_absP [tyr -> H1];
    rewrite typing_absE; apply H0.
Qed.

Hint Resolve ctxleq_preserves_typing subject_subst subject_reduction.

End subject_reduction_proof.

(*******************************************************************************
  Strong normalization proof with the type-free version of reducibility
*******************************************************************************)

Module strong_normalization_proof_typefree.

Fixpoint reducible (ty : typ) (t : term) : Prop :=
  match ty with
    | tyvar n => SN t
    | tyl ->t tyr => forall t', reducible tyl t' -> reducible tyr (t @ t')
  end.

Lemma CR2 t t' ty : t ~>b1 t' -> reducible ty t -> reducible ty t'.
Proof.
elim: ty t t' => /= [_ | tyl IHl tyr IHr] t t' H.
- by case; apply.
- by move => H0 t'' H1; apply IHr with (t @ t''); auto.
Qed.

Hint Resolve CR2.

Lemma CR1_and_CR3 ty :
  (forall t, reducible ty t -> SN t) /\
  (forall t, neutral t ->
             (forall t', t ~>b1 t' -> reducible ty t') -> reducible ty t).
Proof.
elim: ty; first by [].
move => /= tyl [IHl1 IHl2] tyr [IHr1 IHr2];
  split => [t H | tl H H0 tr H1].
- suff: SN ([fun t => t @ 0] t) by apply acc_preservation; constructor.
  apply IHr1, IHr2 => // t' H0.
  apply (CR2 H0), H, IHl2 => // t'' H1; inversion H1.
- elim/Acc_ind': tr / {H1} (IHl1 tr H1) (H1) => tr IH H1.
  apply IHr2 => // t' H2; move: H; inversion H2; subst => // _; eauto.
Qed.

Definition CR1 t ty := proj1 (CR1_and_CR3 ty) t.
Definition CR3 t ty := proj2 (CR1_and_CR3 ty) t.

Lemma abs_reducibility t tyl tyr :
  (forall t', reducible tyl t' -> reducible tyr (substitute 0 [:: t'] t)) ->
  reducible (tyl ->t tyr) (abs tyl t).
Proof.
move => /= H t' H0.
have H1: SN t by
  move: (CR1 (H t' H0)); apply acc_preservation => x y; apply subst_betared1.
move: t t' H1 {H0} (CR1 H0) H (H0); refine (Acc_ind2 _) => t t' IH IH' H H0.
apply CR3 => // t'' H1; inversion H1; subst; eauto; inversion H5; subst.
by apply IH; auto => t'' H2; apply (CR2 (subst_betared1 0 [:: t''] H6)), H.
Qed.

Lemma reduce_lemma ctx (ctx' : seq (term * typ)) t ty :
  [seq Some p.2 | p <- ctx'] ++ ctx \|- t \: ty ->
  Forall (fun p => reducible p.2 p.1) ctx' ->
  reducible ty (substitute 0 (unzip1 ctx') t).
Proof.
elim: t ty ctx ctx'.
- move => /= n ty ctx ctx'.
  rewrite subn0 size_map shiftzero.
  elim: ctx' n => [| c' ctx' IH []] /=.
  + move => n _ _; rewrite nth_nil subn0.
    apply CR3 => //; auto => t' H0; inversion H0.
  + case/eqP => ->; tauto.
  + by move => n H [_ H0]; apply IH.
- move => tl IHl tr IHr tyr ctx ctx' /typing_appP [tyl H H0] H1.
  by move: (IHl (tyl ->t tyr) ctx ctx') => /=;
    apply => //; apply IHr with ctx.
- move => tyl t IH ty ctx ctx' /typing_absP [tyr -> H] H0.
  simpl substitute; apply abs_reducibility => t' H1.
  by rewrite subst_app /=; apply (IH tyr ctx ((t', tyl) :: ctx')).
Qed.

Theorem typed_term_is_sn ctx t ty : ctx \|- t \: ty -> SN t.
Proof.
by move/(@reduce_lemma ctx [::]) => /= /(_ I); rewrite subst_nil; apply CR1.
Qed.

End strong_normalization_proof_typefree.

(*******************************************************************************
  Strong normalization proof with the Kripke-style reducibility
*******************************************************************************)

Module strong_normalization_proof_kripke.

Import subject_reduction_proof.

Fixpoint reducible (ctx : context typ) (ty : typ) (t : term) : Prop :=
  match ty with
    | tyvar n => SN t
    | tyl ->t tyr => forall t' ctx',
        ctx <=c ctx' -> ctx' \|- t' \: tyl -> reducible ctx' tyl t' ->
        reducible ctx' tyr (t @ t')
  end.

Lemma ctxleq_preserves_reducibility ctx ctx' t ty :
  ctx <=c ctx' -> reducible ctx ty t -> reducible ctx' ty t.
Proof.
case: ty => //= tyl tyr H H0 t1 ctx'' H1.
apply H0; move: H H1; apply ctxleq_trans.
Qed.

Lemma CR2 ctx t t' ty :
  t ~>b1 t' -> reducible ctx ty t -> reducible ctx ty t'.
Proof.
elim: ty ctx t t'.
- by move => /= _ _ t t' H []; apply.
- move => /= tyl IHl tyr IHr ctx t1 t2 H H0 t3 ctx' H1 H2 H3.
  by apply IHr with (t1 @ t3); auto.
Qed.

Hint Resolve ctxleq_preserves_reducibility CR2.

Lemma CR1_and_CR3 ty :
  (forall ctx t, ctx \|- t \: ty -> reducible ctx ty t -> SN t) /\
  (forall ctx t, ctx \|- t \: ty -> neutral t ->
   (forall t', t ~>b1 t' -> reducible ctx ty t') -> reducible ctx ty t).
Proof.
elim: ty; first by [].
move => /= tyl [IHl1 IHl2] tyr [IHr1 IHr2];
  split => [ctx t H H0 | ctx tl H H0 H1 tr ctx' H2 H3 H4].
- set H1 := ctxindex_last ctx tyl.
  have H2: ctx ++ [:: Some tyl] \|- t @ size ctx \: tyr by
    apply/typing_appP; exists tyl; eauto.
  suff: SN ([fun t => t @ size ctx] t) by
    apply acc_preservation; constructor.
  apply (IHr1 _ _ H2), IHr2 => // t' H3.
  apply (CR2 H3), H0 => //=.
  apply IHl2 => // x H4; inversion H4.
- have H5: SN tr by apply IHl1 with ctx'.
  elim/Acc_ind': tr / H5 H2 H3 H4 => tr IH H2 H3 H4.
  have H5: ctx' \|- tl @ tr \: tyr by apply/typing_appP; exists tyl; eauto.
  apply IHr2 => // t' H6; move: H0; inversion H6; subst => // _; eauto.
Qed.

Definition CR1 t ty := proj1 (CR1_and_CR3 ty) t.
Definition CR3 t ty := proj2 (CR1_and_CR3 ty) t.

Lemma abs_reducibility ctx t tyl tyr :
  ctx \|- abs tyl t \: tyl ->t tyr ->
  (forall t' ctx', ctx <=c ctx' -> ctx' \|- t' \: tyl ->
   reducible ctx' tyl t' -> reducible ctx' tyr (substitute 0 [:: t'] t)) ->
  reducible ctx (tyl ->t tyr) (abs tyl t).
Proof.
move => /= H H0 t' ctx' H1 H2 H3.
have H4: ctx' \|- substitute 0 [:: t'] t \: tyr by
  apply (subject_subst0 [:: (t', tyl)]); rewrite /= ?H2 // -typing_absE;
    move: H; apply ctxleq_preserves_typing.
have {H4} H4: SN t by
  move: (CR1 H4 (H0 t' ctx' H1 H2 H3));
    apply acc_preservation => x y; apply subst_betared1.
move: t t' {H2 H3} H4 (CR1 H2 H3) H H0 H1 (H2) (H3);
  refine (Acc_ind2 _) => t t' IH IH' H H0 H1 H2 H3; apply CR3 => //.
- apply/typing_appP; exists tyl; last apply H2.
  by move: H; apply ctxleq_preserves_typing.
- move => t'' H4.
  inversion H4; subst => {H4}; eauto; inversion H8; subst => {H8}.
  apply IH => //; eauto => t'' ctx'' H4 H5 H6.
  by apply (CR2 (subst_betared1 0 [:: t''] H7)), H0.
Qed.

Lemma reduce_lemma ctx (ctx' : seq (term * typ)) t ty :
  [seq Some p.2 | p <- ctx'] ++ ctx \|- t \: ty ->
  all (fun p => ctx \|- p.1 \: p.2) ctx' ->
  Forall (fun p => reducible ctx p.2 p.1) ctx' ->
  reducible ctx ty (substitute 0 (unzip1 ctx') t).
Proof.
elim: t ty ctx ctx'.
- move => /= n ty ctx ctx'.
  rewrite subn0 size_map shiftzero.
  elim: ctx' n => [| c' ctx' IH []] /=.
  + move => n H _ _; rewrite nth_nil subn0.
    apply CR3 => //; auto => t' H0; inversion H0.
  + case/eqP => ->; tauto.
  + by move => n H /andP [_ H0] [_]; apply IH.
- move => tl IHl tr IHr tyr ctx ctx' /typing_appP [tyl H H0] H1 H2.
  move: (IHl (tyl ->t tyr) ctx ctx') => /=; apply; auto.
  by apply subject_subst0.
- move => tyl t IH ty ctx ctx' /typing_absP [tyr -> H] H0 H1.
  simpl substitute; apply abs_reducibility;
    first by apply (@subject_subst0 (abs tyl t)) => //; rewrite typing_absE.
  move => /= t2 ctx2 H2 H3 H4.
  rewrite subst_app /=.
  apply (IH tyr ctx2 ((t2, tyl) :: ctx')) => /=.
  + by move: H; rewrite -!typing_absE;
      apply ctxleq_preserves_typing; rewrite ctxleq_appl.
  + rewrite H3 /=; move: H0; apply sub_all => p; eauto.
  + intuition; move: H1; apply Forall_impl; eauto.
Qed.

Theorem typed_term_is_sn ctx t ty : ctx \|- t \: ty -> SN t.
Proof.
move => H; move: (@reduce_lemma ctx [::] _ _ H) => /= /(_ erefl I).
by rewrite subst_nil; apply CR1.
Qed.

End strong_normalization_proof_kripke.

(*******************************************************************************
  Strong normalization proof with the typed version of reducibility
*******************************************************************************)

Module strong_normalization_proof_typed.

Import subject_reduction_proof.

Fixpoint list_hyp ty : seq typ :=
  if ty is tyl ->t tyr then tyl :: list_hyp tyl ++ list_hyp tyr else [::].

Fixpoint list_hyp' (ctx : context typ) t : seq typ :=
  oapp list_hyp [::] (typing ctx t) ++
  match t with
    | var n => [::]
    | app tl tr => list_hyp' ctx tl ++ list_hyp' ctx tr
    | abs ty t => list_hyp' (Some ty :: ctx) t
  end.

Lemma list_hyp'E ctx t :
  list_hyp' ctx t =
  oapp list_hyp [::] (typing ctx t) ++
  match t with
    | var n => [::]
    | app tl tr => list_hyp' ctx tl ++ list_hyp' ctx tr
    | abs ty t => list_hyp' (Some ty :: ctx) t
  end.
Proof. by case: t. Qed.

Lemma ctxleq_list_hyp' ctx ctx' t ty :
  ctx <=c ctx' -> ctx \|- t \: ty -> list_hyp' ctx' t = list_hyp' ctx t.
Proof.
elim: t ty ctx ctx' => //=.
- move => n ty ctx ctx' H H0.
  by rewrite -(eqP (ctxleq_preserves_typing H H0)) -(eqP H0).
- move => tl IHl tr IHr tyr ctx ctx' H H0.
  rewrite -(eqP (ctxleq_preserves_typing H H0)) -(eqP H0) /=; congr cat.
  case/typing_appP: H0 => tyl H0 H1.
  by rewrite (IHl (tyl ->t tyr) ctx ctx') // (IHr tyl ctx ctx').
- move => tyl t IH ty ctx ctx' H H0.
  rewrite -(eqP (ctxleq_preserves_typing H H0)) -(eqP H0) /=; congr cat.
  case/typing_absP: H0 => tyr _ H0.
  by rewrite (IH tyr (Some tyl :: ctx) (Some tyl :: ctx')) // ctxleqE eqxx.
Qed.

Fixpoint reducible (ctx : context typ) (ty : typ) (t : term) : Prop :=
  match ty with
    | tyvar n => SN t
    | tyl ->t tyr => forall t',
        ctx \|- t' \: tyl -> reducible ctx tyl t' -> reducible ctx tyr (t @ t')
  end.

Lemma CR2 ctx t t' ty :
  t ~>b1 t' -> reducible ctx ty t -> reducible ctx ty t'.
Proof.
elim: ty ctx t t'.
- by move => /= _ _ t t' H []; apply.
- move => /= tyl IHl tyr IHr ctx t1 t2 H H0 t3 H1 H2.
  by apply IHr with (t1 @ t3); auto.
Qed.

Hint Resolve CR2.

Lemma CR1_and_CR3 ty :
  (forall (ctx : context typ) t,
   all (fun ty => Some ty \in ctx) (list_hyp ty) ->
   ctx \|- t \: ty -> reducible ctx ty t -> SN t) /\
  (forall ctx t,
   all (fun ty => Some ty \in ctx) (list_hyp ty) ->
   ctx \|- t \: ty -> neutral t ->
   (forall t', t ~>b1 t' -> reducible ctx ty t') -> reducible ctx ty t).
Proof.
elim: ty; first by [].
move => /= tyl [IHl1 IHl2] tyr [IHr1 IHr2]; split => ctx tl.
- case/andP => /(nthP None) [x _] /esym /eqP H;
    rewrite all_cat; case/andP => H0 H1 H2 H3.
  have H4: ctx \|- tl @ x \: tyr by apply/typing_appP; exists tyl.
  suff: SN ([fun t => t @ x] tl) by apply acc_preservation; constructor.
  by apply (IHr1 ctx) => //; apply IHr2 => // t' H5;
    apply (CR2 H5); apply H3 => //; apply IHl2 => // y H6; inversion H6.
- case/andP => _; rewrite all_cat; case/andP => H H0 H1 H2 H3 tr H4 H5.
  have H6: SN tr by apply (IHl1 ctx).
  elim/Acc_ind': tr / H6 H4 H5 => tr IH H4 H5.
  have H6: ctx \|- tl @ tr \: tyr by apply/typing_appP; exists tyl.
  apply IHr2 => // t' H7; move: H2; inversion H7; subst => // _; eauto.
Qed.

Definition CR1 t ty := proj1 (CR1_and_CR3 ty) t.
Definition CR3 t ty := proj2 (CR1_and_CR3 ty) t.

Lemma abs_reducibility (ctx : context typ) t tyl tyr :
  all (fun ty => Some ty \in ctx) (list_hyp (tyl ->t tyr)) ->
  ctx \|- abs tyl t \: tyl ->t tyr ->
  (forall t', ctx \|- t' \: tyl ->
   reducible ctx tyl t' -> reducible ctx tyr (substitute 0 [:: t'] t)) ->
  reducible ctx (tyl ->t tyr) (abs tyl t).
Proof.
move => /= /andP [] H; rewrite all_cat; case/andP => H0 H1 H2 H3 t' H4 H5.
have H6: ctx \|- substitute 0 [:: t'] t \: tyr by
  apply (subject_subst0 [:: (t', tyl)]); rewrite /= ?H4 // -typing_absE.
have {H6} H6: SN t by
  move: (CR1 H1 H6 (H3 t' H4 H5));
    apply acc_preservation => x y; apply subst_betared1.
move: t t' {H4 H5} H6 (CR1 H0 H4 H5) H2 H3 (H4) (H5);
  refine (Acc_ind2 _) => t t' IH IH' H2 H3 H4 H5; apply CR3 => //.
- by apply/typing_appP; exists tyl.
- move => t'' H6.
  inversion H6; subst => {H6}; eauto; inversion H10; subst => {H10}.
  apply IH => //; eauto => t'' ctx'' H6.
  by apply (CR2 (subst_betared1 0 [:: t''] H9)), H3.
Qed.

Lemma reduce_lemma ctx (ctx' : seq (term * typ)) t ty :
  [seq Some p.2 | p <- ctx'] ++ ctx \|- t \: ty ->
  all (fun ty => Some ty \in ctx)
      (list_hyp' ([seq Some p.2 | p <- ctx'] ++ ctx) t) ->
  all (fun p => ctx \|- p.1 \: p.2) ctx' ->
  Forall (fun p => reducible ctx p.2 p.1) ctx' ->
  reducible ctx ty (substitute 0 (unzip1 ctx') t).
Proof.
elim: t ty ctx ctx'.
- move => /= n ty ctx ctx' H.
  rewrite -(eqP H) cats0 subn0 size_map shiftzero /=.
  elim: ctx' n H => [| c' ctx' IH []] /=.
  + move => n H H0 _ _; rewrite nth_nil subn0.
    apply CR3 => // t' H1; inversion H1.
  + case/eqP => ->; tauto.
  + by move => n H H0 /andP [_ H1] [_]; apply IH.
- move => /= tl IHl tr IHr tyr ctx ctx' H.
  rewrite -(eqP H) /=; case/typing_appP: H => tyl H H0.
  rewrite !all_cat; case/and3P => H1 H2 H3 H4 H5.
  move: (IHl (tyl ->t tyr) ctx ctx') => /=; apply; auto.
  by apply subject_subst0.
- move => /= tyl t IH ty ctx ctx' H.
  rewrite -(eqP H) /=; case/typing_absP: H => tyr -> H.
  rewrite all_cat; case/andP => H0 H1 H2 H3.
  simpl substitute; apply abs_reducibility => //;
    first by apply (@subject_subst0 (abs tyl t)) => //; rewrite typing_absE.
  move => /= t2 H4 H5; rewrite subst_app /=.
  by apply (IH tyr ctx ((t2, tyl) :: ctx')) => //=; rewrite H4.
Qed.

Theorem typed_term_is_sn ctx t ty : ctx \|- t \: ty -> SN t.
Proof.
move => H.
have H0: ctx ++ map some (list_hyp' ([::] ++ ctx) t) \|- t \: ty by
  move: H; apply ctxleq_preserves_typing, ctxleq_appr.
move: (@reduce_lemma _ [::] _ _ H0) => /=.
rewrite (ctxleq_list_hyp' (ctxleq_appr ctx _) H).
have ->: forall xs ys, all (fun x => Some x \in xs ++ map some ys) ys by
  move => A xs ys; apply/allP => x H1;
    rewrite mem_cat; apply/orP/or_intror/map_f.
move/(_ erefl erefl I); rewrite subst_nil; apply CR1 => //.
by apply/allP => /= ty' H1; rewrite list_hyp'E mem_cat;
  apply/orP/or_intror/map_f; rewrite mem_cat -(eqP H) H1.
Qed.

End strong_normalization_proof_typed.

(*******************************************************************************
 Normal forms: beta normal form and long beta/eta normal form
*******************************************************************************)

Fixpoint beta_normal (nf : bool) (t : term) : bool :=
  match t with
    | var m => true
    | tl @ tr => beta_normal false tl && beta_normal true tr
    | abs _ t => nf && beta_normal true t
  end.

Lemma beta_normal_imply (nf nf' : bool) (t : term) :
  nf ==> nf' -> beta_normal nf t -> beta_normal nf' t.
Proof. by case: t nf nf' => //= _ t [] []. Qed.

Lemma beta_normal_shift (d c : nat) (nf : bool) (t : term) :
  beta_normal nf (shift d c t) = beta_normal nf t.
Proof.
by elim: t nf c => [| tl IHl tr IHr _ c | _ t IH []] //=; rewrite IHl IHr.
Qed.

Lemma beta_normalPn (nf : bool) (t : term) :
  reflect
    ((if t is abs _ _ then ~~ nf else false) \/ exists t', t ~>b1 t')
    (~~ beta_normal nf t).
Proof.
apply/(iffP idP); elim: t nf => [n | tl IHl tr IHr | ty t IH] nf //=.
- rewrite negb_and => /orP [/IHl | /IHr] {IHl IHr} [] H; right.
  - by case: tl H => //= ty tl _; eexists; constructor.
  - by case: H => tl' H; exists (tl' @ tr); constructor.
  - by case: tr H.
  - by case: H => tr' H; exists (tl @ tr'); constructor.
- case: nf => //=; last by left.
  case/IH; first by case t.
  by case => t' H; right; exists (abs ty t'); constructor.
- by case => // -[] t H; inversion H.
- case => // -[] t H; rewrite negb_and; inversion H; subst => //=.
  + by rewrite IHl //=; right; exists t1'.
  + by rewrite IHr ?orbT //=; right; exists t2'.
- by case: nf => //= -[] // [t' H];
    inversion H; subst; apply IH; right; exists t'0.
Qed.

Lemma beta_normalP (nf : bool) (t : term) :
  reflect
    ((if t is abs _ _ then nf else true) /\ forall t', ~ t ~>b1 t')
    (beta_normal nf t).
Proof.
apply/(iffP idP);
  last by rewrite -(negbK (beta_normal _ _));
    case => H H0; apply/beta_normalPn => -[];
    [case: t nf H H0 => //= k t [] | case => t' /H0].
rewrite -(negbK (beta_normal _ _)) => /beta_normalPn H; split.
- by case: t nf H => //= k t [] //= []; left.
- by move => t' H0; apply H; right; exists t'.
Qed.

Lemma beta_normal_equiv_rtc (t t' : term) :
  beta_normal true t' -> t ==b t' -> t ~>b t'.
Proof.
Abort.

Lemma beta_normal_uniqueness (t t' : term) (ty : typ) :
  t ==b t' -> beta_normal true t -> beta_normal true t' -> t = t'.
Proof.
Abort.

Lemma beta_normal_existence (t : term) :
  SN t -> exists2 t', t ~>b t' & beta_normal true t'.
Proof.
elim/Acc_ind': t / => t IH.
case: (boolP (beta_normal true t)); first by move => H; exists t.
case/beta_normalPn; first by case t.
by case => t' H; case: (IH _ H) => t'' H0 H1;
   exists t'' => //;apply rt1n_trans with t'.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Operators_Properties.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(************************************************************************)
(** * Some properties of the operators on relations                     *)
(************************************************************************)
(** * Initial version by Bruno Barras                                   *)
(************************************************************************)

Require Import Relation_Definitions.
Require Import Relation_Operators.

Section Properties.

  Implicit Arguments clos_refl_trans [A].
  Implicit Arguments clos_refl_trans_1n [A].
  Implicit Arguments clos_refl_trans_n1 [A].
  Implicit Arguments clos_refl_sym_trans [A].
  Implicit Arguments clos_refl_sym_trans_1n [A].
  Implicit Arguments clos_refl_sym_trans_n1 [A].
  Implicit Arguments clos_trans [A].
  Implicit Arguments clos_trans_1n [A].
  Implicit Arguments clos_trans_n1 [A].
  Implicit Arguments inclusion [A].
  Implicit Arguments preorder [A].

  Variable A : Type.
  Variable R : relation A.

  Section Clos_Refl_Trans.

    Local Notation "R *" := (clos_refl_trans R) (at level 8, left associativity).

    (** Correctness of the reflexive-transitive closure operator *)

    Lemma clos_rt_is_preorder : preorder R*.
    Proof.
      apply Build_preorder.
      exact (rt_refl A R).

      exact (rt_trans A R).
    Qed.

    (** Idempotency of the reflexive-transitive closure operator *)

    Lemma clos_rt_idempotent : inclusion (R*)* R*.
    Proof.
      red in |- *.
      induction 1; auto with sets.
      intros.
      apply rt_trans with y; auto with sets.
    Qed.

  End Clos_Refl_Trans.

  Section Clos_Refl_Sym_Trans.

    (** Reflexive-transitive closure is included in the
        reflexive-symmetric-transitive closure *)

    Lemma clos_rt_clos_rst :
      inclusion (clos_refl_trans R) (clos_refl_sym_trans R).
    Proof.
      red in |- *.
      induction 1; auto with sets.
      apply rst_trans with y; auto with sets.
    Qed.

    (** Correctness of the reflexive-symmetric-transitive closure *)

    Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R).
    Proof.
      apply Build_equivalence.
      exact (rst_refl A R).
      exact (rst_trans A R).
      exact (rst_sym A R).
    Qed.

    (** Idempotency of the reflexive-symmetric-transitive closure operator *)

    Lemma clos_rst_idempotent :
      inclusion (clos_refl_sym_trans (clos_refl_sym_trans R))
      (clos_refl_sym_trans R).
    Proof.
      red in |- *.
      induction 1; auto with sets.
      apply rst_trans with y; auto with sets.
    Qed.

  End Clos_Refl_Sym_Trans.

  Section Equivalences.

  (** *** Equivalences between the different definition of the reflexive,
      symmetric, transitive closures *)

  (** *** Contributed by P. Castéran *)

    (** Direct transitive closure vs left-step extension *)

    Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y.
    Proof.
     induction 1.
     left; assumption.
     right with y; auto.
     left; auto.
    Qed.

    Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y.
    Proof.
      induction 1.
      left; assumption.
      generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1.
      right with y; auto.
      right with y; auto.
      eapply IHIHclos_trans1; auto.
      apply clos_t1n_trans; auto.
    Qed.

    Lemma clos_trans_t1n_iff : forall x y,
        clos_trans R x y <-> clos_trans_1n R x y.
    Proof.
      split.
      apply clos_trans_t1n.
      apply clos_t1n_trans.
    Qed.

    (** Direct transitive closure vs right-step extension *)

    Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y.
    Proof.
      induction 1.
      left; assumption.
      right with y; auto.
      left; assumption.
    Qed.

    Lemma clos_trans_tn1 :  forall x y, clos_trans R x y -> clos_trans_n1 R x y.
    Proof.
      induction 1.
      left; assumption.
      elim IHclos_trans2.
      intro y0; right with y.
      auto.
      auto.
      intros.
      right with y0; auto.
    Qed.

    Lemma clos_trans_tn1_iff : forall x y,
        clos_trans R x y <-> clos_trans_n1 R x y.
    Proof.
      split.
      apply clos_trans_tn1.
      apply clos_tn1_trans.
    Qed.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by left-step extension *)

    Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y.
    Proof.
      intros x y H.
      right with y;[assumption|left].
    Qed.

    Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y.
    Proof.
      intros x y H.
      right with x;[assumption|left].
    Qed.

    Lemma clos_rt1n_rt : forall x y,
        clos_refl_trans_1n R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 3 with y; auto.
      constructor 1; auto.
    Qed.

    Lemma clos_rt_rt1n : forall x y,
        clos_refl_trans R x y -> clos_refl_trans_1n R x y.
    Proof.
      induction 1.
      apply clos_rt1n_step; assumption.
      left.
      generalize IHclos_refl_trans2; clear IHclos_refl_trans2;
        induction IHclos_refl_trans1; auto.

      right with y; auto.
      eapply IHIHclos_refl_trans1; auto.
      apply clos_rt1n_rt; auto.
    Qed.

    Lemma clos_rt_rt1n_iff : forall x y,
      clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
    Proof.
      split.
      apply clos_rt_rt1n.
      apply clos_rt1n_rt.
    Qed.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by right-step extension *)

    Lemma clos_rtn1_rt : forall x y,
        clos_refl_trans_n1 R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 3 with y; auto.
      constructor 1; assumption.
    Qed.

    Lemma clos_rt_rtn1 :  forall x y,
        clos_refl_trans R x y -> clos_refl_trans_n1 R x y.
    Proof.
      induction 1.
      apply clos_rtn1_step; auto.
      left.
      elim IHclos_refl_trans2; auto.
      intros.
      right with y0; auto.
    Qed.

    Lemma clos_rt_rtn1_iff : forall x y,
        clos_refl_trans R x y <-> clos_refl_trans_n1 R x y.
    Proof.
      split.
      apply clos_rt_rtn1.
      apply clos_rtn1_rt.
    Qed.

    (** Induction on the left transitive step *)

    Lemma clos_refl_trans_ind_left :
      forall (x:A) (P:A -> Prop), P x ->
	(forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) ->
	forall z:A, clos_refl_trans R x z -> P z.
    Proof.
      intros.
      revert H H0.
      induction H1; intros; auto with sets.
      apply H1 with x; auto with sets.

      apply IHclos_refl_trans2.
      apply IHclos_refl_trans1; auto with sets.

      intros.
      apply H0 with y0; auto with sets.
      apply rt_trans with y; auto with sets.
    Qed.

    (** Induction on the right transitive step *)

    Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A),
      P z ->
      (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) ->
      forall x, clos_refl_trans_1n R x z -> P x.
      induction 3; auto.
      apply H0 with y; auto.
    Qed.

    Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A),
      P z ->
      (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) ->
      forall x, clos_refl_trans R x z -> P x.
      intros P z Hz IH x Hxz.
      apply clos_rt_rt1n_iff in Hxz.
      elim Hxz using rt1n_ind_right; auto.
      clear x Hxz.
      intros x y Hxy Hyz Hy.
      apply clos_rt_rt1n_iff in Hyz.
      eauto.
    Qed.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric left-step extension *)

    Lemma clos_rst1n_rst  : forall x y,
      clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 4 with y; auto.
      case H;[constructor 1|constructor 3; constructor 1]; auto.
    Qed.

    Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y ->
        clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z.
      induction 1.
      auto.
      intros; right with y; eauto.
    Qed.

    Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y ->
      clos_refl_sym_trans_1n R y x.
    Proof.
      intros x y H; elim H.
      constructor 1.
      intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto.
      right with x0.
      tauto.
      left.
    Qed.

    Lemma clos_rst_rst1n  : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y.
      induction 1.
      constructor 2 with y; auto.
      constructor 1.
      constructor 1.
      apply clos_rst1n_sym; auto.
      eapply clos_rst1n_trans; eauto.
    Qed.

    Lemma clos_rst_rst1n_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y.
    Proof.
      split.
      apply clos_rst_rst1n.
      apply clos_rst1n_rst.
    Qed.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric right-step extension *)

    Lemma clos_rstn1_rst : forall x y,
      clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 4 with y; auto.
      case H;[constructor 1|constructor 3; constructor 1]; auto.
    Qed.

    Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z.
    Proof.
      intros x y z H1 H2.
      induction H2.
      auto.
      intros.
      right with y0; eauto.
    Qed.

    Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y x.
    Proof.
      intros x y H; elim H.
      constructor 1.
      intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto.
      right with z.
      tauto.
      left.
    Qed.

    Lemma clos_rst_rstn1 : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y.
    Proof.
      induction 1.
      constructor 2 with x; auto.
      constructor 1.
      constructor 1.
      apply clos_rstn1_sym; auto.
      eapply clos_rstn1_trans; eauto.
    Qed.

    Lemma clos_rst_rstn1_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y.
    Proof.
      split.
      apply clos_rst_rstn1.
      apply clos_rstn1_rst.
    Qed.

  End Equivalences.

End Properties.

(* begin hide *)
(* Compatibility *)
Notation trans_tn1 := clos_trans_tn1 (only parsing).
Notation tn1_trans := clos_tn1_trans (only parsing).
Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing).

Notation trans_t1n := clos_trans_t1n (only parsing).
Notation t1n_trans := clos_t1n_trans (only parsing).
Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing).

Notation R_rtn1 := clos_rtn1_step (only parsing).
Notation trans_rt1n := clos_rt_rt1n (only parsing).
Notation rt1n_trans := clos_rt1n_rt (only parsing).
Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing).

Notation R_rt1n := clos_rt1n_step (only parsing).
Notation trans_rtn1 := clos_rt_rtn1 (only parsing).
Notation rtn1_trans := clos_rtn1_rt (only parsing).
Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing).

Notation rts1n_rts := clos_rst1n_rst (only parsing).
Notation rts_1n_trans := clos_rst1n_trans (only parsing).
Notation rts1n_sym := clos_rst1n_sym (only parsing).
Notation rts_rts1n := clos_rst_rst1n (only parsing).
Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing).

Notation rtsn1_rts := clos_rstn1_rst (only parsing).
Notation rtsn1_trans := clos_rstn1_trans (only parsing).
Notation rtsn1_sym := clos_rstn1_sym (only parsing).
Notation rts_rtsn1 := clos_rst_rstn1 (only parsing).
Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing).
(* end hide *)


Require Import List Crush.
Import ListNotations.

Set Implicit Arguments.

(** Implement a queue with two stacks, so all operations are of amortized O(1).
    Tweaked the implementation from http://www.geeksforgeeks.org/queue-using-stacks,
    where we force that if the first stack is empty, then the second one must be
    empty too. *)

Section TwoStackQueue.
  Parameter A : Type.

  Definition stack := list.
  Definition queue : Type := (stack A * stack A) % type.

  Definition IsQueue (q : queue) : Prop :=
    match q with
    | ([], []) => True
    | ([], _) => False
    | _ => True
    end.

  Definition AbsRelate (q : queue) (l : list A) :=
    match q with
    | (xs, ys) => xs ++ rev ys = l
    end.

  Definition empty : queue := ([], []).

  Definition is_empty (q : queue) : bool :=
    match q with
    | ([], _) => true
    | _ => false
    end.

  Definition front (q : queue) : option A :=
    match q with
    | ([], _) => None
    | (x :: xs, _) => Some x
    end.

  Definition enque (x : A) (q : queue) : queue :=
    match q with
    | ([], _) => ([x], [])
    | (ys, xs) => (ys, x :: xs)
    end.

  Definition deque (q : queue) : queue :=
    match q with
    | ([], _) => ([], [])
    | ([x], ys) => (rev ys, [])
    | (x :: xs, ys) => (xs, ys)
    end.

  (* Some useful tactics. *)
  (* Our slogan is, using only one tactic to prove everything! *)

  Ltac break_match :=
    match goal with
    | [ H : context [ match ?X with _ => _ end ] |- _ ] => destruct X eqn:?
    | [ |- context [ match ?X with _ => _ end ] ] => destruct X eqn:?
    end.

  Ltac break_queue :=
    match goal with
    | [ q : queue |- _ ] => destruct q
    end.

  Ltac breaker := repeat (break_match || break_queue).
  Ltac crush := repeat (crush' false fail; breaker); crush' false fail.

  Theorem IsQueue_empty :
    IsQueue empty.
  Proof. crush. Qed.

  Theorem IsQueue_enque :
    forall (q : queue) (x : A),
      IsQueue q ->
      IsQueue (enque x q).
  Proof. crush. Qed.

  Theorem IsQueue_deque :
    forall (q : queue),
      IsQueue q ->
      IsQueue (deque q).
  Proof. crush. Qed.

  Theorem AbsRelate_empty :
    AbsRelate empty [].
  Proof. crush. Qed.

  Theorem AbsRelate_front0 :
    forall (q : queue),
      AbsRelate q [] ->
      front q = None.
  Proof. crush. Qed.

  Theorem AbsRelate_front :
    forall (q : queue) (x : A) (xs : list A),
      IsQueue q ->
      AbsRelate q (x :: xs) ->
      front q = Some x.
  Proof. crush. Qed.

  Theorem AbsRelate_enque :
    forall (q : queue) (x : A) (xs : list A),
      IsQueue q ->
      AbsRelate q xs ->
      AbsRelate (enque x q) (xs ++ [x]).
  Proof. crush. Qed.

  Theorem AbsRelate_deque0 :
    forall (q : queue),
      AbsRelate q [] ->
      AbsRelate (deque q) [].
  Proof. crush. Qed.

  Theorem AbsRelate_deque :
    forall (q : queue) (x : A) (xs : list A),
      IsQueue q ->
      AbsRelate q (x :: xs) ->
      AbsRelate (deque q) xs.
  Proof. crush. Qed.
End TwoStackQueue.

Require Extraction.
Require Import ExtrHaskellBasic.

Extraction Language Haskell.

Extract Constant A => "Prelude.Int".

Extraction "Queue.hs" queue empty is_empty front enque deque.


(* File: My_Nth.v  (last edited on 25/10/2000) (c) Klaus Weich  *)

From Coq Require Export List Plus.

Section My_Nth.

Variable B : Set.

Inductive my_nth : nat -> list B -> B -> Prop :=
  | My_NthO : forall (l : list B) (a : B), my_nth 0 (a :: l) a
  | My_NthS :
      forall (n : nat) (l : list B) (b : B),
      my_nth n l b -> forall a : B, my_nth (S n) (a :: l) b.

Lemma inv_nth_nil : forall (n : nat) (a : B), my_nth n nil a -> False.
intros.
inversion H.
Qed.

Lemma inv_nthO :
 forall (a : B) (l : list B) (b : B), my_nth 0 (a :: l) b -> a = b.
intros.
inversion H.
trivial.
Qed.

Lemma inv_nthS :
 forall (n : nat) (a : B) (l : list B) (b : B),
 my_nth (S n) (a :: l) b -> my_nth n l b.
intros.
inversion H.
assumption.
Qed.

Lemma my_nth_rec :
 forall P : nat -> list B -> B -> Set,
 (forall (l : list B) (a : B), P 0 (a :: l) a) ->
 (forall (n : nat) (l : list B) (b : B),
  my_nth n l b -> P n l b -> forall a : B, P (S n) (a :: l) b) ->
 forall (n : nat) (l : list B) (y : B), my_nth n l y -> P n l y.
intros P base step n.
elim n; clear n.
intros l; case l; clear l.
intros y nth; elimtype False.
apply (inv_nth_nil 0 y nth).
intros a l b nth.
 rewrite (inv_nthO a l b nth).
apply base.

intros n ih l.
case l; clear l.
intros y nth; elimtype False.
apply (inv_nth_nil (S n) y nth).
intros a l b nth.
apply step.
apply (inv_nthS n a l b nth).
apply ih.
apply (inv_nthS n a l b nth).
Qed.

Lemma nth_in : forall (n : nat) (l : list B) (a : B), my_nth n l a -> In a l.
intros n l a nth.
elim nth; clear nth.
intros.
simpl in |- *; left; trivial.
intros.
simpl in |- *; right; assumption.
Qed.

Lemma nth_app0 :
 forall (n : nat) (l0 l1 : list B) (a : B),
 my_nth n l0 a -> my_nth n (l0 ++ l1) a.
intros n l0.
generalize n; clear n.
elim l0; clear l0.
intros n l1 a nth; elimtype False.
apply (inv_nth_nil n a nth).
intros a0 l0 ih n.
case n; clear n.
intros l1 a nth.
 rewrite (inv_nthO a0 l0 a nth).
simpl in |- *; apply My_NthO.
intros n l1 a nth.
simpl in |- *; apply My_NthS.
apply ih.
apply (inv_nthS n a0 l0 a nth).
Qed.

Lemma nth_app1 :
 forall (n : nat) (l0 l1 : list B) (a : B),
 my_nth n l1 a -> my_nth (length l0 + n) (l0 ++ l1) a.
intros n l0; elim l0; clear l0.
simpl in |- *; trivial.
intros a0 l0 ih l1 a nth.
simpl in |- *.
apply My_NthS.
apply ih.
assumption.
Qed.

Inductive inv_my_nth_app (n : nat) (l0 l1 : list B) (a : B) : Set :=
  | Inv_Nth_App0 : my_nth n l0 a -> inv_my_nth_app n l0 l1 a
  | Inv_Nth_App1 :
      forall n' : nat, my_nth n' l1 a -> inv_my_nth_app n l0 l1 a.

Lemma inv_nth_app :
 forall (n : nat) (l0 l1 : list B) (a : B),
 my_nth n (l0 ++ l1) a -> inv_my_nth_app n l0 l1 a.
intros n l0 l1 a.
generalize n; clear n.
elim l0; clear l0; simpl in |- *.
intros n nth.
right with n.
assumption.
intros a0 l0 ih_l0 n.
case n; clear n.
intros nth.
left.
 rewrite (inv_nthO a0 (l0 ++ l1) a nth).
apply My_NthO.
intros n nth.
elim (ih_l0 n).
intros nth_l0.
left.
apply My_NthS; assumption.
intros n' nth_l1.
right with n'; assumption.
apply inv_nthS with a0; assumption.
Qed.

Inductive nth_split (a : B) (l : list B) : Set :=
    Nth_Split_Intro :
      forall l1 l2 : list B, l = l1 ++ a :: l2 -> nth_split a l.

Lemma my_nth_split :
 forall (n : nat) (l : list B) (a : B), my_nth n l a -> nth_split a l.
intros n; elim n; clear n.
intros l a nth.
apply Nth_Split_Intro with (nil (A:=B)) (tail l).
inversion_clear nth.
simpl in |- *; trivial.
intros n ih l a.
case l; clear l.
intros nth; elimtype False; inversion_clear nth.
intros a0 l nth.
elim (ih l a); clear ih.
intros l1 l2 H.
apply Nth_Split_Intro with (a0 :: l1) l2.
 rewrite H; simpl in |- *; trivial.
inversion_clear nth; assumption.
Qed.

Lemma in_nth :
 forall (a : B) (l : list B), In a l -> exists n : nat, my_nth n l a.
intros b l; elim l; clear l.
intros in_b; inversion_clear in_b.
intros a l ih in_a.
inversion_clear in_a.
exists 0.
 rewrite H.
apply My_NthO.
elim ih; try assumption.
intros n nth.
exists (S n).
apply My_NthS; assumption.
Qed.

End My_Nth.


(** * FLX 53 satisfy hypothesis in [Float_spec] *)

(** Uses the Flocq library (http://flocq.gforge.inria.fr) to build a
    record [Float_spec] corresponding to IEEE754 binary64 format with
    a rounding to nearest. More precisely Flocq's FLX(53) is a model
    of binary64 without underflows, NaNs nor overflows. *)

Require Import Reals mathcomp.analysis.Rstruct Psatz.
From mathcomp Require Import ssreflect ssrbool eqtype.

Require Import Flocq.Core.Zaux.
Require Import Flocq.Core.Raux.
Require Import Flocq.Core.Defs.
Require Import Flocq.Core.Generic_fmt.
Require Import Flocq.Core.FLX.
Require Import Flocq.Core.Ulp.
Require Import Flocq.Prop.Relative.
Require Import Flocq.Prop.Plus_error.
Require Import Flocq.Prop.Div_sqrt_error.

Require Import bounded.
Require Import float_spec.

Require Import float_spec.

#[global] Obligation Tactic := idtac.  (* no automatic intro *)

Open Scope R_scope.

Section Flx64.

Let prec := 53%Z.
Let emax := 1024%Z.

Let emin := (3 - emax - prec)%Z.
Let fexp := FLX_exp prec.

Lemma Pprec : (0 < prec)%Z.
Proof. now compute. Qed.

Instance valid_exp : Valid_exp fexp.
Proof. now apply FLX_exp_valid. Qed.

Definition generic_format_pred (x : R) : bool :=
  x == @F2R radix2
            {| Fnum := Ztrunc (scaled_mantissa radix2 fexp x);
               Fexp := cexp radix2 fexp x |}.

Definition format x := generic_format_pred x.

Let F := FS_of format.

Lemma format0 : format 0.
Proof. apply /eqP /generic_format_0. Qed.

Lemma format1 : format 1.
Proof. now apply /eqP; apply generic_format_FLX_1. Qed.

Lemma format_opp x : format x -> format (- x).
Proof. by move /eqP => ?; apply /eqP; apply generic_format_opp. Qed.

Definition eps := bpow radix2 (-53).

Lemma eps_pos : 0 <= eps.
Proof. apply bpow_ge_0. Qed.

Lemma eps_lt_1 : eps < 1.
Proof.
unfold eps, bpow.
apply (Rmult_lt_reg_r (IZR (Z.pow_pos radix2 53)));
  [now fold (bpow radix2 53); apply bpow_gt_0|].
rewrite Rinv_l; [rewrite Rmult_1_l|now apply Rgt_not_eq, Rlt_gt;
                                    fold (bpow radix2 53); apply bpow_gt_0].
change 1 with (IZR 1); apply IZR_lt.
unfold Z.pow_pos; simpl.
now compute.
Qed.

Let b_eps := bounded eps.
Let b_epsd1peps := bounded (eps / (1 + eps)).

Definition eta := 0.

Lemma eta_pos : 0 <= eta.
Proof. apply Rle_refl. Qed.

Let b_eta := bounded eta.

(** The tie-break rule doesn't really matter. *)
Variable choice : Z -> bool.

(** All we need is rounding to nearest. *)
Program Definition frnd (x : R) : F :=
  @Build_FS_of _ (round radix2 fexp (Znearest choice) x) _.
Next Obligation.
move=> x; apply/eqP.
now apply generic_format_round; [apply FLX_exp_valid|apply valid_rnd_N].
Qed.

Lemma frnd_F (x : F) : frnd x = x.
Proof.
apply val_inj => /=.
by apply round_generic; [apply valid_rnd_N|apply /eqP; case x].
Qed.

Lemma frnd_spec_aux (x : R) :
  exists (d : b_epsd1peps),
    round radix2 fexp (Znearest choice) x = (1 + d) * x :> R.
Proof.
destruct (@relative_error_N_FLX'_ex radix2 _ Pprec choice x) as (d, (Hd, Hr)).
replace (u_ro _ _) with eps in Hd;
  [|now unfold u_ro, eps; change (/2) with (bpow radix2 (-1));
    rewrite <-bpow_plus].
now exists (Build_bounded Hd); simpl; rewrite Rmult_comm.
Qed.

Lemma frnd_spec (x : R) :
  exists (d : b_epsd1peps) (e : b_eta),
    round radix2 fexp (Znearest choice) x = (1 + d) * x + e :> R
    /\ d * e = 0.
Proof.
destruct (frnd_spec_aux x) as (d, Hd).
exists d, (bounded_0 (Rle_refl _)); simpl.
now rewrite Rplus_0_r Rmult_0_r; split.
Qed.

Lemma fplus_spec (x y : F) :
  exists d : b_epsd1peps, frnd (x + y) = (1 + d) * (x + y) :> R.
Proof. now destruct (frnd_spec_aux (x + y)) as (d, Hd); exists d. Qed.

Lemma fplus_spec_l (x y : F) : Rabs (frnd (x + y) - (x + y)) <= Rabs x.
Proof.
by apply plus_error_le_l; [apply FLX_exp_valid|apply /eqP..]; [|case x|case y].
Qed.

Lemma fplus_spec2 (x y : F) : y <= 0 -> frnd (x + y) <= x.
Proof.
intros Hy.
unfold frnd; simpl.
rewrite <- (round_generic radix2 fexp (Znearest choice) x) at 2;
  [|now apply /eqP; case x].
now apply round_le; [apply FLX_exp_valid|apply valid_rnd_N|lra].
Qed.

Lemma fmult_spec2 x : 0 <= frnd (x * x).
Proof.
unfold fmult, frnd; simpl.
rewrite <- (round_0 radix2 fexp (Znearest choice)).
apply round_le; [now apply FLX_exp_valid|now apply valid_rnd_N|].
apply misc.sqr_ge_0.
Qed.

Lemma fsqrt_spec (x : F) :
  exists d : bounded (1 - 1 / sqrt (1 + 2 * eps)),
    frnd (sqrt x) = (1 + d) * (sqrt x) :> R.
Proof.
assert (Hprec1 : (1 < prec)%Z); [now simpl|].
move: x => [x /= /eqP fx].
destruct (@sqrt_error_N_FLX_ex radix2 _ Pprec choice Hprec1 _ fx)
  as (d, (Hd, Hr)).
replace (u_ro _ _) with eps in Hd;
  [|now unfold eps, u_ro; change (/ 2) with (bpow radix2 (-1));
    rewrite <-bpow_plus].
now exists (Build_bounded Hd); simpl; rewrite Rmult_comm.
Qed.

Definition flx64 : Float_spec :=
  @Build_Float_spec
    format
    format0
    format1
    format_opp
    eps
    eps_pos
    eps_lt_1
    eta
    eta_pos
    frnd
    frnd_F
    frnd_spec
    fplus_spec
    fplus_spec_l
    fplus_spec2
    fmult_spec2
    fsqrt_spec.

(** A variant of flx64 wit eta <> 0 (useful for cholesky) *)

Definition eta' := bpow radix2 (-1075).

Lemma eta'_pos : 0 <= eta'.
Proof. apply bpow_ge_0. Qed.

Let b_eta' := bounded eta'.

Lemma frnd_spec' (x : R) :
  exists (d : b_epsd1peps) (e : b_eta'),
    round radix2 fexp (Znearest choice) x = (1 + d) * x + e :> R
    /\ d * e = 0.
Proof.
destruct (frnd_spec_aux x) as (d, Hd).
exists d, (bounded_0 eta'_pos); simpl.
now rewrite Rplus_0_r Rmult_0_r; split.
Qed.

Definition flx64' : Float_spec :=
  @Build_Float_spec
    format
    format0
    format1
    format_opp
    eps
    eps_pos
    eps_lt_1
    eta'
    eta'_pos
    frnd
    frnd_F
    frnd_spec'
    fplus_spec
    fplus_spec_l
    fplus_spec2
    fmult_spec2
    fsqrt_spec.

End Flx64.