Require Import init.

Require Export ord_order.
Require Import ord_plus.
Require Import set.
Require Import function.
Require Export mult_ring.
Require Import nat.

Definition ord_mult_le (A B : ord_type) (a b : ord_U A * ord_U B) :=
    match a, b with
    | (a1, b1), (a2, b2) =>
        (ord_le B b1 b2 ∧ b1 ≠ b2) ∨ (ord_le A a1 a2 ∧ b1 = b2)
    end.

Lemma ord_mult_antisym : ∀ A B, Antisymmetric (ord_mult_le A B).
Proof.
    intros A B.
    get_ord_wo A.
    get_ord_wo B.
    split.
    intros [a1 b1] [a2 b2]
           [[b_eq1 b_neq1]|[a_eq1 b_eq1]] [[b_eq2 b_neq2]|[a_eq2 b_eq2]].
    -   pose proof (antisym b_eq1 b_eq2).
        contradiction.
    -   symmetry in b_eq2.
        contradiction.
    -   symmetry in b_eq1.
        contradiction.
    -   apply f_equal2; try exact b_eq1.
        apply antisym; assumption.
Qed.

Lemma ord_mult_wo : ∀ A B, WellOrdered (ord_mult_le A B).
Proof.
    intros A B.
    get_ord_wo A.
    get_ord_wo B.
    split.
    intros S [[xa xb] Sx].
    pose (SB b := ∃ a, S (a, b)).
    assert (∃ x, SB x) as SB_nempty.
    {
        exists xb.
        exists xa.
        exact Sx.
    }
    pose proof (well_ordered SB SB_nempty) as [yb [SBy yb_min]].
    pose (SA a := S (a, yb)).
    assert (∃ x, SA x) as SA_nempty by exact SBy.
    pose proof (well_ordered SA SA_nempty) as [ya [SAy ya_min]].
    exists (ya, yb).
    split; try assumption.
    intros [a b] Sab.
    cbn.
    classic_case (yb = b) as [eq|neq].
    -   subst yb.
        right.
        split; [>|reflexivity].
        apply ya_min.
        unfold SA.
        exact Sab.
    -   left.
        split; [>|exact neq].
        apply yb_min.
        unfold SB.
        exists a.
        exact Sab.
Qed.

Notation "A ⊗ B" :=
    (make_ord_type (ord_U A * ord_U B) (ord_mult_le A B)
    (ord_mult_antisym A B) (ord_mult_wo A B))
    : ord_scope.

(* begin hide *)
Section OrdMult.

Local Open Scope ord_scope.

Lemma ord_mult_wd : ∀ A B C D, A ~ B → C ~ D → A ⊗ C ~ B ⊗ D.
Proof.
    intros A B C D [f [f_bij f_iso]] [g [g_bij g_iso]].
    exists (λ x, (f (fst x), g (snd x))).
    split.
    split; split.
    -   intros [a1 c1] [a2 c2] eq.
        inversion eq as [eq1]; rename H into eq2.
        apply f_bij in eq1.
        apply g_bij in eq2.
        subst.
        reflexivity.
    -   intros [b d].
        pose proof (sur f b) as [a a_eq].
        pose proof (sur g d) as [c c_eq].
        exists (a, c); cbn.
        rewrite a_eq, c_eq.
        reflexivity.
    -   intros [a1 c1] [a2 c2]; cbn.
        rewrite f_iso.
        rewrite g_iso.
        assert ((c1 ≠ c2) = (g c1 ≠ g c2)) as eq1.
        {
            apply propositional_ext; split.
            -   intros neq eq.
                apply g_bij in eq.
                contradiction.
            -   intros neq eq.
                subst.
                contradiction.
        }
        assert ((c1 = c2) = (g c1 = g c2)) as eq2.
        {
            apply propositional_ext; split.
            -   intros eq.
                subst.
                reflexivity.
            -   intros eq.
                apply g_bij in eq.
                exact eq.
        }
        rewrite eq1, eq2.
        reflexivity.
Qed.

End OrdMult.

Open Scope ord_scope.

Global Instance ord_mult_class : Mult ord := {
    mult := binary_op (binary_self_wd ord_mult_wd)
}.

Lemma ord_ldist : ∀ α β γ, α * (β + γ) = α * β + α * γ.
Proof.
    intros A B C.
    equiv_get_value A B C.
    unfold plus, mult; equiv_simpl.
    exists (λ x, match (snd x) with
                 | inl b => inl (fst x, b)
                 | inr c => inr (fst x, c)
                 end).
    split.
    split; split.
    -   intros [a1 [b1|c1]] [a2 [b2|c2]] eq; cbn in *.
        all: inversion eq.
        all: reflexivity.
    -   intros [[a b]|[a c]].
        +   exists (a, inl b); cbn.
            reflexivity.
        +   exists (a, inr c); cbn.
            reflexivity.
    -   intros [a1 [b1|c1]] [a2 [b2|c2]]; cbn.
        +   rewrite inl_neq.
            rewrite inl_eq.
            reflexivity.
        +   split; try trivial.
            intros C0; clear C0.
            left.
            split; try trivial.
            intro eq; inversion eq.
        +   split; try contradiction.
            intros [[a b]|[c d]]; try contradiction.
            inversion d.
        +   rewrite inr_neq.
            rewrite inr_eq.
            reflexivity.
Qed.
Global Instance ord_ldist_class : Ldist ord := {
    ldist := ord_ldist
}.

Lemma ord_mult_assoc : ∀ α β γ, α * (β * γ) = (α * β) * γ.
Proof.
    intros A B C.
    equiv_get_value A B C.
    unfold mult; equiv_simpl.
    exists (λ x, ((fst x, fst (snd x)), snd (snd x))).
    split.
    split; split.
    -   intros [a1 [b1 c1]] [a2 [b2 c2]] eq; cbn in *.
        inversion eq.
        reflexivity.
    -   intros [[a b] c].
        exists (a, (b, c)).
        cbn.
        reflexivity.
    -   intros [a1 [b1 c1]] [a2 [b2 c2]].
        cbn.
        split.
        +   intros H.
            repeat destruct H.
            *   left; split; assumption.
            *   right; split; try assumption.
                left; split; try assumption.
                intro contr; subst; contradiction.
            *   inversion H0.
                right.
                split; try trivial.
                right; split; try assumption.
                reflexivity.
        +   intros H.
            repeat destruct H.
            *   left.
                split.
                --  left; split; assumption.
                --  intro contr; inversion contr; contradiction.
            *   left.
                split.
                --  right; split; assumption.
                --  intro contr; inversion contr; contradiction.
            *   right.
                split; try assumption.
                apply f_equal2; assumption.
Qed.
Global Instance ord_mult_assoc_class : MultAssoc ord := {
    mult_assoc := ord_mult_assoc
}.

Lemma ord_mult_lanni : ∀ α, 0 * α = 0.
Proof.
    intros A.
    symmetry.
    equiv_get_value A.
    unfold zero; cbn; unfold nat_to_ord, mult; equiv_simpl.
    assert (∀ m : set_type (λ m : nat, m < 0), False) as none.
    {
        intros [m m_lt].
        exact (nat_neg2 m_lt).
    }
    exists (λ x, False_rect _ (none x)).
    split.
    split; split.
    -   intros a.
        exfalso.
        apply none in a.
        contradiction.
    -   intros [a b].
        exfalso.
        apply none in a.
        contradiction.
    -   intros a.
        exfalso.
        apply none in a.
        contradiction.
Qed.
Global Instance ord_mult_lanni_class : MultLanni ord := {
    mult_lanni := ord_mult_lanni
}.

Lemma ord_mult_ranni : ∀ α, α * 0 = 0.
Proof.
    intros A.
    symmetry.
    equiv_get_value A.
    unfold zero; cbn; unfold nat_to_ord, mult; equiv_simpl.
    assert (∀ m : set_type (λ m : nat, m < 0), False) as none.
    {
        intros [m m_lt].
        exact (nat_neg2 m_lt).
    }
    exists (λ x, False_rect _ (none x)).
    split.
    split; split.
    -   intros a.
        exfalso.
        apply none in a.
        contradiction.
    -   intros [a b].
        exfalso.
        apply none in b.
        contradiction.
    -   intros a.
        exfalso.
        apply none in a.
        contradiction.
Qed.
Global Instance ord_mult_ranni_class : MultRanni ord := {
    mult_ranni := ord_mult_ranni
}.

Global Instance ord_one : One ord := {
    one := nat_to_ord 1
}.

Lemma ord_mult_lid : ∀ α, 1 * α = α.
Proof.
    intros A.
    symmetry.
    equiv_get_value A.
    unfold one; cbn; unfold nat_to_ord, mult; equiv_simpl.
    assert (zero (U := nat)  < 1) as z_lt.
    {
        split; try apply nat_pos.
        intro contr; inversion contr.
    }
    exists (λ x, ([0|z_lt], x)).
    split.
    split; split.
    -   intros a b eq.
        inversion eq.
        reflexivity.
    -   intros [a b].
        exists b.
        apply f_equal2; try reflexivity.
        destruct a as [a a_lt].
        apply set_type_eq; cbn.
        unfold one in a_lt; cbn in a_lt.
        rewrite nat_lt_suc_le in a_lt.
        apply nat_neg_eq.
        exact a_lt.
    -   intros a b.
        cbn.
        split.
        +   intros ab.
            classic_case (a = b) as [eq|neq].
            *   right.
                split; trivial.
                apply refl.
            *   left.
                split; assumption.
        +   intros [[c d]|[e f]].
            *   exact c.
            *   rewrite f.
                get_ord_wo A.
                destruct (connex b b); assumption.
Qed.
Global Instance ord_mult_lid_class : MultLid ord := {
    mult_lid := ord_mult_lid
}.

Lemma ord_mult_rid : ∀ α, α * 1 = α.
Proof.
    intros A.
    symmetry.
    equiv_get_value A.
    unfold one; cbn; unfold nat_to_ord, mult; equiv_simpl.
    assert (zero (U := nat)  < 1) as z_lt.
    {
        split; try apply nat_pos.
        intro contr; inversion contr.
    }
    exists (λ x, (x, [0|z_lt])).
    split.
    split; split.
    -   intros a b eq.
        inversion eq.
        reflexivity.
    -   intros [a b].
        exists a.
        apply f_equal2; try reflexivity.
        destruct b as [b b_lt].
        apply set_type_eq; cbn.
        unfold one in b_lt; cbn in b_lt.
        rewrite nat_lt_suc_le in b_lt.
        apply nat_neg_eq.
        exact b_lt.
    -   intros a b.
        cbn.
        split.
        +   intros ab.
            classic_case (a = b) as [eq|neq].
            *   right.
                split; trivial.
            *   right.
                split; trivial.
        +   intros [[c d]|[e f]].
            *   contradiction.
            *   exact e.
Qed.
Global Instance ord_mult_rid_class : MultRid ord := {
    mult_rid := ord_mult_rid
}.

Lemma ord_le_mult : ∀ α β, 0 ≤ α → 0 ≤ β → 0 ≤ α * β.
Proof.
    intros α β a b.
    apply ord_le_zero.
Qed.
Global Instance ord_le_mult_class : OrderMult ord := {
    le_mult := ord_le_mult
}.
(* end hide *)

Theorem ord_lt_lmult : ∀ {α β} γ, zero ≠ γ → α < β → γ * α < γ * β.
Proof.
    intros A B C C_neq lt.
    equiv_get_value A B C.
    get_ord_wo B.
    get_ord_wo C.
    unfold mult; equiv_simpl.
    rewrite ord_lt_initial in *.
    destruct lt as [x [f [f_bij f_iso]]].
    assert (∃ x : ord_U C, True) as C_nempty.
    {
        classic_contradiction contr.
        apply C_neq.
        symmetry.
        rewrite not_ex in contr.
        rewrite not_true in contr.
        unfold zero; cbn.
        unfold nat_to_ord; equiv_simpl.
        exists (λ x, False_rect _ (contr x)).
        split.
        split; split.
        -   intros a.
            contradiction (contr a).
        -   intros [b b_eq].
            contradiction (nat_neg2 b_eq).
        -   intros a.
            contradiction (contr a).
    }
    pose proof (well_ordered _ C_nempty) as [y [C0 y_min']]; clear C0.
    assert (∀ c : ord_U C, ord_le C y c) as y_min.
    {
        intros c.
        apply y_min'.
        exact true.
    }
    clear y_min'.
    exists (y, x).
    pose (g (ca : ord_U (C ⊗ A)) := (fst ca, [f (snd ca)|])).
    assert (∀ ca, initial_segment_set (C ⊗ B) (y, x) (g ca)) as g_in.
    {
        intros [c a].
        unfold g; cbn.
        destruct (f a) as [fa fa_lt]; cbn.
        split; cbn.
        -   left.
            exact fa_lt.
        -   intro contr; inversion contr.
            subst x.
            destruct fa_lt; contradiction.
    }
    exists (λ ca, [g ca|g_in ca]).
    split.
    split; split.
    -   intros [c1 a1] [c2 a2] eq.
        unfold g in eq; cbn in eq.
        inversion eq as [[eq1 eq2]].
        apply set_type_eq in eq2.
        apply f_bij in eq2.
        rewrite eq2; reflexivity.
    -   intros [[c b] cb_lt].
        assert (initial_segment_set B x b) as b_lt.
        {
            destruct cb_lt as [[leq|leq] neq].
            -   exact leq.
            -   destruct leq as [leq eq].
                subst b.
                specialize (y_min c).
                pose proof (antisym y_min leq).
                subst c.
                contradiction.
        }
        pose proof (sur f [b|b_lt]) as [a a_eq].
        exists (c, a).
        apply set_type_eq; cbn.
        unfold g; cbn.
        apply f_equal2; try reflexivity.
        rewrite a_eq.
        reflexivity.
    -   intros [c1 a1] [c2 a2].
        cbn.
        rewrite f_iso; cbn.
        unfold initial_segment_le.
        assert ((a1 ≠ a2) = ([f a1|] ≠ [f a2|])) as eq1.
        {
            apply propositional_ext; split; intros neq eq.
            -   apply set_type_eq in eq.
                apply f_bij in eq.
                contradiction.
            -   subst; contradiction.
        }
        assert ((a1 = a2) = ([f a1|] = [f a2|])) as eq2.
        {
            apply propositional_ext; split; intros eq.
            -   rewrite eq; reflexivity.
            -   apply set_type_eq in eq.
                apply f_bij in eq.
                exact eq.
        }
        rewrite eq1, eq2.
        reflexivity.
Qed.

Theorem ord_le_lmult : ∀ {α β} γ, α ≤ β → γ * α ≤ γ * β.
Proof.
    intros α β γ leq.
    classic_case (0 = γ) as [γ_eq|γ_neq].
    -   rewrite <- γ_eq.
        do 2 rewrite mult_lanni.
        apply refl.
    -   classic_case (α = β) as [eq|neq].
        +   rewrite eq.
            apply refl.
        +   apply ord_lt_lmult; try split; assumption.
Qed.
Lemma ord_le_lmult_pos : ∀ α β γ, 0 ≤ γ → α ≤ β → γ * α ≤ γ * β.
Proof.
    intros α β γ z leq.
    apply ord_le_lmult.
    exact leq.
Qed.
(* begin hide *)
Global Instance ord_le_lmult_class : OrderLmult ord := {
    le_lmult_pos := ord_le_lmult_pos
}.
(* end hide *)

Theorem ord_lt_rmult : ∀ {α β} γ, α < β → α * γ ≤ β * γ.
Proof.
    intros A B C eq.
    classic_contradiction contr.
    rewrite nle_lt in contr.
    equiv_get_value A B C.
    get_ord_wo B.
    get_ord_wo C.
    unfold mult in contr; equiv_simpl in contr.
    rewrite ord_lt_initial in eq, contr.
    destruct eq as [b [f [f_bij f_iso]]].
    destruct contr as [[a c] [g [g_bij g_iso]]].
    pose (h x := ([f (fst [g x|])|], snd [g x|])).
    assert (Injective h) as h_inj.
    {
        split.
        intros [b1 c1] [b2 c2] eq.
        unfold h in eq.
        inversion eq as [[eq1 eq2]].
        apply set_type_eq in eq1.
        apply f_bij in eq1.
        clear eq.
        pose proof (prod_combine _ _ eq1 eq2) as eq; clear eq1 eq2.
        apply set_type_eq in eq.
        apply g_bij in eq.
        exact eq.
    }
    assert (∀ a b, ord_le (B ⊗ C) a b ↔ ord_le (B ⊗ C) (h a) (h b)) as h_iso.
    {
        intros [b1 c1] [b2 c2].
        rewrite g_iso.
        cbn.
        destruct (g (b1, c1)) as [[gbc1_a gbc1_c] gbc1_lt]; cbn.
        destruct (g (b2, c2)) as [[gbc2_a gbc2_c] gbc2_lt]; cbn.
        rewrite f_iso.
        cbn.
        unfold initial_segment_le.
        reflexivity.
    }
    pose proof (ord_iso_le _ h h_inj h_iso (b, c)) as leq.
    unfold h in leq.
    destruct (g (b, c)) as [[gbc_a gbc_c] gbc_lt].
    cbn in leq.
    destruct (f gbc_a) as [fgbc fgbc_lt].
    unfold initial_segment_set in *.
    cbn in gbc_lt, leq.
    destruct gbc_lt as [gbc_lt gbc_neq].
    destruct fgbc_lt as [fgbc_lt fgbc_neq].
    destruct gbc_lt as [gbc_lt|gbc_lt], leq as [leq|leq].
    -   destruct gbc_lt as [gbc_lt gbc_neq2], leq as [leq_lt leq_neq].
        pose proof (antisym gbc_lt leq_lt).
        contradiction.
    -   destruct leq as [leq_lt leq_eq].
        symmetry in leq_eq.
        destruct gbc_lt; contradiction.
    -   destruct gbc_lt as [gbc_lt gbc_eq].
        symmetry in gbc_eq.
        destruct leq; contradiction.
    -   destruct leq as [leq_leq leq_eq].
        pose proof (antisym fgbc_lt leq_leq).
        contradiction.
Qed.

Theorem ord_le_rmult : ∀ {α β} γ, α ≤ β → α * γ ≤ β * γ.
Proof.
    intros α β γ leq.
    classic_case (0 = γ) as [γ_eq|γ_neq].
    -   rewrite <- γ_eq.
        do 2 rewrite mult_ranni.
        apply refl.
    -   classic_case (α = β) as [eq|neq].
        +   rewrite eq.
            apply refl.
        +   apply ord_lt_rmult; try split; assumption.
Qed.
Lemma ord_le_rmult_pos : ∀ α β γ, 0 ≤ γ → α ≤ β → α * γ ≤ β * γ.
Proof.
    intros α β γ z leq.
    apply ord_le_rmult.
    exact leq.
Qed.
(* begin hide *)
Global Instance ord_le_rmult_class : OrderRmult ord := {
    le_rmult_pos := ord_le_rmult_pos
}.
(* end hide *)

Lemma ord_mult_lcancel : ∀ α β γ, 0 ≠ γ → γ * α = γ * β → α = β.
Proof.
    intros α β γ γ_nz eq.
    destruct (trichotomy α β) as [[leq|H]|leq]; try assumption.
    -   apply ord_lt_lmult with γ in leq; try exact γ_nz.
        destruct leq; contradiction.
    -   symmetry in eq.
        apply ord_lt_lmult with γ in leq; try exact γ_nz.
        destruct leq; contradiction.
Qed.
(* begin hide *)
Global Instance ord_mult_lcancel_class : MultLcancel ord := {
    mult_lcancel := ord_mult_lcancel
}.
(* end hide *)

Theorem ord_lt_mult_lcancel : ∀ {α β} γ, γ * α < γ * β → α < β.
Proof.
    intros α β γ eq.
    classic_contradiction contr.
    rewrite nlt_le in contr.
    apply ord_le_lmult with γ in contr.
    rewrite <- nlt_le in contr.
    contradiction.
Qed.

Theorem ord_le_mult_lcancel : ∀ {α β} γ, 0 ≠ γ → γ * α ≤ γ * β → α ≤ β.
Proof.
    intros α β γ γ_nz leq.
    classic_case (α = β) as [eq|neq].
    -   rewrite <- eq.
        apply refl.
    -   apply ord_lt_mult_lcancel with γ.
        split; try exact leq.
        intro contr.
        apply mult_lcancel in contr; try exact γ_nz.
        contradiction.
Qed.
Lemma ord_le_mult_lcancel_pos : ∀ α β γ, 0 < γ → γ * α ≤ γ * β → α ≤ β.
Proof.
    intros α β γ [γ_leq γ_nz] leq.
    apply ord_le_mult_lcancel with γ; assumption.
Qed.
(* begin hide *)
Global Instance ord_le_mult_lcancel_pos_class : OrderMultLcancel ord := {
    le_mult_lcancel_pos := ord_le_mult_lcancel_pos
}.
(* end hide *)

Theorem ord_lt_mult_rcancel : ∀ {α β} γ, α * γ < β * γ → α < β.
Proof.
    intros α β γ eq.
    classic_contradiction contr.
    rewrite nlt_le in contr.
    apply ord_le_rmult with γ in contr.
    rewrite <- nlt_le in contr.
    contradiction.
Qed.

Theorem ord_mult_zero_is_zero : ∀ α β, 0 = α * β → {0 = α} + {0 = β}.
Proof.
    intros α β eq.
    classic_case (0 = α) as [α_z|α_nz].
    -   left; exact α_z.
    -   right.
        rewrite neq_sym in α_nz.
        rename α into A.
        rename β into B.
        rename α_nz into A_nz.
        equiv_get_value A B.
        unfold zero in *; cbn in *.
        unfold nat_to_ord, mult in *; equiv_simpl.
        equiv_simpl in eq.
        equiv_simpl in A_nz.
        destruct eq as [f [f_bij f_iso]].
        assert (∀ m : set_type (λ n : nat, n < 0), False) as m_empty.
        {
            intros [m m_lt].
            apply nat_neg2 in m_lt.
            contradiction.
        }
        assert (ord_U A) as a.
        {
            clear B f f_bij f_iso.
            assert (∃ a : ord_U A, True).
            {
                classic_contradiction contr.
                apply A_nz.
                rewrite not_ex in contr.
                rewrite not_true in contr.
                exists (λ x, False_rect _ (contr x)).
                split.
                split; split.
                +   intros m.
                    exfalso.
                    contradiction (contr m).
                +   intros m.
                    contradiction (m_empty m).
                +   intros m.
                    exfalso.
                    contradiction (contr m).
            }
            destruct (ex_to_type H).
            assumption.
        }
        exists (λ m, False_rect _ (m_empty m)).
        split.
        split; split.
        +   intros m.
            exfalso.
            contradiction (m_empty m).
        +   intros b.
            pose proof (sur f (a, b)) as [m m_eq].
            contradiction (m_empty m).
        +   intros m.
            exfalso.
            contradiction (m_empty m).
Qed.

Theorem ord_le_one : ∀ α, α < 1 → 0 = α.
Proof.
    intros A eq.
    equiv_get_value A.
    unfold zero, one in *; cbn in *.
    unfold nat_to_ord in *.
    equiv_simpl.
    rewrite ord_lt_initial in eq.
    destruct eq as [[x x_lt] [f [f_bij f_iso]]].
    cbn in *.
    assert (ord_U A → False) as a_empty.
    {
        intros a.
        pose proof (f a) as [[b b_lt] b_eq].
        destruct b_eq as [b_leq b_neq].
        cbn in b_leq.
        unfold one in x_lt; cbn in x_lt.
        pose proof x_lt as x_lt2.
        rewrite nat_lt_suc_le in x_lt2.
        apply nat_neg_eq in x_lt2.
        subst x.
        unfold le in b_leq; cbn in b_leq.
        apply nat_neg_eq in b_leq.
        subst.
        contradiction b_neq.
        apply set_type_eq; reflexivity.
    }
    assert (∀ m : set_type (λ n : nat, n < 0), False) as m_empty.
    {
        intros [m m_lt].
        apply nat_neg2 in m_lt.
        contradiction.
    }
    exists (λ m, False_rect _ (m_empty m)).
    split.
    split; split.
    +   intros m.
        exfalso.
        contradiction (m_empty m).
    +   intros a.
        contradiction (a_empty a).
    +   intros m.
        exfalso.
        contradiction (m_empty m).
Qed.

Theorem ord_le_self_lmult : ∀ α β, 0 ≠ β → α ≤ β * α.
Proof.
    intros α β β_nz.
    rewrite <- (mult_lid α) at 1.
    apply ord_le_rmult.
    classic_contradiction contr.
    rewrite nle_lt in contr.
    apply ord_le_one in contr.
    contradiction.
Qed.

Theorem ord_le_self_rmult : ∀ α β, 0 ≠ β → α ≤ α * β.
Proof.
    intros α β β_nz.
    rewrite <- (mult_rid α) at 1.
    apply ord_le_lmult.
    classic_contradiction contr.
    rewrite nle_lt in contr.
    apply ord_le_one in contr.
    contradiction.
Qed.

Theorem nat_to_ord_mult : ∀ a b,
    nat_to_ord a * nat_to_ord b = nat_to_ord (a * b).
Proof.
    intros a b.
    unfold nat_to_ord, mult at 1; equiv_simpl.
    pose (dom := prod_type (set_type (λ m, m < a)) (set_type (λ m, m < b))).
    pose (f (n : dom) := [fst n|] * b + [snd n|]).
    assert (∀ n : dom, f n < a * b) as f_in.
    {
        intros [[m m_lt] [n n_lt]].
        unfold f; cbn.
        clear dom f.
        destruct a.
        -   apply nat_neg2 in m_lt.
            contradiction.
        -   rewrite nat_mult_lsuc.
            rewrite nat_lt_suc_le in m_lt.
            apply nat_le_rmult with b in m_lt.
            apply le_rplus with n in m_lt.
            apply lt_lplus with (a * b) in n_lt.
            rewrite (plus_comm b).
            exact (le_lt_trans m_lt n_lt).
    }
    exists (λ x, [f x|f_in x]).
    split.
    split; split.
    -   intros [[m1 m1_lt] [n1 n1_lt]] [[m2 m2_lt] [n2 n2_lt]] eq.
        inversion eq as [eq2]; clear eq.
        unfold f in eq2; cbn in eq2.
        destruct (trichotomy m1 m2) as [[leq|eq]|leq].
        +   exfalso.
            apply nat_lt_ex in leq as [c c_eq].
            rewrite <- c_eq in eq2.
            rewrite rdist in eq2.
            rewrite <- plus_assoc in eq2.
            apply plus_lcancel in eq2.
            rewrite eq2 in n1_lt.
            rewrite nat_mult_lsuc in n1_lt.
            rewrite <- plus_assoc in n1_lt.
            rewrite <- (plus_rid b) in n1_lt at 3.
            apply lt_plus_lcancel in n1_lt.
            contradiction (nat_neg2 n1_lt).
        +   subst.
            apply plus_lcancel in eq2.
            subst.
            apply f_equal2; apply set_type_eq; reflexivity.
        +   exfalso.
            apply nat_lt_ex in leq as [c c_eq].
            rewrite <- c_eq in eq2.
            rewrite rdist in eq2.
            rewrite <- plus_assoc in eq2.
            apply plus_lcancel in eq2.
            rewrite <- eq2 in n2_lt.
            rewrite nat_mult_lsuc in n2_lt.
            rewrite <- plus_assoc in n2_lt.
            rewrite <- (plus_rid b) in n2_lt at 3.
            apply lt_plus_lcancel in n2_lt.
            contradiction (nat_neg2 n2_lt).
    -   intros [n n_lt].
        (* TODO: Finish this proof once you have Euclidean division *)
Abort.

Theorem ord_not_trivial : 0 ≠ 1.
Proof.
    intros contr.
    symmetry in contr.
    unfold one, zero in contr; cbn in contr.
    unfold nat_to_ord in contr; equiv_simpl in contr.
    destruct contr as [f].
    pose proof (nat_lt_suc 0) as z_lt.
    contradiction (nat_lt_0_false (f [0|z_lt])).
Qed.

Theorem ord_lt_1 : ∀ α, α < 1 → 0 = α.
Proof.
    intros A A_lt.
    equiv_get_value A.
    unfold one, zero in *; cbn in *.
    unfold nat_to_ord in *.
    equiv_simpl.
    rewrite ord_lt_initial in A_lt.
    destruct A_lt as [[z z_lt] [f [f_bij f_iso]]].
    pose proof (nat_lt_one_eq z z_lt); subst z.
    exists (λ x, False_rect _ (nat_lt_0_false x)).
    split.
    1: split; split.
    -   intros a.
        contradiction (nat_lt_0_false a).
    -   intros a.
        exfalso.
        destruct (f a) as [[x x_lt'] x_lt]; cbn in *.
        unfold initial_segment_set in x_lt; cbn in x_lt.
        destruct x_lt as [leq neq].
        apply neq.
        apply antisym; try exact leq.
        unfold le; cbn.
        apply nat_pos.
    -   intros a.
        contradiction (nat_lt_0_false a).
Qed.
(* begin hide *)
Close Scope ord_scope.
(* end hide *)


Section Setoid.

  (** We define predicates over a type of states **)
  Axiom state: Type.
  Definition Pred:= state -> Prop.

  (** We consider extentional equivalence as our equivalence **)
  Definition PEq (P1 P2: Pred): Prop := forall x, P1 x <-> P2 x.
  Infix "≡" := PEq (at level 50).

  (** ≡ is an equivalence relation **)
  Lemma PEq_reflexive: forall P, P ≡ P.
  Proof.
    intros P s; split; auto.
  Qed.

  Lemma PEq_trans: forall P1 P2 P3 (H1: P1 ≡ P2) (H2: P2 ≡ P3),
      P1 ≡ P3.
  Proof.
    intros P1 P2 P3 H1 H2 s; split; intros H3; [apply H2, H1 | apply H1,H2]; assumption.
  Qed.

  Lemma PEq_symm: forall P1 P2 (H: P1 ≡ P2), P2 ≡ P1.
  Proof.
    intros P1 P2 H s; split; intros H'; apply H; assumption.
  Qed.

  (** However, at this point, we need to use these lemmas explicitly.
      We declare it a parametric relation.
   **)
  Require Import Coq.Setoids.Setoid.

  Add Parametric Relation: Pred PEq
      reflexivity proved by PEq_reflexive
      symmetry proved by PEq_symm
      transitivity proved by PEq_trans
        as PEq_equiv.

  (** Tactics are now supported **)
  Goal forall P, P ≡ P.
    reflexivity.
  Qed.

  (** The underlying mechanism are type classes **)
   Require Import Classes.RelationClasses.

   Instance PEq_equiv': @Equivalence Pred PEq :=
     { Equivalence_Reflexive := PEq_reflexive;
       Equivalence_Symmetric := PEq_symm;
       Equivalence_Transitive := PEq_trans}.

  (** The same can be done for weaker relations than equivalence ones.
      Here for an implication for instance
   **)

  Definition PWeaker (P1 P2: Pred): Prop := forall s, P2 s -> P1 s.
  Infix "⊆":= PWeaker (at level 10).
  Lemma PWeaker_reflexive: forall P, P ⊆ P.
  Proof.
    intros ? ?; auto.
  Qed.

  Lemma PWeaker_trans: forall P1 P2 P3 (H1: P1 ⊆ P2) (H2: P2 ⊆ P3), P1 ⊆ P3.
  Proof.
    intros P1 P2 P3 H1 H2 s H3; apply H1,H2,H3.
  Qed.

  Add Parametric Relation: Pred PWeaker
      reflexivity proved by PWeaker_reflexive
      transitivity proved by PWeaker_trans
        as PWeaker_preorder.

  (** We now turn to the question of morphisms **)

  (** We define the join of two predicates, as well as false **)
  Definition PJoin P1 P2: Pred := fun s => P1 s \/ P2 s.
  Infix "∪" := PJoin (at level 15, right associativity).
  Lemma Join_idempotent: forall Q, Q ≡ Q ∪ Q.
  Proof.
    intros Q s; split; intros H.
    left; assumption.
    destruct H; assumption.
  Qed.

  Goal forall Q, Q ≡ Q ∪ Q ∪ Q.
    intros Q.
    (** Fails violently **)
    (* rewrite <- Join_idempotent. *)
  Abort.

  Require Import Setoid.

  Add Parametric Morphism : PJoin with
        signature (PEq ==> PEq ==> PEq) as foo.
  Proof.
    intros Q1 Q1' eq1 Q2 Q2' eq2 s; split; intros H;
      (destruct H; [left; apply eq1; assumption | right; apply eq2; assumption]).
  Qed.

  Goal forall Q, Q ≡ Q ∪ Q ∪ Q.
    intros Q.
    do 2 rewrite <- Join_idempotent.
    reflexivity.
  Qed.

  (* Once again, instances can be defined explicitly *)
  Require Import Morphisms.
  Instance foo': Proper (PEq ==> PEq ==> PEq) PJoin.
  Proof.
    intros Q1 Q1' eq1 Q2 Q2' eq2 s; split; intros H;
      (destruct H; [left; apply eq1; assumption | right; apply eq2; assumption]).
  Qed.

  (** For non symmetric relations, we may specify covariant and contravariant morphisms **)
  Definition PImpl (P1 P2: Pred) := fun s => (P1 s -> P2 s).
  Infix "→" := PImpl (at level 15, right associativity).

  Add Parametric Morphism : PImpl with
        signature (PWeaker --> PWeaker ++> PWeaker) as foo''.
  Proof.
    intros Q1 Q1' impl1 Q2 Q2' impl2 s H H1.
    apply (impl2 s).
    apply H.
    apply (impl1 s).
    assumption.
  Qed.

End Setoid.


(** * RecordSub: Subtyping with Records *)

Require Export MoreStlc.

(* ###################################################### *)
(** * Core Definitions *)

(* ################################### *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | TTop   : ty
  | TBase  : id -> ty
  | TArrow : ty -> ty -> ty
  (* record types *)
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TTop" | Case_aux c "TBase" | Case_aux c "TArrow"
  | Case_aux c "TRNil" | Case_aux c "TRCons" ].

Inductive tm : Type :=
  (* proper terms *)
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  (* record terms *)
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tproj" | Case_aux c "trnil" | Case_aux c "trcons" ].

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

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

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

Inductive well_formed_ty : ty -> Prop :=
  | wfTTop :
        well_formed_ty TTop
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons 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
  | tvar y => if eq_id_dec x y then s else t
  | tabs y T t1 =>  tabs y T (if eq_id_dec x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr2 => trcons i (subst x s t1) (subst x s tr2)
  end.

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

(* ################################### *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_rnil : value trnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (trcons i v vr).

Hint Constructors value.

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

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

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tproj tr i) ==> (tproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons 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. *)

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 TTop
  | S_Arrow : forall S1 S2 T1 T2,
    subtype T1 S1 ->
    subtype S2 T2 ->
    subtype (TArrow S1 S2) (TArrow T1 T2)
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (TRCons i T1 T2) ->
    subtype (TRCons i T1 T2) TRNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    subtype S1 T1 ->
    subtype Sr2 Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    subtype (TRCons i S1 Sr2) (TRCons i T1 Tr2)
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (TRCons i1 T1 (TRCons i2 T2 Tr3)) ->
    i1 <> i2 ->
    subtype (TRCons i1 T1 (TRCons i2 T2 Tr3))
            (TRCons i2 T2 (TRCons 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 := (TBase (Id 6)).
Notation B := (TBase (Id 7)).
Notation C := (TBase (Id 8)).

Definition TRcd_j  :=
  (TRCons j (TArrow B B) TRNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  TRCons k (TArrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (TArrow C TRcd_kj)
          (TArrow C TRNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_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! *)

(** **** Exercise: 2 stars *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_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 (TArrow TTop TRcd_kj)
          (TArrow (TArrow C C) TRcd_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 (TArrow TRNil (TRCons j A TRNil))
          (TArrow (TRCons k B TRNil) TRNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars *)
Example subtyping_example_4 :
  subtype (TRCons x A (TRCons y B (TRCons z C TRNil)))
          (TRCons z C (TRCons y B (TRCons x A TRNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Definition trcd_kj :=
  (trcons k (tabs z A (tvar z))
           (trcons j (tabs z B (tvar z))
                      trnil)).

End Examples.

(* ###################################################################### *)
(** ** Properties of Subtyping *)

(** *** 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 ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  T_cases (induction T) Case; intros; try solve by inversion.
  Case "TRCons".
    inversion H. subst. unfold Tlookup in H0.
    destruct (eq_id_dec i i0)...  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. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  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 Tlookup. unfold Tlookup in Hget.
    destruct (eq_id_dec i k)...
    SCase "i = k -- we're looking up the first field".
      inversion Hget. subst. exists S1...
  Case "S_RcdPerm".
    exists Ti. split.
    SCase "lookup".
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eq_id_dec i i1)...
      SSCase "i = i1 -- we're looking up the first field".
        destruct (eq_id_dec i i2)...
        SSSCase "i = i2 - -contradictory".
          destruct H0.
          subst...
    SCase "subtype".
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars (rcd_types_match_informal) *)
(** Write a careful informal proof of the [rcd_types_match]
    lemma. *)

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

(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, optional (sub_inversion_arrow) *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (TArrow V1 V2) ->
     exists U1, exists U2,
       (U=(TArrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (TArrow 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 eq_id_dec x x' then Some T else Gamma x'.

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

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      has_type Gamma (tvar 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 (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (TArrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tapp t1 t2) T2
  | T_Proj : forall Gamma i t T Ti,
      has_type Gamma t T ->
      Tlookup i T = Some Ti ->
      has_type Gamma (tproj 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 trnil TRNil
  | 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 (trcons i t tr) (TRCons i T Tr)

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

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
           (trcons k (tabs z A (tvar z))
                     (trcons j (tabs z B (tvar z))
                               trnil))
           TRcd_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
           (tapp (tabs x TRcd_j (tproj (tvar x) j))
                   (trcd_kj))
           (TArrow 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 *)
Example typing_example_2 :
  has_type empty
           (tapp (tabs z (TArrow (TArrow C C) TRcd_j)
                           (tproj (tapp (tvar z)
                                            (tabs x C (tvar x)))
                                    j))
                   (tabs z (TArrow C C) trcd_kj))
           (TArrow 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 *)

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 ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  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.
    destruct (eq_id_dec i i0).
    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) *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (TArrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tabs 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 ([x:=t2]t12)...
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tapp 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 (tproj t' i)...
  Case "T_RCons".
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2...
      SSCase "tail steps".
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    SCase "head steps".
      right. destruct H1 as [t' Hstp].
      exists (trcons 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 ==> [x:=t2]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 [Tlookup 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 [tlookup 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]. *)

(* ########################################## *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tvar x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tvar 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 (tapp t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (TArrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tapp 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 (tabs x S1 t2) T ->
     (exists S2, subtype (TArrow S1 S2) T
              /\ has_type (extend Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tabs 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 (tproj t1 i) Ti ->
  exists T, exists Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tproj 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 (trcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (TRCons 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 (trcons 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 (TRCons 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 (tabs x S1 s2) (TArrow 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 (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (trcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (trcons 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. destruct (eq_id_dec x x0)...
  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. rewrite neq_id 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 ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  t_cases (induction t) Case; intros; simpl.
  Case "tvar".
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold extend in Hctx.
    destruct (eq_id_dec x y)...
    SCase "x=y".
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      destruct (subtype__wf _ _ Hsub)...
  Case "tapp".
    destruct (typing_inversion_app _ _ _ _ Htypt) as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  Case "tabs".
    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 (TArrow T1 T2)... apply T_Abs...
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst.  rewrite neq_id...
  Case "tproj".
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  Case "trnil".
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  Case "trcons".
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (TRCons i Ti Tr)...
    apply T_RCons...
    SCase "record_ty Tr".
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    SCase "record_tm ([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' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] 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 [Tlookup 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
       [tlookup 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. *)

(* ###################################################### *)
(** ** Exercises on Typing *)

(** **** Exercise: 2 stars, 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

[]
*)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)