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

Require Export In_Gamma.
Require Export Forces_NGamma.

Definition forces_gamma (gamma : flist) (work : nf_list)
  (k : kripke_tree) := forall a : form, in_gamma gamma work a -> forces_t k a.

Lemma forces_gamma_cons_gamma :
 forall (gamma : flist) (work : nf_list) (k : kripke_tree) (a : form),
 forces_t k a ->
 forces_gamma gamma work k -> forces_gamma (a :: gamma) work k.
intros gamma work k a forces_a forces_gamma0.
unfold forces_gamma in |- *.
intros c in_gamma0.
elim (in_gamma_cons_gamma_rev a gamma work c in_gamma0); clear in_gamma0.
intros in_gamma0.
apply forces_gamma0; assumption.
intros eq_c;  rewrite eq_c; assumption.
Qed.

Lemma forces_gamma_cons_gamma_tail :
 forall (gamma : flist) (work : nf_list) (k : kripke_tree) (a : form),
 forces_gamma (a :: gamma) work k -> forces_gamma gamma work k.
intros gamma work k a forces_gamma0.
unfold forces_gamma in |- *.
intros c in_gamma0.
apply forces_gamma0.
apply in_gamma_cons_gamma_tail; assumption.
Qed.

Lemma forces_gamma_cons_gamma_head :
 forall (gamma : flist) (work : nf_list) (k : kripke_tree) (a : form),
 forces_gamma (a :: gamma) work k -> forces_t k a.
intros gamma work k a forces_gamma0.
apply forces_gamma0.
apply in_gamma_cons_gamma_head; assumption.
Qed.

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

Lemma forces_gamma_shift_gamma_work :
 forall (a : normal_form) (gamma : flist) (work : nf_list) (k : kripke_tree),
 forces_gamma (nf2form a :: gamma) work k -> forces_gamma gamma (a :: work) k.
intros a gamma work k forces_gamma0.
unfold forces_gamma in |- *.
intros c in_gamma.
apply forces_gamma0.
apply in_gamma_shift_work_gamma; assumption.
Qed.

Lemma forces_gamma_shift_work_gamma :
 forall (a : normal_form) (gamma : flist) (work : nf_list) (k : kripke_tree),
 forces_gamma gamma (a :: work) k -> forces_gamma (nf2form a :: gamma) work k.
intros a gamma work k forces_gamma0.
unfold forces_gamma in |- *.
intros c in_gamma.
apply forces_gamma0.
apply in_gamma_shift_gamma_work; assumption.
Qed.

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

Lemma forces_gamma_cons_gamma_weak :
 forall (gamma : flist) (work : nf_list) (k : kripke_tree) (a b : form),
 (forces_t k a -> forces_t k b) ->
 forces_gamma (a :: gamma) work k -> forces_gamma (b :: gamma) work k.
intros gamma work k a b forces_ab forces_gamma0.
apply forces_gamma_cons_gamma.
apply forces_ab.
apply forces_gamma_cons_gamma_head with gamma work; assumption.
apply forces_gamma_cons_gamma_tail with a; assumption.
Qed.

Lemma forces_gamma_cons_gamma_weak2 :
 forall (gamma : flist) (work : nf_list) (k : kripke_tree) (a b c : form),
 (forces_t k a -> forces_t k b -> forces_t k c) ->
 forces_gamma (a :: b :: gamma) work k -> forces_gamma (c :: gamma) work k.
intros gamma work k a b c forces_abc forces_gamma0.
apply forces_gamma_cons_gamma.
apply forces_abc.
apply forces_gamma_cons_gamma_head with (b :: gamma) work; assumption.
apply forces_gamma_cons_gamma_head with gamma work.
apply forces_gamma_cons_gamma_tail with a; assumption.
apply forces_gamma_cons_gamma_tail with b.
apply forces_gamma_cons_gamma_tail with a; assumption.
Qed.


Require Import Category Functor FunctionalExtensionality Program.Equality ProofIrrelevance.

Definition transport {A : Type} (B : A -> Type) {a b : A}: a = b -> B a -> B b.
Proof.
  intros [] ?; assumption.
Defined.

Definition transport_hom o := o->o->Type.

Record Cat_ObHom := {
  c1_ob : Type;
  c1_hom : transport_hom c1_ob;
}.

Lemma eq_cat_oh (c1 c2: Cat_ObHom)
  (e_ob:  c1_ob c1 = c1_ob c2)
  (e_hom: transport transport_hom e_ob (c1_hom c1) = c1_hom c2)
  : c1 = c2.
destruct c1, c2. simpl in *.
now destruct e_ob, e_hom.
Qed.

Definition transport_id oh := forall (a: c1_ob oh), (c1_hom oh) a a.
Definition transport_comp oh := forall (a b c: c1_ob oh), (c1_hom oh) a b -> (c1_hom oh) b c -> (c1_hom oh) a c.

Record Cat_Data := {
  c2_oh : Cat_ObHom;
  c2_id : transport_id c2_oh;
  c2_comp : transport_comp c2_oh;
}.

Lemma eq_cat_data (d1 d2: Cat_Data)
  (e_oh: c2_oh d1 = c2_oh d2)
  (e_id: transport transport_id e_oh (c2_id d1) = c2_id d2)
  (e_comp: transport transport_comp e_oh (c2_comp d1) = c2_comp d2)
  : d1 = d2.
destruct d1, d2. simpl in *.
now destruct e_oh, e_id, e_comp.
Qed.

Definition cat_oh_of (C: Category) := Build_Cat_ObHom ob hom.
Definition cat_data_of (C: Category) := Build_Cat_Data (cat_oh_of C) id (@comp C).

Lemma cat_simpl_eq (C D: Category) : cat_data_of C = cat_data_of D -> C = D.
set (c := cat_data_of C).
set (d := cat_data_of D).
intro e.
(* assert (e_cd := e).
change (cat_data_of C) with c in e_cd ; change (cat_data_of D) with d in e_cd. *)
destruct C, D.

unfold cat_data_of, cat_oh_of in c, d, e.
simpl in *.

assert (e_ob : ob = ob0).
now dependent destruction e.
destruct e_ob.

assert (e_hom : hom = hom0).
now dependent destruction e.
destruct e_hom.

assert (e_id : id = id0).
apply functional_extensionality_dep ; intro.
assert (e_idc : id = c2_id c). reflexivity.
assert (e_idd : id0 = c2_id d). reflexivity.
rewrite e_idc, e_idd.
dependent destruction e.
admit.
destruct e_id.

assert (e_comp : comp = comp0).
repeat (apply functional_extensionality_dep ; intro).
admit.
destruct e_comp.

assert (e_id_r : cat_id_r = cat_id_r0).
apply proof_irrelevance. destruct e_id_r.

assert (e_id_l : cat_id_l = cat_id_l0).
apply proof_irrelevance. destruct e_id_l.

assert (e_assoc : cat_comp_assoc = cat_comp_assoc0).
apply proof_irrelevance. destruct e_assoc.

reflexivity.
Admitted.


Require Import Coq.Bool.Bool.

(* Quantifiers : Linear & Unrestricted [Figure 1-3, q] *)
Inductive q : Type :=
  | qlin : q  (* [Figure 1-3, lin] *)
  | qun : q.  (* [Figure 1-3, un] *)

Definition q_eq ( x : q ) ( y : q ) : bool :=
  match x, y with
  | qun, qun => true
  | qlin, qlin => true
  | _, _ => false
  end.

Example q_eq_test : q_eq qun qlin = false.
Proof. simpl. reflexivity. Qed.

(* Boolean Literal : True & False [Figure 1-3, b] *)
Inductive b : Type :=
  | btrue : b    (* [Figure 1-3, true] *)
  | bfalse : b.  (* [Figure 1-3, false] *)

Definition b_eq ( x : b ) ( y : b ) : bool :=
  match x, y with
  | btrue, btrue => true
  | bfalse, bfalse => true
  | _, _ => false
  end.

Example b_eq_test : b_eq btrue bfalse = false.
Proof. simpl. reflexivity. Qed.

(* Names of the Variables, [See Figure 1-3, x] *)
Inductive id : Type :=
  | Id : nat -> id
  | Pt : nat -> id.

Fixpoint nat_eq ( m : nat ) ( n : nat ) : bool :=
  match m, n with
  | O, O => true
  | S _, O => false
  | O, S _ => false
  | S m', S n' => nat_eq m' n'
  end.

Proposition nat_eq_refl : forall n, nat_eq n n = true.
Proof.
  intros. induction n.
  - simpl. reflexivity.
  - simpl. apply IHn.
Qed.

Lemma nat_eq_to_eq : forall m n, nat_eq m n = true -> m = n.
Proof.
  intros m. induction m; induction n; intros H.
  - reflexivity.
  - compute in H. inversion H.
  - compute in H. inversion H.
  - simpl in H. apply IHm in H. rewrite -> H. reflexivity.
Qed.

Definition var_eq ( x : id ) ( y : id ) : bool :=
  match x, y with
  | Id m, Id n => nat_eq m n
  | Pt m, Pt n => nat_eq m n
  | _, _ => false
  end.

Proposition var_eq_refl : forall x, var_eq x x = true.
Proof.
  intros. destruct x; simpl; apply nat_eq_refl.
Qed.

Lemma var_eq_to_eq : forall x y, var_eq x y = true -> x = y.
Proof.
  intros. destruct x. destruct y. inversion H. apply nat_eq_to_eq in H1.
  rewrite -> H1. reflexivity.
Admitted.

(* Type and Pretype *)
Reserved Notation "'qty'" (at level 10).  (* [Figure 1-3, P] *)

Inductive ty : Type :=  (* Figure 1-3, T] *)
  | ty_bool : qty               (* [Figure 1-3, Bool] *)
  | ty_pair : ty -> ty -> qty   (* [Figure 1-3, T*T] *)
  | ty_arrow : ty -> ty -> qty  (* [Figure 1-3, T->T] *)

where "'qty'" := (q -> ty).

Notation "T ** T'" := (ty_pair T T') (at level 20, left associativity).

Notation "T --> T'" := (ty_arrow T T') (at level 40, left associativity).

Fixpoint ty_eq ( T1 : ty ) ( T2 : ty ) : bool :=
  match T1, T2 with
  | ty_bool q1, ty_bool q2 => q_eq q1 q2
  | ty_pair TT1 TT2 Q, ty_pair TT'1 TT'2 Q' =>
    andb (q_eq Q Q') (andb (ty_eq TT1 TT'1) (ty_eq TT2 TT'2))
  | ty_arrow TT1 TT2 Q, ty_arrow TT'1 TT'2 Q' =>
    andb (q_eq Q Q') (andb (ty_eq TT1 TT'1) (ty_eq TT2 TT'2))
  | _, _ => false
  end.

Definition ty_eq_refl : forall t, ty_eq t t = true.
Proof.
  intros. induction t; simpl.
  - destruct q0; simpl; reflexivity.
  - apply andb_true_iff. split.
    { destruct q0; simpl; reflexivity. }
    apply andb_true_iff. split.
    { apply IHt1. }
    { apply IHt2. }
  - apply andb_true_iff. split.
    { destruct q0; simpl; reflexivity. }
    apply andb_true_iff. split.
    { apply IHt1. }
    { apply IHt2. }
Qed.

(* Terms [Figure 1-3, t] *)
Inductive tm : Type :=
  | tmvar : id -> tm                       (* [Figure 1-3, x] *)
  | tmbool : q -> b -> tm                  (* [Figure 1-3, q b] *)
  | tmif : tm -> tm -> tm -> tm            (* [Figure 1-3, if t then t else t] *)
  | tmpair : q -> tm -> tm -> tm           (* [Figure 1-3, q <t, t>] *)
  | tmsplit : tm -> id -> id -> tm -> tm   (* [Figure 1-3, split t as x, y in t] *)
  | tmabs : q -> id -> ty -> tm -> tm      (* [Figure 1-3, q λx:T.t] *)
  | tmapp : tm -> tm -> tm.                (* [Figure 1-3, t t] *)

Fixpoint tm_eq ( t1 : tm ) ( t2 : tm ) : bool :=
  match t1, t2 with
  | tmvar x, tmvar y => var_eq x y
  | tmbool q1 x, tmbool q2 y => andb (q_eq q1 q2) (b_eq x y)
  | tmif t1 t2 t3, tmif t'1 t'2 t'3 =>
    andb (tm_eq t1 t'1) (andb (tm_eq t2 t'2) (tm_eq t3 t'3))
  | tmpair q1 t1 t2, tmpair q'1 t'1 t'2 =>
    andb (q_eq q1 q'1) (andb (tm_eq t1 t'1) (tm_eq t2 t'2))
  | tmsplit t1 x y t2, tmsplit t'1 x' y' t'2 =>
    andb (andb (var_eq x x') (var_eq y y')) (andb (tm_eq t1 t'1) (tm_eq t2 t'2))
  | tmabs Q x T t, tmabs Q' x' T' t' =>
    andb (andb (q_eq Q Q') (ty_eq T T')) (andb (var_eq x x') (tm_eq t t'))
  | tmapp t1 t2, tmapp t'1 t'2 => andb (tm_eq t1 t'1) (tm_eq t2 t'2)
  | _, _ => false
  end.

Proposition tm_eq_refl : forall t, tm_eq t t = true.
Proof.
  Admitted.

Example tm_eq_test_1 : tm_eq (tmvar (Id 0)) (tmvar (Id 0)) = true.
Proof. simpl. reflexivity. Qed.

Example tm_eq_test_2 : forall x y g,
  x = tmvar (Id 0) ->
  y = tmvar (Id 0) ->
  g = tmbool qun bfalse ->
  tm_eq (tmif g x y) (tmif g y x) = true.
Proof. intros. rewrite -> H. rewrite -> H0. rewrite -> H1.
  simpl. reflexivity. Qed.

(* Variable Id Substitution *)
Fixpoint rpi ( t : tm ) ( x : id ) ( y : id ) : tm :=  (* [x->y]t *)
  match t with
  | tmvar x' => if var_eq x x' then tmvar y else t
  | tmif t1 t2 t3 => tmif (rpi t1 x y) (rpi t2 x y) (rpi t3 x y)
  | tmpair qi t1 t2 => tmpair qi (rpi t1 x y) (rpi t2 x y)
  | tmsplit t1 x1 x2 t2 =>
      if orb (var_eq x x1) (var_eq x x2)
        then tmsplit (rpi t1 x y) x1 x2 t2
        else tmsplit (rpi t1 x y) x1 x2 (rpi t2 x y)
  | tmabs qi x' T t' => if var_eq x x' then t else tmabs qi x' T (rpi t' x y)
  | tmapp t1 t2 => tmapp (rpi t1 x y) (rpi t2 x y)
  | _ => t
  end.

(* Values and PreValues *)
Reserved Notation "'pv'" (at level 10).  (* [Figure 1-7, w] *)

Inductive v : Type :=             (* [Figure 1-7, v] *)
  | pvbool : b -> pv              (* [Figure 1-7, b] *)
  | pvpair : id -> id -> pv       (* [Figure 1-7, <x, y>] *)
  | pvabs : id -> ty -> tm -> pv  (* [Figure 1-7, λx:T.t] *)

where "'pv'" := (q -> v).

Axiom v_unique : forall (vi vi' : pv), (vi qlin) <> (vi' qun).

Definition v_eq (vi vi' : v) : bool :=
  match vi, vi' with
  | pvbool bi qi, pvbool bi' qi' => andb (b_eq bi bi') (q_eq qi qi')
  | pvpair x y qi, pvpair x' y' qi' =>
      andb (andb (var_eq x x') (var_eq y y')) (q_eq qi qi')
  | pvabs x ti t qi, pvabs x' ti' t' qi' =>
      andb (andb (var_eq x x') (ty_eq ti ti')) (andb (tm_eq t t') (q_eq qi qi'))
  | _, _ => false
  end.

Definition v_eq_refl : forall vi, v_eq vi vi = true.
Proof.
  intros vi. induction vi; simpl.
  - apply andb_true_iff. split.
    { destruct b0; simpl; reflexivity. }
    { destruct q0; simpl; reflexivity. }
  - apply andb_true_iff. split.
    { apply andb_true_iff. split; apply var_eq_refl. }
    { destruct q0; simpl; reflexivity. }
  - apply andb_true_iff. split.
    { apply andb_true_iff. split. { apply var_eq_refl. } { apply ty_eq_refl. } }
    { apply andb_true_iff. split. { apply tm_eq_refl. }
      destruct q0; simpl; reflexivity. }
Qed.

Fixpoint v_q (vi : v) : q :=
  match vi with
  | pvbool bi qi => qi
  | pvpair x y qi => qi
  | pvabs x ti t' qi => qi
  end.

Fixpoint tmv (t : v) : tm :=
  match t with
  | pvbool bi qi => tmbool qi bi
  | pvpair x y qi => tmpair qi (tmvar x) (tmvar y)
  | pvabs x ti t' qi => tmabs qi x ti t'
  end.


(* TLC in Coq
 *
 * Module: tlc.syntax.function
 * Purpose: Contains the syntax of functions.
 *)

Require Import mathcomp.ssreflect.choice.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.

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

(* Externally implemented function terms
 * These are functions that cannot be expressed directly within the term
 * language.  Functions that must be defined recursively are among this class.
 *)
Inductive function :=
(* Boolean equality *)
| FEqual
(* Naturals *)
| FAdd
(* Lists *)
| FMap
| FCount
| FConcat
| FSetUnion.

(* Equality *)
Section eq.

  (* Boolean equality *)
  Definition function_eq f1 f2 :=
    match f1, f2 with
    (* Boolean equality *)
    | FEqual, FEqual => true
    (* Naturals *)
    | FAdd, FAdd => true
    (* Lists *)
    | FMap, FMap => true
    | FCount, FCount => true
    | FConcat, FConcat => true
    | FSetUnion, FSetUnion => true
    (* Unequal *)
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma function_eqP : Equality.axiom function_eq.
  Proof.
    by case; case; constructor.
  Qed.

  (* EqType canonical structures *)
  Definition function_eqMixin := EqMixin function_eqP.
  Canonical function_eqType := EqType function function_eqMixin.

End eq.


Require Import ZF ZFpairs ZFsum ZFnats ZFrelations ZFord ZFfix ZFstable.
Require Import ZFgrothendieck ZFcoc.
Require Import ZFlist.
Import ZFrepl.

(** In this file we develop the theory of W-types in Prop:
    - typing
    - existence of a fixpoint
    - recursor
 *)

Section W_Prop_theory.

(** * Definition and properties of the W-type operator *)

Variable A : set.
Variable B : set -> set.
Hypothesis Bext : ext_fun A B.

(* The intended type operator *)
Definition W_F X := sup A (fun x => cc_arr (B x) X).

Lemma wfm1 : forall X, ext_fun A (fun x => cc_arr (B x) X).
do 2 red; intros.
apply cc_arr_morph; auto with *.
Qed.
Hint Resolve wfm1.

Lemma W_F_intro X a f :
  ext_fun (B a) f ->
  a ∈ A ->
  (forall i, i ∈ B a -> f i ∈ X) ->
  cc_lam (B a) f ∈ W_F X.
intros.
unfold W_F; rewrite sup_ax; auto.
exists a; trivial.
apply cc_arr_intro; intros; auto with *.
Qed.

Lemma W_F_elim X x :
  x ∈ W_F X ->
  exists2 w, w ∈ A &
  (forall i, i ∈ B w -> cc_app x i ∈ X) /\
  x == cc_lam (B w) (cc_app x).
intros.
unfold W_F in H; rewrite sup_ax in H; auto.
destruct H as (w,?,?); exists w; trivial.
split; intros.
 apply cc_arr_elim with (1:=H0); trivial.

 apply cc_eta_eq in H0; trivial.
Qed.

Instance W_F_mono : Proper (incl_set ==> incl_set) W_F.
do 3 red; intros.
apply W_F_elim in H0; destruct H0 as (w,?,(?,?)).
rewrite H2.
apply W_F_intro; auto.
do 2 red; intros; apply cc_app_morph; auto with *.
Qed.

Instance W_F_morph : morph1 W_F.
apply Fmono_morph; auto with *.
Qed.

(* W_F not stable! *)

Lemma W_F_bound : W_F (singl empty) ⊆ singl empty.
red; intros.
apply W_F_elim in H.
destruct H as (w,?,(?,?)).
rewrite H1.
apply singl_intro_eq.
apply cc_impredicative_lam.
 do 2 red; intros; apply cc_app_morph; auto with *.

 intros.
 apply singl_elim; auto.
Qed.

Lemma W_F_typ X : X ⊆ singl empty -> W_F X ⊆ singl empty.
intros.
transitivity (W_F (singl empty)).
 apply W_F_mono; trivial.

 apply W_F_bound.
Qed.

  Definition W := FIX (singl empty) W_F.

  Lemma W_typ : W ∈ props.
apply power_intro.
change (W ⊆ singl prf_trm).
apply lfp_typ.
apply W_F_typ.
Qed.

  Lemma W_eqn : W == W_F W.
symmetry; apply FIX_eqn.
 apply W_F_mono.

 apply W_F_typ.
Qed.

  Definition Wi := TI W_F.

  Lemma Wi_mono o o' : isOrd o -> isOrd o' -> o ⊆ o' -> Wi o ⊆ Wi o'.
intros.
apply TI_mono; trivial.
apply W_F_morph.
Qed.

  Lemma Wi_W o : isOrd o -> Wi o ⊆ W.
intros.
apply TI_FIX; trivial.
 apply W_F_mono.
 apply W_F_typ.
Qed.

  Lemma W_case (P:set->Prop) :
    Proper (eq_set ==> iff) P ->
    (forall x f, x ∈ A ->
     f ∈ cc_arr (B x) W ->
     P f) ->
    forall a, a ∈ W -> P a.
intros.
cut (a ∈ subset W P).
 intros.
 rewrite subset_ax in H2; destruct H2 as (_,(a',?,?)).
 rewrite H2; trivial.
revert a H1.
apply lower_bound.
unfold M'.
apply subset_intro.
 apply power_intro; intros.
 apply subset_elim1 in H1.
 apply power_elim with (2:=H1).
 apply W_typ.

 do 2 red; intros.
 apply subset_intro.
  rewrite W_eqn.
  revert H1; apply W_F_mono.
  red; intros.
  apply subset_elim1 in H1; trivial.

  apply W_F_elim in H1.
  destruct H1 as (w,?,(?,?)).
  rewrite H3; apply H0 with w; trivial.
  apply cc_arr_intro; intros.
   do 2 red; intros; apply cc_app_morph; auto with *.

   specialize H2 with (1:=H4).
   apply subset_elim1 in H2; trivial.
Qed.

  Lemma Wi_case o (P:set->Prop) :
    isOrd o ->
    Proper (eq_set ==> iff) P ->
    (forall x f, x ∈ A ->
     f ∈ cc_arr (B x) (Wi o) ->
     P f) ->
    forall a, a ∈ Wi (osucc o) -> P a.
intros.
unfold Wi in H2; rewrite TI_mono_succ in H2; auto.
2:apply W_F_mono.
apply W_F_elim in H2.
destruct H2 as (w,?,(?,?)).
apply H1 with w; trivial.
rewrite H4; apply cc_arr_intro; intros; auto.
do 2 red; intros; apply cc_app_morph; auto with *.
Qed.

  Lemma Wi_ind o (P:set->Prop) :
    isOrd o ->
    Proper (eq_set==>iff) P ->
    (forall o', isOrd o' -> o' ⊆ o ->
     (forall a, a ∈ Wi o' -> P a) ->
     (forall a, a ∈ Wi (osucc o') -> P a)) ->
    forall a, a ∈ Wi o -> P a.
intros oo Pm Hrec.
apply isOrd_ind with (2:=oo); intros.
apply TI_elim in H2; auto with *.
destruct H2 as (o',?,?).
apply Hrec with o'.
 apply isOrd_inv with y; trivial.

 transitivity y; trivial.
 red; intros; apply isOrd_trans with o'; trivial.

 intros.
 apply H1 with o'; trivial.

 unfold Wi; rewrite TI_mono_succ; auto with *.
 apply isOrd_inv with y; trivial.
Qed.

  Lemma W_ind (P:set->Prop) :
    Proper (eq_set==>iff) P ->
    (forall X, X ⊆ W ->
     (forall a, a ∈ X -> P a) ->
     (forall a, a ∈ W_F X -> P a)) ->
    forall a, a ∈ W -> P a.
intros.
cut (a ∈ subset W P).
 intros.
 apply subset_elim2 in H2.
 destruct H2 as (a',eqa,?).
 rewrite eqa; trivial.
revert a H1; apply lower_bound.
unfold M'.
apply subset_intro.
 apply power_intro; intros.
 apply subset_elim1 in H1.
 apply power_elim with (1:=W_typ); trivial.

 do 2 red; intros.
 apply subset_intro.
  rewrite W_eqn.
  revert H1; apply W_F_mono.
  red; intros.
  apply subset_elim1 in H1; trivial.

  apply H0 with (subset W P); trivial.
   red; intros.
   apply subset_elim1 in H2; trivial.

   intros.
   apply subset_elim2 in H2.
   destruct H2 as (a',eqa,?).
   rewrite eqa; trivial.
Qed.

Section WindColl.

Hypothesis coll_ax :
  forall A (R:set->set->Prop),
  Proper (eq_set ==> eq_set ==> iff) R ->
  exists B, forall x, x ∈ A ->
         (exists y, R x y) -> exists2 y, y ∈ B & R x y.

  Lemma same_fix :
    W == Ffix W_F (singl zero).
assert (Ffix W_F (singl zero) == W_F (Ffix W_F (singl zero))).
 apply Ffix_fix_coll; trivial.
  apply W_F_mono.

  apply W_F_typ.
apply incl_eq.
 apply lower_bound.
 apply subset_intro.
  apply power_intro; intros.
  apply Ffix_inA in H0; trivial.

  red; intros.
  rewrite <- H; reflexivity.

 red; intros.
 rewrite Ffix_def in H0.
 2:apply W_F_mono.
 2:apply W_F_typ.
 destruct H0.
 revert H1; apply TI_FIX; trivial.
 apply W_F_mono.
 apply W_F_typ.
Qed.

  Lemma W_ind_coll (P:set->Prop) :
    Proper (eq_set ==> iff) P ->
    (forall o, isOrd o ->
     (forall a, a ∈ Wi o -> P a) ->
     (forall a, a ∈ Wi (osucc o) -> P a)) ->
    forall a, a ∈ W -> P a.
intros.
rewrite same_fix in H1.
destruct Ffix_fix_coll_stage with (1:=W_F_mono) (2:=W_F_typ); trivial.
apply H3 in H1.
apply Wi_ind with (o:=x); trivial.
intros.
apply H0 with (o:=o'); trivial.
Qed.

End WindColl.

(** Recursor on W *)

Require Import ZFfunext ZFfixrec.

Section Recursor.

  Hint Resolve W_F_mono.

  Lemma Wi_fix :
    forall (P:set->Prop) o,
    isOrd o ->
    (forall i, isOrd i -> i ⊆ o ->
     (forall i' m, lt i' i -> m ∈ TI W_F i' -> P m) ->
     forall n, n ∈ TI W_F i -> P n) ->
    forall n, n ∈ TI W_F o -> P n.
intros P o is_ord Prec.
induction is_ord using isOrd_ind; intros; eauto.
Qed.

  Variable ord : set.
  Hypothesis oord : isOrd ord.

  Variable F : set -> set -> set.
  Hypothesis Fm : morph2 F.

  Variable U : set -> set -> set.
  Hypothesis Umono : forall o o' x x',
    isOrd o' -> o' ⊆ ord -> isOrd o -> o ⊆ o' ->
    x ∈ TI W_F o -> x == x' ->
    U o x ⊆ U o' x'.

  Let Ty o := cc_prod (TI W_F o) (U o).
  Hypothesis Ftyp : forall o f, isOrd o -> o ⊆ ord ->
    f ∈ Ty o -> F o f ∈ Ty (osucc o).

  Let Q o f := forall x, x ∈ TI W_F o -> cc_app f x ∈ U o x.

  Definition Wi_ord_irrel :=
    forall o o' f g,
    isOrd o' -> o' ⊆ ord -> isOrd o -> o ⊆ o' ->
    f ∈ Ty o -> g ∈ Ty o' ->
    fcompat (TI W_F o) f g ->
    fcompat (TI W_F (osucc o)) (F o f) (F o' g).

  Hypothesis Firrel : Wi_ord_irrel.

  Definition WREC := REC F.

Lemma Umorph : forall o o', isOrd o' -> o' ⊆ ord -> o == o' ->
    forall x x', x ∈ TI W_F o -> x == x' -> U o x == U o' x'.
intros.
apply incl_eq.
 apply Umono; auto.
  rewrite H1; trivial.
  rewrite H1; reflexivity.

 apply Umono; auto.
  rewrite H1; trivial.
  rewrite H1; trivial.
  rewrite H1; reflexivity.
  rewrite <- H3; rewrite <- H1; trivial.
  symmetry; trivial.
Qed.

Lemma Uext : forall o, isOrd o -> o ⊆ ord -> ext_fun (TI W_F o) (U o).
red; red; intros.
apply Umorph; auto with *.
Qed.

  Lemma WREC_typing : forall o f, isOrd o -> o ⊆ ord ->
    is_cc_fun (TI W_F o) f -> Q o f -> f ∈ Ty o.
intros.
rewrite cc_eta_eq' with (1:=H1).
apply cc_prod_intro; intros; auto.
 do 2 red; intros.
 rewrite H4; reflexivity.

 apply Uext; trivial.
Qed.

Let Wi_cont : forall o,
   isOrd o -> TI W_F o == sup o (fun o' => TI W_F (osucc o')).
apply TI_mono_eq; trivial.
Qed.

Let Qm :
   forall o o',
   isOrd o ->
   o ⊆ ord ->
   o == o' -> forall f f', fcompat (TI W_F o) f f' -> Q o f -> Q o' f'.
intros.
unfold Q in H3|-*; intros.
rewrite <- H1 in H4.
specialize H3 with (1:=H4).
red in H2; rewrite <- H2; trivial.
revert H3; apply Umono; auto with *.
 rewrite <- H1; trivial.
 rewrite <- H1; trivial.
 rewrite <- H1; reflexivity.
Qed.

Let Qcont : forall o f : set,
 isOrd o ->
 o ⊆ ord ->
 is_cc_fun (TI W_F o) f ->
 (forall o' : set, o' ∈ o -> Q (osucc o') f) -> Q o f.
intros.
red; intros.
apply TI_elim in H3; auto with *.
destruct H3.
rewrite <- TI_mono_succ in H4; eauto using isOrd_inv.
generalize (H2 _ H3 _ H4).
apply Umono; eauto using isOrd_inv with *.
red; intros.
apply isOrd_plump with x0; eauto using isOrd_inv.
apply olts_le in H5; trivial.
Qed.

Let Qtyp : forall o f,
 isOrd o ->
 o ⊆ ord ->
 is_cc_fun (TI W_F o) f ->
 Q o f -> is_cc_fun (TI W_F (osucc o)) (F o f) /\ Q (osucc o) (F o f).
intros.
assert (F o f ∈ Ty (osucc o)).
 apply Ftyp; trivial.
 apply WREC_typing; trivial.
split.
 apply cc_prod_is_cc_fun in H3; trivial.

 red; intros.
 apply cc_prod_elim with (1:=H3); trivial.
Qed.

  Lemma Firrel_W : stage_irrelevance ord (TI W_F) Q F.
red; red; intros.
destruct H1 as (oo,(ofun,oty)); destruct H2 as (o'o,(o'fun,o'ty)).
apply Firrel; trivial.
 apply WREC_typing; trivial.
 transitivity o'; trivial.

 apply WREC_typing; trivial.
Qed.

  Lemma WREC_recursor : recursor ord (TI W_F) Q F.
split; auto.
 apply TI_morph.

 apply Firrel_W.
Qed.
Hint Resolve WREC_recursor.

  (* Main properties of WREC: typing and equation *)
  Lemma WREC_wt : WREC ord ∈ Ty ord.
intros.
apply WREC_typing; auto with *.
 apply REC_wt with (1:=oord) (2:=WREC_recursor).
 apply REC_wt with (1:=oord) (2:=WREC_recursor).
Qed.

  Lemma WREC_ind : forall P x,
    Proper (eq_set==>eq_set==>eq_set==>iff) P ->
    (forall o x, isOrd o -> lt o ord ->
     x ∈ W_F (TI W_F o) ->
     (forall y, y ∈ TI W_F o -> P o y (cc_app (WREC ord) y)) ->
     forall w, isOrd w -> w ⊆ ord -> lt o w ->
     P w x (cc_app (F ord (WREC ord)) x)) ->
    x ∈ TI W_F ord ->
    P ord x (cc_app (WREC ord) x).
intros.
unfold WREC.
apply REC_ind with (2:=WREC_recursor); auto.
intros.
apply TI_elim in H4; auto with *.
destruct H4 as (o',?,?).
apply H0 with o'; eauto using isOrd_inv.
red; auto.
Qed.

  Lemma WREC_expand : forall n,
    n ∈ TI W_F ord -> cc_app (WREC ord) n == cc_app (F ord (WREC ord)) n.
intros.
apply REC_expand with (2:=WREC_recursor) (Q:=Q); auto.
Qed.

  Lemma WREC_irrel o o' :
    isOrd o ->
    isOrd o' ->
    o ⊆ o' ->
    o' ⊆ ord ->
    eq_fun (TI W_F o) (cc_app (WREC o)) (cc_app (WREC o')).
red; intros.
rewrite <- H4.
apply REC_ord_irrel with (2:=WREC_recursor); auto with *.
Qed.

End Recursor.

End W_Prop_theory.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rplus.
Require Export XR_Rplus_assoc.
Require Export XR_Ropp.
Require Export XR_Rplus_0_l.
Require Export XR_Rplus_0_r.
Require Export XR_Rplus_opp_l.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 = R0 -> r2 = - r1.
Proof.
  intros x y h.
  pattern y ; rewrite <- Rplus_0_l.
  rewrite <- Rplus_opp_l with x.
  rewrite Rplus_assoc.
  rewrite h. clear h.
  rewrite Rplus_0_r.
  reflexivity.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import tacs rel_utils list_utils finite.

Require Import almost_full list_contract_af.

Require Import tree proof.

Require Import formula relevant_contract.
Require Import sequent_rules relevant_LR2.

Set Implicit Arguments.

(* LR2 is used to decide relevant logic *)

Local Notation " g '|--' a " := ((g,a):Seq) (at level 70, no associativity).

Section LR2_decider.

  (* Redundancy for LR2 is the reflexivce and transitive closure of the contraction rule *)

  Definition redund (y x : Seq) := list_contract Form_eq_dec (fst x) (fst y) /\ snd x = snd y.

  Infix "≺r" := redund (at level 70, no associativity).

  (* We transport the af_t property from a product (Ramsey theorem)
     using the very useful af_t_relmap ...

     It works like a charm on Sigma types, try with af_t_comap
     instead and you will feel the difference ...
  *)

  Theorem Kripke_LR2 ga A : af_t (redund restr LR_sf (ga |-- A)).
  Proof.
    generalize (ga |-- A); clear ga A; intro s.
    generalize (af_t_prod (af_t_list_contract Form_eq_dec (sf_Seq_finite_t s))
                          (af_t_eq_finite (sf_Seq_finite_t s))).
    apply af_t_relmap with (f := fun x y => proj1_sig (fst x) = fst (proj1_sig y)
                                         /\ proj1_sig (snd x) = snd (proj1_sig y)).

    intros ((ga,a) & H); simpl.
    red in H.
    assert (Forall (sf_Seq s) ga) as H1.
      apply Forall_forall; intros u Hu.
      apply H; left; exists u; split; auto.
      apply sf_Form_refl.
    assert (sf_Seq s a) as H2.
      apply H; right; apply sf_Form_refl.
    exists (exist _ ga H1, exist _ a H2); auto.

    intros ((? & ?) & (? & ?)) ((? & ?) & (? & ?)) ((?,?) & ?) ((?,?) & ?); simpl.
    intros (? & ?) (? & ?); subst; unfold rel_prod; simpl.
    intros []; split; auto.
  Qed.

  Theorem LR2_decider : forall s, { t | proof LR2_rules s t } + { forall t, ~ proof LR2_rules s t }.
  Proof.
    apply proof_decider with (1 := LR2_rules_finite_t) (sf := LR_sf) (redund := redund).

    apply LR_sf_refl.
    apply LR_sf_trans.
    apply sf_LR2_rules.
    2: intros []; apply Kripke_LR2.

    (* contraction is height preserving (Curry's lemma) *)

    unfold redund; intros (ga,a) (de,b) t; simpl.
    intros H1 (H2 & ?); subst b.
    destruct (@LR2_Curry (tree_ht t) de ga a a) as (t' & Ht'); try tauto.
    exists t; split; auto; red; auto.
    exists t'; apply Ht'.
  Qed.

End LR2_decider.

Check LR2_decider.
Print Assumptions LR2_decider.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "/Users/jikl/demos/coq/software-foundation-exercise/logic_foundation" as LF.
From Coq Require Import Bool.Bool.
From LF Require Import Maps.
From PLF Require Import SmallStep.
From PLF Require Import Stlc.
From PLF Require MoreStlc.

Module STLCTypes.
  Export STLC.

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

  Lemma eqb_ty_refl : forall T1,
      eqb_ty T1 T1 = true.
  Proof.
    intro T1. induction T1.
    - reflexivity.
    - simpl. rewrite IHT1_1, IHT1_2. reflexivity.
  Qed.

  Lemma eqb_ty__eq : forall T1 T2,
      eqb_ty T1 T2 = true -> T1 = T2.
  Proof.
    intro T1. induction T1.
    - intro T2. induction T2.
      + reflexivity.
      + intro H. inversion H.
    - intro T2. induction T2.
      + intro H. inversion H.
      + intro H. inversion H.
        Search andb.
        apply andb_prop in H1.
        destruct H1 as [H1 H2].
        apply IHT1_1 in H1.
        apply IHT1_2 in H2.
        subst. reflexivity.
  Qed.

End STLCTypes.

Module FirstTry.
  Import STLCTypes.

  Fixpoint type_check (Gamma : context ) (t : tm) : option ty :=
    match t with
    | var x => Gamma x
    | abs x T11 t12 =>
      match type_check (update Gamma x T11) t12 with
      | Some T12 => Some (Arrow T11 T12)
      | _ => None
      end
    | app t1 t2 =>
      match type_check Gamma t1, type_check Gamma t2 with
      | Some (Arrow T11 T12), Some T2 =>
        if eqb_ty T11 T2 then Some T12 else None
      | _, _ => None
      end
    | tru | fls => Some Bool
    | test guard t f =>
      match type_check Gamma guard with
      | Some Bool =>
        match type_check Gamma t, type_check Gamma f with
        | Some T1, Some T2 =>
          if eqb_ty T1 T2 then Some T1 else None
        | _, _ => None
        end
      | _ => None
      end
    end.

End FirstTry.

Notation " x <- e1 ;; e2" := (match e1 with
                              | Some x => e2
                              | None => None
                              end)
                               (right associativity, at level 60).

Notation " 'return' e " := (Some e) (at level 60).

Notation " 'fail' " := None.

Module STLCChecker.
  Import STLCTypes.

  Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
    match t with
    | var x =>
      match Gamma x with
      | Some T => return T
      | None => fail
      end
    | abs x T11 t12 =>
      T12 <- type_check (update Gamma x T11) t12 ;;
    return (Arrow T11 T12)
    | app t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | Arrow T11 T12 =>
        if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
    | tru | fls => return Bool
    | test guard t1 t2 =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match Tguard with
      | Bool =>
        if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end
    end.

  Theorem type_checking_sound : forall Gamma t T,
      type_check Gamma t = Some T -> has_type Gamma t T.
  Proof with eauto with db.
    intros Gamma t. generalize dependent Gamma.
    induction t; intros Gamma T Htc; inversion Htc.
    - rename s into x. destruct (Gamma x) eqn:H.
      rename t into T'. inversion H0; subst.
      + apply T_Var...
      + inversion H0.
    - (* app *)
      remember (type_check Gamma t1) as TO1.
      destruct TO1 as [T1 |]; try solve_by_invert.
      destruct T1 as [|T11 T12]; try solve_by_invert;
      remember (type_check Gamma t2) as TO2;
      destruct TO2 as [T2 |]; try solve_by_invert.
      destruct (eqb_ty T11 T2) eqn: Heqb.
      apply eqb_ty__eq in Heqb.
      inversion H0; subst...
      inversion H0.
    - rename s into x. rename t into T1.
      remember (x |-> T1; Gamma) as G'.
      remember (type_check G' t0) as TO2.
      destruct TO2; try solve_by_invert.
      inversion H0; subst...
    - eauto with db.
    - eauto with db.
    - remember (type_check Gamma t1) as TOc.
      remember (type_check Gamma t2) as TO1.
      remember (type_check Gamma t3) as TO2.
      destruct TOc as [Tc|]; try solve_by_invert.
      destruct Tc; try solve_by_invert;
        destruct TO1 as [T1|]; try solve_by_invert;
          destruct TO2 as [T2|]; try solve_by_invert.
      destruct (eqb_ty T1 T2) eqn:Heqb;
        try solve_by_invert.
      apply eqb_ty__eq in Heqb.
      inversion H0. subst. subst...
  Qed.

  Theorem type_checking_complete : forall Gamma t T,
      has_type Gamma t T -> type_check Gamma t = Some T.
  Proof with auto with db.
    intros Gamma t T Hty.
    induction Hty; simpl.
    - destruct (Gamma x0) eqn:H0; assumption.
    - rewrite IHHty...
    - rewrite IHHty1. rewrite IHHty2.
      rewrite (eqb_ty_refl T11)...
    - reflexivity.
    - reflexivity.
    - rewrite IHHty1. rewrite IHHty2.
      rewrite IHHty3. rewrite (eqb_ty_refl T)...
  Qed.

End STLCChecker.

Module TypecheckerExtensions.

  Definition manual_grade_for_type_checking_sound : option (nat * string) :=
    None.

  Definition manual_grade_for_type_checking_complete : option (nat * string) := None.

  Import MoreStlc.
  Import STLCExtended.

  Fixpoint eqb_ty (T1 T2 : ty) : bool :=
    match T1, T2 with
    | Nat, Nat => true
    | Unit, Unit => true
    | Arrow T11 T12, Arrow T21 T22 =>
      (eqb_ty T11 T21) && (eqb_ty T12 T22)
    | Prod T11 T12, Prod T21 T22 =>
      (eqb_ty T11 T21) && (eqb_ty T12 T22)
    | Sum T11 T12, Sum T21 T22 =>
      (eqb_ty T11 T21) && (eqb_ty T12 T22)
    | List T11, List T21 => eqb_ty T11 T21
    | _, _ => false
    end.

  Lemma eqb_ty_refl : forall T1,
      eqb_ty T1 T1 = true.
  Proof.
    intro T1.
    induction T1; simpl.
    - rewrite IHT1_1, IHT1_2. auto.
    - auto.
    - rewrite IHT1_1, IHT1_2. auto.
    - assumption.
    - auto.
    - rewrite IHT1_1, IHT1_2. auto.
  Qed.

  Lemma eqb_ty__eq : forall T1 T2,
  eqb_ty T1 T2 = true -> T1 = T2.
  Proof.
    intros T1.
    induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq;
      try reflexivity;
      try (rewrite andb_true_iff in H0; inversion H0 as [Hbeq1 Hbeq2];
           apply IHT1_1 in Hbeq1; apply IHT1_2 in Hbeq2; subst; auto);
      try (apply IHT1 in Hbeq; subst; auto).
  Qed.

  Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | var x =>
      match Gamma x with
      | Some T => return T
      | None => fail
      end
  | abs x1 T1 t2 =>
      T2 <- type_check (update Gamma x1 T1) t2 ;;
      return (Arrow T1 T2)
  | app t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | Arrow T11 T12 =>
          if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | const _ =>
      return Nat
  | scc t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | Nat => return Nat
      | _ => fail
      end
  | prd t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | Nat => return Nat
      | _ => fail
      end
  | mlt t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1, T2 with
      | Nat, Nat => return Nat
      | _,_ => fail
      end
  | test0 guard t f =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t ;;
      T2 <- type_check Gamma f ;;
      match Tguard with
      | Nat => if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  | tinl T t =>
    T1 <- type_check Gamma t;;
      return (Sum T1 T)
  | tinr T t =>
    T2 <- type_check Gamma t;;
      return (Sum T T2)
  | tcase t0 x1 t1 x2 t2 =>
    T0 <- type_check Gamma t0 ;;
    match T0 with
    | Sum T01 T02 =>
      T1 <- type_check (x1 |-> T01; Gamma) t1 ;;
      T2 <- type_check (x2 |-> T02; Gamma) t2 ;;
      if eqb_ty T1 T2 then return T1 else fail
    | _ => fail
    end
  | tnil T => return (List T)
  | tcons t1 t2 =>
    T1 <- type_check Gamma t1 ;;
    T2 <- type_check Gamma t2 ;;
    match T2 with
    | List T3 =>
      if eqb_ty T1 T3 then return T2 else fail
    | _ => fail
    end
  | tlcase t0 t1 x21 x22 t2 =>
    match type_check Gamma t0 with
    | Some (List T) =>
      T1' <- type_check Gamma t1 ;;
      T2' <- type_check (x21 |-> T; x22 |-> (List T); Gamma) t2 ;;
      if eqb_ty T1' T2' then return T1' else fail
    | _ => fail
    end
  (* unit *)
  | unit => return Unit
  (* pairs *)
  | tpair t1 t2 =>
    T1 <- type_check Gamma t1 ;;
    T2 <- type_check Gamma t2 ;;
      return (Prod T1 T2)
  | tfst t =>
    T <- type_check Gamma t ;;
    match T with
    | Prod T1 T2 => return T1
    | _ => fail
    end
  | tsnd t =>
    T <- type_check Gamma t ;;
    match T with
    | Prod T1 T2 => return T2
    | _ => fail
    end
  | tlet x t1 t2 =>
    T1 <- type_check Gamma t1 ;;
    type_check (x |-> T1; Gamma) t2
  | tfix t1 =>
    T <- type_check Gamma t1 ;;
    match T with
    | Arrow T1 T2 =>
      if eqb_ty T1 T2 then return T1 else fail
    | _ => fail
    end
  end.

  Ltac invert_typecheck Gamma t T :=
    remember (type_check Gamma t) as TO;
    destruct TO as [T|];
    try solve_by_invert; try (inversion H0; eauto with db); try (subst; eauto with db).

  Ltac analyze T T1 T2 :=
    destruct T as [T1 T2 | |T1 T2|T1| |T1 T2]; try solve_by_invert.

  Ltac fully_invert_typecheck Gamma t T T T2 :=
    let TX := fresh T in
    remember (type_check Gamma t) as TO;
    destruct TO as [TX|]; try solve_by_invert;
    destruct TX as [T1 T2| |T1 T2|T1| |T1 T2];
    try solve_by_invert; try (inversion H0; eauto with db);
    try (subst; eauto with db).

  Ltac case_equality S T :=
    destruct (eqb_ty S T) eqn: Heqb;
    inversion H0; apply eqb_ty__eq in Heqb; subst; subst; eauto with db.

  Theorem type_checking_sound : forall Gamma t T,
      type_check Gamma t = Some T -> has_type Gamma t T.
  Proof with eauto with db.
    intros Gamma t. generalize dependent Gamma.
    induction t; intros Gamma T Htc; inversion Htc.
    - rename s into x. destruct (Gamma x) eqn:H.
      + inversion H0; subst. apply T_Var...
      + inversion H0.
    - invert_typecheck Gamma t1 T1.
      invert_typecheck Gamma t2 T2.
      analyze T1 T11 T12.
      case_equality T11 T2.
    - rename s into x. rename t into T1.
      remember (x |-> T1; Gamma) as Gamma'.
      invert_typecheck Gamma' t0 T0.
    - eauto with db.
    - rename t into t1.
      fully_invert_typecheck Gamma t1 T1 T11 T12.
    - rename t into t1.
      fully_invert_typecheck Gamma t1 T1 T11 T12.
    - invert_typecheck Gamma t1 T1.
      invert_typecheck Gamma t2 T2.
      analyze T1 T11 T12; analyze T2 T21 T22.
      inversion H0. subst...
    - invert_typecheck Gamma t1 T1.
      invert_typecheck Gamma t2 T2.
      invert_typecheck Gamma t3 T3.
      destruct T1; try solve_by_invert.
      case_equality T2 T3.
    - invert_typecheck Gamma t0 T1.
    - invert_typecheck Gamma t0 T2.
    - destruct (type_check Gamma t1) eqn:TS.
      + destruct t; try inversion H0.
        invert_typecheck (s |-> t4; Gamma) t2 T1.
        invert_typecheck (s0 |-> t5; Gamma) t3 T2.
        case_equality T1 T2.
      + inversion H0.
    - eauto with db.
    - invert_typecheck Gamma t1 T1.
      destruct (type_check Gamma t2) eqn: TL.
      + rename t into T'. destruct T'; try inversion H0.
        case_equality T1 T'.
      + inversion H0.
    - rename s into x31. rename s0 into x32.
      fully_invert_typecheck Gamma t1 T1 T11 T12.
      invert_typecheck Gamma t2 T2.
      remember (x31 |-> T1; x32 |-> List T1; Gamma) as G'.
      invert_typecheck G' t3 T3.
      case_equality T2 T3.
    - apply T_Unit.
    - invert_typecheck Gamma t1 T1.
      invert_typecheck Gamma t2 T2.
    - fully_invert_typecheck Gamma t T1 T11 T12.
    - fully_invert_typecheck Gamma t T1 T11 T12.
    - invert_typecheck Gamma t1 T1.
    - fully_invert_typecheck Gamma t T1 T11 T12.
      case_equality T1 T12.
  Qed.

  Theorem type_checking_complete : forall Gamma t T,
      has_type Gamma t T -> type_check Gamma t = Some T.
  Proof.
    intros Gamma t T Hty.
    induction Hty; simpl;
      try (rewrite IHHty);
      try (rewrite IHHty1);
      try (rewrite IHHty2);
      try (rewrite IHHty3);
      try (rewrite (eqb_ty_refl T));
      try (rewrite (eqb_ty_refl T1));
      try (rewrite (eqb_ty_refl T2));
      eauto.
    - destruct (Gamma x); try solve_by_invert. eauto with db.
  Qed.

End TypecheckerExtensions.

Module StepFunction.

  Import MoreStlc.
  Import STLCExtended.

  Fixpoint is_value (t : tm) : bool :=
    match t with
    | abs _ _ _ => true
    | const _ => true
    | tinl T t' => is_value t'
    | tinr T t' => is_value t'
    | tnil T => true
    | tcons t1 t2 => is_value t1 && is_value t2
    | unit => true
    | tpair t1 t2 => is_value t1 && is_value t2
    | _ => false
    end.

  Theorem is_value_sound : forall t,
      is_value t = true -> value t.
  Proof with eauto with db.
    intro t. induction t; intro H; try solve_by_invert; eauto with db...
    - inversion H. Search andb. rewrite andb_true_iff in H1.
      destruct H1 as [H1 H2].
      apply IHt1 in H1.
      apply IHt2 in H2.
      apply (v_lcons _ _ H1 H2).
    - inversion H. rewrite andb_true_iff in H1.
      destruct H1 as [H1 H2].
      apply IHt1 in H1.
      apply IHt2 in H2.
      apply (v_pair _ _ H1 H2).
  Qed.

  Theorem is_value_complete : forall t,
      value t -> is_value t = true.
  Proof.
    intros t H. induction H; simpl; eauto with db.
    - rewrite andb_true_iff; auto.
    - rewrite andb_true_iff; auto.
  Qed.

  Fixpoint stepf (t : tm) : option tm :=
    if is_value t then fail
    else
      match t with
      | var nm => fail
      | app t1 t2 =>
        if is_value t1 then
          if is_value t2 then
            match t1 with
            | abs x T11 t12 => return ([x:=t2]t12)
            | _ => fail
            end
          else
            t2' <- stepf t2 ;;
            return (app t1 t2')
        else
          t1' <- stepf t1 ;;
          return (app t1' t2)
    | scc t1 =>
      match t1 with
      | const n => return (const (S n))
      | _ => t1' <- stepf t1;; return (scc t1')
      end
    | prd t1 =>
      match t1 with
      | const n => return (const (Nat.pred n))
      | _ => t1' <- stepf t1 ;; return (prd t1')
      end
    | mlt t1 t2 =>
      match t1 with
      | const n1 =>
        match t2 with
        | const n2 => return (const (mult n1 n2))
        | _ => t2' <- stepf t2 ;; return (mlt t1 t2')
        end
      | _ =>
        if is_value t1 then
          fail
        else
          t1' <- stepf t1 ;; return (mlt t1' t2)
      end
    | test0 t1 t2 t3 =>
      match t1 with
      | const 0 => return t2
      | const (S n) => return t3
      | _ => t1' <- stepf t1 ;; return (test0 t1' t2 t3)
      end
    | tinl T t1 =>
      t1' <- stepf t1 ;; return (tinl T t1')
    | tinr T t1 =>
      t1' <- stepf t1 ;; return (tinr T t1')
    | tcase t0 y1 t1 y2 t2 =>
      if is_value t0 then
        match t0 with
        | tinl T v0 => return ([y1:=v0]t1)
        | tinr T v0 => return ([y2:=v0]t2)
        | _ => fail
        end
      else
        t0' <- stepf t0 ;; return (tcase t0' y1 t1 y2 t2)
    | tcons t1 t2 =>
      if is_value t1 then
        t2' <- stepf t2 ;; return (tcons t1 t2')
      else
        t1' <- stepf t1 ;; return (tcons t1' t2)
    | tlcase t1 t2 x1 x2 t3 =>
      match t1 with
      | tnil T => return t2
      | tcons v1 vl =>
        if is_value t1 then
          return (subst x2 vl (subst x1 v1 t3))
        else
          t1' <- stepf t1 ;; return (tlcase t1' t2 x1 x2 t3)
      | _ => t1' <- stepf t1 ;; return (tlcase t1' t2 x1 x2 t3)
      end
    | tpair t1 t2 =>
      if is_value t1 then
        t2' <- stepf t2 ;; return (tpair t1 t2')
      else
        t1' <- stepf t1 ;; return (tpair t1' t2)
    | tfst t =>
      if is_value t then
        match t with
        | tpair v1 v2 => return v1
        | _ => fail
        end
      else
        t' <- stepf t ;; return (tfst t')
    | tsnd t =>
      if is_value t then
        match t with
        | tpair v1 v2 => return v2
        | _ => fail
        end
      else
        t' <- stepf t ;; return (tsnd t')
    | tlet x t1 t2 =>
      if is_value t1 then
        return ([x:=t1]t2)
      else
        t1' <- stepf t1 ;; return (tlet x t1' t2)
    | tfix t =>
      match t with
      | abs xf T1 t2 => return ([xf:=tfix (abs xf T1 t2)] t2)
      | _ => t' <- stepf t ;; return (tfix t')
      end
    | _ => fail
    end.

  Theorem sound_stepf : forall t t',
      stepf t = Some t' -> t --> t'.
  Proof with eauto with db.
    intro t. induction t; intros t' H; try solve [inversion H].
    - inversion H. destruct (is_value t1) eqn:Vt1.
      + destruct (is_value t2) eqn:Vt2.
        * destruct t1; try inversion H1. subst.
          clear H1. apply ST_AppAbs. apply (is_value_sound _ Vt2).
        * destruct (stepf t2) eqn:St2; inversion H1; subst.
          clear H1. apply ST_App2.
          apply (is_value_sound _ Vt1). auto.
      + destruct (stepf t1) eqn:St1; inversion H1; subst.
        clear H1. apply ST_App1. auto.
    - inversion H. destruct (stepf t); destruct t; try inversion H1; subst...
    - inversion H. destruct (stepf t); destruct t; try inversion H1; subst...
    - inversion H. destruct (is_value t1) eqn:Vt1.
      + destruct t1; try solve [inversion H1].
        destruct (stepf t2) eqn:St2; destruct t2; inversion H1...
      + destruct (stepf t1) eqn:St1; destruct t1;
          try solve [inversion Vt1]; inversion H1...
    - inversion H. destruct (stepf t1); destruct t1; inversion H1...
      + destruct n; inversion H1...
      + destruct n; inversion H1...
    - inversion H. destruct (is_value t0) eqn:Vt0; inversion H1...
      destruct (stepf t0) eqn:St0; inversion H1...
    - inversion H. destruct (is_value t0) eqn:Vt0; inversion H1...
      destruct (stepf t0) eqn:St0; inversion H1...

    - inversion H. destruct (stepf t1) eqn:St1;
      destruct (is_value t1) eqn:Vt1;
      destruct t1; inversion H1;
      try apply is_value_sound in Vt1; inversion Vt1;
      try apply ST_CaseInl...
    - inversion H. destruct (is_value t1) eqn:Vt1.
      + destruct (is_value t2) eqn:Vt2.
        * simpl in H1; inversion H1.
        * simpl in H1. destruct (stepf t2) eqn:St2; inversion H1.
          apply ST_Cons2... apply is_value_sound...
      + simpl in H1. destruct (stepf t1) eqn:St1; inversion H1.
        apply ST_Cons1...
    - inversion H. destruct (stepf t1) eqn:St1.
      + destruct (is_value t1) eqn:Vt1.
        * destruct t1; inversion H1; inversion Vt1; inversion St1;
            try (rewrite H3 in H4; inversion H4).
        * destruct t1; inversion H1; inversion St1;
            apply ST_Lcase1; apply IHt1...
      + destruct t1; inversion H1; subst...
        destruct (is_value t1_1) eqn:Vt11.
        * destruct (is_value t1_2) eqn:Vt12.
          { simpl in H2. inversion H2. apply ST_LcaseCons.
            { apply is_value_sound. apply Vt11. }
            { apply is_value_sound. apply Vt12. }
          }
          { simpl in H2. inversion H2. }
        * simpl in H2. inversion H2.
    - inversion H. destruct (is_value t1) eqn: Vt1.
      + destruct (is_value t2) eqn: Vt2.
        * simpl in H1. inversion H1.
        * simpl in H1. destruct (stepf t2) eqn:St1; inversion H1.
          apply ST_Pair2.
          { apply is_value_sound. auto. }
          { apply IHt2... }
      + simpl in H1. destruct (stepf t1) eqn:St1; inversion H1.
        * apply ST_Pair1. apply IHt1...
    - inversion H. destruct (is_value t) eqn:Vt.
      + destruct t; inversion H1. inversion Vt. subst.
        rewrite andb_true_iff in H3. destruct H3 as [H3 H4].
        apply ST_FstPair; apply is_value_sound; assumption.
      + destruct (stepf t) eqn:St; inversion H1.
        apply ST_Fst. apply IHt...
    - inversion H. destruct (is_value t) eqn:Vt.
      + destruct t; inversion H1. inversion Vt. subst.
        rewrite andb_true_iff in H3. destruct H3 as [H3 H4].
        apply ST_SndPair; apply is_value_sound; assumption.
      + destruct (stepf t) eqn:St; inversion H1.
        apply ST_Snd. apply IHt...
    - inversion H. destruct (is_value t1) eqn:Vt1; inversion H1.
      + apply ST_LetValue. apply is_value_sound...
      + destruct (stepf t1) eqn:St1; inversion H2.
        apply ST_Let1. apply IHt1...
    - inversion H.
      destruct (stepf t) eqn: St; destruct t;
        inversion H1; inversion St;
          try (apply ST_Fix1; apply IHt); auto.
      apply ST_FixAbs.
  Qed.


Require Export XR_Rplus_comm.
Require Export XR_Rplus_lt_compat_l.

Local Open Scope R_scope.

Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r.
Proof.
intros x y z.
intro hyz.
repeat rewrite (Rplus_comm _ x).
apply Rplus_lt_compat_l.
exact hyz.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*          Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008        *)
(************************************************************************)

Local Open Scope type_scope.

Require Import List.

(** * Generic dependently-typed operators about [n]-ary functions *)

(** The type of [n]-ary function: [nfun A n B] is
    [A -> ... -> A -> B] with [n] occurrences of [A] in this type. *)

Fixpoint nfun A n B :=
 match n with
  | O => B
  | S n => A -> (nfun A n B)
 end.

Notation " A ^^ n --> B " := (nfun A n B)
 (at level 50, n at next level) : type_scope.

(** [napply_cst _ _ a n f] iterates [n] times the application of a
    particular constant [a] to the [n]-ary function [f]. *)

Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B :=
 match n return (A^^n-->B) -> B with
  | O => fun x => x
  | S n => fun x => napply_cst _ _ a n (x a)
 end.

(** A generic transformation from an n-ary function to another one.*)

Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n :
 (A^^n-->B) -> (A^^n-->C) :=
 match n return (A^^n-->B) -> (A^^n-->C) with
  | O => f
  | S n => fun g a => nfun_to_nfun _ _ _ f n (g a)
 end.

(** [napply_except_last _ _ n f] expects [n] arguments of type [A],
    applies [n-1] of them to [f] and discard the last one. *)

Definition napply_except_last (A B:Type) :=
 nfun_to_nfun A B (A->B) (fun b a => b).

(** [napply_then_last _ _ a n f] expects [n] arguments of type [A],
    applies them to [f] and then apply [a] to the result. *)

Definition napply_then_last (A B:Type)(a:A) :=
 nfun_to_nfun A (A->B) B (fun fab => fab a).

(** [napply_discard _ b n] expects [n] arguments, discards then,
    and returns [b]. *)

Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B :=
 match n return A^^n-->B with
  | O => b
  | S n => fun _ => napply_discard _ _ b n
 end.

(** A fold function *)

Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
 match n return (A^^n-->B) with
  | O => b
  | S n => fun a => (nfold _ _ f (f a b) n)
 end.

(** [n]-ary products : [nprod A n] is [A*...*A*unit],
  with [n] occurrences of [A] in this type. *)

Fixpoint nprod A n : Type := match n with
 | O => unit
 | S n => (A * nprod A n)%type
end.

Notation "A ^ n" := (nprod A n) : type_scope.

(** [n]-ary curryfication / uncurryfication *)

Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) :=
  match n return (A^n -> B) -> (A^^n-->B) with
  | O => fun x => x tt
  | S n => fun f a => ncurry _ _ n (fun p => f (a,p))
  end.

Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) :=
 match n return (A^^n-->B) -> (A^n -> B) with
  | O => fun x _ => x
  | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p
 end.

(** Earlier functions can also be defined via [ncurry/nuncurry].
    For instance : *)

Definition nfun_to_nfun_bis A B C (f:B->C) n :
 (A^^n-->B) -> (A^^n-->C) :=
 fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)).

(** We can also us it to obtain another [fold] function,
    equivalent to the previous one, but with a nicer expansion
    (see for instance Int31.iszero). *)

Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
 match n return (A^^n-->B) with
  | O => b
  | S n => fun a =>
      nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n)
 end.

(** From [nprod] to [list] *)

Fixpoint nprod_to_list (A:Type) n : A^n -> list A :=
 match n with
  | O => fun _ => nil
  | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p)
 end.

(** From [list] to [nprod] *)

Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) :=
 match l return A^(length l) with
  | nil => tt
  | x::l => (x, nprod_of_list _ l)
 end.

(** This gives an additional way to write the fold *)

Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) :=
  ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)).


(** * RecordSub_J: レコードのサブタイプ *)
(* * RecordSub: Subtyping with Records *)

(* $Date: 2011-04-04 09:00:42 -0400 (Mon, 04 Apr 2011) $ *)

Require Export MoreStlc_J.

(* ###################################################### *)
(* * Core Definitions *)
(** * 中核部の定義 *)

(* ################################### *)
(* *** Syntax *)
(** *** 構文 *)

Inductive ty : Type :=
  (* proper types *)
  | ty_Top   : ty
  | ty_base  : id -> ty
  | ty_arrow : ty -> ty -> ty
  (* record types *)
  | ty_rnil : ty
  | ty_rcons : id -> ty -> ty -> ty.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_Top" | Case_aux c "ty_base" | Case_aux c "ty_arrow"
  | Case_aux c "ty_rnil" | Case_aux c "ty_rcons" ].

Inductive tm : Type :=
  (* proper terms *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  | tm_proj : tm -> id -> tm
  (* record terms *)
  | tm_rnil :  tm
  | tm_rcons : id -> tm -> tm -> tm.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app" | Case_aux c "tm_abs"
  | Case_aux c "tm_proj" | Case_aux c "tm_rnil" | Case_aux c "tm_rcons" ].

(* ################################### *)
(* *** Well-Formedness *)
(** *** Well-Formedness *)

Inductive record_ty : ty -> Prop :=
  | rty_nil :
        record_ty ty_rnil
  | rty_cons : forall i T1 T2,
        record_ty (ty_rcons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtm_nil :
        record_tm tm_rnil
  | rtm_cons : forall i t1 t2,
        record_tm (tm_rcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfty_Top :
        well_formed_ty ty_Top
  | wfty_base : forall i,
        well_formed_ty (ty_base i)
  | wfty_arrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (ty_arrow T1 T2)
  | wfty_rnil :
        well_formed_ty ty_rnil
  | wfty_rcons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (ty_rcons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ################################### *)
(* *** Substitution *)
(** *** 置換 *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tm_var y => if beq_id x y then s else t
  | tm_abs y T t1 =>  tm_abs y T (if beq_id x y then t1 else (subst x s t1))
  | tm_app t1 t2 => tm_app (subst x s t1) (subst x s t2)
  | tm_proj t1 i => tm_proj (subst x s t1) i
  | tm_rnil => tm_rnil
  | tm_rcons i t1 tr2 => tm_rcons i (subst x s t1) (subst x s tr2)
  end.

(* ################################### *)
(* *** Reduction *)
(** *** 簡約 *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tm_abs x T t)
  | v_rnil : value tm_rnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (tm_rcons i v vr).

Hint Constructors value.

Fixpoint ty_lookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | ty_rcons i' T Tr' => if beq_id i i' then Some T else ty_lookup i Tr'
  | _ => None
  end.

Fixpoint tm_lookup (i:id) (tr:tm) : option tm :=
  match tr with
  | tm_rcons i' t tr' => if beq_id i i' then Some t else tm_lookup i tr'
  | _ => None
  end.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tm_app (tm_abs x T t12) v2) ==> (subst x v2 t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tm_app t1 t2) ==> (tm_app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tm_app v1 t2) ==> (tm_app v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tm_proj tr i) ==> (tm_proj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tm_lookup i tr = Some vi    ->
       (tm_proj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (tm_rcons i t1 tr2) ==> (tm_rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (tm_rcons i v1 tr2) ==> (tm_rcons i v1 tr2')

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj1" | Case_aux c "ST_ProjRcd" | Case_aux c "ST_Rcd"
  | Case_aux c "ST_Rcd_Head" | Case_aux c "ST_Rcd_Tail" ].

Hint Constructors step.

(* ###################################################################### *)
(* * Subtyping *)
(** * サブタイプ *)

(* Now we come to the interesting part.  We begin by defining
    the subtyping relation and developing some of its important
    technical properties. *)
(** おもしろい部分に来ました。サブタイプ関係を定義し、
    その重要な技術的性質のいくつかを調べることから始めます。 *)

(* ################################### *)
(* ** Definition *)
(** ** 定義 *)

(* The definition of subtyping is essentially just what we
    sketched in the motivating discussion, but we need to add
    well-formedness side conditions to some of the rules. *)
(** サブタイプの定義は、本質的には、動機付けの議論で概観した通りです。
    ただ、いくつかの規則に付加条件として well-formedness を追加する必要があります。 *)

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    subtype T T
  | S_Trans : forall S U T,
    subtype S U ->
    subtype U T ->
    subtype S T
  | S_Top : forall S,
    well_formed_ty S ->
    subtype S ty_Top
  | S_Arrow : forall S1 S2 T1 T2,
    subtype T1 S1 ->
    subtype S2 T2 ->
    subtype (ty_arrow S1 S2) (ty_arrow T1 T2)
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (ty_rcons i T1 T2) ->
    subtype (ty_rcons i T1 T2) ty_rnil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    subtype S1 T1 ->
    subtype Sr2 Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    subtype (ty_rcons i S1 Sr2) (ty_rcons i T1 Tr2)
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (ty_rcons i1 T1 (ty_rcons i2 T2 Tr3)) ->
    i1 <> i2 ->
    subtype (ty_rcons i1 T1 (ty_rcons i2 T2 Tr3))
            (ty_rcons i2 T2 (ty_rcons i1 T1 Tr3)).

Hint Constructors subtype.

Tactic Notation "subtype_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "S_Refl" | Case_aux c "S_Trans" | Case_aux c "S_Top"
  | Case_aux c "S_Arrow" | Case_aux c "S_RcdWidth"
  | Case_aux c "S_RcdDepth" | Case_aux c "S_RcdPerm" ].

(* ############################################### *)
(* ** Subtyping Examples and Exercises *)
(** ** サブタイプの例と練習問題 *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).
Notation j := (Id 3).
Notation k := (Id 4).
Notation i := (Id 5).
Notation A := (ty_base (Id 6)).
Notation B := (ty_base (Id 7)).
Notation C := (ty_base (Id 8)).

Definition ty_rcd_j  :=
  (ty_rcons j (ty_arrow B B) ty_rnil).     (* {j:B->B} *)
Definition ty_rcd_kj :=
  ty_rcons k (ty_arrow A A) ty_rcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (ty_arrow C ty_rcd_kj)
          (ty_arrow C ty_rnil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold ty_rcd_kj, ty_rcd_j. apply S_RcdWidth; auto.
Qed.

(* The following facts are mostly easy to prove in Coq.  To get
    full benefit from the exercises, make sure you also
    understand how to prove them on paper! *)
(** 以下の事実のほとんどはCoqで証明することは簡単です。
    練習問題の効果を最大にするため、どのように証明するかを理解していることを紙の上でも確認しなさい!
    *)

(* **** Exercise: 2 stars *)
(** **** 練習問題: ★★ *)
Example subtyping_example_1 :
  subtype ty_rcd_kj ty_rcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* **** Exercise: 1 star *)
(** **** 練習問題: ★ *)
Example subtyping_example_2 :
  subtype (ty_arrow ty_Top ty_rcd_kj)
          (ty_arrow (ty_arrow C C) ty_rcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* **** Exercise: 1 star *)
(** **** 練習問題: ★ *)
Example subtyping_example_3 :
  subtype (ty_arrow ty_rnil (ty_rcons j A ty_rnil))
          (ty_arrow (ty_rcons k B ty_rnil) ty_rnil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* **** Exercise: 2 stars *)
(** **** 練習問題: ★★ *)
Example subtyping_example_4 :
  subtype (ty_rcons x A (ty_rcons y B (ty_rcons z C ty_rnil)))
          (ty_rcons z C (ty_rcons y B (ty_rcons x A ty_rnil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Definition tm_rcd_kj :=
  (tm_rcons k (tm_abs z A (tm_var z))
           (tm_rcons j (tm_abs z B (tm_var z))
                      tm_rnil)).

End Examples.

(* ###################################################################### *)
(* ** Properties of Subtyping *)
(** ** サブタイプの性質 *)

(* *** Well-Formedness *)
(** *** Well-Formedness *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  subtype_cases (induction Hsub) Case;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  Case "S_RcdPerm".
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  ty_lookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  ty_cases (induction T) Case; intros; try solve by inversion.
  Case "ty_rcons".
    inversion H. subst. unfold ty_lookup in H0.
    remember (beq_id i i0) as b. destruct b; subst...
    inversion H0. subst...  Qed.

(* *** Field Lookup *)
(** *** フィールド参照 *)

(* Our record matching lemmas get a little more complicated in
    the presence of subtyping for two reasons: First, record
    types no longer necessarily describe the exact structure of
    corresponding terms.  Second, reasoning by induction on
    [has_type] derivations becomes harder in general, because
    [has_type] is no longer syntax directed. *)
(** サブタイプがあることで、レコードマッチング補題はいくらか複雑になります。
    それには2つの理由があります。
    1つはレコード型が対応する項の正確な構造を記述する必要がなくなることです。
    2つ目は、[has_type]の導出に関する帰納法を使う推論が一般には難しくなることです。
    なぜなら、[has_type]が構文指向ではなくなるからです。 *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  ty_lookup i T = Some Ti ->
  exists Si, ty_lookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  subtype_cases (induction Hsub) Case; intros Ti Hget;
    try solve by inversion.
  Case "S_Refl".
    exists Ti...
  Case "S_Trans".
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  Case "S_RcdDepth".
    rename i0 into k.
    unfold ty_lookup. unfold ty_lookup in Hget.
    remember (beq_id i k) as b. destruct b...
    SCase "i = k -- we're looking up the first field".
      inversion Hget. subst. exists S1...
  Case "S_RcdPerm".
    exists Ti. split.
    SCase "lookup".
      unfold ty_lookup. unfold ty_lookup in Hget.
      remember (beq_id i i1) as b. destruct b...
      SSCase "i = i1 -- we're looking up the first field".
        remember (beq_id i i2) as b. destruct b...
        SSSCase "i = i2 - -contradictory".
          destruct H0.
          apply beq_id_eq in Heqb. apply beq_id_eq in Heqb0.
          subst...
    SCase "subtype".
      inversion H. subst. inversion H5. subst...  Qed.

(* **** Exercise: 3 stars (rcd_types_match_informal) *)
(** **** 練習問題: ★★★ (rcd_types_match_informal) *)
(* Write a careful informal proof of the [rcd_types_match]
    lemma. *)
(** [rcd_types_match]補題の非形式的証明を注意深く記述しなさい。 *)

(* FILL IN HERE *)
(** [] *)

(* *** Inversion Lemmas *)
(** *** 反転補題 *)

(* **** Exercise: 3 stars, optional (sub_inversion_arrow) *)
(** **** 練習問題: ★★★, optional (sub_inversion_arrow) *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (ty_arrow V1 V2) ->
     exists U1, exists U2,
       (U=(ty_arrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (ty_arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(* * Typing *)
(** * 型付け *)

Definition context := id -> (option ty).
Definition empty : context := (fun _ => None).
Definition extend (Gamma : context) (x:id) (T : ty) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tm_app t1 t2) T2
  | T_Proj : forall Gamma i t T Ti,
      has_type Gamma t T ->
      ty_lookup i T = Some Ti ->
      has_type Gamma (tm_proj t i) Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      has_type Gamma t S ->
      subtype S T ->
      has_type Gamma t T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      has_type Gamma tm_rnil ty_rnil
  | T_RCons : forall Gamma i t T tr Tr,
      has_type Gamma t T ->
      has_type Gamma tr Tr ->
      record_ty Tr ->
      record_tm tr ->
      has_type Gamma (tm_rcons i t tr) (ty_rcons i T Tr).

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Proj" | Case_aux c "T_Sub"
  | Case_aux c "T_RNil" | Case_aux c "T_RCons" ].

(* ############################################### *)
(* ** Typing Examples *)
(** ** 型付けの例 *)

Module Examples2.
Import Examples.

(* **** Exercise: 1 star *)
(** **** 練習問題: ★ *)
Example typing_example_0 :
  has_type empty
           (tm_rcons k (tm_abs z A (tm_var z))
                     (tm_rcons j (tm_abs z B (tm_var z))
                               tm_rnil))
           ty_rcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* **** Exercise: 2 stars *)
(** **** 練習問題: ★★ *)
Example typing_example_1 :
  has_type empty
           (tm_app (tm_abs x ty_rcd_j (tm_proj (tm_var x) j))
                   (tm_rcd_kj))
           (ty_arrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j) {k=(\z:A.z), j=(\z:B.z)} : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* **** Exercise: 2 stars, optional *)
(** **** 練習問題: ★★, optional *)
Example typing_example_2 :
  has_type empty
           (tm_app (tm_abs z (ty_arrow (ty_arrow C C) ty_rcd_j)
                           (tm_proj (tm_app (tm_var z)
                                            (tm_abs x C (tm_var x)))
                                    j))
                   (tm_abs z (ty_arrow C C) tm_rcd_kj))
           (ty_arrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ###################################################################### *)
(* ** Properties of Typing *)
(** ** 型付けの性質 *)

(* *** Well-Formedness *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  has_type_cases (induction Htyp) Case...
  Case "T_App".
    inversion IHHtyp1...
  Case "T_Proj".
    eapply wf_rcd_lookup...
  Case "T_Sub".
    apply subtype__wf in H.
    destruct H...
Qed.

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

(* *** Field Lookup *)
(** *** フィールド参照 *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  ty_lookup i T = Some Ti ->
  exists vi, tm_lookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  has_type_cases (induction Htyp) Case; intros; subst; try solve by inversion.
  Case "T_Sub".
    apply (rcd_types_match S) in H0... destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  Case "T_RCons".
    simpl in H0. simpl. simpl in H1.
    remember (beq_id i i0) as b. destruct b.
    SCase "i is first".
      inversion H1. subst. exists t...
    SCase "i in tail".
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

(* ########################################## *)
(* *** Progress *)
(** *** 進行 *)

(* **** Exercise: 3 stars (canonical_forms_of_arrow_types) *)
(** **** 練習問題: ★★★ (canonical_forms_of_arrow_types) *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (ty_arrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tm_abs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  has_type_cases (induction Ht) Case;
    intros HeqGamma; subst...
  Case "T_Var".
    inversion H.
  Case "T_App".
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists (subst x t2 t12)...
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...
    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tm_app t1' t2)...
  Case "T_Proj".
    right. destruct IHHt...
    SCase "rcd is value".
      destruct (lookup_field_in_value t T i Ti) as [t' [Hget Ht']]...
    SCase "rcd_steps".
      destruct H0 as [t' Hstp]. exists (tm_proj t' i)...
  Case "T_RCons".
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2...
      SSCase "tail steps".
        right. destruct H2 as [tr' Hstp].
        exists (tm_rcons i t tr')...
    SCase "head steps".
      right. destruct H1 as [t' Hstp].
      exists (tm_rcons i t' tr)...  Qed.

(* Informal proof of progress:

    Theorem : For any term [t] and type [T], if [empty |- t : T]
      then [t] is a value or [t ==> t'] for some term [t'].

    Proof : Let [t] and [T] be given such that [empty |- t : T].  We go
      by induction on the typing derivation.  Cases [T_Abs] and
      [T_RNil] are immediate because abstractions and [{}] are always
      values.  Case [T_Var] is vacuous because variables cannot be
      typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that
        [t = t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and
        [empty |- t2 : T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then
          [t1 t2 ==> t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 ==> t2'] for some term [t2'].  Then
            [t1 t2 ==> t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for some
            [x], [S1], and [s2].  And [(\x:S1.s2) t2 ==> [t2/x]s2] by
            [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        is a term [tr], type [Tr] and label [i] such that [t = tr.i],
        [empty |- tr : Tr], and [ty_lookup i Tr = Some T].

        The IH for the typing subderivation gives us that either [tr]
        is a value or it steps.  If [tr ==> tr'] for some term [tr'],
        then [tr.i ==> tr'.i] by rule [ST_Proj1].

        Otherwise, [tr] is a value.  In this case, lemma
        [lookup_field_in_value] yields that there is a term [ti] such
        that [tm_lookup i tr = Some ti].  It follows that [tr.i ==> ti]
        by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then there
        exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
        that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
        [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then
          [{i=t1, tr} ==> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr ==> tr'] for some term [tr'].  Then
            [{i=t1, tr} ==> {i=t1, tr'}] by rule [ST_Rcd_Tail],
            since [t1] is a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)
(** 進行の非形式的証明:

    定理： 任意の項[t]と型[T]について、[empty |- t : T]ならば、
      [t]は値であるか、ある項[t']について [t ==> t'] である。

    証明 : [t]と[T]が [empty |- t : T] を満たすとする。
      型付け導出についての帰納法を使う。
      [T_Abs]と[T_RNil]の場合は自明である。それは、関数抽象と[{}]は常に値だからである。
      [T_Var]の場合は考えなくて良い。なぜなら変数は空コンテキストで型付けできないからである。

      - 型付け導出の最後のステップが[T_App]の適用だった場合、
        項 [t1] [t2] と型 [T1] [T2] があって [t = t1 t2]、[T = T2]、
        [empty |- t1 : T1 -> T2]、[empty |- t2 : T1] となる。

        これらの型付け導出の帰納法の仮定より、[t1]は値であるかステップを進めることができ、
        また[t2]は値であるかステップを進めることができる。
        それぞれの場合を考える:

        - ある項[t1']について [t1 ==> t1'] とする。
          すると[ST_App1]より [t1 t2 ==> t1' t2] である。

        - そうでないならば[t1]は値である。

          - ある項[t2']について [t2 ==> t2'] とする。
            すると[t1]が値であることから規則[ST_App2]により [t1 t2 ==> t1 t2'] となる。

          - そうでなければ[t2]は値である。補題[canonical_forms_for_arrow_types]により、
            ある[x]、[S1]、[s2]について [t1 = \x:S1.s2] である。
            すると[t2]が値であることから、[ST_AppAbs]により
            [(\x:S1.s2) t2 ==> [t2/x]s2] となる。

      - 導出の最後のステップが[T_Proj]の適用だった場合、
        項[tr]、型[Tr]、ラベル[i]が存在して [t = tr.i]、[empty |- tr : Tr]、
        [ty_lookup i Tr = Some T] となる。

        導出の一部である型付け導出の帰納仮定より、[tr]は値であるかステップを進むことができる。
        もしある項[tr']について [tr ==> tr'] ならば、規則[ST_Proj1]より
        [tr.i ==> tr'.i] となる。

        そうでなければ、[tr]は値である。この場合、補題[lookup_field_in_value]
        により項[ti]が存在して [tm_lookup i tr = Some ti] となる。
        これから、規則[ST_ProjRcd]より [tr.i ==> ti] となる。

      - 導出の最後のステップが[T_Sub]の適用だった場合、
        型[S]が存在して [S <: T] かつ [empty |- t : S] となる。
        導出の一部である型付け導出の帰納法の仮定から求める結果がすぐに得られる。

      - 導出の最後のステップが[T_RCons]の適用だった場合、
        項[t1] [tr]、型 [T1 Tr]、ラベル[i]が存在して
        [t = {i=t1, tr}]、[T = {i:T1, Tr}]、[record_tm tr]、
        [record_tm Tr]、[empty |- t1 : T1]、[empty |- tr : Tr] となる。

        これらの型付け導出についての帰納法の仮定より、[t1]は値であるか、ステップを進めることができ、
        [tr]は値であるかステップを進めることができることが言える。
        それそれの場合を考える:

        - ある項[t1']について [t1 ==> t1'] とする。
          すると規則[ST_Rcd_Head]から [{i=t1, tr} ==> {i=t1', tr}] となる。

        - そうではないとき、[t1]は値である。

          - ある項[tr']について [tr ==> tr'] とする。
            すると[t1]が値であることから、規則[ST_Rcd_Tail]より
            [{i=t1, tr} ==> {i=t1, tr'}] となる。

          - そうではないとき、[tr]も値である。すると、[v_rcons]から [{i=t1, tr}] は値である。
*)

(* ########################################## *)
(* *** Inversion Lemmas *)
(** *** 反転補題 *)

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

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tm_app t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (ty_arrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tm_app t1 t2) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_App".
    exists T1...
  Case "T_Sub".
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tm_abs x S1 t2) T ->
     (exists S2, subtype (ty_arrow S1 S2) T
              /\ has_type (extend Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tm_abs x S1 t2) as t.
  has_type_cases (induction H) Case;
    inversion Heqt; subst; intros; try solve by inversion.
  Case "T_Abs".
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  Case "T_Sub".
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (tm_proj t1 i) Ti ->
  exists T, exists Si,
    ty_lookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tm_proj t1 i) as t.
  has_type_cases (induction H) Case;
    inversion Heqt; subst; intros; try solve by inversion.
  Case "T_Proj".
    assert (well_formed_ty Ti) as Hwf.
      SCase "pf of assertion".
        apply (wf_rcd_lookup i T Ti)...
        apply has_type__wf in H...
    exists T. exists Ti...
  Case "T_Sub".
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U. exists Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (tm_rcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (ty_rcons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (tm_rcons i ti tr) as t.
  has_type_cases (induction Hty) Case;
    inversion Heqt; subst...
  Case "T_Sub".
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri. exists Rr...
  Case "T_RCons".
    assert (well_formed_ty (ty_rcons i T Tr)) as Hwf.
      SCase "pf of assertion".
        apply has_type__wf in Hty1.
        apply has_type__wf in Hty2...
    exists T. exists Tr...  Qed.

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

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

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tm_proj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (tm_rcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (tm_rcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold extend. remember (beq_id x x0) as e.
    destruct e...
  Case "T_App".
    apply T_App with T1...
  Case "T_RCons".
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; subst; inversion Hafi; subst...
  Case "T_Abs".
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold extend in Hctx. apply not_eq_beq_id_false in H3.
    rewrite H3 in Hctx...  Qed.

(* ########################################## *)
(* *** Preservation *)
(** *** 保存 *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma (subst x v t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  tm_cases (induction t) Case; intros; simpl.
  Case "tm_var".
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold extend in Hctx.
    remember (beq_id x y) as e. destruct e...
    SCase "x=y".
      apply beq_id_eq in Heqe. subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      destruct (subtype__wf _ _ Hsub)...
  Case "tm_app".
    destruct (typing_inversion_app _ _ _ _ Htypt) as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  Case "tm_abs".
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (ty_arrow T1 T2)... apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
  Case "tm_proj".
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  Case "tm_rnil".
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  Case "tm_rcons".
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (ty_rcons i Ti Tr)...
    apply T_RCons...
    SCase "record_ty Tr".
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    SCase "record_tm (subst x v t2)".
      inversion Hrcdt2; subst; simpl...  Qed.

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

(* Informal proof of [preservation]:

    Theorem: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t ==> t'], then [empty |- t' : T].

    Proof: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and {} don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [t2/x]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [t2/x] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [ty_lookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr ==> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tm_lookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)
(** [preservation]の非形式的証明:

    定理: [t]、[t']が項で[T]が型であり [empty |- t : T] かつ [t ==> t'] ならば、
     [empty |- t' : T] である。

    証明: [t]と[T]が [empty |- t : T] であるとする。
     [t']を特化しないまま、型付け導出の構造についての帰納法で証明を進める。
     [T_Var]の場合は前と同様考える必要はない。コンテキストが空だからである。

     - もし導出の最後ステップで使った規則が[T_App]ならば、
       項[t1] [t2]と型[T1] [T2]があり、[t = t1 t2]、
       [T = T2]、[empty |- t1 : T1 -> T2]、[empty |- t2 : T1] である。

       ステップ関係の定義を見ることにより、 [t1 t2] がステップを進める方法は3通りであることがわかる。
       [ST_App1]と[ST_App2]の場合は型付け導出の帰納法の仮定と[T_App]を使うことで、
       すぐに証明が完了する。

       そうではなく[ST_AppAbs]により [t1 t2] がステップを進めるとする。
       すると、ある型[S]と項[t12]について [t1 = \x:S.t12] かつ [t' = [t2/x]t12]
       となる。

       補題[abs_arrow]より、[T1 <: S] かつ [x:S1 |- s2 : T2] であるから、
       補題[substitution_preserves_typing]より [empty |- [t2/x] t12 : T2]
       となり、これが求める結果である。

     - もし導出の最後ステップで使った規則が[T_Proj]ならば、
       項[tr]、型[Tr]、ラベル[i]が存在して [t = tr.i] かつ [empty |- tr : Tr]
       かつ [ty_lookup i Tr = Some T] となる。

       型付け導出の帰納仮定より、任意の項[tr']について、[tr ==> tr'] ならば
       [empty |- tr' Tr] である。ステップ関係の定義より、射影がステップを進める方法は2つである。
       [ST_Proj1]の場合は帰納仮定からすぐに証明される。

       そうではなく[tr.i]のステップが[ST_ProjRcd]による場合、
       [tr]は値であり、ある項[vi]があって [tm_lookup i tr = Some vi] かつ
       [t' = vi] となる。しかし補題[lookup_field_in_value]より
       [empty |- vi : Ti] となるが、これが求める結果である。

     - もし導出の最後ステップで使った規則が[T_Sub]ならば、型[S]が存在して
       [S <: T] かつ [empty |- t : S] となる。
       型付け導出の帰納法の仮定と[T_Sub]の適用により結果がすぐに得られる。

     - もし導出の最後ステップで使った規則が[T_RCons]ならば、
       項 [t1] [tr]、型 [T1 Tr]、ラベル[i]が存在して
       [t = {i=t1, tr}]、[T = {i:T1, Tr}]、[record_tm tr]、
       [record_tm Tr]、[empty |- t1 : T1]、[empty |- tr : Tr] となる。

       ステップ関係の定義より、[t]は[ST_Rcd_Head]または[ST_Rcd_Tail]
       によってステップを進めたはずである。[ST_Rcd_Head]の場合、
       [t1]の型付け導出についての帰納仮定と[T_RCons]より求める結果が得られる。
       [ST_Rcd_Tail]の場合、[tr]の型付け導出についての帰納仮定、[T_RCons]、
       および[step_preserves_record_tm]補題の使用から求める結果が得られる。 *)

(* ###################################################### *)
(* ** Exercises on Typing *)
(** ** 型付けの練習問題 *)

(* **** Exercise: 2 stars, optional (variations) *)
(** **** 練習問題: ★★, optional (variations) *)
(* Each part of this problem suggests a different way of
    changing the definition of the STLC with records and
    subtyping.  (These changes are not cumulative: each part
    starts from the original language.)  In each part, list which
    properties (Progress, Preservation, both, or neither) become
    false.  If a property becomes false, give a counterexample.
    - Suppose we add the following typing rule:
[[[
                            Gamma |- t : S1->S2
                    S1 <: T1      T1 <: S1     S2 <: T2
                    -----------------------------------              (T_Funny1)
                            Gamma |- t : T1->T2
]]]

    - Suppose we add the following reduction rule:
[[[
                             ------------------                     (ST_Funny21)
                             {} ==> (\x:Top. x)
]]]

    - Suppose we add the following subtyping rule:
[[[
                               --------------                        (S_Funny3)
                               {} <: Top->Top
]]]

    - Suppose we add the following subtyping rule:
[[[
                               --------------                        (S_Funny4)
                               Top->Top <: {}
]]]

    - Suppose we add the following evaluation rule:
[[[
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})
]]]

    - Suppose we add the same evaluation rule *and* a new typing rule:
[[[
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})

                           ----------------------                    (T_Funny6)
                           empty |- {} : Top->Top
]]]

    - Suppose we *change* the arrow subtyping rule to:
[[[
                          S1 <: T1       S2 <: T2
                          -----------------------                    (S_Arrow')
                               S1->S2 <: T1->T2
]]]

[]
*)
(** この問題のそれぞれの部分は、レコードとサブタイプを持つSTLCの定義を変更する別々の方法を表しています。
    (これらの変更は累積的ではありません。それぞれの部分はもともとの言語から始めます。)
    それぞれの部分について、(進行、保存の)性質のうち成立するものをリストアップしなさい。
    また、成立しない性質について、反例を挙げなさい。
    - 次の型付け規則を追加する:
[[
                            Gamma |- t : S1->S2
                    S1 <: T1      T1 <: S1     S2 <: T2
                    -----------------------------------              (T_Funny1)
                            Gamma |- t : T1->T2
]]

    - 次の簡約規則を追加する:
[[
                             ------------------                     (ST_Funny21)
                             {} ==> (\x:Top. x)
]]

    - 次のサブタイプ規則を追加する:
[[
                               --------------                        (S_Funny3)
                               {} <: Top->Top
]]

    - 次のサブタイプ規則を追加する:
[[
                               --------------                        (S_Funny4)
                               Top->Top <: {}
]]

    - 次の評価規則を追加する:
[[
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})
]]

    - 上と同じ評価規則と新しい型付け規則を追加する:
[[
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})

                           ----------------------                    (T_Funny6)
                           empty |- {} : Top->Top
]]

    - 関数型についてのサブタイプ規則を次のものに変更する:
[[
                          S1 <: T1       S2 <: T2
                          -----------------------                    (S_Arrow')
                               S1->S2 <: T1->T2
]]

[]
*)