Require Import axiom.axiom.
Require Import axiom.logic.
Require Import operation.basic.
Require Import relation.relation.
Require Import relation.function.
Require Import relation.util_function.
Require Import relation.equiv.
Require Import nat.inductive.
Require Import nat.nat.
Require Import nat.recursion.
Require Import nat.nat_arith.
Require Import nat.order.

(* Integer *)
Definition int_ctor_rel :=
  subset_ctor (fun x =>
    exists a b c d, x = ⟨⟨a, b⟩, ⟨c, d⟩⟩ /\ a +ₙ d = b +ₙ c)
    (cp (cp ω ω) (cp ω ω)).

Lemma int_ctor_rel_refl: r_refl int_ctor_rel (cp ω ω).
Proof.
  intros x P1.
  apply subset_intro.
  + apply cp_intro.
    - apply P1.
    - apply P1.
  + destruct (cp_elim _ _ _ P1) as [a [b [P2 [P3 P4]]]].
    exists a. exists b. exists a. exists b.
    split.
    - rewrite P4.
      reflexivity.
    - apply (add_commutative _ _ P2 P3).
Qed.

Lemma int_ctor_rel_sym: r_sym int_ctor_rel.
Proof.
  intros x y P1.
  apply subset_intro.
  + apply cp_swap.
    apply (subset_elim_2 _ _ _ P1).
  + destruct (subset_elim _ _ _ P1) as [P2 [a [b [c [d [P3 P4]]]]]].
    exists c. exists d. exists a. exists b.
    split.
    - apply (opair_equal_swap _ _ _ _ P3).
    - destruct (cp_elim_2 _ _ _ _ P2) as [P5 P6].
      rewrite (opair_equal_elim_fst _ _ _ _ P3) in P5.
      rewrite (opair_equal_elim_snd _ _ _ _ P3) in P6.
      destruct (cp_elim_2 _ _ _ _ P5) as [Q1 Q2].
      destruct (cp_elim_2 _ _ _ _ P6) as [Q3 Q4].
      rewrite (add_commutative _ _ Q3 Q2).
      rewrite (add_commutative _ _ Q4 Q1).
      symmetry.
      apply P4.
Qed.

Lemma int_ctor_rel_trans: r_trans int_ctor_rel.
Proof.
  intros x y z P1 P2.
  apply subset_intro.
  + apply cp_intro.
    - destruct (subset_elim _ _ _ P1) as [P3 _].
      destruct (cp_elim_2 _ _ _ _ P3) as [P4 _].
      apply P4.
    - destruct (subset_elim _ _ _ P2) as [P3 _].
      destruct (cp_elim_2 _ _ _ _ P3) as [_ P4].
      apply P4.
  + destruct (subset_elim _ _ _ P1) as [Q1 [a1 [a2 [a3 [a4 [Q2 Q3]]]]]].
    destruct (subset_elim _ _ _ P2) as [R1 [b1 [b2 [b3 [b4 [R2 R3]]]]]].
    exists a1. exists a2. exists b3. exists b4.
    split.
    - rewrite (opair_equal_elim_fst _ _ _ _ Q2).
      rewrite (opair_equal_elim_snd _ _ _ _ R2).
      reflexivity.
    - rewrite Q2 in Q1.
      destruct (cp_elim_2 _ _ _ _ Q1) as [Q4 Q5].
      destruct (cp_elim_2 _ _ _ _ Q4) as [Q6 Q7].
      destruct (cp_elim_2 _ _ _ _ Q5) as [Q8 Q9].
      rewrite R2 in R1.
      destruct (cp_elim_2 _ _ _ _ R1) as [_ R5].
      destruct (cp_elim_2 _ _ _ _ R5) as [R6 R7].
      pose (opair_equal_elim_snd _ _ _ _ Q2) as P3.
      rewrite (opair_equal_elim_fst _ _ _ _ R2) in P3.
      pose (add_equation _ _ _ _ Q3 R3) as P4.
      rewrite (opair_equal_elim_fst _ _ _ _ P3) in P4.
      rewrite (opair_equal_elim_snd _ _ _ _ P3) in P4.
      rewrite (add_commutative _ _ Q9 R6) in P4.
      rewrite (add_associative _ _ _ (add_is_nat _ _ Q7 Q8) R6 Q9) in P4.
      rewrite (add_commutative _ _
        (add_is_nat _ _ Q6 Q9) (add_is_nat _ _ Q8 R7)) in P4.
      rewrite (add_associative _ _ _ (add_is_nat _ _ Q8 R7) Q6 Q9) in P4.
      pose ((add_cancellation _ _ _
        (add_is_nat _ _ (add_is_nat _ _ Q8 R7) Q6)
        (add_is_nat _ _ (add_is_nat _ _ Q7 Q8) R6) Q9) P4) as P5.
      rewrite <- (add_associative _ _ _ Q8 R7 Q6) in P5.
      rewrite (add_commutative _ _ Q8 (add_is_nat _ _ R7 Q6)) in P5.
      rewrite (add_commutative _ _ R7 Q6) in P5.
      rewrite (add_commutative _ _ Q7 Q8) in P5.
      rewrite <- (add_associative _ _ _ Q8 Q7 R6) in P5.
      rewrite (add_commutative _ _ Q8 (add_is_nat _ _ Q7 R6)) in P5.
      apply ((add_cancellation _ _ _
        (add_is_nat _ _ Q6 R7)
        (add_is_nat _ _ Q7 R6) Q8) P5).
Qed.

Lemma int_ctor_rel_is_equiv_rel: equiv_rel int_ctor_rel (cp ω ω).
Proof.
  split. split.
  + apply cp_subset_rel.
  + split.
    - apply (cp_subset_dom _ _ (cp ω ω)).
      apply (subset_elim_2).
    - apply (cp_subset_ran _ (cp ω ω) _).
      apply (subset_elim_2).
  + split.
    - apply int_ctor_rel_refl.
    - split.
      * apply int_ctor_rel_sym.
      * apply int_ctor_rel_trans.
Qed.

Definition ℤ := (cp ω ω)[\ int_ctor_rel].

Definition int (m: set) (n: set) :=
  (cp ω ω)[int_ctor_rel, ⟨m, n⟩].

Notation "z.0" := (int n.0 n.0).

Notation "z.1" := (int n.1 n.0).

Notation "z.2" := (int n.2 n.0).

Notation "z.-1" := (int n.0 n.1).

Lemma int_ctor_is_int: forall m n, m ∈ ω -> n ∈ ω -> int m n ∈ ℤ.
Proof.
  intros m n P1 P2.
  apply (equiv_part_intro _ _ _ int_ctor_rel_is_equiv_rel).
  apply (cp_intro _ _ _ _ P1 P2).
Qed.

Lemma int_elim: forall x, x ∈ ℤ -> exists m n,
  m ∈ ω /\ n ∈ ω /\ x = (int m n).
Proof.
  intros x P1.
  destruct (equiv_part_elim_1 _ _ _ P1) as [s [P2 P3]].
  destruct (cp_elim _ _ _ P2) as [m [n [P4 [P5 P6]]]].
  exists m. exists n.
  split.
  + apply P4.
  + split.
    - apply P5.
    - rewrite P6 in P3.
      apply P3.
Qed.

Lemma int_elim_fst: forall m n, int m n ∈ ℤ -> m ∈ ω.
Proof.
  intros m n P1.
  destruct (int_elim _ P1) as [m2 [n2 [P2 [P3 P4]]]].
  symmetry in P4.
  pose (equiv_class_eq_elim _ _ _ _
    int_ctor_rel_is_equiv_rel (cp_intro _ _ _ _ P2 P3) P4) as P5.
  pose (equiv_rel_elim_2 _ _ _ _ int_ctor_rel_is_equiv_rel P5) as P6.
  destruct (cp_elim_2 _ _ _ _ P6) as [P7 _].
  apply P7.
Qed.

Lemma int_elim_snd: forall m n, int m n ∈ ℤ -> n ∈ ω.
Proof.
  intros m n P1.
  destruct (int_elim _ P1) as [m2 [n2 [P2 [P3 P4]]]].
  symmetry in P4.
  pose (equiv_class_eq_elim _ _ _ _
    int_ctor_rel_is_equiv_rel (cp_intro _ _ _ _ P2 P3) P4) as P5.
  pose (equiv_rel_elim_2 _ _ _ _ int_ctor_rel_is_equiv_rel P5) as P6.
  destruct (cp_elim_2 _ _ _ _ P6) as [_ P7].
  apply P7.
Qed.

Lemma int_intro: forall m n, m ∈ ω -> n ∈ ω -> int m n ∈ ℤ.
Proof.
  intros m n P1 P2.
  apply subset_intro.
  + apply subset_in_power.
    intros x P3.
    apply (equiv_rel_elim_2 _ _ _ _ int_ctor_rel_is_equiv_rel
      (equiv_class_elim_1 _ _ _ _ P3)).
  + exists (⟨m, n⟩).
    split.
    - is_nat.
    - reflexivity.
Qed.

Lemma zero_is_int: z.0 ∈ ℤ.
Proof.
  apply int_intro.
  apply empty_is_nat.
  apply empty_is_nat.
Qed.

Lemma one_is_int: z.1 ∈ ℤ.
Proof.
  apply int_intro.
  apply one_is_nat.
  apply empty_is_nat.
Qed.

Lemma two_is_int: z.2 ∈ ℤ.
Proof.
  apply int_intro.
  apply suc_is_nat.
  apply one_is_nat.
  apply empty_is_nat.
Qed.

Lemma int_equal_elim: forall m1 n1 m2 n2, m1 ∈ ω -> n1 ∈ ω ->
  int m1 n1 = int m2 n2 -> m1 +ₙ n2 = n1 +ₙ m2.
Proof.
  intros m1 n1 m2 n2 P1 P2 P3.
  pose (cp_intro _ _ _ _ P1 P2) as P4.
  pose (equiv_class_eq_elim _ _ _ _ int_ctor_rel_is_equiv_rel P4 P3) as P5.
  destruct (subset_elim _ _ _ P5) as [_ [a [b [c [d [P6 P7]]]]]].
  rewrite (opair_equal_elim_fst _ _ _ _ (opair_equal_elim_fst _ _ _ _ P6)).
  rewrite (opair_equal_elim_fst _ _ _ _ (opair_equal_elim_snd _ _ _ _ P6)).
  rewrite (opair_equal_elim_snd _ _ _ _ (opair_equal_elim_fst _ _ _ _ P6)).
  rewrite (opair_equal_elim_snd _ _ _ _ (opair_equal_elim_snd _ _ _ _ P6)).
  apply P7.
Qed.

Lemma int_equal_intro: forall m1 n1 m2 n2, m1 ∈ ω -> n1 ∈ ω ->
  m2 ∈ ω -> n2 ∈ ω -> m1 +ₙ n2 = n1 +ₙ m2 -> int m1 n1 = int m2 n2.
Proof.
  intros m1 n1 m2 n2 P1 P2 P3 P4 P5.
  apply equiv_class_eq_intro.
  apply (equiv_class_intro_1 _ _ _ _ int_ctor_rel_is_equiv_rel).
  apply subset_intro.
  + is_nat.
  + exists m1. exists n1. exists m2. exists n2.
    split.
    - reflexivity.
    - apply P5.
Qed.

Lemma int_zero_elim: forall m n, m ∈ ω -> n ∈ ω -> int m n = z.0 -> m = n.
Proof.
  intros m n P1 P2 P3.
  pose (int_equal_elim _ _ _ _ P1 P2 P3) as P4.
  rewrite (add_zero _ P1) in P4.
  rewrite (add_zero _ P2) in P4.
  apply P4.
Qed.

Lemma inverse_one_is_int: z.-1 ∈ ℤ.
Proof.
  apply int_intro.
  apply empty_is_nat.
  apply one_is_nat.
Qed.

Lemma int_zero_ne_one: z.0 <> z.1.
Proof.
  intros P1.
  pose (int_equal_elim _ _ _ _ empty_is_nat empty_is_nat P1) as P2.
  rewrite (add_zero _ empty_is_nat) in P2.
  rewrite (add_zero_l _ one_is_nat) in P2.
  pose (suc_intro_1 n.0) as P3.
  rewrite <- P2 in P3.
  absurd (n.0 ∈ n.0).
  + apply not_in_empty.
  + apply P3.
Qed.

Ltac is_nat_z :=
  repeat match goal with
    | [ H: int ?P _ ∈ ℤ |- ?P ∈ ω      ] => apply (int_elim_fst _ _ H)
    | [ H: int _ ?P ∈ ℤ |- ?P ∈ ω      ] => apply (int_elim_snd _ _ H)
    | [                 |- ⟨_, _⟩ ∈  ℤ ] => apply (int_intro)
    | [                 |- int _ _ ∈ ℤ ] => apply (int_ctor_is_int)
    | _ => is_nat
  end.
(*----------------------------------------------------------------------------*)

(* Addition *)
Definition int_add :=
  subset_ctor (fun x => exists m n p q,
    x = ⟨⟨int m n , int p q⟩, int (m +ₙ p) (n +ₙ q)⟩) (cp (cp ℤ ℤ) ℤ).

Notation "x +z y" := (int_add [ ⟨x, y⟩ ]) (at level 60, no associativity).

Lemma int_add_is_function: function int_add.
Proof.
  split.
  + apply cp_subset_rel.
  + intros a b1 b2 P1 P2.
    destruct (subset_elim _ _ _ P1) as [Q1 [qm [qn [qp [qq Q2]]]]].
    destruct (cp_elim_2 _ _ _ _ Q1) as [Q4 Q5].
    destruct (cp_elim _ _ _ Q4) as [qa [qb [Q6 [Q7 Q8]]]].
    rewrite (opair_equal_elim_snd _ _ _ _ Q2).
    rewrite (opair_equal_elim_fst _ _ _ _ Q2) in Q4.
    destruct (cp_elim_2 _ _ _ _ Q4) as [Q9 Q10].
    destruct (subset_elim _ _ _ P2) as [R1 [rm [rn [rp [rq R2]]]]].
    destruct (cp_elim_2 _ _ _ _ R1) as [R4 R5].
    destruct (cp_elim _ _ _ R4) as [ra [rb [R6 [R7 R8]]]].
    rewrite (opair_equal_elim_snd _ _ _ _ R2).
    rewrite (opair_equal_elim_fst _ _ _ _ R2) in R4.
    destruct (cp_elim_2 _ _ _ _ R4) as [R9 R10].
    apply equiv_class_eq_intro.
    apply (equiv_class_intro_1 _ _ _ _ int_ctor_rel_is_equiv_rel).
    apply subset_intro.
    - is_nat_z.
    - exists (qm +ₙ qp). exists (qn +ₙ qq).
      exists (rm +ₙ rp). exists (rn +ₙ rq).
      split.
      * reflexivity.
      * pose (opair_equal_elim_fst _ _ _ _ Q2) as P3.
        rewrite (opair_equal_elim_fst _ _ _ _ R2) in P3.
        apply (add_cancellation_2 _ _ _ _
          (int_equal_elim _ _ _ _ (int_elim_fst _ _ R9)
          (int_elim_snd _ _ R9) (opair_equal_elim_fst _ _ _ _ P3))).
        apply (add_cancellation_2 _ _ _ _
          (int_equal_elim _ _ _ _ (int_elim_fst _ _ R10)
          (int_elim_snd _ _ R10) (opair_equal_elim_snd _ _ _ _ P3))).
        nat_normal_form.
        nat_red.
        all: is_nat_z.
Qed.

Lemma int_add_dom: dom(int_add) = cp ℤ ℤ.
Proof.
  apply subset_asym.
  split.
  + intros x P1.
    destruct (dom_elim _ _ P1) as [y P2].
    destruct (cp_elim_2 _ _ _ _ (subset_elim_2 _ _ _ P2)) as [P3 _].
    apply P3.
  + intros x P1.
    destruct (cp_elim _ _ _ P1) as [a [b [P2 [P3 P4]]]].
    destruct (int_elim _ P2) as [qm [qn [Q1 [Q2 Q3]]]].
    destruct (int_elim _ P3) as [rm [rn [R1 [R2 R3]]]].
    apply dom_intro.
    exists (int (qm +ₙ rm) (qn +ₙ rn)).
    apply subset_intro.
    - is_nat_z.
    - exists qm. exists qn. exists rm. exists rn.
      rewrite P4.
      rewrite Q3.
      rewrite R3.
      reflexivity.
Qed.

Lemma int_add_ran: ran(int_add) = ℤ.
Proof.
  apply subset_asym.
  split.
  + intros y P1.
    destruct (ran_elim _ _ P1) as [x P2].
    destruct (cp_elim_2 _ _ _ _ (subset_elim_2 _ _ _ P2)) as [_ P3].
    apply P3.
  + intros y P1.
    destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
    apply ran_intro.
    exists (⟨int qm qn, int n.0 n.0⟩).
    apply subset_intro.
    - is_nat_z.
    - exists qm. exists qn. exists n.0. exists n.0.
      * rewrite Q3.
        rewrite (add_zero _ Q1).
        rewrite (add_zero _ Q2).
        reflexivity.
Qed.

Lemma int_add_is_int: forall a b, a ∈ ℤ -> b ∈ ℤ -> a +z b ∈ ℤ.
Proof.
  intros a b P1 P2.
  rewrite <- int_add_ran.
  apply (fval_ran _ _ int_add_is_function).
  rewrite int_add_dom.
  apply cp_intro.
  + apply P1.
  + apply P2.
Qed.

Ltac is_nat_z2 :=
  repeat match goal with
    | [ |- _ +z _ ∈ ℤ ] => apply int_add_is_int
    | _                 => is_nat_z
  end.

Lemma int_add_elim: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->
  (int m n) +z (int p q) = (int (m +ₙ p) (n +ₙ q)).
Proof.
  intros m n p q P1 P2 P3 P4.
  symmetry.
  apply (fval_intro _ _ _ int_add_is_function).
  apply subset_intro.
  + is_nat_z.
  + exists m. exists n. exists p. exists q.
    reflexivity.
Qed.

Lemma int_add_commutative: forall a b, a ∈ ℤ -> b ∈ ℤ -> a +z b = b +z a.
Proof.
  intros a b P1 P2.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  apply (fval_intro _ _ _ int_add_is_function).
  apply (subset_intro).
  + is_nat_z2.
  + exists rm. exists rn. exists qm. exists qn.
    rewrite Q3.
    rewrite R3.
    rewrite (int_add_elim _ _ _ _ Q1 Q2 R1 R2).
    rewrite (add_commutative _ _ Q1 R1).
    rewrite (add_commutative _ _ Q2 R2).
    reflexivity.
Qed.

Lemma int_add_associative: forall a b c, a ∈ ℤ -> b ∈ ℤ -> c ∈ ℤ ->
  a +z (b +z c) = (a +z b) +z c.
Proof.
  intros a b c P1 P2 P3.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  destruct (int_elim _ (int_add_is_int _ _ P1 P2)) as [tm [tn [T1 [T2 T3]]]].
  destruct (int_elim _ (int_add_is_int _ _ P2 P3)) as [um [un [U1 [U2 U3]]]].
  apply (fval_intro _ _ _ int_add_is_function).
  apply (subset_intro).
  + is_nat_z2.
  + exists tm. exists tn. exists sm. exists sn.
    apply (opair_equal_intro).
    - rewrite T3.
      rewrite S3.
      reflexivity.
    - rewrite <- (int_add_elim _ _ _ _ T1 T2 S1 S2).
      rewrite <- T3.
      rewrite Q3.
      rewrite R3.
      rewrite S3.
      rewrite (int_add_elim _ _ _ _ R1 R2 S1 S2).
      rewrite (int_add_elim _ _ _ _ Q1 Q2 R1 R2).
      rewrite (int_add_elim qm qn (rm +ₙ sm) (rn +ₙ sn)).
      rewrite (int_add_elim (qm +ₙ rm) (qn +ₙ rn) sm sn).
      f_equal.
      apply (add_associative _ _ _ Q1 R1 S1).
      apply (add_associative _ _ _ Q2 R2 S2).
      all: is_nat.
Qed.

Lemma int_add_zero: forall a, a ∈ ℤ -> a +z z.0 = a.
Proof.
  intros a P1.
  destruct (int_elim _ P1) as [m [n [P2 [P3 P4]]]].
  rewrite P4.
  rewrite (int_add_elim _ _ _ _ P2 P3 empty_is_nat empty_is_nat).
  rewrite (add_zero _ P2).
  rewrite (add_zero _ P3).
  reflexivity.
Qed.

Lemma int_add_equation: forall m n p q, m = n -> p = q -> m +z p = n +z q.
Proof.
  intros m n p q P1 P2.
  rewrite P1.
  rewrite P2.
  reflexivity.
Qed.
(*----------------------------------------------------------------------------*)

(* Multiple *)
Definition int_multi :=
  subset_ctor (fun x => exists m n p q,
    x = ⟨⟨int m n , int p q⟩, int ((m ×ₙ p) +ₙ (n ×ₙ q)) ((m ×ₙ q) +ₙ (n ×ₙ p))⟩)
    (cp (cp ℤ ℤ) ℤ).

Notation "x ×z y" := (int_multi [ ⟨x, y⟩ ]) (at level 60, no associativity).

Lemma int_multi_is_function: function int_multi.
Proof.
  split.
  + apply cp_subset_rel.
  + intros a b1 b2 P1 P2.
    destruct (subset_elim _ _ _ P1) as [Q1 [qm [qn [qp [qq Q2]]]]].
    destruct (cp_elim_2 _ _ _ _ Q1) as [Q4 Q5].
    destruct (cp_elim _ _ _ Q4) as [qa [qb [Q6 [Q7 Q8]]]].
    rewrite (opair_equal_elim_snd _ _ _ _ Q2).
    rewrite (opair_equal_elim_fst _ _ _ _ Q2) in Q4.
    destruct (cp_elim_2 _ _ _ _ Q4) as [Q9 Q10].
    destruct (subset_elim _ _ _ P2) as [R1 [rm [rn [rp [rq R2]]]]].
    destruct (cp_elim_2 _ _ _ _ R1) as [R4 R5].
    destruct (cp_elim _ _ _ R4) as [ra [rb [R6 [R7 R8]]]].
    rewrite (opair_equal_elim_snd _ _ _ _ R2).
    rewrite (opair_equal_elim_fst _ _ _ _ R2) in R4.
    destruct (cp_elim_2 _ _ _ _ R4) as [R9 R10].
    apply equiv_class_eq_intro.
    apply (equiv_class_intro_1 _ _ _ _ int_ctor_rel_is_equiv_rel).
    apply subset_intro.
    - is_nat_z.
    - exists (qm ×ₙ qp +ₙ qn ×ₙ qq).
      exists (qm ×ₙ qq +ₙ qn ×ₙ qp).
      exists (rm ×ₙ rp +ₙ rn ×ₙ rq).
      exists (rm ×ₙ rq +ₙ rn ×ₙ rp).
      split.
      * reflexivity.
      * pose (opair_equal_elim_fst _ _ _ _ Q2) as P3.
        rewrite (opair_equal_elim_fst _ _ _ _ R2) in P3.
        pose (int_equal_elim _ _ _ _
          (int_elim_fst _ _ R9) (int_elim_snd _ _ R9)
          (opair_equal_elim_fst _ _ _ _ P3)) as P4.
        apply (add_cancellation_2 _ _ _ _ (multi_equation_2 _ _ rp P4)).
        symmetry.
        apply (add_cancellation_2 _ _ _ _ (multi_equation_2 _ _ rq P4)).
        pose (int_equal_elim _ _ _ _
          (int_elim_fst _ _ R10) (int_elim_snd _ _ R10)
          (opair_equal_elim_snd _ _ _ _ P3)) as P5.
        apply (add_cancellation_2 _ _ _ _ (multi_equation_2 _ _ qn P5)).
        symmetry.
        apply (add_cancellation_2 _ _ _ _ (multi_equation_2 _ _ qm P5)).
        nat_normal_form.
        rewrite (multi_commutative rq qm).
        rewrite (multi_commutative rp qn).
        rewrite (multi_commutative rq qn).
        rewrite (multi_commutative rq rm).
        rewrite (multi_commutative rp qm).
        rewrite (multi_commutative rp rn).
        rewrite (multi_commutative rn rq).
        rewrite (multi_commutative rp rm).
        nat_red.
        all: is_nat_z.
Qed.

Lemma int_multi_dom: dom(int_multi) = cp ℤ ℤ.
Proof.
  apply (subset_asym).
  split.
  + intros x P1.
    destruct (dom_elim _ _ P1) as [y P2].
    destruct (subset_elim _ _ _ P2) as [P3 _].
    destruct (cp_elim_2 _ _ _ _ P3) as [P4 _].
    apply P4.
  + intros x P1.
    destruct (cp_elim _ _ _ P1) as [a [b [P2 [P3 P4]]]].
    destruct (int_elim _ P2) as [qm [qn [Q1 [Q2 Q3]]]].
    destruct (int_elim _ P3) as [rm [rn [R1 [R2 R3]]]].
    apply dom_intro.
    exists (int ((qm ×ₙ rm) +ₙ (qn ×ₙ rn)) ((qm ×ₙ rn) +ₙ (qn ×ₙ rm))).
    apply subset_intro.
    - is_nat_z2.
    - exists qm. exists qn. exists rm. exists rn.
      rewrite P4.
      rewrite Q3.
      rewrite R3.
      reflexivity.
Qed.

Lemma int_multi_ran: ran(int_multi) = ℤ.
Proof.
  apply (subset_asym).
  split.
  + intros y P1.
    destruct (ran_elim _ _ P1) as [x P2].
    destruct (subset_elim _ _ _ P2) as [P3 _].
    destruct (cp_elim_2 _ _ _ _ P3) as [_ P4].
    apply P4.
  + intros x P1.
    destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
    apply ran_intro.
    exists (⟨int qm qn, int n.1 n.0⟩).
    apply subset_intro.
    - is_nat_z2.
    - exists qm. exists qn. exists n.1. exists n.0.
      rewrite Q3.
      rewrite (multi_zero _ Q1).
      rewrite (multi_zero _ Q2).
      rewrite (multi_one _ Q1).
      rewrite (multi_one _ Q2).
      rewrite (add_zero _ Q1).
      rewrite (add_commutative _ _ empty_is_nat Q2).
      rewrite (add_zero _ Q2).
      reflexivity.
Qed.

Lemma int_multi_is_int: forall a b, a ∈ ℤ -> b ∈ ℤ -> a ×z b ∈ ℤ.
Proof.
  intros a b P1 P2.
  rewrite <- int_multi_ran.
  apply (fval_ran _ _ int_multi_is_function).
  rewrite int_multi_dom.
  apply cp_intro.
  + apply P1.
  + apply P2.
Qed.

Ltac is_nat_z3 :=
  repeat match goal with
    | [ |- _ ×z _ ∈ ℤ ] => apply int_multi_is_int
    | _                 => is_nat_z2
  end.

Lemma int_multi_elim: forall m n p q, m ∈ ω -> n ∈ ω -> p ∈ ω -> q ∈ ω ->
  (int m n) ×z (int p q) = (int ((m ×ₙ p) +ₙ (n ×ₙ q)) ((m ×ₙ q) +ₙ (n ×ₙ p))).
Proof.
  intros m n p q P1 P2 P3 P4.
  symmetry.
  apply (fval_intro _ _ _ int_multi_is_function).
  apply subset_intro.
  + is_nat_z.
  + exists m. exists n. exists p. exists q.
    reflexivity.
Qed.

Lemma int_multi_commutative: forall a b, a ∈ ℤ -> b ∈ ℤ -> a ×z b = b ×z a.
Proof.
  intros a b P1 P2.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  apply (fval_intro _ _ _ int_multi_is_function).
  apply (subset_intro).
  + is_nat_z3.
  + exists rm. exists rn. exists qm. exists qn.
    rewrite Q3.
    rewrite R3.
    rewrite (int_multi_elim _ _ _ _ Q1 Q2 R1 R2).
    rewrite (multi_commutative _ _ Q1 R1).
    rewrite (multi_commutative _ _ Q2 R2).
    rewrite (multi_commutative _ _ Q1 R2).
    rewrite (multi_commutative _ _ Q2 R1).
    rewrite (add_commutative (rn ×ₙ qm) (rm ×ₙ qn)).
    reflexivity.
    all: is_nat.
Qed.

Lemma int_multi_associative: forall a b c, a ∈ ℤ -> b ∈ ℤ -> c ∈ ℤ ->
  a ×z (b ×z c) = (a ×z b) ×z c.
Proof.
  intros a b c P1 P2 P3.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  destruct (int_elim _ (int_multi_is_int _ _ P1 P2)) as [tm [tn [T1 [T2 T3]]]].
  destruct (int_elim _ (int_multi_is_int _ _ P2 P3)) as [um [un [U1 [U2 U3]]]].
  apply (fval_intro _ _ _ int_multi_is_function).
  apply (subset_intro).
  + is_nat_z3.
  + exists tm. exists tn. exists sm. exists sn.
    apply (opair_equal_intro).
    - rewrite T3.
      rewrite S3.
      reflexivity.
    - rewrite <- (int_multi_elim _ _ _ _ T1 T2 S1 S2).
      rewrite <- T3.
      rewrite Q3.
      rewrite R3.
      rewrite S3.
      rewrite (int_multi_elim _ _ _ _ R1 R2 S1 S2).
      rewrite (int_multi_elim _ _ _ _ Q1 Q2 R1 R2).
      rewrite (int_multi_elim qm qn _ _).
      rewrite (int_multi_elim _ _ sm sn).
      f_equal.
      nat_normal_form.
      rewrite (multi_cyc_2 _ _ _ R1 S2 Q2).
      rewrite (multi_cyc_2 _ _ _ R2 S2 Q1).
      rewrite (multi_cyc_2 _ _ _ R1 S1 Q1).
      rewrite (multi_cyc_2 _ _ _ R2 S1 Q2).
      nat_red.
      all: is_nat.
      nat_normal_form.
      rewrite (multi_cyc_2 _ _ _ R1 S1 Q2).
      rewrite (multi_cyc_2 _ _ _ R2 S1 Q1).
      rewrite (multi_cyc_2 _ _ _ R2 S2 Q2).
      rewrite (multi_cyc_2 _ _ _ R1 S2 Q1).
      nat_red.
      all: is_nat.
Qed.

Lemma int_multi_zero: forall a, a ∈ ℤ -> a ×z z.0 = z.0.
Proof.
  intros a P1.
  destruct (int_elim _ P1) as [m [n [P2 [P3 P4]]]].
  rewrite P4.
  rewrite (int_multi_elim _ _ _ _ P2 P3 empty_is_nat empty_is_nat).
  rewrite (multi_zero _ P2).
  rewrite (multi_zero _ P3).
  rewrite (add_zero _ empty_is_nat).
  reflexivity.
Qed.

Lemma int_multi_one: forall a, a ∈ ℤ -> a ×z z.1 = a.
Proof.
  intros a P1.
  destruct (int_elim _ P1) as [m [n [P2 [P3 P4]]]].
  rewrite P4.
  rewrite (int_multi_elim _ _ _ _ P2 P3 one_is_nat empty_is_nat).
  rewrite (multi_zero _ P2).
  rewrite (multi_zero _ P3).
  rewrite (multi_one _ P2).
  rewrite (multi_one _ P3).
  rewrite (add_zero _ P2).
  rewrite (add_zero_l _ P3).
  reflexivity.
Qed.

Lemma int_distributive_l: forall m n p, m ∈ ℤ -> n ∈ ℤ -> p ∈ ℤ ->
  m ×z (n +z p) = (m ×z n) +z (m ×z p).
Proof.
  intros m n p P1 P2 P3.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  destruct (int_elim _ P3) as [sm [sn [S1 [S2 S3]]]].
  rewrite Q3.
  rewrite R3.
  rewrite S3.
  rewrite (int_add_elim _ _ _ _ R1 R2 S1 S2).
  rewrite (int_multi_elim _ _ _ _ Q1 Q2 R1 R2).
  rewrite (int_multi_elim _ _ _ _ Q1 Q2 S1 S2).
  rewrite (int_multi_elim _ _ _ _ Q1 Q2
    (add_is_nat _ _ R1 S1) (add_is_nat _ _ R2 S2)).
  rewrite int_add_elim.
  all: is_nat.
  f_equal.
  + nat_normal_form.
    nat_red.
    all: is_nat.
  + nat_normal_form.
    nat_red.
    all: is_nat.
Qed.

Lemma int_distributive_r: forall m n p, m ∈ ℤ -> n ∈ ℤ -> p ∈ ℤ ->
  (m +z n) ×z p = (m ×z p) +z (n ×z p).
Proof.
  intros m n p P1 P2 P3.
  rewrite (int_multi_commutative (m +z n) p).
  rewrite (int_multi_commutative m p).
  rewrite (int_multi_commutative n p).
  apply int_distributive_l.
  all: is_nat_z3.
Qed.

Lemma int_multi_equation: forall m n p q, m = n -> p = q -> m ×z p = n ×z q.
Proof.
  intros m n p q P1 P2.
  rewrite P1.
  rewrite P2.
  reflexivity.
Qed.
(*----------------------------------------------------------------------------*)

(* Addition Inverse *)
Lemma int_add_inverse_exist: forall a, exists b, a ∈ ℤ -> b ∈ ℤ /\ a +z b = z.0.
Proof.
  intros a.
  destruct (LEM (a ∈ ℤ)) as [P1 | P1].
  + destruct (int_elim _ P1) as [m [n [P2 [P3 P4]]]].
    exists (int n m).
    intros P5.
    split.
    - apply (int_ctor_is_int _ _ P3 P2).
    - rewrite P4.
      rewrite (int_add_elim _ _ _ _ P2 P3 P3 P2).
      apply (equiv_class_eq_intro).
      apply (equiv_class_intro_1 _ _ _ _ int_ctor_rel_is_equiv_rel).
      apply (subset_intro).
      * is_nat_z2.
      * exists (m +ₙ n).
        exists (n +ₙ m).
        exists n.0. exists n.0.
        rewrite (add_commutative _ _ P2 P3).
        split.
        ++reflexivity.
        ++reflexivity.
  + exists ∅.
    intros P2.
    contradiction.
Qed.

Definition int_add_inverse (a:set) :=
  extract_set (int_add_inverse_exist a).

Notation "-z a" := (int_add_inverse a) (at level 60).

Lemma int_add_inverse_intro_1: forall a, a ∈ ℤ -> -z a ∈ ℤ.
Proof.
  intros a P1.
  destruct (extract_set_property (int_add_inverse_exist a) P1) as [P2 _].
  apply P2.
Qed.

Ltac is_nat_z4 :=
  repeat match goal with
    | [ |- -z _ ∈ ℤ ] => apply int_add_inverse_intro_1
    | _               => is_nat_z3
  end.

Lemma int_add_inverse_intro_2: forall a, a ∈ ℤ -> a +z (-z a) = z.0.
Proof.
  intros a P1.
  destruct (extract_set_property (int_add_inverse_exist a) P1) as [_ P2].
  apply P2.
Qed.

Lemma int_add_inverse_unique: forall a b, a ∈ ℤ -> b ∈ ℤ -> a +z b = z.0 ->
  b = -z a.
Proof.
  intros a b P1 P2 P4.
  pose (int_add_inverse_intro_1 _ P1) as P3.
  pose (int_add_inverse_intro_2 _ P1) as P5.
  pose (int_add_zero _ P2) as P6.
  rewrite <- P5 in P6.
  rewrite (int_add_associative _ _ _ P2 P1 P3) in P6.
  rewrite (int_add_commutative _ _ P2 P1) in P6.
  rewrite P4 in P6.
  rewrite (int_add_commutative _ _ zero_is_int P3) in P6.
  rewrite (int_add_zero _ P3) in P6.
  symmetry.
  apply P6.
Qed.

Lemma inverse_one_is_inverse_one: z.-1 = -z z.1.
Proof.
  apply (int_add_inverse_unique _ _ one_is_int inverse_one_is_int).
  rewrite int_add_elim.
  rewrite add_zero.
  rewrite add_zero_l.
  apply int_equal_intro.
  all: is_nat.
Qed.

Notation "a -z b"  := (a +z (-z b)) (at level 60).

Lemma int_add_inverse_elim_1: forall m n, m ∈ ω -> n ∈ ω -> -z int m n = int n m.
Proof.
  intros m n P1 P2.
  symmetry.
  apply int_add_inverse_unique.
  all: is_nat_z2.
  rewrite int_add_elim.
  apply int_equal_intro.
  all: is_nat_z2.
  rewrite add_zero.
  rewrite add_zero.
  rewrite add_commutative.
  all: is_nat_z2.
Qed.

Lemma int_add_inverse_elim_2: forall a, a ∈ ℤ -> -z a = z.-1 ×z a.
Proof.
  intros a P1.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  rewrite Q3.
  rewrite int_multi_commutative.
  rewrite int_multi_elim.
  rewrite multi_zero.
  rewrite multi_zero.
  rewrite multi_one.
  rewrite multi_one.
  rewrite add_zero.
  rewrite add_zero_l.
  apply int_add_inverse_elim_1.
  all: is_nat_z2.
Qed.

Lemma int_equal_add_1: forall a b c, a = b -> a +z c = b +z c.
Proof.
  intros a b c P1.
  rewrite P1.
  reflexivity.
Qed.

Lemma int_equal_add_2: forall a b c, a ∈ ℤ -> b ∈ ℤ -> c ∈ ℤ ->
  a +z c = b +z c -> a = b.
Proof.
  intros a b c P1 P2 P3 P4.
  pose (int_equal_add_1 _ _ (-z c) P4) as P5.
  rewrite <- int_add_associative in P5.
  rewrite <- int_add_associative in P5.
  rewrite int_add_inverse_intro_2 in P5.
  rewrite int_add_zero in P5.
  rewrite int_add_zero in P5.
  apply P5.
  all: is_nat_z4.
Qed.

Lemma int_equal_multi: forall a b c, a = b -> a ×z c = b ×z c.
Proof.
  intros a b c P1.
  rewrite P1.
  reflexivity.
Qed.

Lemma int_add_inverse_multi_distributive_l: forall a b, a ∈ ℤ -> b ∈ ℤ ->
  -z (a ×z b) = (-z a) ×z b.
Proof.
  intros a b P1 P2.
  rewrite (int_add_inverse_elim_2 (a ×z b)).
  rewrite int_multi_associative.
  rewrite <- (int_add_inverse_elim_2 a).
  reflexivity.
  all: is_nat_z3.
Qed.

Lemma int_add_inverse_multi_distributive_r: forall a b, a ∈ ℤ -> b ∈ ℤ ->
  -z (a ×z b) = a ×z (-z b).
Proof.
  intros a b P1 P2.
  rewrite (int_multi_commutative a b).
  rewrite (int_multi_commutative a (-z b)).
  apply int_add_inverse_multi_distributive_l.
  all: is_nat_z4.
Qed.

Lemma int_not_zero_elim: forall m n, m ∈ ω -> n ∈ ω -> int m n <> z.0 -> m <> n.
Proof.
  intros m n P1 P2 P3 P4.
  rewrite P4 in P3.
  absurd (int n n = z.0).
  + apply P3.
  + apply int_equal_intro.
    all: is_nat_z3.
Qed.

Lemma int_not_zero_intro: forall m n, m ∈ ω -> n ∈ ω -> m <> n -> int m n <> z.0.
Proof.
  intros m n P1 P2 P3 P4.
  absurd (m = n).
  + apply P3.
  + pose (int_equal_elim _ _ _ _ P1 P2 P4) as P5.
    rewrite (add_zero _ P1) in P5.
    rewrite (add_zero _ P2) in P5.
    apply P5.
Qed.

Lemma int_no_zero_divisor: forall m n, m ∈ ℤ -> n ∈ ℤ -> m ×z n = z.0
  -> m = z.0 \/ n = z.0.
Proof.
  intros m n P1 P2.
  apply contraposition4.
  intros P3.
  destruct (int_elim _ P1) as [qm [qn [Q1 [Q2 Q3]]]].
  destruct (int_elim _ P2) as [rm [rn [R1 [R2 R3]]]].
  rewrite Q3.
  rewrite R3.
  rewrite (int_multi_elim _ _ _ _ Q1 Q2 R1 R2).
  apply int_not_zero_intro.
  all: is_nat_z3.
  rewrite Q3 in P3.
  rewrite R3 in P3.
  destruct (not_or_and _ _ P3) as [Q4 R4].
  destruct (not_equal_less _ _ Q1 Q2 (int_not_zero_elim _ _ Q1 Q2 Q4)) as [Q5|Q5].
  + destruct (not_equal_less _ _ R1 R2 (int_not_zero_elim _ _ R1 R2 R4)) as [R5|R5].
    - apply (less_not_equal_2).
      all: is_nat_z3.
      apply (order_inequation _ _ _ _ Q1 Q2 R1 R2 Q5 R5).
    - apply (less_not_equal_1).
      all: is_nat_z3.
      apply (order_inequation _ _ _ _ Q1 Q2 R2 R1 Q5 R5).
  + destruct (not_equal_less _ _ R1 R2 (int_not_zero_elim _ _ R1 R2 R4)) as [R5|R5].
    - apply (less_not_equal_1).
      all: is_nat_z3.
      rewrite (add_commutative (qm ×ₙ rm) (qn ×ₙ rn)).
      rewrite (add_commutative (qm ×ₙ rn) (qn ×ₙ rm)).
      apply (order_inequation _ _ _ _ Q2 Q1 R1 R2 Q5 R5).
      all: is_nat_z3.
    - apply (less_not_equal_2).
      all: is_nat_z3.
      rewrite (add_commutative (qm ×ₙ rm) (qn ×ₙ rn)).
      rewrite (add_commutative (qm ×ₙ rn) (qn ×ₙ rm)).
      apply (order_inequation _ _ _ _ Q2 Q1 R2 R1 Q5 R5).
      all: is_nat_z3.
Qed.

Lemma int_multi_cancellation: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  l <> z.0 -> m ×z l = n ×z l -> m = n.
Proof.
  intros m n l P1 P2 P3 P4 P5.
  pose (int_equal_add_1 (m ×z l) (n ×z l) (-z (n ×z l)) P5) as P6.
  rewrite (int_add_inverse_intro_2 (n ×z l)) in P6.
  rewrite int_add_inverse_multi_distributive_l in P6.
  rewrite <- int_distributive_r in P6.
  destruct (int_no_zero_divisor (m +z (-z n)) l) as [P7|P7].
  all: is_nat_z4.
  + pose (int_equal_add_1 (m +z (-z n)) (z.0) n P7) as P8.
    rewrite <- int_add_associative in P8.
    rewrite (int_add_commutative (-z n) n) in P8.
    rewrite (int_add_inverse_intro_2 n) in P8.
    rewrite (int_add_zero) in P8.
    rewrite (int_add_commutative) in P8.
    rewrite (int_add_zero) in P8.
    apply P8.
    all: is_nat_z4.
  + contradiction.
Qed.
(*----------------------------------------------------------------------------*)

(* Other thory *)
Lemma int_add_cyc: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  (m +z n) +z l = (m +z l) +z n.
Proof.
  intros m n l P1 P2 P3.
  rewrite <- (int_add_associative _ _ _ P1 P3 P2).
  rewrite (int_add_commutative _ _ P3 P2).
  rewrite (int_add_associative _ _ _ P1 P2 P3).
  reflexivity.
Qed.

Lemma int_multi_cyc: forall m n l, m ∈ ℤ -> n ∈ ℤ -> l ∈ ℤ ->
  (m ×z n) ×z l = (m ×z l) ×z n.
Proof.
  intros m n l P1 P2 P3.
  rewrite <- (int_multi_associative _ _ _ P1 P3 P2).
  rewrite (int_multi_commutative _ _ P3 P2).
  rewrite (int_multi_associative _ _ _ P1 P2 P3).
  reflexivity.
Qed.
(*----------------------------------------------------------------------------*)

(* TODO: def two variable function *)
(* TODO: refine equiv and int *)
(* TODO: refine names, intro -> i, elim -> e, equal -> eq ...*)
(* TODO: refine elim_1 2 3 ... to some meanful name? *)
(* TODO: refine oreder of add and multi *)


(* We minimize the use of the Rule of Excluded Middle. *)
Axiom REM : forall (P : Prop), P \/ ~P.

(* Chapter 1: Introduction *)

(* In axiomatic set theory, the notions of a set and elementhood are primitive,
and remain undefined. All the properites that are provable about sets and
elementhood will be derived from the axioms. *)

Definition set : Type.
Admitted.

Definition In : set -> set -> Prop.
Admitted.

(* This is a theorem of classical logic which requires the REM. We minimize its use here. *)

Theorem Not_Forall_Implies_Exists : forall (P : set -> Prop),
  (~forall (x : set), ~ P x) -> exists (x : set) , P x.
Proof.
  intros P H. assert (I : (exists x, P x) \/ (~ exists x, P x)).
  { apply REM. }
  destruct I as [I | I]; try assumption.
  assert (Q : forall x, ~ P x).
  { intros x C. apply I. exists x. assumption. }
  apply H in Q. destruct Q.
Qed.

(* Another theorem of classical logic which requires the REM. *)
Theorem DeMorgan : forall (P Q : Prop), ~(P /\ Q) <-> ~P \/ ~Q.
Proof.
  intros P Q. split; intros H.
  - assert (I : P \/ ~ P). { apply REM. }
    assert (J : Q \/ ~ Q). { apply REM. }
    destruct I as [I | I]; destruct J as [J | J].
    + assert (T : P /\ Q). { split; assumption. }
      apply H in T. destruct T.
    + right. assumption.
    + left. assumption.
    + left. assumption.
  - intros C. destruct H as [H | H].
    + apply H, C.
    + apply H, C.
Qed.

Theorem DeMorgan' : forall (P Q : Prop), ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
  intros P Q. split; intros H.
  - split.
    + intros C. apply H. left. assumption.
    + intros C. apply H. right. assumption.
  - intros C. destruct C as [C | C].
    + destruct H as [H1 H2]. apply H1, C.
    + apply H, C.
Qed.


Require Import List.
Require Import util.
Require Import SfLib.
Require Import STLC_terms.
Require Import STLC_types.

Definition context := partial_map type.

Unset Elimination Schemes.
Inductive has_type : context -> term -> type -> Prop :=
| T_Var : forall G x T,
            G x = Some T -> has_type G (TVar x) T
| T_Lambda : forall G x T11 T12 t12,
               has_type (extend G x T11) t12 T12 ->
               has_type G (TLambda x T11 t12) (TArrow T11 T12)
| T_App : forall T11 T12 G t1 t2,
            has_type G t1 (TArrow T11 T12) ->
            has_type G t2 T11 ->
            has_type G (TApp t1 t2) T12
| T_True : forall G, has_type G TTrue TBool
| T_False : forall G, has_type G TFalse TBool
| T_If : forall t1 t2 t3 T G,
           has_type G t1 TBool ->
           has_type G t2 T ->
           has_type G t3 T ->
           has_type G (TIf t1 t2 t3) T
| T_Nat : forall G n, has_type G (TNum n) TNat
| T_Plus : forall G l r, has_type G l TNat -> has_type G r TNat -> has_type G (TPlus l r) TNat
| T_EqNat : forall G l r, has_type G l TNat -> has_type G r TNat -> has_type G (TEqNat l r) TBool
| T_Literal : forall G li lv lt,
                Forall2 (has_type G) lv lt ->
                Uniq li ->
                length li = length lv ->
                length li = length lt ->
                has_type G (TLiteral li lv) (TRecord li lt)
| T_Access : forall G li lv lt i v T,
               has_type G (TLiteral li lv) (TRecord li lt) ->
               In (i,v) (combine li lv) -> In (i,T) (combine li lt) ->
               has_type G (TAccess (TLiteral li lv) i) T
| T_Subtype : forall G t T T',
                has_type G t T ->
                subtype T T' ->
                has_type G t T'.
Set Elimination Schemes.

Definition has_type_ind :=
fun (P : context -> term -> type -> Prop)
  (f : forall (G : id -> option type) (x : id) (T : type),
       G x = Some T -> P G (TVar x) T)
  (f0 : forall (G : partial_map type) (x : id) (T11 T12 : type) (t12 : term),
        has_type (extend G x T11) t12 T12 ->
        P (extend G x T11) t12 T12 -> P G (TLambda x T11 t12) (TArrow T11 T12))
  (f1 : forall (T11 T12 : type) (G : context) (t1 t2 : term),
        has_type G t1 (TArrow T11 T12) ->
        P G t1 (TArrow T11 T12) ->
        has_type G t2 T11 -> P G t2 T11 -> P G (TApp t1 t2) T12)
  (f2 : forall G : context, P G TTrue TBool)
  (f3 : forall G : context, P G TFalse TBool)
  (f4 : forall (t1 t2 t3 : term) (T : type) (G : context),
        has_type G t1 TBool ->
        P G t1 TBool ->
        has_type G t2 T ->
        P G t2 T -> has_type G t3 T -> P G t3 T -> P G (TIf t1 t2 t3) T)
  (f5 : forall (G : context) (n : nat), P G (TNum n) TNat)
  (f6 : forall (G : context) (l r : term),
        has_type G l TNat ->
        P G l TNat -> has_type G r TNat -> P G r TNat -> P G (TPlus l r) TNat)
  (f7 : forall (G : context) (l r : term),
        has_type G l TNat ->
        P G l TNat ->
        has_type G r TNat -> P G r TNat -> P G (TEqNat l r) TBool)
  (f8 : forall (G : context) li (lv : list term) (lt : list type),
          length li = length lv ->
          length li = length lt ->
          Uniq li ->
          Forall2 (P G) lv lt ->
          Forall2 (has_type G) lv lt ->
        P G (TLiteral li lv) (TRecord li lt))
  (f9 : forall (G : context) li (lv : list term)
          (lt : list type) (i : id) (v : term)
          (T : type),
        has_type G (TLiteral li lv) (TRecord li lt ) ->
        P G (TLiteral li lv) (TRecord li lt ) ->
        In (i, v) (combine li lv) -> In (i, T) (combine li lt) ->
        P G (TAccess (TLiteral li lv) i) T)
  (f10 : forall G t T T', P G t T -> subtype T T' -> has_type G t T -> P G t T') =>
fix F (c : context) (t : term) (t0 : type) (h : has_type c t t0) {struct h} : P c t t0 :=
  match h in (has_type c0 t1 t2) return (P c0 t1 t2) with
    | T_Var G x T e => f G x T e
    | T_Lambda G x T11 T12 t12 h0 =>
      f0 G x T11 T12 t12 h0 (F (extend G x T11) t12 T12 h0)
    | T_App T11 T12 G t1 t2 h0 h1 =>
      f1 T11 T12 G t1 t2 h0 (F G t1 (TArrow T11 T12) h0) h1 (F G t2 T11 h1)
    | T_True G => f2 G
    | T_False G => f3 G
    | T_If t1 t2 t3 T G h0 h1 h2 =>
      f4 t1 t2 t3 T G h0 (F G t1 TBool h0) h1 (F G t2 T h1) h2 (F G t3 T h2)
    | T_Nat G n => f5 G n
    | T_Plus G l r h0 h1 => f6 G l r h0 (F G l TNat h0) h1 (F G r TNat h1)
    | T_EqNat G l r h0 h1 => f7 G l r h0 (F G l TNat h0) h1 (F G r TNat h1)
    | T_Literal G li lv lt f10 u llv llt =>
      f8 G li lv lt llv llt u
         ((fix forallrec term_list type_list
               (f5 : Forall2 (has_type G)
                             term_list type_list) :
             Forall2 (P G)
                     term_list type_list :=
             match f5 with
               | Forall2_nil => Forall2_nil (P G)
               | Forall2_cons term type terms types
                              ht forall2_rest =>
                 Forall2_cons term type
                              (F G term type ht)
                              (forallrec terms types forall2_rest)
             end) lv lt f10) f10
    | T_Access G li lv lt i v T h0 i0 i1 =>
      f9 G li lv lt i v T h0 (F G (TLiteral li lv) (TRecord li lt) h0) i0 i1
    | T_Subtype G t T T' ht st => f10 G t T T' (F G t T ht) st ht
  end.

Hint Constructors has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var"   | Case_aux c "T_Lambda"
  | Case_aux c "T_App"   | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Nat"   | Case_aux c "T_Plus"
  | Case_aux c "T_EqNat" | Case_aux c "T_Literal"
  | Case_aux c "T_Access" | Case_aux c "T_Subtype" ].

(* various canonical form lemmas - for some types, if a term has that type,
   it must be a particular kind of term *)

Lemma canonical_forms_bool :
  forall (G : context) (t : term),
    has_type G t TBool -> value t -> t = TTrue \/ t = TFalse.
Proof with auto.
  intros.
  remember TBool as x.
  has_type_cases (induction H) Case; try solve by inversion...
  Case "T_Subtype".
    apply IHhas_type in H0... subst.
    apply no_subtypes_bool in H; exact H.
Qed.

Lemma canonical_forms_nat :
  forall (G : context) (t : term),
    has_type G t TNat -> value t -> exists (n : nat), t = TNum n.
Proof with auto.
  intros. remember TNat as TN.
  has_type_cases (induction H) Case; intros; try solve by inversion.
  Case "T_Nat". exists n...
  Case "T_Subtype".
    apply IHhas_type in H0... subst.
    apply no_subtypes_nat in H...
Qed.

Lemma canonical_forms_lambda :
  forall (G : context) (t : term) (T A R : type),
    has_type G t (TArrow A R) -> value t ->
      exists (i : id) (ty : type) (te : term), t = TLambda i ty te.
Proof with auto.
  intros. remember (TArrow A R) as TArr.
  generalize dependent A; generalize dependent R.
  has_type_cases (induction H) Case; intros; try solve by inversion.
  Case "T_Lambda".
    exists x. exists T11. exists t12...
  Case "T_Subtype".
    subst.
    apply consistent_subtypes_lambda with T0 A R in H.
    inversion H. inversion H2. inversion H3; subst.
    apply IHhas_type with x0 x in H0...
Qed.

(* if a literal has a record type, there are several inferences we can make about it *)
Lemma has_type_literal_info :
  forall G li lv li' lt,
    has_type G (TLiteral li lv) (TRecord li' lt) ->
    length li = length lv /\ length li' = length lt /\ Uniq li /\ Uniq li'.
Proof with eauto.
  intros.
  remember (TLiteral li lv). remember (TRecord li' lt).
  generalize dependent li'. generalize dependent lt.
  has_type_cases (induction H) Case; intros; inversion Heqt; inversion Heqt0; subst.
  Case "T_Literal". inversion Heqt0. subst...
  Case "T_Subtype". remember H. clear Heqs. apply consistent_subtypes_record in s.
    inversion s. inversion H3. clear s H3. subst.
    apply IHhas_type with (lt := x0) (li' := x) in H1...
    inversion H1. clear H1.
    inversion H3. inversion H4. clear H4.
    clear H3. clear IHhas_type.
    remember (TRecord li' lt). remember (TRecord x x0). generalize dependent li'.
    generalize dependent lt. generalize dependent x. generalize x0.
    subtype_cases (induction H) SCase; intros; inversion Heqt; inversion Heqt0; subst...
      SCase "Sub_refl". inversion H. subst...
      SCase "Sub_trans". remember H1. clear Heqs.
        apply consistent_subtypes_record in s. inversion s. inversion H8. subst.
        clear s. clear H8.
        remember H0. clear Heqh.
        apply IHsubtype1 with (x0 := x1) (x4 := x) (lt := x3) (li' := x2) in h...
        inversion h. inversion H9. inversion H11. clear h. clear H9. clear H11.
        apply T_Subtype with (T' := TRecord x2 x3) in H0...
      SCase "Sub_r_width". split... split... split... inversion H7...
      SCase "Sub_r_depth". subst...
      SCase "Sub_r_perm". split... split... split...
        inversion H8...
Qed.

(* this is a stronger form of the above lemma, which is used in the proof of this one *)
Lemma literal_info :
  forall G li lv li' lt,
    has_type G (TLiteral li lv) (TRecord li' lt) ->
    (forall i T, In (i,T) (combine li' lt) -> exists t, In (i,t) (combine li lv) /\
                                                        has_type G t T) /\
    Uniq li /\ Uniq li' /\
    length li = length lv /\
    length li' = length lt.
Proof with eauto.
  intros.
  remember H. clear Heqh.
  apply has_type_literal_info in h. inversion h. inversion H1. inversion H3.
  split... clear H3. clear H1. clear h. intros.
  remember (TLiteral li lv).
  remember (TRecord li' lt). generalize dependent lt. generalize dependent li'.
  generalize dependent T.
  has_type_cases (induction H) Case; intros; inversion Heqt; inversion Heqt0; subst...
  Case "T_Literal". inversion Heqt0. subst. clear H10. clear Heqt. clear H3.
    clear H. clear Heqt0. clear H7. clear H4. clear H6. remember H8. clear Heqi0.
    apply in_combine_r in i0. remember H8. clear Heqi1. apply in_combine_l in i1.
    rewrite H1 in H0. generalize dependent lv. generalize dependent li'.
    induction lt0; intros; try solve by inversion;
    destruct lv; destruct li'; try solve by inversion.
    inversion H8. subst. inversion H5. subst. inversion H. subst. exists t. split...
    unfold In. simpl...
    simpl in *. assert (i <> i2).
    SCase "Proof of assertion". intro. subst. apply in_combine_l in H. inversion H2.
      contradiction.
    unfold not in H3.
    assert (In (i,T) (combine li' lt0)). inversion H8...
    clear H8.
    apply IHlt0 with (lv := lv) in H4...
    inversion H4. exists x. inversion H6. split...
    apply in_combine_r in H4...
    inversion H2...
    apply in_combine_l in H4...
    inversion H5...
  Case "T_Subtype".
    remember H.
    clear Heqs.
    remember s.
    clear Heqs0.
    apply consistent_subtypes_record in s0.
    inversion s0. inversion H8. clear s0. clear H8. subst.
    apply has_type_literal_info in H1.
    inversion H1. inversion H9. inversion H11.
    clear H1. clear H9. clear H11.
    apply record_subtype_inversion in s...
    inversion s. inversion H1. inversion H9.
    clear s. clear H1. clear H9.
    apply H14 in H3. inversion H3. inversion H1.
    clear H3. clear H1.
    inversion H11. subst.
    apply IHhas_type with (li' := x1) (lt := x2) (T := x3) in H9...
    inversion H9. exists x. inversion H1. split...
Qed.

(* needs to be extended, we will need something about the types of the stuff in the literal.
Note that we can't say Forall2 (has_type G) lv lt, since in the presence of subtyping,
ids can move around. *)
(*
Lemma record_type_info :
  forall (G : context) (liv lit : list id) (lv : list term) (lt : list type),
    has_type G (TLiteral liv lv) (TRecord lit lt) -> Uniq liv /\ length liv = length lv.
Proof with auto.
  intros. remember (TLiteral liv lv) as TLit. remember (TRecord lit lt) as TRec.
  generalize dependent liv; generalize dependent lv.
  generalize dependent lit; generalize dependent lt.
  has_type_cases (induction H) Case; intros; subst; try solve by inversion...
  Case "T_Literal".
    inversion HeqTRec; subst. inversion HeqTLit; subst...
  Case "T_Subtype".
    apply consistent_subtypes_record in H.
    inversion H. inversion H1.  inversion H2. inversion H4.  subst.
    apply IHhas_type with (lt := x0) (lit := x)...
Qed.

Lemma record_type_info' :
  forall G t T liv lit lv lt,
    has_type G t T -> t = (TLiteral liv lv) -> T = (TRecord lit lt) ->
    Uniq liv /\ length liv = length lv.
Proof with eauto.
  intros. generalize dependent liv. generalize dependent lv.
  generalize dependent lit. generalize dependent lt.
  has_type_cases (induction H) Case; intros; try solve by inversion...
  Case "T_Literal". inversion H4. inversion H5. subst. subst...
  Case "T_Subtype". subst.
    apply consistent_subtypes_record' with (li' := lit) (lt' := lt) in H...
    inversion H. inversion H1.
    apply IHhas_type with (lt := x0) (lit := x) (lv0 := lv) (liv0 := liv)...
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)         *)
(************************************************************************)

(*********************************************************)
(**          Complements for the real numbers            *)
(*                                                       *)
(*********************************************************)

Require Import Rbase.
Require Import R_Ifp.
Require Import Lra.
Local Open Scope R_scope.

Implicit Type r : R.

(*******************************)
(** *        Rmin              *)
(*******************************)

(*********)
Definition Rmin (x y:R) : R :=
  match Rle_dec x y with
    | left _ => x
    | right _ => y
  end.

(*********)
Lemma Rmin_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmin_case_strong : forall r1 r2 (P:R -> Type),
  (r1 <= r2 -> P r1) -> (r2 <= r1 -> P r2) -> P (Rmin r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmin; destruct (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
Proof.
  intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2) as [Hle|Hnle]; intros.
  split.
  assumption.
  unfold Rgt; exact (Rlt_le_trans r r1 r2 H Hle).
  split.
  generalize (Rnot_le_lt r1 r2 Hnle); intro; exact (Rgt_trans r1 r2 r H0 H).
  assumption.
Qed.

(*********)
Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
Proof.
  intros; unfold Rmin; case (Rle_dec r1 r2); elim H; clear H; intros;
    assumption.
Qed.

(*********)
Lemma Rmin_Rgt : forall r1 r2 r, Rmin r1 r2 > r <-> r1 > r /\ r2 > r.
Proof.
  intros; split.
  exact (Rmin_Rgt_l r1 r2 r).
  exact (Rmin_Rgt_r r1 r2 r).
Qed.

(*********)
Lemma Rmin_l : forall x y:R, Rmin x y <= x.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(*********)
Lemma Rmin_r : forall x y:R, Rmin x y <= y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmin_left : forall x y, x <= y -> Rmin x y = x.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmin_right : forall x y, y <= x -> Rmin x y = y.
Proof.
  intros; apply Rmin_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_min_compat_r : forall x y z, x <= y -> Rmin x z <= Rmin y z.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
Proof.
  intros; do 2 (apply Rmin_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rmin_comm : forall x y:R, Rmin x y = Rmin y x.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); case (Rle_dec y x); intros;
    try reflexivity || (apply Rle_antisym; assumption || auto with real).
Qed.

(*********)
Lemma Rmin_stable_in_posreal : forall x y:posreal, 0 < Rmin x y.
Proof.
  intros; apply Rmin_Rgt_r; split; [ apply (cond_pos x) | apply (cond_pos y) ].
Qed.

(*********)
Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
Proof.
  intros; unfold Rmin.
  case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
Proof.
  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rmax              *)
(*******************************)

(*********)
Definition Rmax (x y:R) : R :=
  match Rle_dec x y with
    | left _ => y
    | right _ => x
  end.

(*********)
Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto.
Qed.

(*********)
Lemma Rmax_case_strong : forall r1 r2 (P:R -> Type),
  (r2 <= r1 -> P r1) -> (r1 <= r2 -> P r2) -> P (Rmax r1 r2).
Proof.
  intros r1 r2 P H1 H2; unfold Rmax; case (Rle_dec r1 r2); auto with real.
Qed.

(*********)
Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
Proof.
  intros; split.
  unfold Rmax; case (Rle_dec r1 r2); intros; auto.
  intro; unfold Rmax; case (Rle_dec r1 r2) as [|Hnle]; elim H; clear H; intros;
    auto.
  apply (Rle_trans r r1 r2); auto.
  generalize (Rnot_le_lt r1 r2 Hnle); clear Hnle; intro; unfold Rgt in H0;
    apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
Qed.

Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
Proof.
  intros p q; unfold Rmax; case (Rle_dec p q); case (Rle_dec q p); auto;
    intros H1 H2; apply Rle_antisym; auto with real.
Qed.

(* begin hide *)
Notation RmaxSym := Rmax_comm (only parsing).
(* end hide *)

(*********)
Lemma Rmax_l : forall x y:R, x <= Rmax x y.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro H1;
    [ assumption | auto with real ].
Qed.

(*********)
Lemma Rmax_r : forall x y:R, y <= Rmax x y.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro H1;
    [ right; reflexivity | auto with real ].
Qed.

(* begin hide *)
Notation RmaxLess1 := Rmax_l (only parsing).
Notation RmaxLess2 := Rmax_r (only parsing).
(* end hide *)

(*********)
Lemma Rmax_left : forall x y, y <= x -> Rmax x y = x.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rmax_right : forall x y, x <= y -> Rmax x y = y.
Proof.
  intros; apply Rmax_case_strong; auto using Rle_antisym.
Qed.

(*********)
Lemma Rle_max_compat_r : forall x y z, x <= y -> Rmax x z <= Rmax y z.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma Rle_max_compat_l : forall x y z, x <= y -> Rmax z x <= Rmax z y.
Proof.
  intros; do 2 (apply Rmax_case_strong; intro); eauto using Rle_trans, Rle_refl.
Qed.

(*********)
Lemma RmaxRmult :
  forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
Proof.
  intros p q r H; unfold Rmax.
  case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
  case H; intros E1.
  case H1; auto with real.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
  case H; intros E1.
  case H2; auto with real.
  apply Rmult_le_reg_l with (r := r); auto.
  rewrite <- E1; repeat rewrite Rmult_0_l; auto.
Qed.

(*********)
Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro;
    [ apply (cond_neg y) | apply (cond_neg x) ].
Qed.

(*********)
Lemma Rmax_lub : forall x y z:R, x <= z -> y <= z -> Rmax x y <= z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

(*********)
Lemma Rmax_lub_lt : forall x y z:R, x < z -> y < z -> Rmax x y < z.
Proof.
  intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
Qed.

Lemma Rmax_Rlt : forall x y z,
  Rmax x y < z <-> x < z /\ y < z.
Proof.
intros x y z; split.
 unfold Rmax; case (Rle_dec x y).
  intros xy yz; split;[apply Rle_lt_trans with y|]; assumption.
  intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption.
 intros [h h']; apply Rmax_lub_lt; assumption.
Qed.

(*********)
Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
Proof.
  intros; unfold Rmax.
  case (Rle_dec x y); intro; assumption.
Qed.

(*******************************)
(** *        Rabsolu           *)
(*******************************)

(*********)
Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
Proof.
  intro; generalize (Rle_dec 0 r); intro X; elim X; intro H; clear X.
  right; apply (Rle_ge 0 r H).
  left; fold (0 > r); apply (Rnot_le_lt 0 r H).
Qed.

(*********)
Definition Rabs r : R :=
  match Rcase_abs r with
    | left _ => - r
    | right _ => r
  end.

(*********)
Lemma Rabs_R0 : Rabs 0 = 0.
Proof.
  unfold Rabs; case (Rcase_abs 0); auto; intro.
  generalize (Rlt_irrefl 0); intro; exfalso; auto.
Qed.

Lemma Rabs_R1 : Rabs 1 = 1.
Proof.
unfold Rabs; case (Rcase_abs 1); auto with real.
intros H; absurd (1 < 0); auto with real.
Qed.

(*********)
Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
Proof.
  intros; unfold Rabs; case (Rcase_abs r); intro; auto.
  apply Ropp_neq_0_compat; auto.
Qed.

(*********)
Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
Proof.
  intros; unfold Rabs; case (Rcase_abs r); trivial; intro;
    absurd (r >= 0).
  exact (Rlt_not_ge r 0 H).
  assumption.
Qed.

(*********)
Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
Proof.
  intros; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge].
  absurd (r >= 0).
  exact (Rlt_not_ge r 0 Hlt).
  assumption.
  trivial.
Qed.

Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
Proof.
  intros a H; case H; intros H1.
  apply Rabs_left; auto.
  rewrite H1; simpl; rewrite Rabs_right; auto with real.
Qed.

(*********)
Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
Proof.
  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge].
  generalize (Ropp_lt_gt_contravar x 0 Hlt); intro; unfold Rgt in H;
    rewrite Ropp_0 in H; left; assumption.
  apply Rge_le; assumption.
Qed.

Lemma Rle_abs : forall x:R, x <= Rabs x.
Proof.
  intro; unfold Rabs; case (Rcase_abs x); intros; lra.
Qed.

Definition RRle_abs := Rle_abs.

Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b.
Proof.
intros a b; unfold Rabs; case Rcase_abs.
 intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it.
intros _ [_ it]; exact it.
Qed.

(*********)
Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
Proof.
  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge];
    [ generalize (Rgt_not_le 0 x Hlt); intro; exfalso; auto | trivial ].
Qed.

(*********)
Lemma Rabs_Rabsolu : forall x:R, Rabs (Rabs x) = Rabs x.
Proof.
  intro; apply (Rabs_pos_eq (Rabs x) (Rabs_pos x)).
Qed.

(*********)
Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
Proof.
  intros; destruct (Rabs_pos x) as [|Heq]; auto.
  apply Rabs_no_R0 in H; symmetry in Heq; contradiction.
Qed.

(*********)
Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
Proof.
  intros; unfold Rabs; case (Rcase_abs (x - y)) as [Hlt|Hge];
    case (Rcase_abs (y - x)) as [Hlt'|Hge'].
  apply Rminus_lt, Rlt_asym in Hlt; apply Rminus_lt in Hlt'; contradiction.
  rewrite (Ropp_minus_distr x y); trivial.
  rewrite (Ropp_minus_distr y x); trivial.
  destruct Hge; destruct Hge'.
  apply Ropp_lt_gt_0_contravar in H; rewrite (Ropp_minus_distr x y) in H;
    apply Rlt_asym in H0; contradiction.
  apply Rminus_diag_uniq in H0 as ->; trivial.
  apply Rminus_diag_uniq in H as ->; trivial.
  apply Rminus_diag_uniq in H0 as ->; trivial.
Qed.

(*********)
Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
Proof.
  intros; unfold Rabs; case (Rcase_abs (x * y)) as [Hlt|Hge];
    case (Rcase_abs x) as [Hltx|Hgex];
    case (Rcase_abs y) as [Hlty|Hgey]; auto.
  apply Rmult_lt_gt_compat_neg_l with (r:=x), Rlt_asym in Hlty; trivial.
    rewrite Rmult_0_r in Hlty; contradiction.
  rewrite (Ropp_mult_distr_l_reverse x y); trivial.
  rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
    rewrite (Rmult_comm x y); trivial.
  destruct Hgex as [| ->], Hgey as [| ->].
  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in H0; trivial.
    rewrite Rmult_0_r in H0; contradiction.
  rewrite Rmult_0_r in Hlt; contradiction (Rlt_irrefl 0).
  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
  rewrite (Rmult_opp_opp x y); trivial.
  destruct Hge. destruct Hgey.
  apply Rmult_lt_compat_r with (r:=y), Rlt_asym in Hltx; trivial.
    rewrite Rmult_0_l in Hltx; contradiction.
  rewrite H0, Rmult_0_r in H; contradiction (Rlt_irrefl 0).
  rewrite <- Ropp_mult_distr_l, H, Ropp_0; trivial.
  destruct Hge. destruct Hgex.
  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in Hlty; trivial.
    rewrite Rmult_0_r in Hlty; contradiction.
  rewrite H0, 2!Rmult_0_l; trivial.
  rewrite <- Ropp_mult_distr_r, H, Ropp_0; trivial.
Qed.

(*********)
Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
Proof.
  intro; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge];
    case (Rcase_abs (/ r)) as [Hlt'|Hge']; auto;
    intros.
  apply Ropp_inv_permute; auto.
  rewrite <- Ropp_inv_permute; trivial.
  destruct Hge' as [| ->].
  apply Rinv_lt_0_compat, Rlt_asym in Hlt; contradiction.
  rewrite Ropp_0; trivial.
  destruct Hge as [| ->].
  apply Rinv_0_lt_compat, Rlt_asym in H0; contradiction.
  contradiction (refl_equal 0).
Qed.

Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
Proof.
  intro; replace (-x) with (-1 * x) by ring.
  rewrite Rabs_mult.
  replace (Rabs (-1)) with 1.
  apply Rmult_1_l.
  unfold Rabs; case (Rcase_abs (-1)).
  intro; ring.
  rewrite <- Ropp_0.
  intro H0; apply Ropp_ge_cancel in H0.
  elim (Rge_not_lt _ _ H0).
  apply Rlt_0_1.
Qed.

(*********)
Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
Proof.
  intros a b; unfold Rabs; case (Rcase_abs (a + b)) as [Hlt|Hge];
    case (Rcase_abs a) as [Hlta|Hgea];
    case (Rcase_abs b) as [Hltb|Hgeb].
  apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
    reflexivity.
(**)
  rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
    unfold Rle; elim Hgeb; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
    elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
    rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
      unfold Rle; elim Hgea; intro.
  left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
    elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
      clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
  right; rewrite H; apply Ropp_0.
(**)
  exfalso; generalize (Rplus_ge_compat_l a b 0 Hgeb); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rge_trans (a + b) a 0 H Hgea); intro; clear H;
        unfold Rge in H0; elim H0; intro; clear H0.
  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 Hlt); intro; auto.
  absurd (a + b = 0); auto.
  apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
(**)
  exfalso; generalize (Rplus_lt_compat_l a b 0 Hltb); intro;
    elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
      generalize (Rlt_trans (a + b) a 0 H Hlta); intro; clear H;
        destruct Hge.
  unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
    apply (Rlt_irrefl (a + b)); assumption.
  rewrite H in H0; apply (Rlt_irrefl 0); assumption.
(**)
  rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
    apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
      unfold Rminus; rewrite (Ropp_involutive a);
        generalize (Rplus_lt_compat_l a a 0 Hlta); clear Hge Hgeb;
          intro; elim (Rplus_ne a); intros v w; rewrite v in H;
            clear v w; generalize (Rlt_trans (a + a) a 0 H Hlta);
              intro; apply (Rlt_le (a + a) 0 H0).
(**)
  apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
    unfold Rminus; rewrite (Ropp_involutive b);
      generalize (Rplus_lt_compat_l b b 0 Hltb); clear Hge Hgea;
        intro; elim (Rplus_ne b); intros v w; rewrite v in H;
          clear v w; generalize (Rlt_trans (b + b) b 0 H Hltb);
            intro; apply (Rlt_le (b + b) 0 H0).
(**)
  unfold Rle; right; reflexivity.
Qed.

(*********)
Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
Proof.
  intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
    unfold Rminus; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
      rewrite (Rplus_comm (Rabs b) (Rabs a));
        rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
          rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
            replace (Rabs a) with (Rabs (a + 0)).
  rewrite <- (Rplus_opp_r b); rewrite <- (Rplus_assoc a b (- b));
    rewrite (Rplus_comm a b); rewrite (Rplus_assoc b a (- b)).
  exact (Rabs_triang b (a + - b)).
  rewrite (proj1 (Rplus_ne a)); trivial.
Qed.

(* ||a|-|b||<=|a-b| *)
Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b).
Proof.
  cut
    (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)).
  intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]].
  rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
    do 2 rewrite Ropp_minus_distr.
  apply H; left; assumption.
  rewrite Heq; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
    apply Rabs_pos.
  apply H; left; assumption.
  intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b).
  apply Rabs_triang_inv.
  rewrite (Rabs_right (Rabs a - Rabs b));
    [ reflexivity
      | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r;
        replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a);
        [ assumption | ring ] ].
Qed.

(*********)
Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
Proof.
  unfold Rabs; intros; case (Rcase_abs x); intro.
  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt;
    rewrite Ropp_involutive; intro; assumption.
  assumption.
Qed.

(*********)
Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
Proof.
  unfold Rabs; intro x; case (Rcase_abs x) as [Hlt|Hge]; intros.
  generalize (Ropp_gt_lt_0_contravar x Hlt); unfold Rgt; intro;
    generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
  apply (Rlt_trans x 0 a Hlt H1).
  generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
    unfold Rgt; trivial.
  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H Hge); intro;
    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a);
      generalize (Rge_gt_trans x 0 (- a) Hge H1); unfold Rgt;
        intro; split; assumption.
Qed.

Lemma RmaxAbs :
  forall (p q:R) r, p <= q -> q <= r -> Rabs q <= Rmax (Rabs p) (Rabs r).
Proof.
  intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto with real.
  apply RmaxLess2; auto.
  apply Rge_trans with p; auto with real; apply Rge_trans with q;
    auto with real.
  apply Rge_trans with p; auto with real.
  rewrite (Rabs_left p); auto.
  case (Rle_or_lt 0 q); intros H'2.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with r; auto.
  apply RmaxLess2; auto.
  apply Rge_trans with q; auto with real.
  rewrite (Rabs_left q); auto.
  case (Rle_or_lt 0 r); intros H'3.
  repeat rewrite Rabs_right; auto with real.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
  rewrite (Rabs_left r); auto.
  apply Rle_trans with (- p); auto with real.
  apply RmaxLess1; auto.
Qed.

Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
Proof.
  intros z; case z; unfold Z.abs.
  apply Rabs_R0.
  now intros p0; apply Rabs_pos_eq, (IZR_le 0).
  unfold IZR at 1.
  intros p0; rewrite Rabs_Ropp.
  now apply Rabs_pos_eq, (IZR_le 0).
Qed.

Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z).
Proof.
  intros.
  now rewrite Rabs_Zabs.
Qed.

Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y).
intros x y; apply Rmax_case_strong.
 now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar].
now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar].
Qed.

Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y).
intros x y; apply Rmin_case_strong.
 now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar].
now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar].
Qed.

Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c.
Proof.
intros a b c.
unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b);
  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
  match goal with
  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
   case id; apply Rle_trans with z; auto with real
  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
   case id; apply Rle_trans with z; auto with real
  end.
Qed.

Lemma Rminmax : forall a b, Rmin a b <= Rmax a b.
Proof.
intros a b; destruct (Rle_dec a b).
 rewrite Rmin_left, Rmax_right; assumption.
now rewrite Rmin_right, Rmax_left; assumption ||
  apply Rlt_le, Rnot_le_gt.
Qed.

Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) =
  Rmin (Rmin x y) z.
Proof.
intros a b c.
unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b);
  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
  match goal with
  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
   case id; apply Rle_trans with z; auto with real
  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
   case id; apply Rle_trans with z; auto with real
  end.
Qed.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix theory with Dependent Record
  author    : ZhengPu Shi
  date      : 2021.12
*)

Require Export MatrixTheory.
Require Import DepRec.Matrix.

(* ######################################################################### *)
(** * Basic matrix theory implemented with Dependent Record *)

Module BasicMatrixTheoryDR (E : ElementType) <: BasicMatrixTheory E.

  (** Basic library *)
  Export BasicConfig TupleExt SetoidListListExt HierarchySetoid.

  (* ==================================== *)
  (** ** Matrix element type *)
  Export E.

  Infix "==" := (eqlistA Aeq) : list_scope.
  Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope list_scope.
  Open Scope dlist_scope.
  Open Scope mat_scope.

  (* ==================================== *)
  (** ** Matrix type and basic operations *)

  Definition mat r c := @mat A r c.

  (** matrix equality *)
  Definition meq {r c : nat} := @meq A Aeq r c.
  Infix "==" := meq : mat_scope.

  Lemma meq_equiv r c : Equivalence (@meq r c).
  Proof.
    apply Equiv_meq.
  Qed.

  Global Existing Instance meq_equiv.

  (** Get n-th element of a matrix *)
  Definition mnth {r c} (m : mat r c) (ri ci : nat) :=
    @mnth A A0 r c m ri ci.
  Notation "m ! i ! j" := (mnth m i j).

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
    m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (m1!ri!ci == m2!ri!ci)%A).
  Proof.
    intros. apply meq_iff_mnth. apply Equiv_Aeq.
  Qed.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)
  Ltac lma :=
    cbv; repeat constructor;
    try ring; try easy.

  (* ==================================== *)
  (** ** Convert between list list and matrix *)

  (** *** list list to mat *)

  (* Tips: we can design the needed sequence of parameters, and it maybe different
     with the original implementation *)
  Definition l2m {r c} (dl : list (list A)) : mat r c := l2m A0 dl r c.

  (** l2m is a proper morphism *)
  Lemma l2m_aeq_mor : forall r c, Proper (eqlistA (eqlistA Aeq) ==> meq) (@l2m r c).
  Proof.
    Admitted.

  Global Existing Instance l2m_aeq_mor.

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
    length d1 = r -> width d1 c ->
    length d2 = r -> width d2 c ->
    ~(d1 == d2)%dlist -> ~(@l2m r c d1 == l2m d2).
  Proof.
    apply l2m_inj.
  Qed.

  Lemma l2m_surj : forall {r c} (m : mat r c), (exists d, l2m d == m).
  Proof.
    apply l2m_surj.
  Qed.

  (** *** mat to list list *)

  Definition m2l {r c} (m : mat r c) : list (list A) := mdata m.

  (** m2l is a proper morphism *)
  Lemma m2l_aeq_mor : forall r c, Proper (meq ==> eqlistA (eqlistA Aeq)) (@m2l r c).
  Proof.
    Admitted.

  Global Existing Instance m2l_aeq_mor.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
    intros. destruct m. simpl. auto.
  Qed.
  Global Hint Resolve m2l_length : mat.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    intros. destruct m. simpl. auto.
  Qed.
  Global Hint Resolve m2l_width : mat.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
    (H2 : width dl c), (@m2l r c (l2m dl) == dl)%dlist.
  Proof.
    intros. unfold m2l,l2m. unfold Matrix.l2m. simpl.
    apply l2m_aux_eq; auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
  Proof.
    intros. unfold m2l,l2m. unfold Matrix.l2m. destruct m; simpl.
    hnf. simpl. apply l2m_aux_eq; auto.
  Qed.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
    ~(m1 == m2) -> ~(m2l m1 == m2l m2)%dlist.
  Proof.
    intros. destruct m1,m2. unfold meq,Matrix.meq in *; simpl in *. auto.
  Qed.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
    length d = r -> width d c ->
    (exists m, (@m2l r c m == d)%dlist).
  Proof.
    intros. exists (mk_mat d H H0). simpl. easy.
  Qed.

  (* ==================================== *)
  (** ** Specific matrix *)

  Definition mk_mat_1_1 (a11 : A) : mat 1 1 :=
    mk_mat_1_1 a11.
  Definition mk_mat_3_1 (a1 a2 a3 : A) : mat 3 1 :=
    mk_mat_3_1 a1 a2 a3.
  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : mat 3 3 :=
    mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33.
  Definition mk_mat_2_2 (a11 a12 a21 a22 : A) : mat 2 2 :=
    mk_mat_2_2 a11 a12 a21 a22.

  (* ==================================== *)
  (** ** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3.
  Proof.
    destruct t as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    exact (mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33).
  Defined.

  (** mat_3x3 -> tuple_3x3 *)

  (** old style, deprecated *)
  Definition m2t_3x3' (m : mat 3 3) : @T_3x3 A :=
    ((mnth m 0 0, mnth m 0 1, mnth m 0 2),
     (mnth m 1 0, mnth m 1 1, mnth m 1 2),
     (mnth m 2 0, mnth m 2 1, mnth m 2 2)).

  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A.
    destruct m as [dl].
    remember (hd [] dl) as l1.
    remember (hd [] (tl dl)) as l2.
    remember (hd [] (tl (tl dl))) as l3.
    remember (hd A0 l1, hd A0 (tl l1), hd A0 (tl (tl l1))) as t1.
    remember (hd A0 l2, hd A0 (tl l2), hd A0 (tl (tl l2))) as t2.
    remember (hd A0 l3, hd A0 (tl l3), hd A0 (tl (tl l3))) as t3.
    exact (t1, t2, t3).
  Defined.

  (* ToDo: we havn't define the equality on T_3x3, do it later .. *)
  (* Lemma m2t_t2m_id_3x3 : forall (x : @T_3x3 A), m2t_3x3 (t2m_3x3 x) = x. *)
(*     Proof.
    destruct x as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    simpl. auto.
  Qed. *)

  Lemma t2m_m2t_id_3x3 (m : mat 3 3) : t2m_3x3 (m2t_3x3 m) == m.
  Proof.
    destruct m as [dl HH HW]; simpl. unfold mk_mat_3_3,meq,Matrix.meq; simpl.
    do 4 (destruct dl; simpl in *; try easy).
    inv HW. inv H2. inv H4.
    do 4 (destruct l,l0,l1; simpl in *; try easy).
  Qed.

  (** m[0,0] : mat_1x1 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := mnth m 0 0.

  (* ==================================== *)
  (** ** Matrix transposition *)

  Definition mtrans {r c} (m : mat r c): mat c r := @mtrans A r c m.

  Global Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), m \T\T == m.
  Proof.
    apply @mtrans_trans. apply Equiv_Aeq.
  Qed.

  (* ==================================== *)
  (** ** Mapping of matrix *)

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c := matmap f m.

  (** Mapping of two matrices *)
  Definition mmap2 {r c} (f : A -> A -> A) (m1  m2 : mat r c) : mat r c :=
    matmap2 f m1 m2.

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
    (f_comm : forall a b : A, (f a b == f b a)%A) (m1 m2 : mat r c),
    mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    intros. apply @matmap2_comm. constructor. auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
    (f_assoc : forall a b c, (f (f a b) c == f a (f b c))%A) (m1 m2 m3 : mat r c),
    mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros. apply @matmap2_assoc. constructor; auto. apply Equiv_Aeq.
  Qed.

End BasicMatrixTheoryDR.

(* ######################################################################### *)
(** * Decidable matrix theory implemented with Dependent Record *)

Module DecidableMatrixTheoryDR (E : DecidableElementType) <: DecidableMatrixTheory E.

  Include BasicMatrixTheoryDR E.

  (** meq is decidable *)
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec. apply Dec_Aeq.
  Qed.

End DecidableMatrixTheoryDR.

(* ######################################################################### *)
(** * Ring matrix theory implemented with Dependent Record *)

Module RingMatrixTheoryDR (E : RingElementType) <: RingMatrixTheory E.

  Include BasicMatrixTheoryDR E.

  (** ** Declare ring instance to use ring tactic *)

  (** How to declare that the "Add" is respect to "Aeq" ?
      (1). Add Parametric Morphism as xxx.
      (2). Instance xxx.
      (3). Existing Instance xxx.
   *)
  (** (1). Add Parametric Morphism as xxx. *)
  (* Global Add Parametric Morphism : Aadd with signature *)
  (*        Aeq ==> Aeq ==> Aeq as Aadd_aeq_mor. *)
  (* Proof. apply Aadd_aeq_mor. Qed. *)

  (** (2). Instance xxx. *)
  (* Global Instance Aadd_aeq_mor : *)
  (*   Proper (Aeq  ==> Aeq ==> Aeq) (Aadd). *)
  (* Proof.  apply Aadd_aeq_mor. Qed. *)

  (** (3). Existing Instance xxx. *)
  (* Note that, these declarations have been finished in module E. *)
  (* Global Existing Instance Aadd_aeq_mor. *)

  Add Ring ring_thy_inst : Ring_thy.

  (** ** Algebraic matrix theory *)

  (** Zero matrix *)
  Definition mat0 r c : mat r c := mat0 A0.

  (* (** A matrix is a nonzero matrix *) *)
  (* Definition matnonzero {r c} (m : mat r c) : Prop := ~(m == mat0 r c). *)

  (** Unit matrix *)
  Definition mat1 n : mat n n := mat1 A0 A1.

  (** *** Addition of matrix *)

  Definition madd {r c} := @madd A Aadd r c.
  Infix "+" := madd : mat_scope.

  (** m1 + m2 = m2 + m1 *)
  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == m2 + m1.
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
  Proof.
    intros. apply madd_zero_l.
  Qed.

  (** m + 0 = m *)
  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
  Proof.
    intros. apply madd_zero_r.
  Qed.

  (** madd and (dmap2 Aadd) are homomorphic over m2l *)
  Lemma m2l_madd_homo : forall r c,
      Homomorphic (Beq:=eqlistA (eqlistA Aeq)) madd (dmap2 Aadd) (@m2l r c).
  Proof.
    intros. constructor. intros.
    destruct a1,a2. simpl.
    unfold matmap2dl. simpl. easy.
  Qed.

  (** *** Opposite of matrix *)

  Definition mopp {r c} (m : mat r c) : mat r c := @mopp A Aopp r c m.
  Notation "- m" := (mopp m) : mat_scope.

  (** - - m = m *)
  Lemma mopp_opp : forall {r c} (m : mat r c), - - m == m.
  Proof.
    intros. apply mopp_opp.
  Qed.

  (** - m1 = m2 <-> m1 = - m2 *)
  Lemma mopp_exchange : forall {r c} (m1 m2 : mat r c), -m1 == m2 <-> m1 == -m2.
  Proof.
    intros. apply mopp_exchange.
  Qed.

  (** - 0 = 0 *)
  Lemma mopp_mat0 : forall {r c}, - (mat0 r c) == mat0 r c.
  Proof.
    intros. apply mopp_mat0.
  Qed.

  (** m + (-m) = 0 *)
  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
  Proof.
    intros. apply madd_opp.
  Qed.

  (** *** Subtraction of matrix *)

  Definition msub {r c} := @msub A Aadd Aopp r c.
  Infix "-" := msub : mat_scope.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply msub_comm.
  Qed.

  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply msub_assoc.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
  Proof.
    intros. apply msub_zero_l.
  Qed.

  (** m - 0 = m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
  Proof.
    intros. apply msub_zero_r.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == (mat0 r c).
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Scalar multiplication of matrix *)

  (** Left scalar multiplication of matrix *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    @mcmul A Amul r c a m.
  Infix " 'c*' " := mcmul : mat_scope.

  (** Right scalar multiplication of matrix *)
  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    @mmulc A Amul r c m a.
  Infix " '*c' " := mmulc : mat_scope.

  (** m * a = a * m *)
  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c), m *c a == a c* m.
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a * (b * m) = (a * b) * m *)
  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == (a * b)%A c* m.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a * (b * m) = b * (a * m) *)
  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c), a c* (b c* m) == b c* (a c* m).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** a * (m1 + m2) = (a * m1) + (a * m2) *)
  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == (a c* m1) + (a c* m2).
  Proof.
    intros. apply mcmul_distr_l.
  Qed.

  (** (a + b) * m = (a * m) + (b * m) *)
  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof.
    intros. apply mcmul_distr_r.
  Qed.

  (** 0 * m = 0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 r c.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. apply mcmul_1.
  Qed.

  (** (-a) * m = - (a * m) *)
  Lemma mcmul_neg : forall {r c} a (m : mat r c), (-a)%A c* m == - (a c* m).
  Proof.
    intros. apply mcmul_neg.
  Qed.

  (** (-a) * (- m) = (a * m) *)
  Lemma mcmul_neg_mopp : forall {r c} a (m : mat r c), (-a)%A c* (-m) == a c* m.
  Proof.
    intros. apply mcmul_neg_mopp.
  Qed.

  (** *** Multiplication of matrix *)

  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mmul A A0 Aadd Amul r c s m1 m2.
  Infix "*" := mmul : mat_scope.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c A} (m1 : mat r c) (m2 m3 : mat c A),
    m1 * (m2 + m3) == m1 * m2 + m1 * m3.
  Proof.
    intros. apply mmul_add_distr_l.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
    (m1 + m2) * m3 == (m1 * m3) + (m2 * m3).
  Proof.
    intros. apply mmul_add_distr_r.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s A} (m1 : mat r c) (m2 : mat c s) (m3 : mat s A),
    (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply mmul_assoc.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c A} (m : mat c A), (mat0 r c) * m == mat0 r A.
  Proof.
    intros. apply mmul_0_l.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c A} (m : mat r c), m * (mat0 c A) == mat0 r A.
  Proof.
    intros. apply mmul_0_r.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
  Proof.
    intros. apply mmul_1_l.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
  Proof.
    intros. apply mmul_1_r.
  Qed.

End RingMatrixTheoryDR.

(* ######################################################################### *)
(** * Decidable Field matrix theory implemented with Dependent Record *)

Module DecidableFieldMatrixTheoryDR (E : DecidableFieldElementType)
<: DecidableFieldMatrixTheory E.

  Export E.
  Include RingMatrixTheoryDR E.
  Module Export DecMT := DecidableMatrixTheoryDR E.

  (** meq is decidable *)
  Lemma meq_dec : forall (r c : nat), Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec.
  Qed.

  (** ** matrix theory *)

  (** k * m = 0 -> (m = 0) \/ (k = 0) *)
  Lemma mcmul_eq0_imply_m0_or_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 r c in
      (k c* m == m0) -> (m == m0) \/ (k == A0)%A.
  Proof.
    intros. apply mcmul_eq0_imply_m0_or_k0. auto.
  Qed.

  (** (m <> 0 \/ k * m = 0) -> k = 0 *)
  Lemma mcmul_mnonzero_eq0_imply_k0 : forall {r c} (m : mat r c) k,
      let m0 := mat0 r c in
      ~(m == m0) -> k c* m == m0 -> (k == A0)%A.
  Proof.
    intros. apply (mcmul_mnonzero_eq0_imply_k0 m); auto.
  Qed.

  (** k * m = m -> k = 1 \/ m = 0 *)
  Lemma mcmul_same_imply_coef1_or_mzero : forall {r c} k (m : mat r c),
      k c* m == m -> (k == A1)%A \/ (m == mat0 r c).
  Proof.
    intros. apply mcmul_same_imply_coef1_or_mzero. auto.
  Qed.

  (** (m1 <> 0 /\ m2 <> 0 /\ k * m1 = m2) -> k <> 0 *)
  Lemma mcmul_eq_mat_implfy_not_k0 : forall {r c} (m1 m2 : mat r c) k,
      let m0 := mat0 r c in
      ~(m1 == m0) -> ~(m2 == m0) -> k c* m1 == m2 -> ~(k == A0)%A.
  Proof.
    intros. apply mcmul_eq_mat_implfy_not_k0 with m1 m2; auto.
  Qed.

End DecidableFieldMatrixTheoryDR.

(** * Extra Properties *)
Module ExtraMatrixTheoryDR (E : DecidableFieldElementType).

  Export E.
  Include (DecidableFieldMatrixTheoryDR E).

  (** Vector type *)
  Definition vecr n := mat 1 n.
  Definition vecc n := mat n 1.

  (** determinant of a 3D square matrix *)
  Definition det_of_mat_3_3 (m : mat 3 3) : A :=
    let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) :=
      m2t_3x3 m in
    let b1 := (a11 * a22 * a33)%A in
    let b2 := (a12 * a23 * a31)%A in
    let b3 := (a13 * a21 * a32)%A in
    let c1 := (a11 * a23 * a32)%A in
    let c2 := (a12 * a21 * a33)%A in
    let c3 := (a13 * a22 * a31)%A in
    let b := (b1 + b2 + b3)%A in
    let c := (c1 + c2 + c3)%A in
      (b - c)%A.

  (** Skew symmetrix matrix *)
  (* Definition skew_sym_mat_of_v3 (v : vecc 3) : mat 3 3. *)
  (* Proof. *)
  (*   destruct (v3_to_t3 v) as [[x y] z]. *)
  (*   refine (mk_mat_3_3 *)
  (*     A0    (-z)    y *)
  (*     z     A0     (-x) *)
  (*     (-y)  x       A0)%A. *)
  (* Defined. *)

  (* Cross/Vector product of 3D vector *)
  (* Definition v3cross (v1 v2 : V3) : vec 3 := (skew_sym_mat_of_v3 v1) * v2. *)

  (* A matrix is a SO3 (Special Orthogonal group, rotation group) *)
  Definition so3 (m : mat 3 3) : Prop :=
    let so3_mul_unit : Prop := (m \T) * m = mat1 3 in
    let so3_det : Prop := (det_of_mat_3_3 m) = A1 in
      so3_mul_unit /\ so3_det.

End ExtraMatrixTheoryDR.

Module coordinate_transform_test.

  Module Import MT := ExtraMatrixTheoryDR DecidableFieldElementTypeR.
  Import Reals.
  Open Scope R.
  Open Scope mat_scope.

  (* ref:
  https://en.wikipedia.org/wiki/Matrix_(mathematics)#Basic_operations
  *)

  Definition m1 := @l2m 2 3 [[1;3;1];[1;0;0]].
  Definition m2 := @l2m 2 3  [[0;0;5];[7;5;0]].
  Definition m3 := @l2m 2 3  [[1;3;6];[8;5;0]].
  Example madd_m1_m2_eq_m3 : m1 + m2 == m3.
  Proof.
    cbv. repeat constructor; ring.
  Qed.

  Definition m4 := @l2m 2 3 [[1;8;-3];[4;-2;5]].
  Definition m5 := @l2m 2 3 [[2;16;-6];[8;-4;10]].
  Example mscale_2_m4_eq_m5 : 2 c* m4 == m5.
  Proof.
    cbv. repeat constructor; ring.
  Qed.

  Definition m6 := @l2m 2 3 [[1;2;3];[0;-6;7]].
  Definition m7 := @l2m 3 2 [[1;0];[2;-6];[3;7]].
  Example mtrans_m6_eq_m7 : m6 \T == m7.
  Proof.
    cbv. repeat constructor; ring.
  Qed.

  Variable θ ψ φ : R.
  Definition Rx (α : R) : mat 3 3 := mk_mat_3_3
    1         0           0
    0         (cos α)     (sin α)
    0         (-sin α)%R    (cos α).

  Definition Ry (β : R) : mat 3 3 := mk_mat_3_3
    (cos β)   0           (-sin β)%R
    0         1           0
    (sin β)   0           (cos β).

  Definition Rz (γ : R) : mat 3 3 := mk_mat_3_3
    (cos γ)   (sin γ)   0
    (-sin γ)%R  (cos γ)   0
    0         0         1.

  Definition R_b_e_direct : mat 3 3 := (mk_mat_3_3
    (cos θ * cos ψ)
    (cos ψ * sin θ * sin φ - sin ψ * cos φ)
    (cos ψ * sin θ * cos φ + sin φ * sin ψ)

    (cos θ * sin ψ)
    (sin ψ * sin θ * sin φ + cos ψ * cos φ)
    (sin ψ * sin θ * cos φ - cos ψ * sin φ)

    (-sin θ)
    (sin φ * cos θ)
    (cos φ * cos θ))%R.

  Opaque cos sin.

  Lemma Rx_Ry_Rz_eq_Rbe : (Rz ψ)\T * (Ry θ)\T * (Rx φ)\T == R_b_e_direct.
  Proof.
    cbv. repeat constructor; ring.
  Qed.

End coordinate_transform_test.


Require Export D.

(** **** Exercise: 4 stars (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems backward to you, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:
      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}
    Give a counterexample showing that this rule is incorrect
    (informally). Hint: The rule universally quantifies over the
    arithmetic expression [a], and your counterexample needs to
    exhibit an [a] for which the rule doesn't work. *)

Lemma beq_id_refl : forall x,
    beq_id x x = true.
Proof.
  intros. unfold beq_id. simpl. induction x. induction n.
  - reflexivity.
  - simpl. assumption.
Qed.

Theorem hoare_asgn_wrong:
  exists a, ~ {{ fun st => True }} X ::= a {{ fun st => st X = aeval st a}}.
Proof.
  remember (t_update empty_state X 0) as st eqn: Heqst.
  remember (APlus (AId X) (ANum 1)) as X' eqn: HeqX'.
  remember (t_update st X (aeval st X')) as st' eqn: Heqst'.
  exists X'. intros H.
  assert (st' X = aeval st' X' -> False) as Hcontra.
  { subst. simpl. unfold t_update. rewrite beq_id_refl. intros H'. inversion H'. }
  apply Hcontra. eapply H.
  - rewrite Heqst'. apply E_Ass. reflexivity.
  - reflexivity.
Qed.