From Lambda.Util Require Export Lists EqRect.
Require Coq.Vectors.Fin.

(** * System F *)

Equations mapply : forall {A : nat -> Type} (m : nat),
    (forall {n : nat}, A n -> A (S n)) -> forall {n : nat}, A n -> A (m + n) :=
  mapply  O    f a := a;
  mapply (S k) f a := f _ (mapply k f a).

Lemma f_equal_id : forall (A : Set) (x y : A) (h : x = y),
    f_equal id h = h.
Proof.
  intros A x y h.
  destruct h; reflexivity.
Defined.

Equations Derive Signature NoConfusion NoConfusionHom Subterm for Fin.t.

Inductive type (Δ : nat) : Set :=
| TId : Fin.t Δ -> type Δ
| TForall (τ : type (S Δ)) : type Δ
| TArrow (τ₁ τ₂ : type Δ) : type Δ.

Arguments TId {_}.
Arguments TForall {_}.
Arguments TArrow {_}.

Derive Signature for type.
Equations Derive NoConfusion NoConfusionHom Subterm for type.

Declare Scope ty_scope.
Delimit Scope ty_scope with ty.
Coercion TId : Fin.t >-> type.
Notation "'∀' x"
  := (TForall x) (at level 20, right associativity) : ty_scope.
Notation "x '→' y"
  := (TArrow x y) (at level 19, right associativity) : ty_scope.

Equations type_eq_dec : forall {Δ : nat} (τ ρ : type Δ), {τ = ρ} + {τ <> ρ} :=
  type_eq_dec (TId n) (TId m) with Fin.eq_dec n m => {
    | left _     => left _
    | right hneq => right _ };
  type_eq_dec (∀ τ)%ty (∀ ρ)%ty with type_eq_dec τ ρ => {
    | left _     => left _
    | right hneq => right _ };
  type_eq_dec (τ → τ')%ty (ρ → ρ')%ty with type_eq_dec τ ρ => {
    | right hneq => right _
    | left _ with type_eq_dec τ' ρ' => {
      | right hneq => right _
      | left _     => left _ } };
  type_eq_dec _ _ := right _.

Equations ext_type : forall {Δ₁ Δ₂ : nat},
    (Fin.t Δ₁ -> Fin.t Δ₂) -> Fin.t (S Δ₁) -> Fin.t (S Δ₂) :=
  ext_type _  Fin.F1    := Fin.F1;
  ext_type ρ (Fin.FS n) := Fin.FS (ρ n).

Equations rename_type : forall {Δ₁ Δ₂ : nat},
    (Fin.t Δ₁ -> Fin.t Δ₂) -> type Δ₁ -> type Δ₂ :=
  rename_type ρ (TId n) := ρ n;
  rename_type ρ (∀ τ)%ty := (∀ rename_type (ext_type ρ) τ)%ty;
  rename_type ρ (τ → τ')%ty := (rename_type ρ τ → rename_type ρ τ')%ty.

Equations exts_type : forall {Δ₁ Δ₂ : nat},
    (Fin.t Δ₁ -> type Δ₂) -> Fin.t (S Δ₁) -> type (S Δ₂) :=
  exts_type σ Fin.F1     := Fin.F1;
  exts_type σ (Fin.FS n) := rename_type Fin.FS (σ n).

Equations subs_type : forall {Δ₁ Δ₂ : nat},
    (Fin.t Δ₁ -> type Δ₂) -> type Δ₁ -> type Δ₂ :=
  subs_type σ (TId n)     := σ n;
  subs_type σ (∀ τ)%ty    := (∀ subs_type (exts_type σ) τ)%ty;
  subs_type σ (τ → τ')%ty := (subs_type σ τ → subs_type σ τ')%ty.

Equations sub_type_helper : forall {Δ : nat}, type Δ -> Fin.t (S Δ) -> type Δ :=
  sub_type_helper τ Fin.F1     := τ;
  sub_type_helper _ (Fin.FS n) := n.

Definition sub_type {Δ : nat} (body : type (S Δ)) (arg : type Δ) : type Δ :=
  subs_type (sub_type_helper arg) body.

Notation "x '`[[' y ']]'"
  := (sub_type x y) (at level 12, left associativity) : ty_scope.

Equations mapply_ext_type : forall {Δ₁ Δ₂ : nat} (m : nat),
    (Fin.t Δ₁ -> Fin.t Δ₂) -> Fin.t (m + Δ₁) -> Fin.t (m + Δ₂) :=
  mapply_ext_type  O    ρ := ρ;
  mapply_ext_type (S k) ρ := ext_type (mapply_ext_type k ρ).

Lemma mapply_ext_type_eq
  : forall {Δ₁ Δ₂ : nat} (m : nat) (ρ : Fin.t Δ₁ -> Fin.t Δ₂) (X : Fin.t (m + Δ₁)),
    ext_type
      (mapply_ext_type m ρ)
      (eq_rect
         _ _
         (mapply_ext_type m Fin.FS X) _
         (eq_sym (plus_n_Sm _ _)))
    = eq_rect
        _ _
        (mapply_ext_type m Fin.FS (mapply_ext_type m ρ X)) _
        (eq_sym (plus_n_Sm _ _)).
Proof.
  intros Δ₁ Δ₂ m ρ X.
  funelim (mapply_ext_type m Fin.FS); cbn in *.
  - do 3 rewrite mapply_ext_type_equation_1.
    unfold eq_sym.
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₂0) (x:=plus_n_Sm 0 Δ₂0); cbn.
    depelim X; rewrite ext_type_equation_2; reflexivity.
  - do 3 rewrite mapply_ext_type_equation_2.
    pose proof Peano_dec.UIP_nat
         _ _ (eq_sym (plus_n_Sm (S k) Δ₁)) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (eq_sym (plus_n_Sm k Δ₁))).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (eq_sym (plus_n_Sm (S k) Δ₂0)) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (eq_sym (plus_n_Sm k Δ₂0))).
    rewrite h; clear h.
    depelim X.
    + do 2 rewrite ext_type_equation_1. clear H.
      destruct (plus_n_Sm k Δ₁).
      destruct (plus_n_Sm k Δ₂0). reflexivity.
    + do 2 rewrite ext_type_equation_2.
      rewrite map_subst_map.
      do 2 rewrite ext_type_equation_2.
      rewrite map_subst_map.
      rewrite H. reflexivity.
Qed.

Print Assumptions mapply_ext_type_eq.

Lemma mapply_ext_type_eq_rect_zwei :
  forall {Δ₁ Δ₂ : nat} (m : nat) (ρ : Fin.t Δ₁ -> Fin.t Δ₂) (X : Fin.t (m + Δ₁)),
    eq_rect_zwei
      (T:=fun u v => Fin.t u -> Fin.t v)
      (plus_n_Sm m Δ₁)
      (plus_n_Sm m Δ₂)
      (mapply_ext_type (S m) ρ)
      (mapply_ext_type m Fin.FS X)
    = mapply_ext_type m Fin.FS (mapply_ext_type m ρ X).
Proof.
  intros Δ₁ Δ₂ m ρ X.
  funelim (mapply_ext_type m Fin.FS); cbn in *.
  - rewrite mapply_ext_type_equation_2.
    do 3 rewrite mapply_ext_type_equation_1.
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₂0) (x:=plus_n_Sm 0 Δ₂0); cbn.
    rewrite eq_rect_zwei_equation_1.
    rewrite ext_type_equation_2. reflexivity.
  - repeat rewrite mapply_ext_type_equation_2.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₁) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm k Δ₁)).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₂0) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm k Δ₂0)).
    rewrite h; clear h.
    rewrite map_subst_map_zwei_both.
    depelim X; cbn.
    + do 2 rewrite ext_type_equation_1; reflexivity.
    + do 4 rewrite ext_type_equation_2.
      specialize H with (ρ:=ρ0) (X:=X).
      rewrite mapply_ext_type_equation_2 in H.
      rewrite H; reflexivity.
Defined.

Print Assumptions mapply_ext_type_eq_rect_zwei.

Lemma mapply_rename_type_ext_type :
  forall {Δ₁ Δ₂ : nat} (m : nat) (τ : type (m + Δ₁)) (ρ : Fin.t Δ₁ -> Fin.t Δ₂),
    @rename_type (m + S Δ₁) (m + S Δ₂)
                 (eq_rect_zwei
                    (T:=fun u v => Fin.t u -> Fin.t v)
                    (plus_n_Sm m Δ₁) (plus_n_Sm m Δ₂) (mapply_ext_type (S m) ρ))
      (@rename_type (m + Δ₁) (m + S Δ₁) (mapply_ext_type m Fin.FS) τ)
    = rename_type
        (mapply_ext_type m Fin.FS)
        (rename_type (mapply_ext_type m ρ) τ).
Proof.
  intros Δ₁ Δ₂ m τ.
  generalize dependent Δ₂.
  depind τ; intros Δ₂ ρ.
  - do 4 rewrite rename_type_equation_1.
    rewrite mapply_ext_type_eq_rect_zwei; reflexivity.
  - do 4 rewrite rename_type_equation_2; f_equal.
    specialize IHτ with (m:=S m) (τ:=τ) (Δ₂:=Δ₂) (ρ:=ρ).
    repeat rewrite mapply_ext_type_equation_2 in *.
    assert
      (doh : {| pr1 := S m + Δ₁; pr2 := τ |}
             = {| pr1 := S (m + Δ₁); pr2 := τ |})
      by reflexivity.
    apply IHτ in doh as IH; clear IHτ doh.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₁) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₁)).
    rewrite h in IH; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₂) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₂)).
    rewrite h in IH; clear h; cbn in *.
    rewrite <- IH; clear IH.
    rewrite map_subst_map_zwei_both. reflexivity.
  - do 4 rewrite rename_type_equation_3.
    rewrite IHτ1, IHτ2; reflexivity.
Defined.

Print Assumptions mapply_rename_type_ext_type.

Lemma rename_type_ext_type : forall {Δ₁ Δ₂ : nat} (τ : type Δ₁) (ρ : Fin.t Δ₁ -> Fin.t Δ₂),
    rename_type (ext_type ρ) (rename_type Fin.FS τ)
    = rename_type Fin.FS (rename_type ρ τ).
Proof.
  intros Δ₁ Δ₂ τ ρ.
  pose proof mapply_rename_type_ext_type 0 τ ρ as h.
  rewrite mapply_ext_type_equation_2 in h.
  do 3 rewrite mapply_ext_type_equation_1 in h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁) in h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂) in h; cbn.
  rewrite eq_rect_zwei_equation_1 in h.
  assumption.
Defined.

Lemma map_rename_typ_ext : forall {Δ₁ Δ₂ : nat} (ρ : Fin.t Δ₁ -> Fin.t Δ₂) (Γ : list (type Δ₁)),
    map (rename_type (ext_type ρ)) (map (rename_type Fin.FS) Γ)
    = map (rename_type Fin.FS) (map (rename_type ρ) Γ).
Proof.
  intros Δ₁ Δ₂ ρ Γ.
  induction Γ as [| τ Γ ih]; cbn; f_equal; auto.
  rewrite rename_type_ext_type; reflexivity.
Defined.

Equations mapply_exts_type : forall {Δ₁ Δ₂ : nat} (m : nat),
    (Fin.t Δ₁ -> type Δ₂) -> Fin.t (m + Δ₁) -> type (m + Δ₂) :=
  mapply_exts_type  O    σ := σ;
  mapply_exts_type (S k) σ := exts_type (mapply_exts_type k σ).

Lemma mapply_subs_type_helper :
  forall (m : nat) {Δ₁ Δ₂ : nat} (ρ : Fin.t Δ₁ -> Fin.t Δ₂)
    (X : Fin.t (S m + Δ₁)) (τ' : type Δ₁),
    eq_rect_zwei
      (T:=fun u v => Fin.t u -> type v)
      (eq_sym (plus_n_Sm m Δ₂)) eq_refl
      (mapply_exts_type
         m
         (sub_type_helper (rename_type ρ τ')))
      (mapply_ext_type (S m) ρ X)
    = rename_type
        (mapply_ext_type m ρ)
        (eq_rect_zwei
           (T:=fun u v => Fin.t u -> type v)
           (eq_sym (plus_n_Sm m Δ₁)) eq_refl
           (mapply_exts_type m (sub_type_helper τ')) X).
Proof.
  intros m; induction m as [| m ih];
    intros Δ₁ Δ₂ ρ X τ'; cbn in *.
  - rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂); cbn.
    do 2 rewrite eq_rect_zwei_equation_1.
    rewrite mapply_ext_type_equation_2.
    rewrite mapply_ext_type_equation_1.
    do 2 rewrite mapply_exts_type_equation_1.
    funelim (ext_type ρ X).
    + rewrite ext_type_equation_1.
      do 2 rewrite sub_type_helper_equation_1.
      reflexivity.
    + rewrite ext_type_equation_2.
      do 2 rewrite sub_type_helper_equation_2.
      rewrite rename_type_equation_1; reflexivity.
  - pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₁) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₁)).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₂) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₂)).
    rewrite h; clear h.
    do 2 rewrite eq_sym_map_distr.
    Set Printing Implicit.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (m + Δ₁))) as h; cbn in h.
    specialize h with
      (p2:=f_equal S eq_refl).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (m + Δ₂))) as h; cbn in h.
    specialize h with
      (p2:=f_equal S eq_refl).
    rewrite h; clear h.
    Unset Printing Implicit.
    do 2 rewrite mapply_ext_type_equation_2.
    do 2 rewrite mapply_exts_type_equation_2.
    depelim X.
    + clear ih. rewrite ext_type_equation_1.
      do 2 rewrite map_subst_map_zwei_both.
      destruct m as [| m].
      * rewrite Eqdep_dec.UIP_refl_nat
          with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
        rewrite Eqdep_dec.UIP_refl_nat
          with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂); cbn.
        do 2 rewrite eq_rect_zwei_equation_1.
        do 2 rewrite exts_type_equation_1.
        rewrite rename_type_equation_1.
        rewrite ext_type_equation_1.
        reflexivity.
      * pose proof Peano_dec.UIP_nat
             _ _ (plus_n_Sm (S m) Δ₁) as h; cbn in h.
        specialize h with
          (p2:=f_equal S (plus_n_Sm m Δ₁)).
        rewrite h; clear h.
        pose proof Peano_dec.UIP_nat
             _ _ (plus_n_Sm (S m) Δ₂) as h; cbn in h.
        specialize h with
          (p2:=f_equal S (plus_n_Sm m Δ₂)).
        rewrite h; clear h; cbn.
        rewrite eq_sym_map_distr with (f:=S) (e:=plus_n_Sm m Δ₂).
        Set Printing Implicit.
        pose proof Peano_dec.UIP_nat
             _ _ (@eq_refl _ (S (m + Δ₁))) as h; cbn in h.
        specialize h with
          (p2:=f_equal S eq_refl).
        rewrite h; clear h.
        pose proof Peano_dec.UIP_nat
             _ _ (@eq_refl _ (S (m + Δ₂))) as h; cbn in h.
        specialize h with
          (p2:=f_equal S eq_refl).
        rewrite h; clear h.
        Unset Printing Implicit.
        do 2 rewrite mapply_exts_type_equation_2.
        rewrite map_subst_map_zwei_both.
        do 2 rewrite exts_type_equation_1.
        rewrite rename_type_equation_1,
          ext_type_equation_1; reflexivity.
    + rewrite ext_type_equation_2.
      do 2 rewrite map_subst_map_zwei_both.
      do 2 rewrite exts_type_equation_2.
      rewrite rename_type_ext_type,<- ih; reflexivity.
Defined.

Lemma mapply_subs_type_exts_type :
  forall {Δ₁ Δ₂ : nat} (m : nat) (ρ : Fin.t Δ₁ -> Fin.t Δ₂)
    (τ : type (S m + Δ₁)) (τ' : type Δ₁),
    subs_type
      (Δ₁:=S m + Δ₂)
      (Δ₂:=m + Δ₂)
      (eq_rect_zwei
         (T:=fun u v => Fin.t u -> type v)
         (eq_sym (plus_n_Sm m Δ₂))
         eq_refl
         (mapply_exts_type
            m
            (sub_type_helper
               (rename_type
                  (Δ₁:=Δ₁) (Δ₂:=Δ₂) ρ τ'))))
      (rename_type
         (Δ₁:=S m + Δ₁) (Δ₂:=S m + Δ₂)
         (mapply_ext_type (S m) ρ) τ)
    = rename_type
        (Δ₁:=m + Δ₁)
        (Δ₂:=m + Δ₂)
        (mapply_ext_type m ρ)
        (subs_type
           (Δ₁:=S m + Δ₁)
           (Δ₂:=m + Δ₁)
           (eq_rect_zwei
              (T:=fun u v => Fin.t u -> type v)
              (eq_sym (plus_n_Sm m Δ₁))
              eq_refl
              (mapply_exts_type
                 m (sub_type_helper τ')))
           τ).
Proof.
  intros Δ₁ Δ₂ m ρ τ; generalize dependent Δ₂.
  depind τ; intros Δ₂ ρ τ'; cbn in *.
  - rewrite rename_type_equation_1.
    do 2 rewrite subs_type_equation_1.
    rewrite mapply_subs_type_helper; reflexivity.
  - rewrite rename_type_equation_2.
    do 2 rewrite subs_type_equation_2.
    rewrite rename_type_equation_2; f_equal.
    specialize IHτ with (Δ₁:=Δ₁) (m:=S m) (τ:=τ).
    pose proof IHτ eq_refl as ih; clear IHτ.
    specialize ih with Δ₂ ρ τ'; cbn in *.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₁) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₁)).
    rewrite h in ih; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S m) Δ₂) as h; cbn in h.
    specialize h with
      (p2:=f_equal S (plus_n_Sm m Δ₂)).
    rewrite h in ih; clear h.
    do 2 rewrite eq_sym_map_distr in ih.
    Set Printing Implicit.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (m + Δ₁))) as h; cbn in h.
    specialize h with
      (p2:=f_equal S eq_refl).
    rewrite h in ih; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (m + Δ₂))) as h; cbn in h.
    specialize h with
      (p2:=f_equal S eq_refl).
    rewrite h in ih; clear h.
    Unset Printing Implicit.
    repeat rewrite mapply_ext_type_equation_2 in *.
    repeat rewrite mapply_exts_type_equation_2 in *.
    do 2 rewrite map_subst_map_zwei_both in ih.
    rewrite <- ih. reflexivity.
  - rewrite rename_type_equation_3.
    do 2 rewrite subs_type_equation_3.
    rewrite rename_type_equation_3; f_equal; eauto.
Defined.

Lemma rename_type_distr_sub_type :
  forall {Δ₁ Δ₂ : nat} (ρ : Fin.t Δ₁ -> Fin.t Δ₂) (τ : type (S Δ₁)) (τ' : type Δ₁),
    (rename_type (ext_type ρ) τ `[[ rename_type ρ τ']])%ty
    = rename_type ρ (τ `[[ τ']])%ty.
Proof.
  intros Δ₁ Δ₂ ρ τ τ'; unfold "_ `[[ _ ]]".
  pose proof mapply_subs_type_exts_type 0 ρ τ τ' as h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁) in h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂) in h.
  do 2 rewrite eq_rect_zwei_equation_1 in h.
  rewrite mapply_ext_type_equation_2 in h.
  rewrite mapply_ext_type_equation_1 in h.
  do 2 rewrite mapply_exts_type_equation_1 in h.
  assumption.
Defined.

Reserved Notation "Γ '⊢' τ" (at level 80, no associativity).

Inductive term : forall {Δ : nat}, list (type Δ) -> type Δ -> Set :=
| Id {Δ : nat} (Γ : list (type Δ)) (τ : type Δ) :
  Has τ Γ ->
  Γ ⊢ τ
| Abs {Δ : nat} (Γ : list (type Δ)) (τ τ' : type Δ) :
  τ :: Γ ⊢ τ' ->
  Γ ⊢ (τ → τ')%ty
| App {Δ : nat} (Γ : list (type Δ)) (τ τ' : type Δ) :
  Γ ⊢ (τ → τ')%ty ->
  Γ ⊢ τ ->
  Γ ⊢ τ'
| TypAbs {Δ : nat} (Γ : list (type Δ)) (τ : type (S Δ)) :
  map (rename_type Fin.FS) Γ ⊢ τ ->
  Γ ⊢ (∀ τ)%ty
| TypApp {Δ : nat} (Γ : list (type Δ)) (τ : type (S Δ)) (τ' : type Δ) :
  Γ ⊢ (∀ τ)%ty ->
  Γ ⊢ (τ `[[ τ' ]])%ty
where "Γ '⊢' τ" := (term Γ τ).

Derive Signature for term.
Equations Derive NoConfusion (* NoConfusionHom *) (*Subterm*) for term.

Declare Scope term_scope.
Delimit Scope term_scope with term.

Notation "'`λ' t"
  := (Abs _ _ _ t)
       (at level 41, right associativity) : term_scope.
Notation "'λ' τ '⇒' t"
  := (Abs _ τ _ t)
       (at level 41, right associativity) : term_scope.
Notation "'λ' τ '↣' .. '↣' ρ '⇒' t"
  := (Abs _ τ _ .. (Abs _ ρ _ t) ..)
       (at level 41, right associativity) : term_scope.
Notation "x '⋅' y"
  := (App _ _ _ x y)
       (at level 40, left associativity) : term_scope.
Notation "'Λ' x"
  := (TypAbs _ _ x)
       (at level 43, right associativity) : term_scope.
Notation "t '⦗' τ '⦘'"
  := (TypApp _ _ τ t)
       (at level 39, left associativity) : term_scope.

Definition ext_Renamer : forall {Δ : nat} {Γ₁ Γ₂ : list (type Δ)},
    (forall τ : type Δ, Has τ Γ₁ -> Has τ Γ₂) -> forall τ : type (S Δ),
      Has τ (map (rename_type Fin.FS) Γ₁) ->
      Has τ (map (rename_type Fin.FS) Γ₂).
Proof.
  intros Δ Γ₁ Γ₂ f τ h.
  apply map_has in h as [τ' τ'eq h]; subst.
  apply has_map,f,h.
Defined.

Equations Rename : forall {Δ : nat} {Γ₁ Γ₂ : list (type Δ)},
    (forall {τ : type Δ}, Has τ Γ₁ -> Has τ Γ₂) ->
    forall {τ : type Δ}, Γ₁ ⊢ τ -> Γ₂ ⊢ τ :=
  Rename ρ (Id _ _ has) := Id _ _ (ρ _ has);
  Rename ρ (λ σ ⇒ t)%term := (λ σ ⇒ Rename (ext_has ρ σ) t)%term;
  Rename ρ (t₁ ⋅ t₂)%term := (Rename ρ t₁ ⋅ Rename ρ t₂)%term;
  Rename ρ (Λ t)%term     := (Λ Rename (ext_Renamer ρ) t)%term;
  Rename ρ (t ⦗ τ ⦘)%term := ((Rename ρ t) ⦗ τ ⦘)%term.

Equations exts : forall {Δ : nat} {Γ₁ Γ₂ : list (type Δ)},
    (forall {τ : type Δ}, Has τ Γ₁ -> Γ₂ ⊢ τ) ->
    forall {ρ τ : type Δ}, Has τ (ρ :: Γ₁) -> ρ :: Γ₂ ⊢ τ :=
  exts σ HasO := Id _ _ HasO;
  exts σ (HasS hs) := Rename (fun τ => HasS (a:=τ)) (σ _ hs).

Equations Rename_type :
  forall {Δ₁ Δ₂ : nat} {Γ : list (type Δ₁)}
    (ρ : Fin.t Δ₁ -> Fin.t Δ₂) {τ : type Δ₁},
    Γ ⊢ τ -> map (rename_type ρ) Γ ⊢ rename_type ρ τ :=
  Rename_type ρ (Id _ _ h) := Id _ _ (has_map (rename_type ρ) h);
  Rename_type ρ (`λ t)%term := (`λ Rename_type ρ t)%term;
  Rename_type ρ (t ⋅ t')%term := (Rename_type ρ t ⋅ Rename_type ρ t')%term;
  Rename_type (Δ₁:=Δ₁) (Δ₂:=Δ₂) (Γ:=Γ) ρ (TypAbs _ τ t) :=
    (Λ eq_rect
       (map (rename_type (ext_type ρ)) (map (rename_type Fin.FS) Γ))
       (fun Γ => Γ ⊢ rename_type (ext_type ρ) τ)
       (Rename_type (ext_type ρ) t)
       (map (rename_type Fin.FS) (map (rename_type ρ) Γ)) _)%term;
  Rename_type (Δ₁:=Δ₁) (Δ₂:=Δ₂) (Γ:=Γ) ρ (TypApp _ τ τ' t)%term :=
    eq_rect
      (rename_type (ext_type ρ) τ `[[ rename_type ρ τ']])%ty
      (fun τ => map (rename_type ρ) Γ ⊢ τ)
      (Rename_type ρ t ⦗ rename_type ρ τ' ⦘)%term
      (rename_type ρ (τ `[[ τ']])%ty) _.
Next Obligation. apply map_rename_typ_ext. Defined.
Next Obligation. apply rename_type_distr_sub_type. Defined.

Print Assumptions Rename_type.

Definition exts_Rename_type : forall {Δ : nat} {Γ₁ Γ₂ : list (type Δ)},
    (forall τ : type Δ, Has τ Γ₁ -> Γ₂ ⊢ τ) -> forall τ : type (S Δ),
      Has τ (map (rename_type Fin.FS) Γ₁) ->
      map (rename_type Fin.FS) Γ₂ ⊢ τ.
Proof.
  intros Δ Γ₁ Γ₂ σ τ h.
  apply map_has in h as [τ₁ ? h]; subst.
  apply Rename_type,σ,h.
Defined.

Equations subs : forall {Δ : nat} {Γ₁ Γ₂ : list (type Δ)},
    (forall {τ : type Δ}, Has τ Γ₁ -> Γ₂ ⊢ τ) ->
    forall {τ : type Δ}, Γ₁ ⊢ τ -> Γ₂ ⊢ τ :=
  subs σ (Id _ _ h)     := σ _ h;
  subs σ (λ τ ⇒ t)%term := (λ τ ⇒ subs (fun τ => exts σ (τ:=τ)) t)%term;
  subs σ (t₁ ⋅ t₂)%term := (subs σ t₁ ⋅ subs σ t₂)%term;
  subs σ (Λ t)%term     := (Λ subs (exts_Rename_type σ) t)%term;
  subs σ (t ⦗ τ ⦘)%term := (subs σ t ⦗ τ ⦘)%term.

Print Assumptions subs.

Equations sub_helper : forall {Δ : nat} {Γ : list (type Δ)} {τ : type Δ},
    Γ ⊢ τ -> forall τ' : type Δ, Has τ' (τ :: Γ) -> Γ ⊢ τ' :=
  sub_helper t _ HasO := t;
  sub_helper _ _ (HasS hs) := Id _ _ hs.

Definition sub {Δ : nat} {Γ : list (type Δ)} {τ τ' : type Δ}
           (body : τ :: Γ ⊢ τ') (arg : Γ ⊢ τ) : Γ ⊢ τ' :=
  subs (sub_helper arg) body.

Notation "x '[[' y ']]'"
  := (sub x y) (at level 38, left associativity) : term_scope.

Lemma mapply_exts_type_rename_type :
  forall (k : nat) {Δ₁ Δ₂ : nat} (X : Fin.t (k + Δ₁))
    (σ : Fin.t Δ₁ -> type Δ₂),
    eq_rect_zwei
      (T:=fun u v => Fin.t u -> type v)
      (plus_n_Sm _ _)
      (plus_n_Sm _ _)
      (mapply_exts_type (S k) σ)
      (mapply_ext_type k Fin.FS X)
    = rename_type (mapply_ext_type k Fin.FS) (mapply_exts_type k σ X).
Proof.
  intro k; induction k as [| k ih]; intros Δ₁ Δ₂ X σ; cbn in *.
  - rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂); cbn.
    rewrite mapply_exts_type_equation_2.
    rewrite mapply_exts_type_equation_1.
    do 2 rewrite mapply_ext_type_equation_1.
    rewrite eq_rect_zwei_equation_1.
    rewrite exts_type_equation_2; reflexivity.
  - pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₁) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₁)).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₂) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₂)).
    rewrite h; clear h.
    do 2 rewrite mapply_exts_type_equation_2.
    rewrite map_subst_map_zwei_both.
    do 2 rewrite mapply_ext_type_equation_2.
    depelim X.
    + clear ih.
      rewrite ext_type_equation_1.
      do 2 rewrite exts_type_equation_1.
      rewrite rename_type_equation_1.
      rewrite ext_type_equation_1.
      reflexivity.
    + rewrite ext_type_equation_2.
      do 2 rewrite exts_type_equation_2.
      specialize ih with (X:=X) (σ:=σ).
      rewrite mapply_exts_type_equation_2 in ih; cbn in *.
      rewrite ih; clear ih.
      rewrite rename_type_ext_type; reflexivity.
Defined.

Lemma mapply_subs_rename_type :
  forall {Δ₁ Δ₂ : nat} (k : nat) (τ : type (k + Δ₁))
    (σ : Fin.t Δ₁ -> type Δ₂),
    subs_type
      (eq_rect_zwei
         (T:=fun u v => Fin.t u -> type v)
         (plus_n_Sm _ _) (plus_n_Sm _ _)
         (mapply_exts_type (S k) σ))
      (rename_type (mapply_ext_type k Fin.FS) τ)
    = rename_type
        (mapply_ext_type k Fin.FS)
        (subs_type (mapply_exts_type k σ) τ).
Proof.
  intros Δ₁ Δ₂ k τ; generalize dependent Δ₂.
  depind τ; intros Δ₂ σ.
  - rewrite rename_type_equation_1.
    do 2 rewrite subs_type_equation_1.
    rewrite mapply_exts_type_rename_type; reflexivity.
  - rewrite rename_type_equation_2.
    do 2 rewrite subs_type_equation_2.
    rewrite rename_type_equation_2; f_equal.
    specialize IHτ with (Δ₁:=Δ₁) (k:=S k) (τ:=τ).
    pose proof IHτ eq_refl as ih; clear IHτ.
    specialize ih with (Δ₂:=Δ₂) (σ:=σ).
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₁) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₁)).
    rewrite h in ih; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₂) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₂)).
    rewrite h in ih; clear h.
    do 2 rewrite mapply_ext_type_equation_2 in ih.
    do 2 rewrite mapply_exts_type_equation_2 in ih. cbn in *.
    rewrite <- ih; clear ih.
    rewrite map_subst_map_zwei_both,
      mapply_exts_type_equation_2; reflexivity.
  - rewrite rename_type_equation_3.
    do 2 rewrite subs_type_equation_3.
    rewrite rename_type_equation_3; f_equal; auto.
Defined.

Lemma subs_rename_type :
  forall {Δ₁ Δ₂ : nat} (σ : Fin.t Δ₁ -> type Δ₂) (τ : type Δ₁),
    subs_type (exts_type σ) (rename_type Fin.FS τ)
    = rename_type Fin.FS (subs_type σ τ).
Proof.
  intros Δ₁ Δ₂ σ τ.
  pose proof mapply_subs_rename_type 0 τ σ as h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁) in h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂) in h; cbn in h.
  rewrite mapply_exts_type_equation_2,
    mapply_exts_type_equation_1 in h.
  do 2 rewrite mapply_ext_type_equation_1 in h.
  rewrite eq_rect_zwei_equation_1 in h.
  assumption.
Defined.

Lemma map_subs_rename_type :
  forall {Δ₁ Δ₂ : nat} (Γ : list (type Δ₁))
    (σ : Fin.t Δ₁ -> type Δ₂),
    map (subs_type (exts_type σ)) (map (rename_type Fin.FS) Γ)
    = map (rename_type Fin.FS) (map (subs_type σ) Γ).
Proof.
  intros Δ₁ Δ₂ Γ σ.
  induction Γ as [| τ Γ ih]; cbn in *; f_equal; auto using subs_rename_type.
Defined.

Print Assumptions map_subs_rename_type.

Lemma mapply_exts_type_idem :
  forall (k : nat) {Δ : nat} (X : Fin.t (k + Δ)) (τ' : type Δ),
    mapply_exts_type
      k (sub_type_helper τ')
      (mapply_ext_type k Fin.FS X) = X.
Proof.
  intro k;
    induction k as [| k ih];
    intros Δ X τ'.
  - rewrite mapply_exts_type_equation_1,
      mapply_ext_type_equation_1,
      sub_type_helper_equation_2; reflexivity.
  - rewrite mapply_exts_type_equation_2,
      mapply_ext_type_equation_2.
    depelim X.
    + rewrite ext_type_equation_1,
        exts_type_equation_1; reflexivity.
    + rewrite ext_type_equation_2,
        exts_type_equation_2.
      rewrite ih, rename_type_equation_1; reflexivity.
Defined.

Lemma mapply_exts_type_subs_type_rename_type_idem :
  forall {Δ : nat} (k : nat) (τ : type (k + Δ)) (τ' : type Δ),
    subs_type
      (mapply_exts_type k (sub_type_helper τ'))
      (rename_type (mapply_ext_type k Fin.FS) τ) = τ.
Proof.
  intros Δ k τ τ'; depind τ.
  - rewrite rename_type_equation_1,
      subs_type_equation_1,
      mapply_exts_type_idem;
      reflexivity.
  - specialize IHτ with (Δ:=Δ0) (k:=S k) (τ:=τ) (τ':=τ').
    pose proof IHτ eq_refl as ih; clear IHτ.
    rewrite rename_type_equation_2,
      subs_type_equation_2; f_equal.
    rewrite mapply_exts_type_equation_2,
      mapply_ext_type_equation_2 in ih.
    cbn in *; assumption.
  - rewrite rename_type_equation_3,
      subs_type_equation_3; f_equal; auto.
Defined.

Lemma subs_type_rename_type_idem :
  forall {Δ : nat} (τ τ' : type Δ),
    subs_type (sub_type_helper τ') (rename_type Fin.FS τ) = τ.
Proof.
  intros Δ τ τ'.
  pose proof
       mapply_exts_type_subs_type_rename_type_idem
       0 τ τ' as h.
  rewrite mapply_exts_type_equation_1,
    mapply_ext_type_equation_1 in h;
    assumption.
Defined.

Lemma map_subs_type_rename_type_idem :
  forall {Δ : nat} (τ' : type Δ) (Γ : list (type Δ)),
    map
      (subs_type (sub_type_helper τ'))
      (map (rename_type Fin.FS) Γ) = Γ.
Proof.
  intros Δ τ' Γ; induction Γ as [| τ Γ ih]; cbn;
    f_equal; auto using subs_type_rename_type_idem.
Defined.

Lemma subs_type_mapply_exts_type_eq_rect_zwei :
  forall (k : nat) {Δ₁ Δ₂ : nat} (X : Fin.t (S k + Δ₁))
    (τ' : type Δ₁) (σ : Fin.t Δ₁ -> type Δ₂),
    subs_type
      (eq_rect_zwei
         (T:=fun u v => Fin.t u -> type v)
         (eq_sym (plus_n_Sm k Δ₂)) eq_refl
         (mapply_exts_type k (sub_type_helper (subs_type σ τ'))))
      (mapply_exts_type (S k) σ X)
    = subs_type
        (mapply_exts_type k σ)
        (eq_rect_zwei
           (T:=fun u v => Fin.t u -> type v)
           (eq_sym (plus_n_Sm k Δ₁)) eq_refl
           (mapply_exts_type k (sub_type_helper τ')) X).
Proof.
  intro k; induction k as [| k ih];
    intros Δ₁ Δ₂ X τ' σ.
  - rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁).
    rewrite Eqdep_dec.UIP_refl_nat
      with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂); cbn.
    rewrite mapply_exts_type_equation_2.
    do 3 rewrite mapply_exts_type_equation_1.
    do 2 rewrite eq_rect_zwei_equation_1.
    depelim X.
    + rewrite exts_type_equation_1,
        subs_type_equation_1.
      do 2 rewrite sub_type_helper_equation_1; reflexivity.
    + rewrite exts_type_equation_2,
        sub_type_helper_equation_2,
        subs_type_equation_1,
        subs_type_rename_type_idem; reflexivity.
  - pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₁) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₁)).
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₂) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₂)).
    rewrite h; clear h; cbn in *.
    do 2 rewrite eq_sym_map_distr.
    Set Printing Implicit.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (k + Δ₂))) (f_equal S eq_refl) as h.
    rewrite h; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (k + Δ₁))) (f_equal S eq_refl) as h.
    rewrite h; clear h.
    Unset Printing Implicit.
    do 4 rewrite mapply_exts_type_equation_2.
    do 2 rewrite map_subst_map_zwei_both.
    depelim X.
    + do 2 rewrite exts_type_equation_1.
      do 2 rewrite subs_type_equation_1.
      do 2 rewrite exts_type_equation_1; reflexivity.
    + do 2 rewrite exts_type_equation_2.
      specialize ih with Δ₁ Δ₂ X τ' σ.
      Check subs_rename_type.
      do 2 rewrite subs_rename_type; f_equal.
      rewrite <- ih; clear ih.
      rewrite mapply_exts_type_equation_2; reflexivity.
Defined.

Lemma mapply_exts_type_subs_mapply_ext_type :
      forall {Δ₁ Δ₂ : nat} (k : nat) (τ : type (S k + Δ₁))
        (τ' : type Δ₁) (σ : Fin.t Δ₁ -> type Δ₂),
        subs_type
          (eq_rect_zwei
             (T:=fun u v => Fin.t u -> type v)
             (eq_sym (plus_n_Sm _ _)) eq_refl
             (mapply_exts_type k (sub_type_helper (subs_type σ τ'))))
          (subs_type (mapply_exts_type (S k) σ) τ)
        = subs_type
            (mapply_exts_type k σ)
            (subs_type
               (eq_rect_zwei
                  (T:=fun u v => Fin.t u -> type v)
                  (eq_sym (plus_n_Sm _ _)) eq_refl
                  (mapply_exts_type k (sub_type_helper τ')))
               τ).
Proof.
  intros Δ₁ Δ₂ k τ τ' σ; depind τ.
  - do 2 rewrite subs_type_equation_1.
    rewrite subs_type_mapply_exts_type_eq_rect_zwei;
      reflexivity.
  - do 4 rewrite subs_type_equation_2; f_equal.
    specialize IHτ with
      (Δ₁:=Δ₁) (Δ₂:=Δ₂) (k:=S k)
      (τ:=τ) (τ':=τ') (σ:=σ).
    pose proof IHτ eq_refl as ih; clear IHτ.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₁) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₁)).
    rewrite h in ih; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (plus_n_Sm (S k) Δ₂) as h; cbn in h.
    specialize h with (f_equal S (plus_n_Sm k Δ₂)).
    rewrite h in ih; clear h; cbn in *.
    do 2 rewrite eq_sym_map_distr in ih.
    Set Printing Implicit.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (k + Δ₂))) (f_equal S eq_refl) as h.
    rewrite h in ih; clear h.
    pose proof Peano_dec.UIP_nat
         _ _ (@eq_refl _ (S (k + Δ₁))) (f_equal S eq_refl) as h.
    rewrite h in ih; clear h.
    Unset Printing Implicit.
    do 4 rewrite mapply_exts_type_equation_2 in ih.
    do 2 rewrite map_subst_map_zwei_both in ih.
    rewrite <- ih; clear ih.
    rewrite mapply_exts_type_equation_2;reflexivity.
  - do 4 rewrite subs_type_equation_3; f_equal; eauto.
Defined.

Lemma subs_ext_type :
  forall {Δ₁ Δ₂ : nat} (σ : Fin.t Δ₁ -> type Δ₂)
    (τ : type (S Δ₁)) (τ' : type Δ₁),
    (subs_type (exts_type σ) τ `[[subs_type σ τ']])%ty
    = subs_type σ (τ `[[ τ']])%ty.
Proof.
  unfold "_ `[[ _ ]]".
  intros Δ₁ Δ₂ σ τ τ'.
  pose proof
       mapply_exts_type_subs_mapply_ext_type
       0 τ τ' σ as h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₁) (x:=plus_n_Sm 0 Δ₁) in h.
  rewrite Eqdep_dec.UIP_refl_nat
    with (n:=S Δ₂) (x:=plus_n_Sm 0 Δ₂) in h; cbn in h.
  rewrite mapply_exts_type_equation_2 in h.
  do 3 rewrite mapply_exts_type_equation_1 in h.
  do 2 rewrite eq_rect_zwei_equation_1 in h.
  assumption.
Defined.

Equations subs_type_term
  : forall {Δ₁ Δ₂ : nat} {Γ : list (type Δ₁)} {τ : type Δ₁}
      (σ : Fin.t Δ₁ -> type Δ₂),
    Γ ⊢ τ -> map (subs_type σ) Γ ⊢ subs_type σ τ :=
  subs_type_term σ (Id _ _ h) := Id _ _ (has_map (subs_type σ) h);
  subs_type_term σ (`λ t)%term := (`λ subs_type_term σ t)%term;
  subs_type_term σ (t₁ ⋅ t₂)%term
  := (subs_type_term σ t₁ ⋅ subs_type_term σ t₂)%term;
  subs_type_term (Δ₁:=Δ₁) (Δ₂:=Δ₂) σ (TypAbs Γ τ t)%term
  := let t' := subs_type_term (exts_type σ) t in
     (Λ
        eq_rect
        _ (fun Γ => Γ ⊢ subs_type (exts_type σ) τ) t' _ _)%term;
  subs_type_term (Δ₁:=Δ₁) (Δ₂:=Δ₂) σ (TypApp Γ τ τ' t)%term
  := let t' := subs_type_term σ t in
    eq_rect
      _ (fun τ => map (subs_type σ) Γ ⊢ τ)
      (t' ⦗subs_type σ τ'⦘)%term _ _.
Next Obligation. apply map_subs_rename_type. Defined.
Next Obligation.
  enough
    ((subs_type (exts_type σ) τ `[[subs_type σ τ']])%ty
     = subs_type σ (τ `[[ τ']])%ty); auto.
  apply subs_ext_type.
Defined.

Print Assumptions subs_type_term.

Definition sub_type_term
           {Δ : nat} {Γ : list (type Δ)} {τ : type (S Δ)}
           (body : map (rename_type Fin.FS) Γ ⊢ τ) (τ' : type Δ)
  : Γ ⊢ (τ `[[τ']])%ty :=
  eq_rect
    _ (fun Γ => Γ ⊢ τ `[[ τ' ]]%ty)
    (subs_type_term (sub_type_helper τ') body) _
    (map_subs_type_rename_type_idem τ' Γ).

Print Assumptions sub_type_term.

Notation "x '[[`' y ']]'"
  := (sub_type_term x y) (at level 38, left associativity) : term_scope.

Reserved Notation "x '-->' y" (at level 80, no associativity).

Inductive bred {Δ : nat} {Γ : list (type Δ)}
  : forall {τ : type Δ}, Γ ⊢ τ -> Γ ⊢ τ -> Prop :=
| bred_bred (τ τ' : type Δ) (t : τ :: Γ ⊢ τ') (t' : Γ ⊢ τ) :
  ((`λ t) ⋅ t')%term -->  (t [[ t' ]])%term
| bred_abs (τ τ' : type Δ) (t t' : τ :: Γ ⊢ τ') :
  t -->  t' ->
  (`λ t)%term --> (`λ t')%term
| bred_app_1 (τ τ' : type Δ) (t₁ t₁' : Γ ⊢ (τ → τ')%ty) (t₂ : Γ ⊢ τ) :
  t₁ --> t₁' ->
  (t₁ ⋅ t₂)%term --> (t₁' ⋅ t₂)%term
| bred_app_2 (τ τ' : type Δ) (t₁ : Γ ⊢ (τ → τ')%ty) (t₂ t₂' : Γ ⊢ τ) :
  t₂ --> t₂' ->
  (t₁ ⋅ t₂)%term --> (t₁ ⋅ t₂')%term
| bred_typ_abs (τ : type (S Δ)) (t t' : map (rename_type Fin.FS) Γ ⊢ τ) :
  t -->  t' ->
  (Λ t)%term --> (Λ t')%term
| bred_typ_app_inner (τ : type (S Δ)) (τ' : type Δ) (t t' : Γ ⊢ (∀ τ)%ty) :
  t -->  t' ->
  (t ⦗τ'⦘)%term -->  (t' ⦗τ'⦘)%term
| bred_typ_app (τ : type (S Δ)) (τ' : type Δ)
               (t : map (rename_type Fin.FS) Γ ⊢ τ) :
  ((Λ t) ⦗τ'⦘)%term -->  (t [[` τ']])%term
where "x '-->' y" := (bred x y).

Print Assumptions bred.

Derive Signature for bred.

Variant value {Δ : nat} {Γ : list (type Δ)}
  : forall {τ : type Δ}, Γ ⊢ τ -> Prop :=
  | Abs_value (τ τ' : type Δ) (t : τ :: Γ ⊢ τ') :
    value (`λ t)%term
  | TypAbs_value (τ : type (S Δ))
                 (t : map (rename_type Fin.FS) Γ ⊢ τ) :
    value (Λ t)%term.

Derive Signature for value.

Lemma canonical_abs :
  forall {Δ : nat} {τ τ' : type Δ} (t : [] ⊢ (τ → τ')%ty),
    value t ->
    exists body : [τ] ⊢ τ', t = (`λ body)%term.
Proof.
  intros Δ τ τ' t v; depelim v; eauto.
Qed.

Print Assumptions canonical_abs.

Lemma canonical_typabs :
  forall {Δ : nat} {Γ : list (type Δ)}
    {τ : type (S Δ)} (t : Γ ⊢ (∀ τ)%ty),
    value t ->
    exists body, t = (Λ body)%term.
Proof.
  intros Δ Γ τ t v; depelim v; eauto.
Qed.

Local Hint Constructors bred : core.
Local Hint Constructors value : core.

Theorem Progress :
  forall {Δ : nat} {τ : type Δ} (t : [] ⊢ τ),
    value t \/ exists t', t -->  t'.
Proof.
  intros Δ τ t; depind t; auto.
  - inv h.
  - right.
    destruct IHt1 as [v1 | (t1' & ih1)]; eauto.
    pose proof canonical_abs t1 v1
      as [t1' t1'eq]; subst; eauto.
  - right.
    destruct IHt as [v | (t' & ih)]; eauto.
    pose proof canonical_typabs t v
      as [t' t'eq]; subst; eauto.
Qed.

Print Assumptions Progress.


(** * PHOAS Representation of Gallina *)
Require Import Coq.Strings.String Coq.Classes.RelationClasses.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Notations.

(** We parameterize the language over a type of basic type codes (for
    things like [Z], [word], [bool]), as well as a type of n-ary
    operations returning one value, and n-ary operations returning two
    values. *)
Delimit Scope ctype_scope with ctype.
Local Open Scope ctype_scope.
Delimit Scope expr_scope with expr.
Local Open Scope expr_scope.
Section language.
  Context (base_type_code : Type).

  Inductive flat_type := Tbase (_ : base_type_code) | Prod (x y : flat_type).
  Bind Scope ctype_scope with flat_type.

  Inductive type := Tflat (_ : flat_type) | Arrow (x : base_type_code) (y : type).
  Bind Scope ctype_scope with type.

  Global Coercion Tflat : flat_type >-> type.
  Infix "*" := Prod : ctype_scope.
  Notation "A -> B" := (Arrow A B) : ctype_scope.
  Local Coercion Tbase : base_type_code >-> flat_type.

  Section interp.
    Section type.
      Context (interp_flat_type : flat_type -> Type).
      Fixpoint interp_type_gen (t : type) :=
        match t with
        | Tflat t => interp_flat_type t
        | Arrow x y => (interp_flat_type x -> interp_type_gen y)%type
        end.
      Section rel.
        Context (R : forall t, interp_flat_type t -> interp_flat_type t -> Prop).
        Fixpoint interp_type_gen_rel_pointwise (t : type)
          : interp_type_gen t -> interp_type_gen t -> Prop :=
          match t with
          | Tflat t => R t
          | Arrow _ y => fun f g => forall x, interp_type_gen_rel_pointwise y (f x) (g x)
          end.
        Global Instance interp_type_gen_rel_pointwise_Reflexive {H : forall t, Reflexive (R t)}
          : forall t, Reflexive (interp_type_gen_rel_pointwise t).
        Proof. induction t; repeat intro; reflexivity. Qed.
        Global Instance interp_type_gen_rel_pointwise_Symmetric {H : forall t, Symmetric (R t)}
          : forall t, Symmetric (interp_type_gen_rel_pointwise t).
        Proof. induction t; simpl; repeat intro; symmetry; eauto. Qed.
        Global Instance interp_type_gen_rel_pointwise_Transitive {H : forall t, Transitive (R t)}
          : forall t, Transitive (interp_type_gen_rel_pointwise t).
        Proof. induction t; simpl; repeat intro; etransitivity; eauto. Qed.
      End rel.
    End type.
    Section flat_type.
      Context (interp_base_type : base_type_code -> Type).
      Fixpoint interp_flat_type_gen (t : flat_type) :=
        match t with
        | Tbase t => interp_base_type t
        | Prod x y => prod (interp_flat_type_gen x) (interp_flat_type_gen y)
        end.
      Definition interp_type := interp_type_gen interp_flat_type_gen.
      Section rel.
        Context (R : forall t, interp_base_type t -> interp_base_type t -> Prop).
        Fixpoint interp_flat_type_gen_rel_pointwise (t : flat_type)
          : interp_flat_type_gen t -> interp_flat_type_gen t -> Prop :=
          match t with
          | Tbase t => R t
          | Prod _ _ => fun x y => interp_flat_type_gen_rel_pointwise _ (fst x) (fst y)
                               /\ interp_flat_type_gen_rel_pointwise _ (snd x) (snd y)
          end.
      End rel.
    End flat_type.
  End interp.

  Section expr_param.
    Context (interp_base_type : base_type_code -> Type).
    Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type).
    Local Notation interp_type := (interp_type interp_base_type).
    Local Notation interp_flat_type := (interp_flat_type_gen interp_base_type).
    Section expr.
      Context {var : base_type_code -> Type}.

      (** N.B. [Let] binds the components of a pair to separate variables, and does so recursively *)
      Inductive exprf : flat_type -> Type :=
      | Const {t : flat_type} : interp_type t -> exprf t
      | Var {t} : var t -> exprf t
      | Op {t1 tR} : op t1 tR -> exprf t1 -> exprf tR
      | LetIn : forall {tx}, exprf tx -> forall {tC}, (interp_flat_type_gen var tx -> exprf tC) -> exprf tC
      | Pair : forall {t1}, exprf t1 -> forall {t2}, exprf t2 -> exprf (Prod t1 t2).
      Bind Scope expr_scope with exprf.
      Inductive expr : type -> Type :=
      | Return {t} : exprf t -> expr t
      | Abs {src dst} : (var src -> expr dst) -> expr (Arrow src dst).
      Bind Scope expr_scope with expr.
      Global Coercion Return : exprf >-> expr.
      (** Sometimes, we want to deal with partially-interpreted
          expressions, things like [prod (exprf A) (exprf B)] rather
          than [exprf (Prod A B)], or like [prod (var A) (var B)] when
          we start with the type [Prod A B].  These convenience
          functions let us recurse on the type in only one place, and
          replace one kind of pairing operator (be it [pair] or [Pair]
          or anything else) with another kind, and simultaneously
          mapping a function over the base values (e.g., [Var] (for
          turning [var] into [exprf]) or [Const] (for turning
          [interp_base_type] into [exprf])). *)
      Fixpoint smart_interp_flat_map {f g}
               (h : forall x, f x -> g (Tbase x))
               (pair : forall A B, g A -> g B -> g (Prod A B))
               {t}
        : interp_flat_type_gen f t -> g t
        := match t return interp_flat_type_gen f t -> g t with
           | Tbase _ => h _
           | Prod A B => fun v => pair _ _
                                       (@smart_interp_flat_map f g h pair A (fst v))
                                       (@smart_interp_flat_map f g h pair B (snd v))
           end.
      Fixpoint SmartVal {T} (val : forall t : base_type_code, T t) t : interp_flat_type_gen T t
        := match t return interp_flat_type_gen T t with
           | Tbase _ => val _
           | Prod A B => (@SmartVal T val A, @SmartVal T val B)
           end.

      (** [SmartVar] is like [Var], except that it inserts
          pair-projections and [Pair] as necessary to handle
          [flat_type], and not just [base_type_code] *)
      Definition SmartVar {t} : interp_flat_type_gen var t -> exprf t
        := @smart_interp_flat_map var exprf (fun t => Var) (fun A B x y => Pair x y) t.
      Definition SmartVarMap {var var'} (f : forall t, var t -> var' t) {t}
        : interp_flat_type_gen var t -> interp_flat_type_gen var' t
        := @smart_interp_flat_map var (interp_flat_type_gen var') f (fun A B x y => pair x y) t.
      Definition SmartVarVar {t} : interp_flat_type_gen var t -> interp_flat_type_gen exprf t
        := SmartVarMap (fun t => Var).
      Definition SmartConst {t} : interp_flat_type t -> interp_flat_type_gen exprf t
        := SmartVarMap (fun t => Const (t:=t)).
    End expr.

    Definition Expr (t : type) := forall var, @expr var t.

    Section interp.
      Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst).

      Fixpoint interpf {t} (e : @exprf interp_flat_type t) : interp_flat_type t
        := match e in exprf t return interp_flat_type t with
           | Const _ x => x
           | Var _ x => x
           | Op _ _ op args => @interp_op _ _ op (@interpf _ args)
           | LetIn _ ex _ eC => let x := @interpf _ ex in @interpf _ (eC x)
           | Pair _ ex _ ey => (@interpf _ ex, @interpf _ ey)
           end.
      Fixpoint interp {t} (e : @expr interp_type t) : interp_type t
        := match e in expr t return interp_type t with
           | Return _ x => interpf x
           | Abs _ _ f => fun x => @interp _ (f x)
           end.

      Definition Interp {t} (E : Expr t) : interp_type t := interp (E _).
    End interp.

    Section map.
      Context {var1 var2 : base_type_code -> Type}.
      Context (fvar12 : forall t, var1 t -> var2 t)
              (fvar21 : forall t, var2 t -> var1 t).

      Fixpoint mapf_interp_flat_type_gen {t} (e : interp_flat_type_gen var2 t) {struct t}
        : interp_flat_type_gen var1 t
        := match t return interp_flat_type_gen _ t -> interp_flat_type_gen _ t with
           | Tbase _ => fvar21 _
           | Prod x y => fun xy => (@mapf_interp_flat_type_gen _ (fst xy),
                                    @mapf_interp_flat_type_gen _ (snd xy))
           end e.

      Fixpoint mapf {t} (e : @exprf var1 t) : @exprf var2 t
        := match e in exprf t return exprf t with
           | Const _ x => Const x
           | Var _ x => Var (fvar12 _ x)
           | Op _ _ op args => Op op (@mapf _ args)
           | LetIn _ ex _ eC => LetIn (@mapf _ ex) (fun x => @mapf _ (eC (mapf_interp_flat_type_gen x)))
           | Pair _ ex _ ey => Pair (@mapf _ ex) (@mapf _ ey)
           end.
    End map.

    Section misc.
      Definition invert_Const {var t} (e : @exprf var t) : option (interp_type t)
        := match e with
           | Const _ v => Some v
           | _ => None
           end.
    End misc.

    Section wf.
      Context {var1 var2 : base_type_code -> Type}.

      Local Notation eP := (fun t => var1 t * var2 t)%type (only parsing).
      Local Notation "x == y" := (existT eP _ (x, y)).
      Fixpoint flatten_binding_list {t} (x : interp_flat_type_gen var1 t) (y : interp_flat_type_gen var2 t) : list (sigT eP)
        := (match t return interp_flat_type_gen var1 t -> interp_flat_type_gen var2 t -> list _ with
            | Tbase _ => fun x y => (x == y) :: nil
            | Prod t0 t1 => fun x y => @flatten_binding_list _ (snd x) (snd y) ++ @flatten_binding_list _ (fst x) (fst y)
            end x y)%list.

      Inductive wff : list (sigT eP) -> forall {t}, @exprf var1 t -> @exprf var2 t -> Prop :=
      | WfConst : forall t G n, @wff G t (Const n) (Const n)
      | WfVar : forall G (t : base_type_code) x x', List.In (x == x') G -> @wff G t (Var x) (Var x')
      | WfOp : forall G {t} {tR} (e : @exprf var1 t) (e' : @exprf var2 t) op,
          wff G e e'
          -> wff G (Op (tR := tR) op e) (Op (tR := tR) op e')
      | WfLetIn : forall G t1 t2 e1 e1' (e2 : interp_flat_type_gen var1 t1 -> @exprf var1 t2) e2',
          wff G e1 e1'
          -> (forall x1 x2, wff (flatten_binding_list x1 x2 ++ G) (e2 x1) (e2' x2))
          -> wff G (LetIn e1 e2) (LetIn e1' e2')
      | WfPair : forall G {t1} {t2} (e1: @exprf var1 t1) (e2: @exprf var1 t2)
                        (e1': @exprf var2 t1) (e2': @exprf var2 t2),
          wff G e1 e1'
          -> wff G e2 e2'
          -> wff G (Pair e1 e2) (Pair e1' e2').
      Inductive wf : list (sigT eP) -> forall {t}, @expr var1 t -> @expr var2 t -> Prop :=
      | WfReturn : forall t G e e', @wff G t e e' -> wf G (Return e) (Return e')
      | WfAbs : forall A B G e e',
          (forall x x', @wf ((x == x') :: G) B (e x) (e' x'))
          -> @wf G (Arrow A B) (Abs e) (Abs e').
    End wf.

    Definition Wf {t} (E : @Expr t) := forall var1 var2, wf nil (E var1) (E var2).

    Axiom Wf_admitted : forall {t} (E:Expr t), @Wf t E.
  End expr_param.
End language.
Global Arguments Prod {_} _ _.
Global Arguments Arrow {_} _ _.
Global Arguments Tbase {_} _.
Infix "*" := (@Prod _) : ctype_scope.
Notation "A -> B" := (@Arrow _ A B) : ctype_scope.

Ltac admit_Wf := apply Wf_admitted.

Global Arguments Const {_ _ _ _ _} _.
Global Arguments Var {_ _ _ _ _} _.
Global Arguments SmartVar {_ _ _ _ _} _.
Global Arguments SmartVal {_} T _ t.
Global Arguments SmartVarVar {_ _ _ _ _} _.
Global Arguments SmartVarMap {_ _ _} _ {_} _.
Global Arguments SmartConst {_ _ _ _ _} _.
Global Arguments Op {_ _ _ _ _ _} _ _.
Global Arguments LetIn {_ _ _ _ _} _ {_} _.
Global Arguments Pair {_ _ _ _ _} _ {_} _.
Global Arguments Return {_ _ _ _ _} _.
Global Arguments Abs {_ _ _ _ _ _} _.
Global Arguments interp_type_gen {_} _ _.
Global Arguments interp_flat_type_gen {_} _ _.
Global Arguments interp_type_gen_rel_pointwise {_} _ _ {_} _ _.
Global Arguments interp_flat_type_gen_rel_pointwise {_} _ _ {_} _ _.
Global Arguments interp_type {_} _ _.
Global Arguments wff {_ _ _ _ _} G {t} _ _.
Global Arguments wf {_ _ _ _ _} G {t} _ _.
Global Arguments Wf {_ _ _ t} _.
Global Arguments Interp {_ _ _} interp_op {t} _.
Global Arguments interp {_ _ _} interp_op {t} _.
Global Arguments interpf {_ _ _} interp_op {t} _.
Global Arguments invert_Const {_ _ _ _ _} _.

Notation "'slet' x := A 'in' b" := (LetIn A (fun x => b)) : expr_scope.
Notation "'λ'  x .. y , t" := (Abs (fun x => .. (Abs (fun y => t%expr)) ..)) : expr_scope.
Notation "( x , y , .. , z )" := (Pair .. (Pair x%expr y%expr) .. z%expr) : expr_scope.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export TypingInfoSigDef.

Set Implicit Arguments.

Module Type TypingInfoProofsSig.
  Include TypingInfoSig.
 Axiom beq_t_refl:  forall a,     beq_t a a = true.
 Hint Resolve beq_t_refl.
 Axiom beq_t_sym:   forall a b,   beq_t a b = beq_t b a.
 Hint Immediate beq_t_sym.
 Axiom beq_t_trans: forall a b c, beq_t a b = true -> beq_t b c = true -> beq_t a c = true.
 Hint Resolve beq_t_trans.
 Axiom beq_t_eq:    forall a b, beq_t a b = true -> a = b.
 Hint Resolve beq_t_eq.
 Axiom beq_t_neq:   forall a b, beq_t a b = false -> a <> b.
 Hint Resolve beq_t_neq.
End TypingInfoProofsSig.


Require Export SystemFR.TypedEquality.
Require Export SystemFR.ErasedArrow.

Opaque T_equivalent_at.
Opaque reducible_values.

Lemma fun_apply:
  forall ρ A B f1 f2 a1 a2,
    valid_interpretation ρ ->
    wf A 0 ->
    wf B 0 ->
    twf B 0 ->
    pfv A term_var = nil ->
    pfv B term_var = nil ->
    [ ρ ⊨ a1 ≡ a2 : A ] ->
    [ ρ ⊨ f1 ≡ f2 : T_arrow A B ] ->
    [ ρ ⊨ app f1 a1 ≡ app f2 a2 : B ].
Proof.
  unfold equivalent_at; steps;
    eauto using reducible_app2, reducible_value_expr.

  unshelve epose proof (H11 (notype_lambda (app f (app (lvar 0 term_var) a1))) _ _ _ _);
    repeat step || apply reducible_lambda || list_utils ||
           (rewrite open_none in * by t_closer);
    t_closer.

  - apply reducible_app2 with B;
      repeat step;
      eauto using reducible_value_expr with step_tactic;
      eauto using reducible_app2, reducible_value_expr.

  - eapply equivalent_square; eauto.
    + eapply equivalent_trans.
      * unfold reduces_to in H5; steps.
        apply equivalent_beta with v; steps; t_closer.
      * repeat step || rewrite open_none in * by t_closer.
        apply equivalent_refl; repeat step || list_utils; eauto with wf erased fv.
    + eapply equivalent_trans.
      * unfold reduces_to in H8; steps.
        apply equivalent_beta with v; steps; t_closer.
      * repeat step || rewrite open_none in * by t_closer.

        unshelve epose proof (H10 (notype_lambda (app f (app f2 (lvar 0 term_var))))
                                 _ _ _ _);
          repeat step || apply reducible_lambda || (rewrite open_none in * by t_closer);
          t_closer;
          try finisher.

        -- apply reducible_app2 with B;
             repeat step;
             eauto using reducible_value_expr with step_tactic;
             eauto using reducible_app2, reducible_value_expr.

        -- apply (equivalent_square _ _ _ _ H16); eauto.
          ++ eapply equivalent_trans.
            ** unfold reduces_to in *; repeat step.
               eapply equivalent_beta; eauto;
                 repeat step || list_utils;
                 try solve [ t_closer ].
            ** repeat step || (rewrite open_none in * by t_closer).
               apply equivalent_refl; steps; t_closer.
          ++ eapply equivalent_trans.
            ** unfold reduces_to in *; repeat step.
               eapply equivalent_beta; eauto;
                 repeat step || list_utils;
                 try solve [ t_closer ].
            ** repeat step || (rewrite open_none in * by t_closer).
               apply equivalent_refl; steps; t_closer.
Qed.

Lemma open_equivalent_fun_apply:
  forall Θ Γ A B a1 a2 f1 f2 p p',
    wf A 0 ->
    wf B 0 ->
    twf A 0 ->
    twf B 0 ->
    subset (fv A) (support Γ) ->
    subset (fv B) (support Γ) ->
    is_erased_type A ->
    is_erased_type B ->
    is_erased_term a1 ->
    is_erased_term a2 ->
    is_erased_term f1 ->
    is_erased_term f2 ->
    wf a1 0 ->
    wf a2 0 ->
    wf f1 0 ->
    wf f2 0 ->
    pfv a1 term_var = nil ->
    pfv a2 term_var = nil ->
    pfv f1 term_var = nil ->
    pfv f2 term_var = nil ->
    [ Θ; Γ ⊨ p : T_equivalent_at (T_arrow A B) f1 f2 ] ->
    [ Θ; Γ ⊨ p': T_equivalent_at A a1 a2 ] ->
    [ Θ; Γ ⊨ uu: T_equivalent_at B (app f1 a1) (app f2 a2) ].
Proof.
  unfold open_reducible;
    repeat step || t_instantiate_sat3 || rewrite subst_equivalent_at in *.

  apply_anywhere equivalent_at_type_prop2;
    repeat step;
    t_closer.

  apply_anywhere equivalent_at_type_prop2;
    repeat step;
    t_closer.

  apply reducible_value_expr; steps.
  apply equivalent_at_prop_type;
    repeat step;
    t_closer.

  apply fun_apply with (psubstitute A lterms term_var); eauto;
    repeat step;
    t_closer.
Qed.

Lemma open_equivalent_at_equivalent:
  forall Θ Γ t1 t2 A,
    is_erased_type A ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf A 0 ->
    wf t1 0 ->
    wf t2 0 ->
    twf A 0 ->
    [ Θ; Γ ⊨ t1 : A ] ->
    [ Θ; Γ ⊨ t2 : A ] ->
    [ Θ; Γ ⊨ t1 ≡ t2 ] ->
    [ Θ; Γ ⊨ uu: T_equivalent_at A t1 t2 ].
Proof.
  unfold open_reducible, open_equivalent;
    repeat step || t_instantiate_sat3 || rewrite subst_equivalent_at ||
           apply reducible_value_expr ||
           apply equivalent_app ||
           apply equivalent_at_prop_type || unfold equivalent_at;
    try solve [ t_closer ];
    try solve [ apply equivalent_refl; auto ].
Qed.

(*
Lemma fun_ext:
  forall ρ A B f1 f2,
    valid_interpretation ρ ->
    [ ρ ⊨ f1 : T_arrow A B ] ->
    [ ρ ⊨ f2 : T_arrow A B ] ->
    (forall a,
      equivalent_at ρ B (app f1 a) (app f2 a)) ->
    equivalent_at ρ (T_arrow A B) f1 f2.
Proof.
  intros; unfold equivalent_at; steps.
Admitted.

Lemma open_reducible_fun_ext:
  forall Θ Γ A B f1 f2 p x,
    [ Θ; Γ ⊨ f1 : T_arrow A B ] ->
    [ Θ; Γ ⊨ f2 : T_arrow A B ] ->
    [ Θ; (x, A) :: Γ ⊨ p: T_equivalent_at B
                                   (app f1 (fvar x term_var))
                                   (app f2 (fvar x term_var)) ] ->
    [ Θ; Γ ⊨ uu: T_equivalent_at (T_arrow A B) f1 f2 ].
Proof.
Admitted.
*)


(* Paolo Torrini, with Mohamed Sami Cherif
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* verification of the initVAddrTable invariant, syntax directed version *)

Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega Bool Coq.Logic.ProofIrrelevance.
Require Import Coq.Lists.List.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import IdModPip.
Require Import DetermA.
Require Import AbbrevA.
Require Import HoareA.
Require Import THoareA.
Require Import Lib.
Require Import Pip_state.
Require Import Pip_stateLib.
Require Import Coq.Structures.Equalities.
Require Import Coq.Logic.Eqdep.
Require Import Hoare_getFstShadow.
Require Import Hoare_writeVirtualInv.
Require Import Hoare_initVAddrTable.
Require Import Pip_DependentTypeLemmas.
Require Import Pip_InternalLemmas.
Require Import Pip_Prop.
Import ListNotations.

Module Hoare_Test_SndShadow_SynDir.

Module SndShadowI := Hoare_Test_SndShadow.
Export SndShadowI.

(**************************************************)

Definition initVAddrTableFun (fenv: funEnv)
           (p:page) (n: nat) : Fun :=
        FC fenv
           [("x",Index)]
           (Val (cst unit tt))
           (initVAddrTableAux "initVAddrTable" "x" p)
           "initVAddrTable"
           n.

Lemma initVAddrTableFun_FunTyping (ftenv: funTC) (fenv: funEnv)
      (k: MatchEnvsT FunTyping fenv ftenv)
      (p:page) (n: nat) :
  FunTyping (initVAddrTableFun fenv p n) (FT [("x",Index)] Unit).
  induction n.
  econstructor.
  exact k.
  econstructor.
  econstructor.
  reflexivity.
  econstructor.

  econstructor.
  exact k.
  unfold initVAddrTableAux at 2.

  econstructor.
  unfold WriteVirtual'.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  simpl.
  reflexivity.

  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.

  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  reflexivity.

  econstructor.
  econstructor.
  repeat econstructor.

  econstructor.
  reflexivity.
  econstructor.
  assumption.
  assumption.

  econstructor.
  econstructor.
  econstructor.
  econstructor.

  repeat econstructor.
  econstructor.
  econstructor.
  econstructor.
  repeat econstructor.

  econstructor.
  econstructor.
  econstructor.
  simpl.
  reflexivity.

  econstructor.
  econstructor.
  repeat econstructor.
  econstructor.

  reflexivity.
  econstructor.
  assumption.
  assumption.
  econstructor.
  econstructor.
  eassumption.
  instantiate (1:=nil).
  instantiate (1:=nil).
  econstructor.
  exact k.
  simpl.
  auto.
  simpl.
  reflexivity.
  simpl.
  reflexivity.

  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  econstructor.
  simpl.
  reflexivity.
  econstructor.
  econstructor.
  repeat econstructor.
  assumption.
Qed.

Definition initVAddrTableR (p:page) (i:index) : Exp :=
Apply
  (QF (initVAddrTableFun nil p tableSize))
  (PS[Val (cst index i)]).

(******* Useful Lemmas *)

Lemma succDWp2 (x:Id) P (fenv: funEnv) (env: valEnv) :
  forall (idx:index), {{fun s => P s  /\ idx < tableSize - 1}}
                        fenv >> (x,(cst index idx))::env >> SuccD x
  {{fun (idxsuc : Value) (s : state) => P s  /\ idx < tableSize - 1
                /\ idxsuc = cst (option index) (succIndexInternal idx)
                /\ exists i, idxsuc = cst (option index) (Some i)}}.
Proof.
intros.
eapply weakenEval.
eapply succDW.
intros.
simpl.
split.
instantiate (1:=idx).
intuition.
intros.
intuition.
destruct idx.
exists (CIndex (i + 1)).
f_equal.
unfold succIndexInternal.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
Qed.

Lemma init_aux1 (table : page)
  (curidx : index)
  (fenv : funEnv)
  (env : valEnv)
  (H : tableSize + curidx >= tableSize) :
  {{fun s : DynamicI.W =>
    forall idx : index,
    idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr
  }}' fenv >> env >> PS [Val (cst index curidx)]
  {{fun (vs : list Value) (s : DynamicI.W) =>
    (forall idx : index,
     idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    vs = [cst index curidx] }}'.

unfold THoarePrmsTriple_Eval.
intros.
inversion X;subst.
destruct vs; inversion H6.
destruct vs ; inversion H3 ; subst.
intuition.
inversion X0;subst.
inversion X2.
inversion X2.
Qed.

Lemma init_aux01 (table : page)
  (curidx : index)
  (fenv : funEnv)
  (env : valEnv)
  (idx : index) :
  {{fun s : DynamicI.W =>
    idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr
  }}' fenv >> env >> PS [Val (cst index curidx)]
  {{fun (vs : list Value) (s : DynamicI.W) =>
    (
     idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    vs = [cst index curidx] }}'.

unfold THoarePrmsTriple_Eval.
intros.
inversion X; subst.
destruct vs; inversion H5.
destruct vs ; inversion H2 ; subst.
intuition.
inversion X0;subst.
inversion X2.
inversion X2.
Qed.

Lemma init_aux2 (idx: index) :
  idx < CIndex (tableSize - 1) \/ idx = CIndex (tableSize - 1).
      destruct idx. simpl in *.
      unfold CIndex.
      case_eq (lt_dec (tableSize - 1) tableSize).
      intros. simpl in *.
      assert (i <= tableSize -1).
      omega.
      apply NPeano.Nat.le_lteq in H0.
      destruct H0.
      left. assumption. right.
      subst.
      assert (Hi =  Pip_state.CIndex_obligation_1 (tableSize - 1) l).
      apply proof_irrelevance.
      subst. reflexivity.
      intros.
      intuition.
Qed.

Lemma init_aux3 (* for the 'false case' *)
 (table : page)
 (curidx : index)
 (fenv : funEnv)
 (env : valEnv)
 (e : Exp)
 (k0 : curidx >= 0)
 (k1 : curidx = CIndex (tableSize - 1)) :
  {{fun s : DynamicI.W =>
    (forall idx : index,
     idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr)
     /\ readVirtual table curidx (memory s) = Some defaultVAddr
  }}
    fenv >> env >> Val (cst unit tt)
  {{fun (_ : Value) (s : DynamicI.W) =>
      forall idx : index, readVirtual table idx (memory s) = Some defaultVAddr
  }}.
intros.
unfold THoareTriple_Eval.
intros.
simpl in *.
assert (idx < CIndex (tableSize - 1) \/ idx = CIndex (tableSize - 1)).
eapply init_aux2.
simpl in *.
inversion X; subst.
Focus 2.
inversion X0.
destruct H.
destruct H0.
eapply H.
exact H0.
subst.
exact H1.
Qed.

Lemma init_aux5 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv) :
  {{fun s : DynamicI.W =>
    idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr}}
  fenv >>
  [("x", cst index curidx)] >> WriteVirtual' table "x" defaultVAddr
  {{fun (_ : Value) (s : state) =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr}}.
unfold WriteVirtual'.
eapply Modify_VHTT3 with (fenv:= fenv)
                         (env:=[("x", cst index curidx)])
                         (XF:=(xf_writeVirtual' table defaultVAddr))
                         (x:="x").
Unshelve.
Focus 3.
exact curidx.
intros.
simpl.
split.
intros.

unfold readVirtual.
unfold add.
simpl.
assert (Hfalse :
    Lib.beqPairs (table, curidx) (table, idx) beqPage beqIndex = false).
    { apply beqPairsFalse.
      right.
      apply indexDiffLtb.
      right; assumption. }
rewrite Hfalse at 1.
assert (lookup table idx (Lib.removeDup table curidx (memory s)
                                            beqPage beqIndex)
               beqPage beqIndex =
        Lib.lookup  table idx  (memory s) beqPage beqIndex) as Hmemory.
    { apply removeDupIdentity.
      right.
      apply indexDiffLtb.
      left; trivial. }
rewrite Hmemory.
apply H in H0.
unfold readVirtual in *.
auto.

unfold writeVirtualInternal.
simpl.
unfold readVirtual.
unfold add.
simpl.
assert (Htrue : Lib.beqPairs (table, curidx) (table, curidx)
                             beqPage beqIndex = true).
    { apply beqPairsTrue.
      intuition. }
rewrite Htrue.
auto.
reflexivity.
Qed.

Lemma init_aux6 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv) :
  {{fun s : state =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr}}
  fenv >>
  [("x", cst index curidx)] >> LtLtb "x" maxIndex
  {{fun (b : Value) (s : DynamicI.W) =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    b = cst bool (Index.ltb curidx maxIndex)}}.
unfold LtLtb.
eapply Modify_VHTT3 with (fenv:= fenv)
                         (env:=[("x", cst index curidx)])
                         (XF:=(xf_Ltb maxIndex))
                         (x:="x").

Unshelve.
Focus 3.
exact curidx.

intros.
destruct H.
split.
intuition.
intuition.
reflexivity.
Qed.

Lemma init_aux7 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv) :
  {{fun s : DynamicI.W =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    cst bool true = cst bool (Index.ltb curidx maxIndex)}}
 fenv >> [("x", cst index curidx)] >> SuccD "x"
  {{(fun (idxsuc : Value) (s : state) =>
    (fun s0 : DynamicI.W =>
     (fun s' : state =>
      (idx < curidx -> readVirtual table idx (memory s') = Some defaultVAddr) /\
      readVirtual table curidx (memory s0) = Some defaultVAddr) s0) s /\
    curidx < tableSize - 1 /\
    idxsuc = cst (option index) (succIndexInternal curidx) /\
    (exists i : index, idxsuc = cst (option index) (Some i)))}}.
eapply weakenEval.
eapply succDWp2.
simpl;intros; intuition.

unfold maxIndex in H2.
inversion H2.
apply inj_pair2 in H3.
symmetry in H3.
apply indexltbTrue in H3.
unfold CIndex in H3.
destruct (lt_dec (tableSize - 1) tableSize).
simpl in *.
assumption.
contradict n.
assert (tableSize > tableSizeLowerBound).
apply tableSizeBigEnough.
unfold tableSizeLowerBound in *.
omega.
Qed.

Lemma init_aux8 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv)
  (v : Value) :
  {{fun s : state =>
    ((idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
     readVirtual table curidx (memory s) = Some defaultVAddr) /\
    curidx < tableSize - 1 /\
    v = cst (option index) (succIndexInternal curidx) /\
    (exists i : index, v = cst (option index) (Some i))}}
   fenv >>
  [("idx", v);
  ("x", cst index curidx)] >> ExtractIndex "idx"
  {{fun (v0 : Value) (s : DynamicI.W) =>
    (fun (v' : Value) (s0 : W) =>
     ((idx < curidx -> readVirtual table idx (memory s0) = Some defaultVAddr) /\
      readVirtual table curidx (memory s0) = Some defaultVAddr /\
      curidx < tableSize - 1) /\
     v' = cst index (match succIndexInternal curidx with | Some i => i
                                                 | None => index_d end)) v0 s}}.

eapply Hoare_env_subst with (fenv:=fun _ => fenv)
           (env:=fun v => [("idx", v); ("x", cst index curidx)])
           (v2:=cst (option index) (succIndexInternal curidx))
      (P2 := (fun s : state =>
    ((idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
     readVirtual table curidx (memory s) = Some defaultVAddr) /\
    curidx < tableSize - 1 /\
    (exists i : index,
        cst (option index) (succIndexInternal curidx) =
        cst (option index) (Some i)))).
intuition.
intuition.
subst.
assumption.

unfold ExtractIndex.

eapply Modify_VHTT3 with (fenv:= fenv)
       (env:= [("idx", cst (option index) (succIndexInternal curidx));
  ("x", cst index curidx)])
                         (XF:=(xf_ExtractIndex))
                         (x:="idx").

Unshelve.
Focus 3.
exact (succIndexInternal curidx).
intros.
destruct H.
destruct H.
destruct H0.
destruct H2.
inversion H2; subst.
repeat apply inj_pair2 in H4.
rewrite H4 in *.

unfold b_eval, b_exec, xf_ExtractIndex, b_mod in *.
simpl in *.

intuition.
reflexivity.
Qed.

Lemma init_aux9 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv)
  (env : valEnv) :
  {{fun s : DynamicI.W =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    cst bool false = cst bool (Index.ltb curidx maxIndex)}}
  fenv >>
  env >> Val (cst unit tt)
  {{fun (_ : Value) (s : DynamicI.W) =>
    readVirtual table idx (memory s) = Some defaultVAddr}}.

unfold THoareTriple_Eval.
intros.
intuition.
inversion X; subst.
Focus 2.
inversion X0.

clear X.
simpl in *.
inversion H2; subst.
repeat eapply inj_pair2 in H3.
symmetry in H3.
apply indexltbFalse in H3.
apply indexBoundEq in H3.

assert (idx < CIndex (tableSize - 1) \/ idx = CIndex (tableSize - 1)) as H4.
eapply init_aux2.
destruct H4.

subst.
eapply H0.
exact H1.

subst.
assumption.
Qed.

Lemma init_aux10 (table : page)
  (idx : index)
  (curidx : index)
  (fenv : funEnv) :
  {{fun s : DynamicI.W =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    curidx < tableSize - 1
  }}' fenv >>
  [("y",
   cst index
     match succIndexInternal curidx with
     | Some i => i
     | None => index_d
     end); ("x", cst index curidx)] >> PS [VLift (Var "y")]
  {{fun (vs : list Value) (s : DynamicI.W) =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    curidx < tableSize - 1 /\
    vs =
    [cst index
       match succIndexInternal curidx with
       | Some i => i
       | None => index_d
       end] }}'.

unfold VLift.
eapply Prms_VHTT1.

instantiate (1:=fun v s => (
    idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
   readVirtual table curidx (memory s) = Some defaultVAddr /\
   curidx < tableSize - 1 /\
   v =
   cst index
     match succIndexInternal curidx with
     | Some i => i
     | None => index_d
     end).
unfold THoareTriple_Eval.
intros.
assert ( EClosure
        fenv
        [("y",
         cst index
           match succIndexInternal curidx with
           | Some i => i
           | None => index_d
           end); ("x", cst index curidx)] (Conf Exp s (Return LL (Var "y")))
        (Conf Exp s (Val (cst index
           match succIndexInternal curidx with
           | Some i => i
           | None => index_d
           end))) ) as X2.
econstructor.
econstructor.
econstructor.
econstructor.
reflexivity.
econstructor.
econstructor.
econstructor.
assert ((s' = s) /\ (v = cst index
                  match succIndexInternal curidx with
                  | Some i => i
                  | None => index_d
                  end)).
eapply ExpConfluence.
exact k3.
exact k1.
eauto.
eauto.
eauto.
intuition; subst.
assumption.
assumption.

unfold THoarePrmsTriple_Eval;intros.
intuition.
inversion X; subst.
assumption.
inversion X0.
inversion X; subst.
assumption.
inversion X0.
inversion X; subst.
symmetry in H8.
eapply map_eq_nil in H8.
subst.
auto.
inversion X0.
Qed.

(******* Main Hoare Triple *)

Lemma initVAddrTableNewProperty'
      (table : page) (curidx : index)
      (fenv: funEnv) (env: valEnv) :
{{ fun s => forall idx : index, idx < curidx ->
                readVirtual table idx (memory s) = Some defaultVAddr }}
  fenv >> env >> initVAddrTableR table curidx
{{ fun _ s => forall idx,
                readVirtual table idx (memory s) = Some defaultVAddr }}.
Proof.

eapply THoare_gen.
intro idx.
unfold initVAddrTableR.
assert (tableSize + curidx >= tableSize) as H by omega.
revert fenv env H.
revert curidx.
generalize tableSize at 1 3.
induction n. simpl.
(** begin case n=0 *)
intros.
destruct curidx.
simpl in *.
omega.
(** env case n=0 *)
intros; simpl.
assert (curidx < tableSize) as k1.
destruct curidx.
intuition.
(* eapply Apply_VHTT1.*)
HoareTac1.
eapply init_aux01.

simpl in *.
split.
reflexivity.

intro vs.
unfold initVAddrTableAux.
eapply Hoare_val_eq_wk with (fenv:= fun _ => [("initVAddrTable",
                               FC [] [("x", Index)]
                                 (Val (cst unit tt))
                                 (initVAddrTableAux "initVAddrTable" "x" table)
                                 "initVAddrTable" n)])
                         (env:= mkVEnv [("x", Index)]).
clear vs.
unfold mkVEnv.
simpl.

eapply BindN_VHTT1 with (P1:= fun s => (
     idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
     readVirtual table curidx s.(memory) = Some defaultVAddr).

eapply init_aux5.

(* eapply IfThenElse_VHTT1. *)
HoareTac1.

eapply init_aux6.
simpl.
eapply BindS_VHTT1 with (x:="y").
eapply BindS_VHTT1 with (x:="idx").
eapply init_aux7.

intros; simpl.

eapply init_aux8.

Focus 2.
eapply init_aux9.

intros; simpl.
eapply (Hoare_eq_wk Value) with
    (fenv:= fun _ => [("initVAddrTable",
             FC [] [("x", Index)] (Val (cst unit tt))
               (initVAddrTableAux "initVAddrTable" "x" table) "initVAddrTable"
               n)])
    (env:= fun v => [("y", v); ("x", cst index curidx)])
    (P:= fun s : DynamicI.W =>
    (idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
    readVirtual table curidx (memory s) = Some defaultVAddr /\
    curidx < tableSize - 1)
    (Q:=fun (_ : Value) (v0 : DynamicI.W) =>
    readVirtual table idx (memory v0) = Some defaultVAddr)
    (vs2:= cst index
      match succIndexInternal curidx with
      | Some i => i
      | None => index_d
      end).

eapply QFun_VHTT.
econstructor.

reflexivity.
clear v.
eapply Apply_VHTT2.

instantiate(1:=fun vs s => (
    idx < curidx -> readVirtual table idx (memory s) = Some defaultVAddr) /\
   readVirtual table curidx (memory s) = Some defaultVAddr /\
   curidx < tableSize - 1 /\
   vs =
   [cst index
     match succIndexInternal curidx with
     | Some i => i
     | None => index_d
     end]).

eapply init_aux10.

intros.
simpl in *.
unfold initVAddrTableFun in IHn.

destruct curidx.
simpl in *.

unfold THoareTriple_Eval in *.
intros.
destruct H0.
destruct H1.
destruct H2.
simpl in *.

case_eq (lt_dec i tableSize).
intros; try contradiction.
rewrite H4 in *.
unfold CIndex in *.
case_eq (lt_dec (i + 1) tableSize); intros.
rewrite H5 in *.
simpl in *.
assert (Z : n+(i+1) = S(n+i)) by omega.

specialize (IHn (CIndex(i+1)) [("initVAddrTable",
               FC [] [("x", Index)] (Val (cst unit tt))
                 (initVAddrTableAux "initVAddrTable" "x" table)
                 "initVAddrTable" n)]
               [("y",
        cst index
          {| i := i + 1; Hi := Pip_state.CIndex_obligation_1 (i + 1) l0 |});
       ("x", cst index {| i := i; Hi := Hi |})]).

assert (n + CIndex (i + 1) = S (n + i)) as k4.
unfold CIndex.
rewrite H5.
simpl.
auto.
rewrite k4 in *.
specialize (IHn H).

eapply IHn.
eauto.
eauto.
instantiate (1:=t).
subst.
simpl in *.
unfold CIndex.
rewrite H5.

exact k3.
subst.
unfold CIndex.
rewrite H5.

exact X.

intro.
simpl in *.
assert (Hor : idx = {| i := i; Hi := Hi |} \/ idx < {| i := i; Hi := Hi |}).
    { simpl in *.
      unfold CIndex in H6.
      destruct (lt_dec (i + 1) tableSize).
      subst.
      simpl in *.
      rewrite NPeano.Nat.add_1_r in H6.
      apply lt_n_Sm_le in H6.
      apply le_lt_or_eq in H6.
      destruct H6.
      right. assumption.
      left. subst.
      destruct idx. simpl in *.
      subst.
      assert (Hi = Hi0).
      apply proof_irrelevance.
      subst. reflexivity. omega. }
destruct Hor.
subst.
eassumption.
apply H0; trivial.
assert (i+1<tableSize) by omega.
contradiction.

intros.
contradiction.
Qed.

End Hoare_Test_SndShadow_SynDir.


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

Require Export dilatations.
Require Export operations_complexes.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma angle_argument :
 forall (z z' : C) (M M' : PO),
 O <> M :>PO ->
 O <> M' :>PO ->
 z = affixe M :>C ->
 z' = affixe M' :>C ->
 cons_AV (vec O M) (vec O M') = plus (argument z') (opp (argument z)) :>AV.
intros.
rewrite (argument_def2 (M:=M) (z:=z)); auto.
rewrite (argument_def2 (M:=M') (z:=z')); auto.
rewrite Chasles_diff; auto with geo.
Qed.
Hint Resolve angle_argument: geo.

Lemma egalite_vecteur_OM_image :
 forall (z z' : C) (M M' : PO),
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C -> vec O M = vec O M' :>PP -> z = z' :>C.
intros.
apply egalite_point_image with (M := M) (M' := M'); eauto with geo.
apply vecteur_nul_conf.
replace (vec M M') with (add_PP (vec O M') (mult_PP (-1) (vec O M)));
 [ idtac | Ringvec ].
rewrite H1; Ringvec.
Qed.

Lemma egalite_vecteur_image :
 forall (z z' : C) (A B A' B' : PO),
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C -> vec A B = vec A' B' :>PP -> z = z' :>C.
intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros D H2; intros; try exact H2.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros D'; intros; try exact H2.
apply egalite_vecteur_OM_image with (M := D) (M' := D').
rewrite H2; auto.
rewrite H3; auto.
rewrite H2; rewrite H3; auto.
Qed.

Lemma egalite_affixe_vecteur_OM :
 forall (z z' : C) (M M' : PO),
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C -> z = z' :>C -> vec O M = vec O M' :>PP.
intros.
replace M' with M; auto.
apply egalite_affixe_point with (3 := H1); auto with geo.
Qed.

Lemma egalite_affixe_vecteur :
 forall (z z' : C) (A B A' B' : PO),
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C -> z = z' :>C -> vec A B = vec A' B' :>PP.
intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros D H2; intros; try exact H2.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros D'; intros; try exact H2.
rewrite <- H2; rewrite <- H3.
apply egalite_affixe_vecteur_OM with (z := z) (z' := z'); auto.
rewrite H2; auto.
rewrite H3; auto.
Qed.
Hint Resolve affixe_vec_AB: geo.

Lemma complexe_translation :
 forall (a z z' : C) (A M M' : PO),
 z = affixe M ->
 z' = affixe M' ->
 a = affixe A -> z' = Cplus z a -> M' = translation O A M :>PO.
intros.
apply rec_translation_vecteur.
apply
 (egalite_affixe_vecteur (z:=a) (z':=Cplus z' (Copp z)) (A:=O) (B:=A) (A':=M)
    (B':=M')); auto with geo.
rewrite H2.
ring.
Qed.

Lemma rec_complexe_translation :
 forall (a z z' : C) (A M M' : PO),
 z = affixe M ->
 z' = affixe M' ->
 a = affixe A -> M' = translation O A M :>PO -> z' = Cplus z a.
intros.
cut (Cplus z' (Copp z) = a); intros.
rewrite <- H3; ring.
apply
 (egalite_vecteur_image (z:=Cplus z' (Copp z)) (z':=a) (A:=M) (B:=M') (A':=O)
    (B':=A)); auto with geo.
symmetry  in |- *; apply translation_vecteur; auto.
Qed.

Ltac paffixe M z := elim (existence_affixe_point M); intros z; intros.

Lemma argument_affixe_produit_positif_vecteur_OM :
 forall (k : R) (M M' : PO) (z z' : C),
 O <> M :>PO ->
 k > 0 ->
 vec O M' = mult_PP k (vec O M) :>PP ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C -> argument z' = argument z :>AV.
intros.
cut (O <> M'); intros.
rewrite (argument_def2 (M:=M) (z:=z)); auto with geo.
rewrite (argument_def2 (M:=M') (z:=z')); auto with geo.
apply angle_produit_positif_r with k; auto with geo.
apply distinct_produit_vecteur with (3 := H1); auto.
auto with real.
Qed.

Lemma argument_affixe_produit_negatif_vecteur_OM :
 forall (k : R) (M M' : PO) (z z' : C),
 O <> M :>PO ->
 k < 0 ->
 vec O M' = mult_PP k (vec O M) :>PP ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 argument z' = plus (argument z) (image_angle pi) :>AV.
intros.
cut (O <> M'); intros.
rewrite (argument_def2 (M:=M) (z:=z)); auto with geo.
rewrite (argument_def2 (M:=M') (z:=z')); auto with geo.
apply angle_produit_negatif_r with k; auto with geo.
apply distinct_produit_vecteur with (3 := H1); auto.
auto with real.
Qed.

Lemma argument_affixe_produit_positif_vecteur :
 forall (k : R) (A B A' B' : PO) (z z' : C),
 A <> B :>PO ->
 k > 0 ->
 vec A' B' = mult_PP k (vec A B) :>PP ->
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C -> argument z' = argument z :>AV.
intros k A B A' B' z z' H H0; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B); intros M;
 intros H1.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros M'; intros H2.
rewrite <- H2; rewrite <- H1; intros.
apply
 (argument_affixe_produit_positif_vecteur_OM (k:=k) (M:=M) (M':=M') (z:=z)
    (z':=z')); auto.
apply distinct_egalite_vecteur with (2 := H1); auto.
Qed.

Lemma argument_affixe_produit_negatif_vecteur :
 forall (k : R) (A B A' B' : PO) (z z' : C),
 A <> B :>PO ->
 k < 0 ->
 vec A' B' = mult_PP k (vec A B) :>PP ->
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C ->
 argument z' = plus (argument z) (image_angle pi) :>AV.
intros k A B A' B' z z' H H0; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B); intros M;
 intros H1.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros M'; intros H2.
rewrite <- H2; rewrite <- H1; intros.
apply
 (argument_affixe_produit_negatif_vecteur_OM (k:=k) (M:=M) (M':=M') (z:=z)
    (z':=z')); auto.
apply distinct_egalite_vecteur with (2 := H1); auto.
Qed.

Lemma module_affixe_produit_vecteur_OM :
 forall (k : R) (M M' : PO) (z z' : C),
 vec O M' = mult_PP k (vec O M) :>PP ->
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C -> module z' = Rabs k * module z.
intros.
rewrite (module_def2 (z:=z) (M:=M)); auto with geo.
rewrite (module_def2 (z:=z') (M:=M')); auto with geo.
Qed.

Lemma module_affixe_produit_vecteur :
 forall (k : R) (A B A' B' : PO) (z z' : C),
 vec A' B' = mult_PP k (vec A B) :>PP ->
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C -> module z' = Rabs k * module z.
intros k A B A' B' z z'; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B); intros M;
 intros H1.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros M'; intros H2.
rewrite <- H2; rewrite <- H1; intros.
apply
 (module_affixe_produit_vecteur_OM (k:=k) (M:=M) (M':=M') (z:=z) (z':=z'));
 auto.
Qed.

Lemma egalite_point_zeroC :
 forall (z : C) (A B : PO),
 A = B -> z = affixe_vec (vec A B) :>C -> z = zeroC :>C.
intros z A B H; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros M H1.
rewrite <- H1; intros.
cut (O = M); intros; auto.
rewrite <- H2 in H0.
rewrite affixe_origine; auto with geo.
apply vecteur_nul_conf.
rewrite H1; rewrite H; Ringvec.
Qed.

Lemma points_distincts_non_zeroC :
 forall (z : C) (A B : PO),
 A <> B :>PO -> z = affixe_vec (vec A B) :>C -> z <> zeroC :>C.
intros z A B H; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros M H1.
rewrite <- H1; intros.
cut (O <> M); intros.
apply nonorigine_image_nonzero with M; auto with geo.
red in |- *; intros; apply H.
apply vecteur_nul_conf.
rewrite <- H1; rewrite H2; Ringvec.
Qed.

Theorem produit_vecteur_image :
 forall (k : R) (z z' : C) (A B A' B' : PO),
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C ->
 vec A' B' = mult_PP k (vec A B) :>PP -> z' = Cmult (Rinj k) z :>C.
intros.
cut (module z' = Rabs k * module z); intros.
2: apply
    (module_affixe_produit_vecteur (k:=k) (A:=A) (B:=B) (A':=A') (B':=B')
       (z:=z) (z':=z')); auto.
discrimine A B.
rewrite (egalite_point_zeroC (z:=z) (A:=A) (B:=B)); auto with geo.
rewrite (egalite_point_zeroC (z:=z') (A:=A') (B:=B')); auto with geo.
apply vecteur_nul_conf.
rewrite H1; rewrite H3; Ringvec.
elim (classic (k = 0)); intros.
rewrite (egalite_point_zeroC (z:=z') (A:=A') (B:=B')); auto with geo.
rewrite H4; rewrite Rinj_zero; ring.
apply vecteur_nul_conf.
rewrite H1; rewrite H4; Ringvec.
cut (A' <> B'); intros.
cut (k > 0 \/ k < 0); intros.
elim H6; [ intros H7; try clear H6 | intros H7; try clear H6; try exact H7 ].
cut (argument z' = argument z); intros.
2: apply
    (argument_affixe_produit_positif_vecteur (k:=k) (A:=A) (B:=B) (A':=A')
       (B':=B') (z:=z) (z':=z')); auto with geo.
apply egalite_forme_polaire.
apply points_distincts_non_zeroC with (1 := H5); auto.
apply nonzero_produit; auto with geo.
apply points_distincts_non_zeroC with (1 := H3); auto with geo.
rewrite H2; rewrite Cmult_module; rewrite module_reel; auto.
rewrite H6; rewrite Cmult_argument; auto with geo.
rewrite argument_reel_pos; auto.
rewrite plus_commutative; symmetry  in |- *; rewrite plus_angle_zero; auto.
apply points_distincts_non_zeroC with (1 := H3); auto with geo.
cut (argument z' = plus (argument z) (image_angle pi)); intros.
2: apply
    (argument_affixe_produit_negatif_vecteur (k:=k) (A:=A) (B:=B) (A':=A')
       (B':=B') (z:=z) (z':=z')); auto with geo.
apply egalite_forme_polaire.
apply points_distincts_non_zeroC with (1 := H5); auto.
apply nonzero_produit; auto with geo.
apply points_distincts_non_zeroC with (1 := H3); auto with geo.
rewrite H2; rewrite Cmult_module; rewrite module_reel; auto.
rewrite H6; rewrite Cmult_argument; auto with geo.
rewrite argument_reel_neg; auto.
rewrite plus_commutative; auto.
apply points_distincts_non_zeroC with (1 := H3); auto with geo.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H6; try clear total_order
 | intros H6;
    (elim H6;
      [ intros H7; try clear H6 total_order
      | intros H7; try clear H6 total_order; try exact H7 ]) ].
right; try assumption.
absurd (k = 0); auto.
left; try assumption.
apply distinct_mult_vecteur with (3 := H1); auto.
Qed.

Theorem produit_reel_affixe_vecteur_OM :
 forall (k : R) (z z' : C) (M M' : PO),
 z = affixe_vec (vec O M) :>C ->
 z' = affixe_vec (vec O M') :>C ->
 z' = Cmult (Rinj k) z :>C -> vec O M' = mult_PP k (vec O M) :>PP.
intros.
cut (module z' = module (Rinj k) * module z); intros.
discrimine O M.
cut (z = zeroC); intros.
replace M with M'.
Ringvec.
apply (egalite_affixe_point (z:=z') (z':=z) (M:=M') (M':=M)); auto with geo.
rewrite H1; rewrite H4; ring.
apply (egalite_point_image (z:=z) (z':=zeroC) (M:=M) (M':=O)); auto with geo.
cut (z <> zeroC); [ idtac | eauto with geo ].
intros H20.
elim Rtotal_order with (r1 := k) (r2 := 0);
 [ intros H6; try clear total_order
 | intros H6;
    (elim H6;
      [ intros H7; try clear H6 | intros H7; try clear H6; try exact H7 ]) ].
rewrite module_reel_neg in H2; auto with real.
cut (k <> 0); intros; [ idtac | auto with real ].
cut (z' <> zeroC); intros.
cut (O <> M'); intros.
cut (cons_AV (vec O M) (vec O M') = image_angle pi); intros.
rewrite (alignes_distance_negatif_colineaire (k:=- k) (A:=O) (B:=M) (C:=M'));
 auto with geo.
replace (- - k) with k; try ring; auto.
rewrite <- (module_def2 (z:=z) (M:=M)); auto with geo.
rewrite <- (module_def2 (z:=z') (M:=M')); auto with geo.
rewrite (angle_argument (z:=z) (z':=z') (M:=M) (M':=M')); auto with geo.
rewrite H1; rewrite Cmult_argument; auto with geo.
rewrite argument_reel_neg; auto with geo.
elim existence_argument with (z := z);
 [ intros; try clear existence_argument | auto with geo ].
rewrite H8; rewrite <- mes_opp; repeat rewrite <- add_mes_compatible.
replace (pi + x + - x) with pi; [ auto | ring ].
apply image_nonzero_nonorigine with z'; auto with geo.
apply nonzero_module.
rewrite H2.
apply Rmult_integral_contrapositive.
split; auto with real geo.
cut (z' = zeroC); intros.
replace M' with O.
rewrite H7; Ringvec.
apply (egalite_affixe_point (z:=zeroC) (z':=z') (M:=O) (M':=M'));
 auto with geo.
apply module_nul_zeroC.
rewrite H2; rewrite H7.
replace (Rinj 0) with zeroC; auto with geo.
rewrite module_zeroC; ring.
rewrite module_reel_pos in H2; auto with real.
cut (k <> 0); intros; [ idtac | auto with real ].
cut (z' <> zeroC); intros.
cut (O <> M'); intros.
cut (cons_AV (vec O M) (vec O M') = image_angle 0); intros.
rewrite (alignes_distance_positif_colineaire (k:=k) (A:=O) (B:=M) (C:=M'));
 auto with geo.
rewrite <- (module_def2 (z:=z) (M:=M)); auto with geo.
rewrite <- (module_def2 (z:=z') (M:=M')); auto with geo.
rewrite (angle_argument (z:=z) (z':=z') (M:=M) (M':=M')); auto with geo.
rewrite H1; rewrite Cmult_argument; auto with geo.
rewrite argument_reel_pos; auto with geo.
elim existence_argument with (z := z);
 [ intros; try clear existence_argument | auto with geo ].
rewrite H8; rewrite <- mes_opp; repeat rewrite <- add_mes_compatible.
replace (0 + x + - x) with 0; [ auto | ring ].
apply image_nonzero_nonorigine with z'; auto with geo.
apply nonzero_module.
rewrite H2.
apply Rmult_integral_contrapositive.
split; auto with real geo.
rewrite H1; rewrite Cmult_module; auto.
Qed.

Theorem produit_reel_affixe_vecteur :
 forall (k : R) (z z' : C) (A B A' B' : PO),
 z = affixe_vec (vec A B) :>C ->
 z' = affixe_vec (vec A' B') :>C ->
 z' = Cmult (Rinj k) z :>C -> vec A' B' = mult_PP k (vec A B) :>PP.
intros k z z' A B A' B'; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B); intros M;
 intros H1.
elim existence_representant_vecteur with (A := O) (B := A') (C := B');
 intros M'; intros H2.
rewrite <- H2; rewrite <- H1; intros.
apply (produit_reel_affixe_vecteur_OM (k:=k) (z:=z) (z':=z') (M:=M) (M':=M'));
 auto.
Qed.

Theorem complexe_homothetie :
 forall (k : R) (j z z' : C) (J M M' : PO),
 z = affixe M ->
 z' = affixe M' ->
 j = affixe J ->
 Cplus z' (Copp j) = Cmult (Rinj k) (Cplus z (Copp j)) ->
 M' = homothetie k J M :>PO.
intros.
apply vecteur_homothetie.
apply produit_reel_affixe_vecteur with (3 := H2); auto with geo.
Qed.

Theorem rec_complexe_homothetie :
 forall (k : R) (j z z' : C) (J M M' : PO),
 z = affixe M ->
 z' = affixe M' ->
 j = affixe J ->
 M' = homothetie k J M :>PO ->
 Cplus z' (Copp j) = Cmult (Rinj k) (Cplus z (Copp j)).
intros.
cut (vec J M' = mult_PP k (vec J M)); intros.
2: apply homothetie_vecteur; auto.
apply produit_vecteur_image with (3 := H3); auto with geo.
Qed.


(** This files implements an efficient implementation of finite maps whose keys
range over Coq's data type of strings [string]. The implementation uses radix-2
search trees (uncompressed Patricia trees) as implemented in the file [pmap]
and guarantees logarithmic-time operations. *)
From stdpp Require Export fin_maps pretty.
From stdpp Require Import gmap.
From stdpp Require Import options.

Notation stringmap := (gmap string).
Notation stringset := (gset string).

(** * Generating fresh strings *)
Section stringmap.
Local Open Scope N_scope.
Let R {A} (s : string) (m : stringmap A) (n1 n2 : N) :=
  n2 < n1 ∧ is_Some (m !! (s +:+ pretty (n1 - 1))).
Lemma fresh_string_step {A} s (m : stringmap A) n x :
  m !! (s +:+ pretty n) = Some x → R s m (1 + n) n.
Proof. split; [lia|]. replace (1 + n - 1) with n by lia; eauto. Qed.
Lemma fresh_string_R_wf {A} s (m : stringmap A) : wf (R s m).
Proof.
  induction (map_wf m) as [m _ IH]. intros n1; constructor; intros n2 [Hn Hs].
  specialize (IH _ (delete_subset m (s +:+ pretty (n2 - 1)) Hs) n2).
  cut (n2 - 1 < n2); [|lia]. clear n1 Hn Hs; revert IH; generalize (n2 - 1).
  intros n1. induction 1 as [n2 _ IH]; constructor; intros n3 [??].
  apply IH; [|lia]; split; [lia|].
  by rewrite lookup_delete_ne by (intros ?; simplify_eq/=; lia).
Qed.
Definition fresh_string_go {A} (s : string) (m : stringmap A) (n : N)
    (go : ∀ n', R s m n' n → string) : string :=
  let s' := s +:+ pretty n in
  match Some_dec (m !! s') with
  | inleft (_↾Hs') => go (1 + n)%N (fresh_string_step s m n _ Hs')
  | inright _ => s'
  end.
Definition fresh_string {A} (s : string) (m : stringmap A) : string :=
  match m !! s with
  | None => s
  | Some _ =>
     Fix_F _ (fresh_string_go s m) (wf_guard 32 (fresh_string_R_wf s m) 0)
  end.
Lemma fresh_string_fresh {A} (m : stringmap A) s : m !! fresh_string s m = None.
Proof.
  unfold fresh_string. destruct (m !! s) as [a|] eqn:Hs; [clear a Hs|done].
  generalize 0 (wf_guard 32 (fresh_string_R_wf s m) 0); revert m.
  fix FIX 3; intros m n [?]; simpl; unfold fresh_string_go at 1; simpl.
  destruct (Some_dec (m !! _)) as [[??]|?]; auto.
Qed.
Definition fresh_string_of_set (s : string) (X : stringset) : string :=
  fresh_string s (mapset.mapset_car X).
Lemma fresh_string_of_set_fresh (X : stringset) s : fresh_string_of_set s X ∉ X.
Proof. apply eq_None_ne_Some, fresh_string_fresh. Qed.

Fixpoint fresh_strings_of_set
    (s : string) (n : nat) (X : stringset) : list string :=
  match n with
  | 0 => []
  | S n =>
     let x := fresh_string_of_set s X in
     x :: fresh_strings_of_set s n ({[ x ]} ∪ X)
  end%nat.
End stringmap.


(** * (Flattened) System Fsub definition and subtyping problem *)

Require Import Utils.psyntax.

Reserved Notation "|-F i ; s <: t" (at level 68, i, s, t at next level).

Inductive subF {w} : nat -> @ntype w 0 -> @ptype w 0 -> Prop :=
  | FTop s : |-F 0; s <: top
  | FAllNeg s t1 t2 i : |-F i; ninst t1 t2  <: pinst t1 s  ->
      |-F S i; uAllN s <: bAllN t1 t2
  where "|-F i ; A <: B" := (subF i A B).

Definition FsubF_SUBTYPE : {w : nat & ( @ntype w 0 * @ptype w 0 )%type} -> Prop
  := fun ntt => let (w, s0) := ntt in let (s, t) := s0
    in exists h, |-F h; s <: t.