Require Import rt.util.all.
Require Import rt.model.arrival.basic.arrival_sequence rt.model.arrival.basic.task rt.model.arrival.basic.task_arrival rt.model.arrival.basic.job.
Require Import rt.implementation.uni.jitter.task
               rt.implementation.uni.jitter.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset TaskArrival.

  Section PeriodicArrivals.

    Variable ts: concrete_taskset.

    (* At any time t, we release Some job of tsk if t is a multiple of the period,
       otherwise we release None. *)
    Definition add_job (arr_time: time) (tsk: concrete_task) :=
      if task_period tsk %| arr_time  then
        Some (Build_concrete_job (arr_time %/ task_period tsk) arr_time
                                 (task_cost tsk) (task_deadline tsk) tsk)
      else
        None.

    (* The arrival sequence at any time t is simply the partial map of add_job. *)
    Definition periodic_arrival_sequence (t: time) := pmap (add_job t) ts.

  End PeriodicArrivals.

  Section Proofs.

    (* Let ts be any concrete task set with valid parameters. *)
    Variable ts: concrete_taskset.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Regarding the periodic arrival sequence built from ts, we prove that...*)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ... arrival times are consistent, ... *)
    Theorem periodic_arrivals_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.
    Proof.
      move => j t ARRj.
      rewrite /arrives_at mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ... every job comes from the task set, ... *)
    Theorem periodic_arrivals_all_jobs_from_taskset:
      forall j,
        arrives_in arr_seq j ->
        job_task j \in ts.
    Proof.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ..., jobs have valid parameters, ... *)
    Theorem periodic_arrivals_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.
    Proof.
      rename H_valid_task_parameters into PARAMS.
      unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj; move: ARRj => /mapP [tsk IN SOME].
      unfold add_job in SOME; desf.
      specialize (PARAMS tsk IN); des.
      unfold valid_sporadic_job, valid_realtime_job, job_cost_positive.
      by repeat split; try (by done); apply leqnn.
    Qed.

    (* ... job arrivals satisfy the sporadic task model, ... *)
    Theorem periodic_arrivals_are_sporadic:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Proof.
      move => j j' /eqP DIFF [arr ARR] [arr' ARR'] SAMEtsk LE.
      rewrite eqE /= /job_eqdef negb_and /= SAMEtsk eq_refl orbF in DIFF.
      rewrite 2!mem_pmap in ARR ARR'.
      move: ARR ARR' => /mapP [tsk_j INj SOMEj] /mapP [tsk_j' INj' SOMEj'].
      unfold add_job in SOMEj, SOMEj'; desf; simpl in *;
      move: Heq0 Heq => /dvdnP [k DIV] /dvdnP [k' DIV'].
      {
        rewrite DIV DIV' -mulSnr.
        rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LESS].
        {
          exfalso; move: DIFF => /negP DIFF; apply DIFF.
          by subst; rewrite EQ !eq_refl.
        }
        subst; rewrite leq_mul2r; apply/orP; right.
        by rewrite ltn_mul2r in LESS; move: LESS => /andP [_ LT].
      }
    Qed.

    (* ... and the arrival sequence has no duplicate jobs. *)
    Theorem periodic_arrivals_is_a_set:
      arrival_sequence_is_a_set arr_seq.
    Proof.
      intros t.
      unfold arr_seq, periodic_arrival_sequence.
      apply (pmap_uniq) with (g := job_task); last by destruct ts.
      by unfold add_job, ocancel; intro tsk; desf.
    Qed.

  End Proofs.

End ConcreteArrivalSequence.


(** Copyright (c) 2015-2022 George M. Van Treeck.
    Rights granted under the Creative Commons
    Attribution License.
    This software uses The Coq Proof Assistance,
    Copyright (c) 1999-2022  The Coq Development Team
    Rights granted under
    GNU Lesser General Public License Version 2.1. *)

Require Import Arith PeanoNat Lia Field Bool Sumbool List.

Require Import Rdefinitions Raxioms RIneq Rfunctions R_Ifp.

Section EuclideanRelations.

(**
   This file contains defintions and proofs for set operations,
   list opertations, the ruler measure, operations on lists of
   real numbers, and finally sections with proofs of volume,
   Minkowski ditances/Lp norms, etc.
*)
(*
   The definitions, lemmas, and proofs of the set operations,
   lists, ruler measure, volume, Minkowski distance, etc. are
   all in one file, because I wanted this file to be easy to
   use by just loading this one file and everything works
   without any special setup of load and import paths.
*)

(** ==================================================== *)
(** This section has generic set definitions and proofs. *)

(** Allow sets of any type. *)
Variable A : Type.
(** Equality of instances of a type is decideable. *)
Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.

(** Member of the set. *)
Fixpoint set_member (a:A) (x: list A) : bool :=
    match x with
    | nil => false
    | a1 :: x1 => if (eq_dec a a1) then true else set_member a x1
    end.

(** Append a list of sets. *)
Fixpoint lists_appended (l: list (list A)) : list A :=
    match l with
    | nil => nil
    | a::x => a++(lists_appended x)
    end.

(** Return a list with the duplicates removed. *)
Fixpoint uniques(x: list A) : list A :=
    match x with
    | nil => nil
    | a1 :: x1 =>
        if set_member a1 x1 then
             uniques x1 else a1 :: uniques x1
    end.

(** Union of a list of sets. *)
Definition union (l: list (list A)) : list A :=
    uniques (lists_appended l).

(** Return a list of the duplicates. *)
Fixpoint dups(x: list A) : list A :=
    match x with
    | nil => nil
    | a1 :: x1 =>
        if set_member a1 x1 then
             a1 :: dups x1 else dups x1
    end.

(** Duplicates in a list of sets. *)
Definition duplicates (l: list (list A)) : list A :=
    dups (lists_appended l).

(** Intersection is the duplicates sets with non-unique
    duplicates removed. *)
Definition intersection (l: list (list A)) : list A :=
    uniques (duplicates l).

(** Difference between a set of uniques, nd, and dups, d. *)
Fixpoint diff_dups (nd d: list A) : list A :=
    match nd with
    | nil => nil
    | a1 :: x1 =>
        if set_member a1 d then
             diff_dups x1 d else a1 :: diff_dups x1 d
    end.

(** Difference between a list of sets. *)
Definition diff (l: list (list A)) : list A :=
    diff_dups (union l) (intersection l).

(** Sum the cardinals of a list of sets. *)
Fixpoint list_lengths_summed (l: list (list A)) : nat :=
    match l with
    | nil => 0
    | a::x => length a + (list_lengths_summed x)
    end.

(** The cardinal of an appended set is equal to sum of
    the cardinals of each set. *)
Lemma cardinal_lists_appended_eq_list_lengths_summed :
    forall (l: list (list A)),
    length (lists_appended l) = list_lengths_summed l.
Proof.
  intros.
  induction l. reflexivity.
  assert (app_l_lists : forall (x: list A) (y: list (list A)),
      lists_appended (x::y) = x++(lists_appended y)).
      intros. induction y. reflexivity. reflexivity.
  rewrite app_l_lists.
  assert (summed_lists : forall (x: list A) (y: list (list A)),
      list_lengths_summed (x::y) = length x + list_lengths_summed y).
      intros. induction y. reflexivity. reflexivity.
  rewrite summed_lists.
  rewrite app_length.
  lia.
Qed.

(** The length of a list is equal to length of the duplicate elements
   plus the unique elements. *)
Lemma set_mem_in_duplicates_or_union : forall (a: A) (l: list A),
    length l = length ((dups l) ++ (uniques l)).
Proof.
  intros.
  induction l. reflexivity. simpl.
  induction set_member. simpl. inversion IHl. reflexivity.
  assert (length (dups l ++ a0 :: uniques l) =
          length (a::nil) + length (dups l ++ uniques l)).
      simpl. rewrite -> app_length. simpl.
      assert (forall n: nat, S n = n + 1).
          intros. lia.
      rewrite -> H. rewrite -> plus_assoc. rewrite <- app_length.
      rewrite <- H. reflexivity.
  rewrite -> H. simpl. inversion IHl. reflexivity.
Qed.

(** The cardinal of a list of sets is equal to the cardinal of
    the union plus duplicates of that list of sets. *)
Lemma card_app_eq_card_union_plus_dups :
    forall (a: A) (l: list (list A)),
    length (lists_appended l) = length (duplicates l ++ union l).
Proof.
  intros. unfold duplicates. unfold union.
  apply set_mem_in_duplicates_or_union. assumption.
Qed.

(** The sum of the cardinal of sets equals the
    cardinal of the union plus the cardinal of the duplicates. *)
Theorem sum_eq_uniques_plus_duplicates :
    forall (a: A) (l: list (list A)),
    list_lengths_summed l = length (duplicates l) + length (union l).
Proof.
  intros. rewrite <- cardinal_lists_appended_eq_list_lengths_summed.
  rewrite <- app_length.
  apply card_app_eq_card_union_plus_dups. assumption.
Qed.

(** The size (cardinal) of the union set is less than and
    equal to the sum of set sizes. *)
Theorem union_sum_inequality :
    forall (a: A) (l: list (list A)),
    length (union l) <= list_lengths_summed l.
Proof.
  intros.
  rewrite -> sum_eq_uniques_plus_duplicates.
  apply le_plus_r. assumption.
Qed.

(** End of generic set operations and proofs. *)

(** ==================================================== *)
(** Start of generic operations on lists. *)

(** default value returned when no set member found. *)
Variable default_element: A.

(** Definition of an empty set. *)
Definition empty_list : list A := nil.

(** Returns the element at position i in the list. *)
Fixpoint list_mem (i:nat) (l:list A) {struct l} : A :=
    match i, l with
    | O, _ => default_element
    | S m, nil => default_element
    | S m, h::t => list_mem m t
    end.

(** End of generic operations on lists. *)

(** ================================================================ *)
(** Start of generic operations and proofs for lists of
    real numbers *)

Local Open Scope nat_scope.
Local Open Scope R_scope.
Local Open Scope list_scope.

(** If two natural numbers are equal then they are also equal
    as real numbers *)
Lemma eq_INR : forall (m n: nat), (m = n)%nat -> INR m = INR n.
Proof.
  induction 1; intros; apply @eq_refl.
Qed.

(** Return a list of n number of real values, initialized
    to 0. *)
Fixpoint rlist (n : nat) (r: R) : list R :=
  match n with
  | O => nil
  | S n' => r:: (rlist n' r)
  end.

(** Returns the element at position i in the list. *)
Fixpoint list_rmem (i:nat) (l:list R) {struct l} : R :=
    match i, l with
    | O, _ => 0
    | S m, Datatypes.nil => 0
    | S m, h::t => list_rmem m t
    end.

(** Raise a real number, r, to the n-th power. *)
Fixpoint Rpow (r: R) (n: nat) : R :=
    match n with
        | 0%nat => 1
        | S n' =>(r * Rpow r n')
    end.

(** x >= 0, n >= 1 -> x^{n} >= 0. *)
Hypothesis Rpow_ge_0 :
    forall (x: R) (n: nat), x >= 0 -> Rpow x n >= 0.

(** r1^n * r2^n = (r1 * r2)^n *)
Hypothesis pow_distributes : forall (r1 r2: R) (n: nat),
    (Rpow r1 n) * (Rpow r2 n) = Rpow (r1 * r2) n.

(** f(x) = f(y) -> x = y applied to power functions *)
Hypothesis pow_eq_args : forall (r1 r2: R) (n: nat),
    Rpow r1 n = Rpow r2 n -> r1 = r2.

(** f(x) <= f(y) -> x <= y applied to power functions *)
Hypothesis pow_le_args : forall (r1 r2: R) (n: nat),
    Rpow r1 n <= Rpow r2 n -> r1 <= r2.

(** f(x) >= f(y) -> x >= y applied to power functions *)
Hypothesis pow_ge_args : forall (r1 r2: R) (n: nat),
    Rpow r1 n >= Rpow r2 n -> r1 >= r2.

(** Assume that if real number, r, exists then that number is
    the n-th root some other real number, r'. *)
Hypothesis nth_root_exists :
    forall (r: R) (n: nat), exists (r': R), r = (Rpow r' n).

(** Two sets of real values are equal if all the elements
    at the same positions are also equal. *)
Inductive eq_list_R : list R -> list R -> Prop :=
  | eq_list_R_nil : eq_list_R Datatypes.nil Datatypes.nil
  | eq_list_R_cons : forall (i: nat) (l1 l2: list R),
      list_rmem i l1 = list_rmem i l2 -> eq_list_R l1 l2.

(** Lists with same real values at same positions are equal. *)
Hypothesis eq_list_R_is_eq : forall (l1 l2: list R),
    eq_list_R l1 l2 -> l1 = l2.

(** Reflexivity on lists of real values. *)
Lemma list_refl : forall (x y: list R), x = y -> y = x.
Proof. intros. apply eq_sym ; assumption. Qed.

(** Sum a list of real numbers. *)
Fixpoint sum_list (l: list R) : R :=
    match l with
      | Datatypes.nil => 0
      | a::l' => a + (sum_list l')
    end.

(** Raise each member of a list of real numbers to
    the n^th power . *)
Fixpoint pow_list (l: list R) (n: nat) : list R :=
  match l with
    | Datatypes.nil => Datatypes.nil
    | a::l' => (Rpow a n)::(pow_list l' n)
  end.

(** Specification of pow_list. *)
Hypothesis pow_list_spec : forall (i n: nat) (a: R) (l: list R),
    (list_rmem i l) = a <-> list_rmem i (pow_list l n) = Rpow a n.

(** Multiply each member of a list of real numbers by the number, r. *)
Fixpoint mult_list (l: list R) (r: R) : list R :=
    match l with
      | Datatypes.nil => Datatypes.nil
      | a::l' => (a*r)::(mult_list l' r)
    end.

(** Specification of mult_list. *)
Hypothesis mult_list_spec : forall (i: nat) (a r: R) (l: list R),
    (list_rmem i l) = a <-> list_rmem i (mult_list l r) = a * r.

(** r * (a1 + a2 + ... + an) = (a1*r) + (a2*r) + ... + (an*r). *)
Hypothesis mult_distributes_over_sum_list :
    forall (l: list R) (r: R),
    (sum_list l) * r = sum_list(mult_list l r).

(** The cartesian product of a list of numbers. *)
Fixpoint cartesian_product (l: list R) : R :=
    match l with
        | Datatypes.nil => 1
        | hd::tl => hd * cartesian_product tl
    end.

(** r^n * (a1 * a2 * ... * an) = (a1*r) * (a2*r) * ... * (an*r). *)
Hypothesis pow_distributes_over_cartesian_product :
    forall (l: list R) (r: R) (n: nat), n = length l ->
    (cartesian_product l) * Rpow r n = cartesian_product (mult_list l r).

(* Binomial coefficitnt, n Choose k at a time:
   n_Choose_k = n!/(k!(n-k)!). *)
Definition n_Choose_k (k n: nat) : R :=
  INR (fact(n))/(INR ((fact(k))* (fact(n-k)))).

(* Binomial expansion term *)
Definition binom_term (x y: R) (k n: nat) : R :=
  n_Choose_k k n * Rpow x (n - k) * Rpow y k.

(* List of binomial terms. *)
(** Raise each member of a list of real numbers to
    the n^th power . *)
Fixpoint binomial_term_list (l: list R) (x y: R) (k n: nat) :
  list R :=
  match l with
    | Datatypes.nil => Datatypes.nil
    | a::l' =>
     (binom_term x y k n)::(binomial_term_list l' x y (k + 1) n)
  end.

(** Specification of a list of n number of binomial terms. *)
Hypothesis binomial_term_list_spec :
    forall (a x y: R) (i k n: nat) (l: list R),
    (list_rmem i l) = a <->
    list_rmem i (binomial_term_list l x y k n) =
        binom_term x y k n.

(** Partially expanded binomial terms,
    x^n + n_Choose_k (n,1)x^(n-k)y^k + y^n. *)
Hypothesis binomial_expansion_equiv :
    forall (x y: R) (n: nat) (l: list R),
    sum_list (binomial_term_list l x y 0%nat n) =
        Rpow x n + Rpow y n +
           sum_list (binomial_term_list l x y 1%nat (n-1)).

(** Lower order binomial terms, for x y >= 0 :
    n_Choose_k (n,1)x^(n-k)y^ >= 0. *)
Hypothesis lower_order_binomial_terms :
    forall (x y: R) (n: nat) (l: list R),
    x = 0 /\ x > 0 /\ y = 0 /\ y > 0 ->
    sum_list (binomial_term_list l x y 1%nat (n-1)) >= 0.

Definition binomial_expansion (x y: R) (n: nat) : list R :=
    binomial_term_list (rlist n 0%R) x y 0%nat n.

Hypothesis binomial_eq :
    forall (x y: R) (n: nat),
    Rpow (x + y) n = sum_list (binomial_expansion x y n).

(** End of generic operations and proofs on lists of real numbers *)

(** ==================================================== *)
(** Start of definitions and proofs for the Ruler Measure *)

(** list_mem returns the ith list in list l. *)
Definition list_list_mem (i: nat) (l: list (list A)) :
    list A := nth i l nil.

(** The ruler measure definition is in terms of the
    floor function. The Coq starndard library does not
    have a real-valued version of the floor function.
    Therefore, the first step is define the floor
    function and prove some properties about the floor
    function. *)

(** Define the floor function as the integer part of
    a real-valued number. *)
Definition R_floor (x: R) : R := IZR (Int_part x).

(** The following lemmas about integer and fractional
    parts of a real number are used to prove properties
    of the R_floor function. *)

(** A real number is the sum of it's whole integer part
    plus the fractional part. *)
Lemma r_eq_ip_plus_frac :
    forall r: R, r = IZR (Int_part r) + frac_part r.
Proof.
  intros. unfold Int_part. unfold frac_part.
  unfold Int_part. apply eq_sym ; trivial. apply Rplus_minus.
Qed.

(** 0 <= r - floor r < 1. That is, a real number minus the
    integer part is equal to the size of the fractional part. *)
Lemma r_minus_floor_ge_0_lt_1 : forall r: R,
    r - R_floor r >= 0 /\ r - R_floor r < 1.
Proof.
  intros. unfold R_floor.
  assert (r = IZR (Int_part r) + frac_part r).
    apply r_eq_ip_plus_frac.
  apply (Rplus_eq_compat_l
    (- IZR (Int_part r)) (r) (IZR (Int_part r) + frac_part r)) in H.
  rewrite -> (Rplus_comm (- IZR (Int_part r)) r) in H.
  rewrite <- (Rplus_assoc
    (-IZR (Int_part r)) (IZR (Int_part r)) (frac_part r) ) in H.
  rewrite -> (Rplus_comm (- IZR (Int_part r))
    (IZR (Int_part r))) in H.
  rewrite -> (Rplus_opp_r (IZR (Int_part r))) in H.
  rewrite -> (Rplus_0_l (frac_part r)) in H.
  assert (frac_part r >= 0 /\ frac_part r < 1).
  apply base_fp. decompose [and] H0.
  assumption.
Qed.

(** If r >= 0 then |r| >= 0. *)
Lemma ge_0_abs_ge_0 : forall r: R, r >= 0 -> Rabs r >= 0.
Proof.
  intros; unfold Rabs; case (Rcase_abs r); intro.
  absurd (r >= 0). exact (Rlt_not_ge r 0 r0). assumption. assumption.
Qed.

(** 0 <= |r - floor r| < 1. *)
Lemma abs_r_minus_floor_ge_0_lt_1 : forall r: R,
    Rabs (r - R_floor r) >= 0 /\ Rabs(r - R_floor r) < 1.
Proof.
  intros. unfold R_floor.
  assert (r - IZR (Int_part r) >= 0 /\ r - IZR (Int_part r) < 1).
    apply r_minus_floor_ge_0_lt_1. decompose [and] H.
  split. revert H0. apply ge_0_abs_ge_0.
  assert (r - IZR (Int_part r) >= 0 ->
    Rabs (r - IZR (Int_part r))= r - IZR (Int_part r)).
  apply Rabs_right with (r := r - IZR (Int_part r)).
  rewrite -> H2. assumption. assumption.
Qed.

(** 0 <= |floor r - r| < 1. *)
Lemma abs_floor_minus_r_ge_0_lt_1 : forall r: R,
    Rabs (R_floor r - r) >= 0 /\ Rabs(R_floor r - r) < 1.
Proof.
  intros. rewrite (Rabs_minus_sym (R_floor r) r).
  apply abs_r_minus_floor_ge_0_lt_1.
Qed.

(** This lemma is missing from the standard library, RIneq.v. *)
Lemma R_lt_mult_lt : forall r r1 r2 : R,
     0 < r -> r1 < r2 -> r * r1 < r * r2.
Proof. intros. apply Rmult_lt_compat_l. assumption. assumption. Qed.

(**
   Now the ruler measure convergence proof follows:
*)

(** The exact size of a interval. *)
Definition exact_size (a b: R) : R := Rabs (b - a).

(** The number of subintervals with size, c. *)
Definition subintervals (a b c: R) : R :=
  R_floor (exact_size a b / c).

(** M is the ruler measure, subintervals * c. *)
Definition M (a b c: R) : R := (subintervals a b c) * c.

(** Used for rewriting between M and subintervals. *)
Lemma subintervals_times_c_eq_measure :
    forall a b c: R, c > 0 ->
    M a b c = (subintervals a b c) * c.
Proof. intros. unfold M. reflexivity. Qed.

(** Let r := subintervals in 0 <= |floor r - r| < 1. *)
Lemma subintervals_div_c_le_size : forall a b c: R,
    c > 0 ->
    Rabs(subintervals a b c - (exact_size a b) / c) < 1.
Proof.
  intros. unfold subintervals.
  apply abs_floor_minus_r_ge_0_lt_1.
Qed.

(** |M - s| < |c|}. *)
Lemma abs_M_minus_s_lt_abs_c : forall a b c: R,
    c > 0 ->
    Rabs((M a b c) - exact_size a b) < Rabs c.
Proof.
  intros. unfold M. unfold subintervals.
  assert (Rabs(R_floor(exact_size a b / c) -
      (exact_size a b) / c) < 1).
    apply subintervals_div_c_le_size.
    assumption.
  apply R_lt_mult_lt with (r := Rabs c)
    (r1 := Rabs (R_floor (exact_size a b / c) - exact_size a b / c))
    (r2 := 1) in H0.
  rewrite -> (Rmult_1_r (Rabs c)) in H0.
  rewrite <- (Rabs_mult (c)
    (R_floor (exact_size a b / c) - (exact_size a b / c))) in H0.
  unfold Rminus in H0.
  rewrite -> (Rmult_plus_distr_l (c)
    (R_floor (exact_size a b / c))
    (- (exact_size a b / c))) in H0.
  unfold Rdiv at 2 in H0.
  rewrite -> (Rmult_comm c (R_floor (exact_size a b / c))) in H0.
  rewrite -> (Ropp_mult_distr_r_reverse (c)
    (exact_size a b * / c)) in H0.
  rewrite <- (Rmult_assoc (c) (exact_size a b) (/ c)) in H0.
  rewrite -> (Rmult_comm c (exact_size a b)) in H0.
  rewrite -> (Rmult_assoc (exact_size a b) (c) (/ c)) in H0.
  rewrite -> (Rinv_r c) in H0.
  rewrite -> (Rmult_1_r (exact_size a b)) in H0.
  assumption.
  apply Rgt_not_eq.
  apply H.
  assert (c <> 0).
  apply Rgt_not_eq.
  apply H.
  revert H1.
    apply Rabs_pos_lt.
Qed.

(** Epsilon-delta proof. limit c->0,
    0 < |c - 0| < delta => |M - s| < epsilon. *)
Lemma M_minus_exact_size_lt_epsilon :
    forall a b c delta epsilon: R,
    c > 0 /\ 0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    0 < Rabs (c - 0) < delta ->
    Rabs(M a b c - exact_size a b) < epsilon.
Proof.
  intros. decompose [and] H.
  assert (Rabs (c - 0) = Rabs c).
  simple apply f_equal_R.
  simple apply Rminus_0_r.
  rewrite -> H5 in H6.
  assert (Rabs(M a b c - exact_size a b) < Rabs c).
    apply abs_M_minus_s_lt_abs_c. assumption.
  rewrite H3 in H6. revert H6. revert H7.
  apply Rlt_trans with
    (r1 := Rabs (M a b c - exact_size a b))
    (r2 := Rabs c)
    (r3 := epsilon).
Qed.

(** Defintion of a Epsilon-delta proof for ruler measure, M. *)
Hypothesis limit_x_Lim1_f_x_eq_Lim2 :
    forall (a b x Lim1 Lim2 delta epsilon:R)
        (f: R->R->R->R) (g: R->R),
    0 < delta /\ 0 < epsilon /\ g delta = epsilon /\
    Rabs (x - Lim1) < delta /\
    Rabs(f a b x - Lim2) < epsilon ->
    f a b x = Lim2.

(* The function relating delta to epsilon to prove
   convergence. *)
Definition delta_eq_epsilon(d: R) : R := d.

(** Epsilon-delta proof. limit c->0,
    0 < |x - 0| < delta, |M - s| < epsilon -> M = s. *)
Lemma limit_c_0_M_eq_exact_size :
    forall (a b c Lim1 Lim2 delta epsilon:R)
        (f: R->R->R->R) (g: R->R),
    c > 0 /\
    f = M /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\ Lim2 = exact_size a b /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs(M a b c - Lim2) < epsilon ->
    M a b c = exact_size a b.
Proof.
  intros. decompose [and] H.
  rewrite <- H2. rewrite <- H4.
  apply limit_x_Lim1_f_x_eq_Lim2 with (Lim1 := Lim1) (Lim2 := Lim2)
      (delta := delta) (epsilon := epsilon) (g := g).
  split. assumption. split. assumption.
  split.
  rewrite -> H1. unfold delta_eq_epsilon. assumption.
  split. assumption.
  rewrite -> H2. assumption.
Qed.

(** End RulerMeasure. *)

(** ======================================= *)
(**
  Now the definitions and theorems about volume and distance.
*)

(** List of the countable domain sets (x_i in X). *)
Variable list_x_i: list A.
(** List of countable domain sets, X = list(i=1 to n) list_x_i *)
Variable X: list (list A).
(** Xpd = union(i=1 to n) list_x_i *)
Variable Xpd: list A.
(** Counters *)
Variables i m n: nat.
(** The boundaries of a domain interval, [a_i,b_i},
   i in [1,n]). *)
Variables a_i b_i: R.
(** The list of the exact size of each interval,
    [a_i,b_i}, i in [1,n]). *)
Variable s: list R.
(** The list of cardnals corresponding to each list_x_i (the
    number of elements in the intervals [a_i,b_i},
    i in [1,n]). *)
Variable p: list R.
(** The ruler interval size. *)
Variable c: R.

(** Volume-specific variable definitions. *)

(** The countable size (length/area/volume) of a set of
    image elements. *)
Variable v v_c: R.
(** The boundaries of the image (size) interval, [v_0,v_m]. *)
Variables v_a v_b: R.

(** An Epsilon-delta definition for c^n used in
    lemma lim_power_c_to_n_eq_c. *)
Hypothesis limit_c_Lim1_f_c_eq_Lim2 :
    forall (c Lim1 Lim2 delta epsilon:R),
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs(c - Lim2) < epsilon ->
    c = 0.

(** An Epsilon-delta definition for c^n used in
    lemma lim_power_c_to_n_eq_c. *)
Hypothesis limit_c_Lim1_f_c_n_eq_Lim2 :
    forall (c Lim1 Lim2 delta epsilon:R)
        (f: R->nat->R) (g: R->R),
    0 < delta /\ 0 < epsilon /\ g delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs(f c n - Lim2) < epsilon ->
    f c n = 0.

(** This lemma is used in the proof of the next lemma. *)
Lemma lim_c_to_n_eq_0 :
    forall ( c Lim1 Lim2 delta epsilon:R)
        (f: R->nat->R) (g: R->R),
    c > 0 /\
    f = Rpow /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\ Lim2 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs ((Rpow c n) - Lim2) < epsilon ->
    Rpow c n = 0.
Proof.
  intros. decompose [and] H.
  rewrite <- H2.
  apply limit_c_Lim1_f_c_n_eq_Lim2 with (Lim1 := Lim1) (Lim2 := Lim2)
      (delta := delta) (epsilon := epsilon) (g := g).
  split. assumption. split. assumption.
  split. rewrite -> H1. unfold delta_eq_epsilon. assumption.
  split. assumption.
  rewrite -> H2. assumption.
Qed.

(** This lemma is used in the volume proof. *)
Lemma lim_c_to_n_eq_lim_c :
    forall ( c Lim1 Lim2 delta epsilon:R)
        (f: R->nat->R) (g: R->R),
    c > 0 /\
    f = Rpow /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\ Lim2 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs ((Rpow c n) - Lim2) < epsilon ->
    Rpow c n = c.
Proof.
  intros. decompose [and] H.
  assert (Lim1 = Lim2). rewrite -> H3. rewrite -> H4. trivial.
  assert (c0 = 0).
  apply limit_c_Lim1_f_c_eq_Lim2 with (Lim1 := Lim1) (Lim2 := Lim2)
      (delta := delta) (epsilon := epsilon).
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  rewrite <- H9. rewrite <- H7. assumption.
  assert (Rpow c0 n = 0).
  apply lim_c_to_n_eq_0 with (Lim1 := Lim1) (Lim2 := Lim2)
      (delta := delta) (epsilon := epsilon) (f := f) (g := g).
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  split. assumption. assumption.
  rewrite <- H11 in H12. assumption.
Qed.

(**
  A countable volume measure of a list of domain sets:
  forall i in [1,n], x_i in ith set of X in
  intersection X = empty_set /\
  p_i = cardinal of ith set of X ->
  size, v_c = |{(X_1,...,X_n)}|=|list_x_1|*...*|list_x_n|.
*)
Hypothesis countable_volume_measure :
    (i <= n)%nat /\ length X = n /\
    duplicates X = empty_list /\
    list_rmem i p = subintervals a_i b_i c /\
    v_c = cartesian_product p.

(** The Euclidean volume (length/area/volume) theorem:
    v, is the length of a real-valued interval in:
    {}a_1, b_1],...,[a_n, b_n]}, where:
    v_c = cartesian_product p => v = cartesian_product(i=1 to n) s_i /\
    v = v_{m} - v_{0} /\
    s_i = b_i - a_i. *)
Theorem Euclidean_volume :
    forall (Lim1 Lim2 delta epsilon p_v: R)
        (f: R->R->R->R) (g: R->R),
    (* ruler based definitions *)
    c > 0 /\
    f = M /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\ Lim2 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    Rabs (c - Lim1) < delta /\
    Rabs ((Rpow c n) - Lim2) < epsilon /\
    Rabs (M a_i b_i c - exact_size a_i b_i) < epsilon /\
    n = length s /\ length p = n /\
    (* The length of each domain interval, exact_size a_i b_i,
       is assinged to a member of s. *)
    list_rmem i s = exact_size a_i b_i /\
    (* The number of subintervals in each domain interval,
       subintervals a_i b_i c, is assinged to a member of p. *)
    list_rmem i p = subintervals a_i b_i c /\
    (* Volume, v, is the length of the range interval, [v_a,v_b]. *)
    v = exact_size v_a v_b /\
    (* Countable n-volume, v_c, is the number of subintervals
       (infinitesimals) in the range interval, [v_a,v_b]. *)
    v_c = subintervals v_a v_b c /\
    (* The definition of countable n-volume as the Cartesian product
       of the number of members in each countable domain set. *)
    v_c = cartesian_product p ->
    v = cartesian_product s.
Proof.
  intros. intros.
  decompose [and] countable_volume_measure. decompose [and] H.
  decompose [and] H0.
  (* Show that each domain interval length, s_i = |b_i - a_i|,
     corresponds to a set of p_i number of size c subintervals. *)
  apply mult_list_spec with (l := p)
      (a := subintervals a_i b_i c) (r := c) in H19.
  rewrite <- subintervals_times_c_eq_measure in H19.
  rewrite -> limit_c_0_M_eq_exact_size with
      (a := a_i) (b := b_i) (c := c) (Lim1 := Lim1)
      (g := g) (delta := delta) (epsilon := epsilon)
      (Lim2 := exact_size a_i b_i) (f := M) in H19.
  rewrite <- H18 in H19.
  (* Show that the list, s, of domain interval lengths corresponds
     to the list, p, of the number of size c subintervals. *)
  apply eq_list_R_cons with  (l1 := mult_list p c) (l2 := s) in H19.
  apply eq_list_R_is_eq in H19.
  (* Show that the Cartesian product of the number of size c
     subintervals equals the product of interval lengths. *)
  assert (cartesian_product (mult_list p c) = cartesian_product s).
  rewrite -> H19.
  reflexivity.
  (* Show that multiplying both sides of countable distance
     by c^{n}, maintains the equivalence relation. *)
  assert (v_c * (Rpow c n) = (cartesian_product p) * (Rpow c n)).
  rewrite <- H23.
  reflexivity.
  (* Show that (cartesian_product p) * Rpow c n =
     cartesian_product s *)
  assert ((cartesian_product p) * Rpow c n =
          cartesian_product (mult_list p c)).
  apply pow_distributes_over_cartesian_product.
  symmetry. assumption.
  rewrite -> H22 in H25.
  (* Show that v_c * Rpow c n = cartesian_product s *)
  rewrite <- H24 in H25.
  (* Show that lim c->0 (v_c * Rpow c n) = lim c->0 (v_c * c) *)
  assert (Rpow c n = c).
  apply lim_c_to_n_eq_lim_c with (c := c) (Lim1 := Lim1)
      (Lim2 := Lim2) (g := g) (delta := delta)
      (epsilon := epsilon) (f := Rpow).
  split. assumption. split. reflexivity.
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  split. assumption. split. assumption.
  split. assumption. assumption.
  rewrite -> H26 in H25.
  (* Show that lim c->0 v_c * c = v *)
  rewrite -> H21 in H25.
  rewrite <- subintervals_times_c_eq_measure in H25.
  rewrite -> limit_c_0_M_eq_exact_size with
      (a := v_a) (b := v_b) (c := c) (Lim1 := Lim1)
      (g := g) (delta := delta) (epsilon := epsilon)
      (Lim2 := exact_size v_a v_b) (f := M) in H25.
  rewrite <- H20 in H25.
  assumption.
  (* Clean up hypothoses *)
  split. assumption. split. reflexivity.
  split. assumption. split. assumption.
  split. reflexivity. split. assumption. split. assumption.
  split. assumption. split. assumption.
  apply M_minus_exact_size_lt_epsilon with
    (a := v_a) (b := v_b) (c := c)
    (delta := delta) (epsilon := epsilon).
  split. assumption. split. assumption. split. assumption.
  split. assumption. split.
  assert (Rabs (c - 0) = Rabs c).
  simple apply f_equal_R.
  simple apply Rminus_0_r.
  assert (Rabs c = c).
  apply Rabs_right. intuition.
  rewrite -> H27.
  rewrite -> H28.
  assumption.
  rewrite <- H8.
  assumption.
  assumption.
  split. assumption. split. reflexivity. split. assumption.
  split. assumption. split. reflexivity. split. assumption.
  split. assumption. split. assumption. split. assumption.
  assumption.
  assumption.
Qed.

(** ================================================================ *)

(** Variables used in the distance proofs. *)

(** List of the countable range sets (y_i in Y). *)
Variable list_y_i: list A.
(** List of countable image sets, Y = union(i=1 to n) list_y_i *)
Variable Y: list (list A).
(** Countable distance is cardinal of Y = union(y_i). *)
Variable d_c: nat.
(** The boundaries of the image (distance) interval, [d_0,d_m]. *)
Variables d_0 d_m: R.
(* The real-valued size of the distance interval [d_0,d_m]. *)
Variable d: R.

(** From the ruler measure, these are exact
    sizes of the domain and image intervals that the
    subintervals must be shown to converge to. *)
Hypothesis exact_d_sizes :
    list_rmem i s = exact_size a_i b_i /\
    d = exact_size d_0 d_m.

(** Definitions of domain and image subintervals that are
    used in Minkowski distance/Lp norm proofs. *)
Hypothesis ruler_d_subintervals :
    c > 0 /\
    subintervals a_i b_i c = INR (length list_x_i) /\
    list_rmem i p = subintervals a_i b_i c /\
    subintervals d_0 d_m c = INR d_c.

(**
  A countable n-volume is the sum of n-volumes.
*)
Hypothesis countable_n_volume :
    exists (m0 : nat),
    length p = m0 /\
    (i <= m0)%nat /\ length Y = m0 /\
    (* list_y_i is the i_th domain set in Y *)
    list_y_i = list_list_mem i Y /\
    list_rmem i p = INR (length list_y_i) /\
    Rpow (INR d_c) n = sum_list (pow_list p n).

(** For econvenience in the following proof steps, create the
    variable pow_d_c = Rsqr d_c. *)
Variable pow_d_c_n: R.
(** From the lemma, pow_d_c_eq_sum_squares, pow_d_c = Rsqr d_c =>
    pow_d_c = sum_list (sqr_list p). *)
Hypothesis pow_d_c_sum_powers :
    pow_d_c_n = sum_list (pow_list p n).

(** Multiply both sides Rsqr c and apply the ruler measure and
    covergence theorem. *)
Lemma d_c_measure :
    forall (Lim1 Lim2 delta epsilon:R)
        (f: R->R->R->R) (g: R->R),
    c > 0 /\
    f = M /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    0 < Rabs (c - Lim1) < delta ->
    pow_d_c_n * Rpow c n = sum_list (pow_list s n).
Proof.
  intros. decompose [and] H.
  decompose [and] exact_d_sizes.
  decompose [and] ruler_d_subintervals.
  assert (pow_d_c_n * (Rpow c n) =
      sum_list (mult_list (pow_list p n) (Rpow c n))).
      rewrite <- mult_distributes_over_sum_list.
      apply Rmult_eq_compat_r with (r := Rpow c n)
          (r1 := pow_d_c_n)
          (r2 := sum_list (pow_list p n)).
      assumption.
  rewrite <- limit_c_0_M_eq_exact_size with
          (a := a_i) (b := b_i) (c := c)  (Lim1 := Lim1)
          (g := g) (delta := delta) (epsilon := epsilon)
          (Lim2 := exact_size a_i b_i) (f := M) in H8.
  unfold M in H8.
  assert (list_rmem i (pow_list s n) =
      Rpow (subintervals a_i b_i c * c) n).
      apply pow_list_spec with
          (l := s) (a := subintervals a_i b_i c * c).
      assumption.
  assert (list_rmem i (pow_list p n) =
        Rpow (subintervals a_i b_i c) n).
      apply pow_list_spec with
          (l := p) (a := subintervals a_i b_i c).
      assumption.
  apply mult_list_spec with (l := pow_list p n)
      (a := Rpow (subintervals a_i b_i c) n)
      (r := Rpow c n) in H17.
  rewrite -> pow_distributes in H17.
  rewrite <- H16 in H17.
  apply eq_list_R_cons in H17. apply eq_list_R_is_eq in H17.
  rewrite -> H17 in H14.
  assumption.
  split. assumption. split. reflexivity. split. assumption.
  split. assumption. split. reflexivity.
  split. assumption. split. assumption. split. assumption.
  split. assumption.
  apply M_minus_exact_size_lt_epsilon with
    (a := a_i) (b := b_i) (c := c)
    (delta := delta) (epsilon := epsilon).
    split. assumption. split. assumption. split. assumption.
    split. assumption.
    split. rewrite <- H3 at 2. assumption.
    rewrite <- H3. assumption.
Qed.

(** d_c = subintervals d_0 d_m c =>
          pow_d_c_n = (subintervals d_0 d_m c)^n *)
Hypothesis pow_d_c_n_eq_pow_image_subintervals :
    pow_d_c_n = Rpow (subintervals d_0 d_m c) n.

(** Multiply both sides by Rpow c n and
    apply the ruler measure and convergence theorem to get
    the distance measure. *)
Lemma pow_d_measure :
    forall (Lim1 Lim2 delta epsilon:R)
        (f: R->R->R->R) (g: R->R),
    c > 0 /\
    f = M /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    0 < Rabs (c - Lim1) < delta ->
    Rpow d n = pow_d_c_n * Rpow c n.
Proof.
  intros. decompose [and] H.
  decompose [and] exact_d_sizes. decompose [and] ruler_d_subintervals.
  rewrite -> H10.
  rewrite <- limit_c_0_M_eq_exact_size with
      (a := d_0) (b := d_m) (c := c)  (Lim1 := Lim1)
      (g := g) (delta := delta) (epsilon := epsilon)
      (Lim2 := exact_size d_0 d_m) (f := M).
  unfold M.
  rewrite -> pow_d_c_n_eq_pow_image_subintervals.
  rewrite <- pow_distributes.
  trivial.
  split. assumption. split. trivial. split. assumption.
  split. assumption. split. trivial. split. assumption.
  split. assumption. split. assumption. split. assumption.
  apply M_minus_exact_size_lt_epsilon with
    (a := d_0) (b := d_m) (c := c)
    (delta := delta) (epsilon := epsilon).
    split. assumption. split. assumption. split. assumption.
    split. assumption.
    split. rewrite <- H3 at 2. assumption.
    rewrite <- H3. assumption.
Qed.

(** Combine the previous two lemmas to prove the
    Minkowski distance. *)
Theorem Minkowski_distance :
    forall (Lim1 Lim2 delta epsilon:R)
        (f: R->R->R->R) (g: R->R),
    c > 0 /\
    f = M /\ g = delta_eq_epsilon /\
    Lim1 = 0 /\
    0 < delta /\ 0 < epsilon /\ delta = epsilon /\
    0 < Rabs (c - Lim1) < delta ->
    Rpow d n = sum_list (pow_list s n).
Proof.
  intros. decompose [and] H.
  decompose [and] exact_d_sizes. decompose [and] ruler_d_subintervals.
  assert (pow_d_c_n * Rpow c n = sum_list (pow_list s n)).
      revert H.
      apply d_c_measure. assumption.
      rewrite <- H14.
  assert (Rpow d n = pow_d_c_n * Rpow c n).
      revert H.
      apply pow_d_measure. assumption.
  rewrite -> H16.
  trivial.
Qed.

(** ================================================================ *)

(** forall a >= 0, b >= 0 => a <= a + b. *)
Hypothesis R_le_plus_r :
    forall (a b: R), a >= 0 /\ b >= 0 -> a <= a + b.

(** forall a >= 0, b >= 0 => a + b >= 0. *)
Hypothesis Rsum_ge_0 :
    forall (a b: R), a >= 0 /\ b >= 0 -> a + b >= 0.

(** forall a >= 0, b >= 0 => a * b >= 0. *)
Hypothesis Rtimes_ge_0 :
    forall (a b: R), a >= 0 /\ b >= 0 -> a * b >= 0.

(** The distance inequality proof should be expressed as:
    forall v_a, v_b >= 0, n >= 1:
    (v_a + v_b)^{1/n) <= v_a^{1/n} + v_b^{1/n}.
    This inequality is used in deriving the metric space triangle
    inequality.
    But, the Coq definition for the type, R, is such that it is not
    possible to construct an n-th root function. For example, given,
    d^n = v <-> d = v^{1/n_, it is difficult to express and compute
    the value for d, where the values of v and n are known.
    Therefore, the inequality proof here stops at the step before
    taking the n-th root of both sides of the inequality. *)
Theorem distance_inequality :
    forall (d_a d_b: R),
    d_a = 0 /\ d_a > 0 /\ d_b = 0 /\ d_b > 0 ->
    Rpow d_a n + Rpow d_b n <= Rpow (d_a + d_b) n.
Proof.
  intros. decompose [and] H.
  rewrite -> binomial_eq.
  unfold binomial_expansion.
  rewrite -> binomial_expansion_equiv.
  assert (forall (a b: R), a >= 0 /\ b >= 0 -> a <= a + b).
    intros. decompose [and] H3.
    apply R_le_plus_r. assumption.
  apply H3 with (a := Rpow d_a n + Rpow d_b n)
(b := sum_list (binomial_term_list (rlist n 0) d_a d_b 1 (n - 1))).
  split.
  apply Rsum_ge_0 with (a := Rpow d_a n) (b := Rpow d_b n).
  split.
  apply Rpow_ge_0 with (x := d_a) (n := n). intuition.
  apply Rpow_ge_0 with (x := d_b) (n := n). intuition.
  apply lower_order_binomial_terms.
  split. assumption. split. assumption. split. assumption.
  assumption.
Qed.

(** Two lists of real values. *)
Variable p1 p2 p3: list R.

Theorem distance_sum_inequality :
    forall (d_a d_b: R),
    d_a = 0 /\ d_a > 0 /\ d_b = 0 /\ d_b > 0 /\
    d_a = sum_list (pow_list p1 n) /\
    d_b = sum_list (pow_list p2 n) ->
    Rpow (sum_list (pow_list p1 n)) n +
      Rpow (sum_list (pow_list p2 n)) n <=
    Rpow (sum_list (pow_list p1 n) + sum_list (pow_list p2 n)) n.
Proof.
  intros. decompose [and] H.
  rewrite <- H4.
  rewrite <- H6.
  apply distance_inequality.
  split. assumption. split. assumption.
  split. assumption. assumption.
Qed.

(** ================================================================ *)

(* Metric space properties *)

(* Points in the domain set of a metric space. *)
Variable u w: R.
(* Range set distances d(u,w), d(u,v), d(v,w) and
   d(w,w). *)
Variable d_u_w d_u_v d_v_w d_w_w d_w_v d_v_u: R.

(* Symmetry: d(v,w) = d(w,v).
   From the Euclidean (smallest) and Manhattan (largest)
   distance proofs, all d(x,y): d(x,y) = (x^n + y^n)^{1/n),
   where 1 <= n <= 2.
   Therefore, d(u,v)^n = u^n + y^n /\ d(v,u)^n = v^n + u^n,
   which implies that d(v,u) = d(u,v). *)
Theorem symmetry :
    Rpow d_u_v n = Rpow u n + Rpow v n /\
    Rpow d_v_u n = Rpow v n + Rpow u n
    -> d_u_v = d_v_u.
Proof.
  intros. decompose [and] H.
  assert (Rpow u n + Rpow v n = Rpow v n + Rpow u n).
    intuition.
  rewrite -> H2 in H0.
  rewrite <- H1 in H0.
  apply pow_eq_args in H0.
  assumption.
Qed.

(* Metric space triangle inequality,
   d(u,w) <= d(u,v) + d(v,w) <->
   d(u,w)^n <= (d(u,v) + d(v,w))^n. *)
Theorem riangle_inequality :
    u >= 0 /\ v >= 0 /\ w >= 0 /\
    d_u_w = 0 /\ d_u_w > 0 /\
    d_u_v = 0 /\ d_u_v > 0 /\ d_v_w = 0 /\ d_v_w > 0 ->
    Rpow d_u_v n = Rpow u n + Rpow v n /\
    Rpow d_v_w n = Rpow v n + Rpow w n /\
    Rpow d_u_w n = Rpow u n + Rpow w n ->
    d_u_w <= d_u_v + d_v_w.
Proof.
  intros. decompose [and] H.
  assert (Rpow u n + Rpow w n <=
            Rpow u n + Rpow w n + (Rpow v n + Rpow v n)).
    assert (forall (a b: R), a >= 0 /\ b >= 0 -> a <= a + b).
      intros. decompose [and] H9.
      apply R_le_plus_r. assumption.
    apply H9 with (a := Rpow u n + Rpow w n)
        (b := Rpow v n + Rpow v n).
  split. apply Rsum_ge_0 with (a := Rpow u n) (b := Rpow w n).
  split. apply Rpow_ge_0. assumption.
    apply Rpow_ge_0. assumption.
    apply Rsum_ge_0. split.
    apply Rpow_ge_0. assumption.
    apply Rpow_ge_0. assumption.
  assert (Rpow u n + Rpow w n + (Rpow v n + Rpow v n) =
    (Rpow u n + Rpow v n) + (Rpow v n + Rpow w n)).
    field.
  rewrite -> H11 in H9.
  decompose [and] H0.
  rewrite <- H12 in H9.
  rewrite <- H14 in H9.
  rewrite <- H15 in H9.
  assert (Rpow d_u_v n + Rpow d_v_w n <= Rpow (d_u_v + d_v_w) n).
  apply distance_inequality.
  split. assumption. split. assumption. split. assumption.
  assumption.
  assert (Rpow d_u_w n <= Rpow (d_u_v + d_v_w) n).
  apply Rle_trans with (r1 := Rpow d_u_w n)
    (r2 := Rpow d_u_v n + Rpow d_v_w n)
    (r3 := Rpow (d_u_v + d_v_w) n).
  assumption.
  assumption.
  apply pow_le_args in H16.
  assumption.
Qed.

(* Non-negativity: d(u,w) >= 0, where for all d(u,w) in R,
   there exists [v_a, v_b] such that d(u,w) = |v_a - v_b|. *)
Theorem non_negativity :
    d_u_w = exact_size v_a v_b ->
    d_u_w >= 0.
Proof.
  intros.
  rewrite -> H.
  unfold exact_size.
  apply Rle_ge with  (r1 := 0) (r2 := Rabs (v_b - v_a)).
  apply Rabs_pos.
Qed.

(* a_v = f(v) *)
Variable a_u a_v a_w: R.

(* f(x) = f(y) <=> x = y *)
Hypothesis exact_size_eq_exact_size :
exact_size a_u a_w = exact_size a_u a_v
-> a_w = a_v.

(* Identity of Indiscernibles: d(w,w) = 0, where for
   all d(u,w) in R, there exists [a_u,a_w] such that
   d(u,w) = |a_u - a_w|, a_u = f(u) and a_w = f(w).
   And so on for d(u,v) and d(v,w). *)
Theorem identity_of_indisceunibles :
  (* from the triange inequality proof: *)
    d_u_w = exact_size a_u a_w /\
    d_u_v = exact_size a_u a_v /\
    d_v_w = exact_size a_v a_w /\
    d_w_w = exact_size a_w a_w /\
    d_u_w < d_u_v + d_v_w /\
    d_u_w = d_u_v + d_v_w /\
    (* from the non-negativity proof, there exists: *)
    d_u_v = 0 /\ d_v_w = 0
    -> d_w_w = 0.
Proof.
  intros. decompose [and] H.
  assert (d_u_w = 0).
  rewrite -> H6 in H5.
  rewrite -> H8 in H5.
  rewrite Rplus_0_r with (r := 0) in H5.
  assumption.
  rewrite <- H6 in H7.
  rewrite -> H0 in H7.
  rewrite -> H2 in H7.
  apply exact_size_eq_exact_size in H7.
  rewrite <- H7 in H1.
  rewrite <- H1 in H3.
  rewrite -> H8 in H3.
  assumption.
Qed.

End EuclideanRelations.


Set Implicit Arguments.

Class Dec (P: Prop) := dec: {P} + {~P}.
Arguments dec _ {_}.

Class Dec1 {X} (p: X -> Prop) := dec1: forall x, Dec (p x).
Arguments dec1 {_} _ {_}.

Class Dec2 {X Y} (p: X -> Y -> Prop) :=  dec2: forall x, Dec1 (p x).
Arguments dec2 {_} {_} _ {_}.

#[export]
Instance dec_conj P Q: Dec P -> Dec Q -> Dec (P /\ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[export]
Instance dec_disj P Q: Dec P -> Dec Q -> Dec (P \/ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[export]
Instance dec_imp P Q: Dec P -> Dec Q -> Dec (P -> Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[export]
Instance dec_iff P Q: Dec P -> Dec Q -> Dec (P <-> Q).
Proof.
  intros; unfold iff; typeclasses eauto.
Qed.

#[export]
Instance dec_neg P: Dec P -> Dec (~ P).
Proof.
  intros [p|np]; firstorder.
Qed.

Lemma iff_dec P Q: Q <-> P -> Dec P -> Dec Q.
Proof. firstorder. Qed.

#[export]
Instance dec1_dec X P (x: X): Dec1 P -> (Dec (P x)).
Proof. intros H; apply H. Qed.

#[export]
Instance dec1_conj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x /\ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec1_disj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x \/ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec1_imp X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x -> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec1_iff X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x <-> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec1_neg X (P: X -> Prop): Dec1 P ->  Dec1 (fun x => ~ P x).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec2_dec1 X Y (P: X -> Y -> Prop)  x: Dec2 P -> Dec1 (P x).
Proof. intros H; apply H. Qed.

#[export]
Instance dec2_dec1' X Y (P: X -> Y -> Prop) y: Dec2 P -> Dec1 (fun x => P x y).
Proof. intros H x; apply H. Qed.

#[export]
Instance dec2_conj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y /\ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec2_disj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y \/ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec2_imp X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y -> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec2_iff X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y <-> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[export]
Instance dec2_neg X Y (P: X -> Y -> Prop): Dec2 P ->  Dec2 (fun x y => ~ P x y).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

Section DecBool.
  Definition decb P {D: Dec P} := if dec P then true else false.
  Arguments decb _ {_}.

  Definition decb1 {X: Type} (Q: X -> Prop) {D: Dec1 Q} x := decb (Q x).
  Arguments decb1 {_} _ {_} _.

  Definition decb2 {X Y: Type} (R: X -> Y -> Prop) {D: Dec2 R} x := decb1 (R x).
  Arguments decb2 {_} {_} _ {_} _.

  Lemma dec_decb (P: Prop) {D: Dec P}: P -> decb P = true.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

  Lemma decb_dec (P: Prop) {D: Dec P}: decb P = true -> P.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

End DecBool.

#[export] Hint Resolve dec_decb : core.
Arguments decb _ {_}.
Arguments decb1 {_} _ {_} _.
Arguments decb2 {_} {_} _ {_} _.

(* Discreteness *)

Class Dis (X: Type) := eq_dec: Dec2 (@eq X).

Notation "a == b" := (eq_dec a b) (at level 60).

#[export]
Instance dis_dec X (D: Dis X): Dec2 (@eq X).
Proof. firstorder. Qed.

#[export]
Instance discrete_False: Dis False.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[export]
Instance discrete_unit: Dis unit.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[export]
Instance discrete_nat: Dis nat.
Proof.
   unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[export]
Instance discrete_bool: Dis bool.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[export]
Instance discrete_option (X: Type) {D: Dis X}: Dis (option X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

#[export]
Instance discrete_sum (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X + Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

#[export]
Instance discrete_prod (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X * Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

#[export]
Instance discrete_list (X: Type) {D: Dis X}: Dis (list X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

Require Import List Arith Lia.

#[export]
Instance In_dec (X: Type) {D: Dis X}: Dec2 (@In X).
Proof.
  intros ??; eapply in_dec, eq_dec.
Qed.

Definition dec_in {X: Type} {D: Dis X} (x: X) (A: list X) :=
  dec2 (@In X) x A.

Notation "x 'el' A" := (dec_in x A) (at level 60).

#[export]
Instance lt_dec : Dec2 lt.
Proof.
  intros ??; eapply lt_dec.
Qed.

#[export]
Instance le_dec : Dec2 le.
Proof.
  intros ??; eapply le_dec.
Qed.

#[export]
Instance gt_dec : Dec2 gt.
Proof.
  intros ??; eapply lt_dec.
Qed.

#[export]
Instance ge_dec : Dec2 ge.
Proof.
  intros ??; eapply le_dec.
Qed.

#[export]
Instance dec_all Y (P: Y -> Prop) (D: Dec1 P):
  Dec1 (fun A => forall x, In x A -> P x).
Proof.
  intros A. eapply iff_dec; [symmetry; eapply Forall_forall|].
  unfold Dec; eapply Forall_dec; eauto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_10.
Require Export GeoCoq.Elements.OriginalProofs.proposition_15.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesreflexive.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angleorderrespectscongruence.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angleorderrespectscongruence2.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_16 :
   forall A B C D,
   Triangle A B C -> BetS B C D ->
   LtA B A C A C D /\ LtA C B A A C D.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (~ eq A C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists E, (BetS A E C /\ Cong E A E C)) by (conclude proposition_10);destruct Tf as [E];spliter.
assert (~ eq B E).
 {
 intro.
 assert (BetS A B C) by (conclude cn_equalitysub).
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq E B) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists F, (BetS B E F /\ Cong E F E B)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (~ eq A C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 contradict.
 }
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (neq E C) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists G, (BetS A C G /\ Cong C G E C)) by (conclude lemma_extension);destruct Tf as [G];spliter.
assert (~ Col B E A).
 {
 intro.
 assert (Col A E C) by (conclude_def Col ).
 assert (Col E A B) by (forward_using lemma_collinearorder).
 assert (Col E A C) by (forward_using lemma_collinearorder).
 assert (neq A E) by (forward_using lemma_betweennotequal).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B C) by (conclude lemma_collinear4).
 contradict.
 }
assert (CongA B E A C E F) by (conclude proposition_15a).
assert (~ Col A E B).
 {
 intro.
 assert (Col B E A) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA A E B B E A) by (conclude lemma_ABCequalsCBA).
assert (CongA A E B C E F) by (conclude lemma_equalanglestransitive).
assert (Cong B E F E) by (forward_using lemma_doublereverse).
assert (Cong E B E F) by (forward_using lemma_congruenceflip).
assert (~ Col E A B).
 {
 intro.
 assert (Col B E A) by (forward_using lemma_collinearorder).
 contradict.
 }
assert ((Cong A B C F /\ CongA E A B E C F /\ CongA E B A E F C)) by (conclude proposition_04).
assert (~ Col B A E).
 {
 intro.
 assert (Col E A B) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Out A C E) by (conclude lemma_ray4).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (neq A B) by (forward_using lemma_angledistinct).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (Out A B B) by (conclude lemma_ray4).
assert (~ Col B A C).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA B A C B A C) by (conclude lemma_equalanglesreflexive).
assert (CongA B A C B A E) by (conclude lemma_equalangleshelper).
assert (CongA B A E E A B) by (conclude lemma_ABCequalsCBA).
assert (CongA B A C E A B) by (conclude lemma_equalanglestransitive).
assert (CongA B A C E C F) by (conclude lemma_equalanglestransitive).
assert (BetS C E A) by (conclude axiom_betweennesssymmetry).
assert (neq C E) by (forward_using lemma_betweennotequal).
assert (Out C E A) by (conclude lemma_ray4).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (~ Col E C F).
 {
 intro.
 assert (Col B E F) by (conclude_def Col ).
 assert (Col F E B) by (forward_using lemma_collinearorder).
 assert (Col F E C) by (forward_using lemma_collinearorder).
 assert (neq E F) by (forward_using lemma_betweennotequal).
 assert (neq F E) by (conclude lemma_inequalitysymmetric).
 assert (Col E B C) by (conclude lemma_collinear4).
 assert (Col A E C) by (conclude_def Col ).
 assert (Col E C B) by (forward_using lemma_collinearorder).
 assert (Col E C A) by (forward_using lemma_collinearorder).
 assert (neq E C) by (forward_using lemma_betweennotequal).
 assert (Col C B A) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (~ eq C F).
 {
 intro.
 assert (Col E C F) by (conclude_def Col ).
 contradict.
 }
assert (Out C F F) by (conclude lemma_ray4).
assert (CongA E C F E C F) by (conclude lemma_equalanglesreflexive).
assert (CongA E C F A C F) by (conclude lemma_equalangleshelper).
assert (CongA B A C A C F) by (conclude lemma_equalanglestransitive).
assert (BetS D C B) by (conclude axiom_betweennesssymmetry).
assert (BetS F E B) by (conclude axiom_betweennesssymmetry).
assert (~ Col D B F).
 {
 intro.
 assert (Col F B D) by (forward_using lemma_collinearorder).
 assert (Col B E F) by (conclude_def Col ).
 assert (Col F B E) by (forward_using lemma_collinearorder).
 assert (neq B F) by (forward_using lemma_betweennotequal).
 assert (neq F B) by (conclude lemma_inequalitysymmetric).
 assert (Col B D E) by (conclude lemma_collinear4).
 assert (Col D B E) by (forward_using lemma_collinearorder).
 assert (Col B C D) by (conclude_def Col ).
 assert (Col D B C) by (forward_using lemma_collinearorder).
 assert (neq B D) by (forward_using lemma_betweennotequal).
 assert (neq D B) by (conclude lemma_inequalitysymmetric).
 assert (Col B E C) by (conclude lemma_collinear4).
 assert (Col E C B) by (forward_using lemma_collinearorder).
 assert (Col A E C) by (conclude_def Col ).
 assert (Col E C A) by (forward_using lemma_collinearorder).
 assert (neq E C) by (forward_using lemma_betweennotequal).
 assert (Col C B A) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
rename_H H;
let Tf:=fresh in
assert (Tf:exists H, (BetS D H E /\ BetS F H C)) by (conclude postulate_Pasch_inner);destruct Tf as [H];spliter.
assert (BetS C H F) by (conclude axiom_betweennesssymmetry).
assert (Out C F H) by (conclude lemma_ray4).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Out C A A) by (conclude lemma_ray4).
assert (CongA B A C A C H) by (conclude lemma_equalangleshelper).
assert (CongA B A C A C F) by (conclude lemma_equalangleshelper).
assert (BetS E H D) by (conclude axiom_betweennesssymmetry).
assert (Out C A E) by (conclude lemma_ray5).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (neq D C) by (forward_using lemma_betweennotequal).
assert (neq C D) by (conclude lemma_inequalitysymmetric).
assert (Out C D D) by (conclude lemma_ray4).
assert (CongA B A C A C H) by (conclude lemma_equalanglestransitive).
assert (LtA B A C A C D) by (conclude_def LtA ).
assert (neq B C) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists e, (BetS B e C /\ Cong e B e C)) by (conclude proposition_10);destruct Tf as [e];spliter.
assert (Col B e C) by (conclude_def Col ).
assert (~ eq A e).
 {
 intro.
 assert (BetS B A C) by (conclude cn_equalitysub).
 assert (Col B A C) by (conclude_def Col ).
 contradict.
 }
assert (neq e A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists f, (BetS A e f /\ Cong e f e A)) by (conclude lemma_extension);destruct Tf as [f];spliter.
assert (~ eq B C).
 {
 intro.
 assert (Col B A C) by (conclude_def Col ).
 contradict.
 }
assert (~ Col A e B).
 {
 intro.
 assert (Col B e C) by (conclude_def Col ).
 assert (Col e B A) by (forward_using lemma_collinearorder).
 assert (Col e B C) by (forward_using lemma_collinearorder).
 assert (neq B e) by (forward_using lemma_betweennotequal).
 assert (neq e B) by (conclude lemma_inequalitysymmetric).
 assert (Col B A C) by (conclude lemma_collinear4).
 contradict.
 }
assert (CongA A e B C e f) by (conclude proposition_15a).
assert (~ Col B e A).
 {
 intro.
 assert (Col A e B) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA B e A A e B) by (conclude lemma_ABCequalsCBA).
assert (CongA B e A C e f) by (conclude lemma_equalanglestransitive).
assert (Cong A e f e) by (forward_using lemma_doublereverse).
assert (Cong e A e f) by (forward_using lemma_congruenceflip).
assert (~ Col e B A).
 {
 intro.
 assert (Col A e B) by (forward_using lemma_collinearorder).
 contradict.
 }
assert ((Cong B A C f /\ CongA e B A e C f /\ CongA e A B e f C)) by (conclude proposition_04).
assert (~ Col A B e).
 {
 intro.
 assert (Col e B A) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Out B C e) by (conclude lemma_ray4).
assert (Out B A A) by (conclude lemma_ray4).
assert (~ Col A B C).
 {
 intro.
 assert (Col B A C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA A B C A B C) by (conclude lemma_equalanglesreflexive).
assert (CongA A B C A B e) by (conclude lemma_equalangleshelper).
assert (CongA A B e e B A) by (conclude lemma_ABCequalsCBA).
assert (CongA A B C e B A) by (conclude lemma_equalanglestransitive).
assert (CongA A B C e C f) by (conclude lemma_equalanglestransitive).
assert (BetS C e B) by (conclude axiom_betweennesssymmetry).
assert (neq C e) by (forward_using lemma_betweennotequal).
assert (Out C e B) by (conclude lemma_ray4).
assert (eq f f) by (conclude cn_equalityreflexive).
assert (nCol e C f) by (conclude lemma_equalanglesNC).
assert (~ eq C f).
 {
 intro.
 assert (Col e C f) by (conclude_def Col ).
 contradict.
 }
assert (Out C f f) by (conclude lemma_ray4).
assert (~ Col e C f).
 {
 intro.
 assert (Col A e f) by (conclude_def Col ).
 assert (Col f e A) by (forward_using lemma_collinearorder).
 assert (Col f e C) by (forward_using lemma_collinearorder).
 assert (neq e f) by (forward_using lemma_betweennotequal).
 assert (neq f e) by (conclude lemma_inequalitysymmetric).
 assert (Col e A C) by (conclude lemma_collinear4).
 assert (Col e C A) by (forward_using lemma_collinearorder).
 assert (Col e C B) by (forward_using lemma_collinearorder).
 assert (neq e C) by (forward_using lemma_betweennotequal).
 assert (Col C A B) by (conclude lemma_collinear4).
 assert (Col B A C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA e C f e C f) by (conclude lemma_equalanglesreflexive).
assert (CongA e C f B C f) by (conclude lemma_equalangleshelper).
assert (CongA A B C B C f) by (conclude lemma_equalanglestransitive).
assert (BetS G C A) by (conclude axiom_betweennesssymmetry).
assert (neq G C) by (forward_using lemma_betweennotequal).
assert (neq C G) by (conclude lemma_inequalitysymmetric).
assert (BetS f e A) by (conclude axiom_betweennesssymmetry).
assert (~ Col G A f).
 {
 intro.
 assert (Col f A G) by (forward_using lemma_collinearorder).
 assert (Col A e f) by (conclude_def Col ).
 assert (Col f A e) by (forward_using lemma_collinearorder).
 assert (neq A f) by (forward_using lemma_betweennotequal).
 assert (neq f A) by (conclude lemma_inequalitysymmetric).
 assert (Col A G e) by (conclude lemma_collinear4).
 assert (Col G A e) by (forward_using lemma_collinearorder).
 assert (Col A C G) by (conclude_def Col ).
 assert (Col G A C) by (forward_using lemma_collinearorder).
 assert (neq A G) by (forward_using lemma_betweennotequal).
 assert (neq G A) by (conclude lemma_inequalitysymmetric).
 assert (Col A e C) by (conclude lemma_collinear4).
 assert (Col e C A) by (forward_using lemma_collinearorder).
 assert (Col B e C) by (conclude_def Col ).
 assert (Col e C B) by (forward_using lemma_collinearorder).
 assert (neq e C) by (forward_using lemma_betweennotequal).
 assert (Col C A B) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists h, (BetS G h e /\ BetS f h C)) by (conclude postulate_Pasch_inner);destruct Tf as [h];spliter.
assert (BetS C h f) by (conclude axiom_betweennesssymmetry).
assert (neq h C) by (forward_using lemma_betweennotequal).
assert (neq C h) by (conclude lemma_inequalitysymmetric).
assert (Out C h f) by (conclude lemma_ray4).
assert (Out C f h) by (conclude lemma_ray5).
assert (Out C B B) by (conclude lemma_ray4).
assert (CongA A B C B C h) by (conclude lemma_equalangleshelper).
assert (CongA A B C B C f) by (conclude lemma_equalangleshelper).
assert (BetS e h G) by (conclude axiom_betweennesssymmetry).
assert (BetS C e B) by (conclude axiom_betweennesssymmetry).
assert (Out C e B) by (conclude lemma_ray4).
assert (Out C B e) by (conclude lemma_ray5).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Out C G G) by (conclude lemma_ray4).
assert (CongA A B C B C h) by (conclude lemma_equalanglestransitive).
assert (LtA A B C B C G) by (conclude_def LtA ).
assert (~ Col G C B).
 {
 intro.
 assert (Col A C G) by (conclude_def Col ).
 assert (Col G C A) by (forward_using lemma_collinearorder).
 assert (neq C G) by (forward_using lemma_betweennotequal).
 assert (neq G C) by (conclude lemma_inequalitysymmetric).
 assert (Col C B A) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA G C B D C A) by (conclude proposition_15a).
assert (~ Col A C D).
 {
 intro.
 assert (Col D C A) by (forward_using lemma_collinearorder).
 assert (Col B C D) by (conclude_def Col ).
 assert (Col D C B) by (forward_using lemma_collinearorder).
 assert (neq C D) by (forward_using lemma_betweennotequal).
 assert (neq D C) by (conclude lemma_inequalitysymmetric).
 assert (Col C A B) by (conclude lemma_collinear4).
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA G C B B C G) by (conclude lemma_ABCequalsCBA).
assert (LtA A B C G C B) by (conclude lemma_angleorderrespectscongruence).
assert (~ Col D C A).
 {
 intro.
 assert (Col A C D) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA D C A A C D) by (conclude lemma_ABCequalsCBA).
assert (CongA G C B A C D) by (conclude lemma_equalanglestransitive).
assert (CongA A C D G C B) by (conclude lemma_equalanglessymmetric).
assert (LtA A B C A C D) by (conclude lemma_angleorderrespectscongruence).
assert (~ Col C B A).
 {
 intro.
 assert (Col A B C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (CongA C B A A B C) by (conclude lemma_ABCequalsCBA).
assert (LtA C B A A C D) by (conclude lemma_angleorderrespectscongruence2).
close.
Qed.

End Euclid.


(** * Records: Adding Records to STLC *)

(* $Date: 2011-03-21 13:05:05 -0400 (Mon, 21 Mar 2011) $ *)

Require Export Stlc.
Require Import Relations.

(* ###################################################################### *)
(** * Adding Records *)

(** We saw in [MoreStlc.v] how records can be treated as syntactic
    sugar for nested uses of products.  This is fine for simple
    examples, but the encoding is informal (in reality, if we really
    treated records this way, it would be carried out in the parser,
    which we are eliding here), and anyway it is not very efficient.
    So it is also interesting to see how records can be treated as
    first-class citizens of the language.

    Recall the informal definitions we gave before: *)

(**
    Syntax:
<<
       t ::=                          Terms:
           | ...
           | {i1=t1, ..., in=tn}         record
           | t.i                         projection

       v ::=                          Values:
           | ...
           | {i1=v1, ..., in=vn}         record value

       T ::=                          Types:
           | ...
           | {i1:T1, ..., in:Tn}         record type
>>
   Reduction:
[[[
                                 ti ==> ti'                            (ST_Rcd)
    --------------------------------------------------------------------
    {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                                 t1 ==> t1'
                               --------------                        (ST_Proj1)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi
]]]
   Typing:
[[[
               Gamma |- t1 : T1     ...     Gamma |- tn : Tn
             --------------------------------------------------         (T_Rcd)
             Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                   (T_Proj)
                             Gamma |- t.i : Ti
]]]
*)

(* ###################################################################### *)
(** * Formalizing Records *)

Module STLCExtendedRecords.

(* ###################################################################### *)
(** *** Syntax and Operational Semantics *)

(** The most obvious way to formalize the syntax of record types would
    be this: *)

Module FirstTry.

Definition alist (X : Type) := list (id * X).

Inductive ty : Type :=
  | ty_base     : id -> ty
  | ty_arrow    : ty -> ty -> ty
  | ty_rcd      : (alist ty) -> ty.

(** Unfortunately, we encounter here a limitation in Coq: this type
    does not automatically give us the induction principle we expect
    -- the induction hypothesis in the [ty_rcd] case doesn't give us
    any information about the [ty] elements of the list, making it
    useless for the proofs we want to do.  *)

(* Check ty_ind.
   ====>
    ty_ind :
      forall P : ty -> Prop,
        (forall i : id, P (ty_base i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0 -> P (ty_arrow t t0)) ->
        (forall a : alist ty, P (ty_rcd a)) ->    (* ??? *)
        forall t : ty, P t
*)

End FirstTry.

(** It is possible to get a better induction principle out of Coq, but
    the details of how this is done are not very pretty, and it is not
    as intuitive to use as the ones Coq generates automatically for
    simple [Inductive] definitions.

    Fortunately, there is a different way of formalizing records that
    is, in some ways, even simpler and more natural: instead of using
    the existing [list] type, we can essentially include its
    constructors ("nil" and "cons") in the syntax of types. *)

Inductive ty : Type :=
  | ty_base : id -> ty
  | ty_arrow : ty -> ty -> ty
  | ty_rnil : ty
  | ty_rcons : id -> ty -> ty -> ty.

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

(** Similarly, at the level of terms, we have constructors [tm_rnil]
    -- the empty record -- and [tm_rcons], which adds a single field to
    the front of a list of fields. *)

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

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

(** Some variables, for examples... *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (ty_base (Id 4)).
Notation B := (ty_base (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

(** [{ i1:A }] *)

(* Check (ty_rcons i1 A ty_rnil). *)

(** [{ i1:A->B, i2:A }] *)

(* Check (ty_rcons i1 (ty_arrow A B)
           (ty_rcons i2 A ty_rnil)). *)

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

(** Generalizing our abstract syntax for records (from lists to the
    nil/cons presentation) introduces the possibility of writing
    strange types like this *)

Definition weird_type := ty_rcons X A B.

(** where the "tail" of a record type is not actually a record type! *)

(** We'll structure our typing judgement so that no ill-formed types
    like [weird_type] are assigned to terms.  To support this, we
    define [record_ty] and [record_tm], which identify record types
    and terms, and [well_formed_ty] which rules out the ill-formed
    types. *)

(** First, a type is a record type if it is built with just [ty_rnil]
    and [ty_rcons] at the outermost level. *)

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

(** Similarly, a term is a record term if it is built with [tm_rnil]
    and [tm_rcons] *)

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

(** Note that [record_ty] and [record_tm] are not recursive -- they
    just check the outermost constructor.  The [well_formed_ty]
    property, on the other hand, verifies that the whole type is well
    formed in the sense that the tail of every record (the second
    argument to [ty_rcons]) is a record.

    Of course, we should also be concerned about ill-formed terms, not
    just types; but typechecking can rules those out without the help
    of an extra [well_formed_tm] definition because it already
    examines the structure of terms.  *)
(** LATER : should they fill in part of this as an exercise?  We
    didn't give rules for it above *)

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

Hint Constructors record_ty record_tm well_formed_ty.

(* ###################################################################### *)
(** *** Substitution *)

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

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

(** Next we define the values of our language.  A record is a value if
    all of its fields are. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tm_abs x T11 t12)
  | v_rnil : value tm_rnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (tm_rcons i v1 vr).

Hint Constructors value.

(** Utility functions for extracting one field from record type or
    term: *)

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

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

(** The [step] function uses the term-level lookup function (for the
    projection rule), while the type-level lookup is needed for
    [has_type]. *)

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

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

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

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

Notation stepmany := (refl_step_closure step).
Notation "t1 '==>*' t2" := (stepmany t1 t2) (at level 40).

Hint Constructors step.

(* ###################################################################### *)
(** *** Typing *)

Definition context := partial_map ty.

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above.  The only major
    difference is the use of [well_formed_ty].  In the informal
    presentation we used a grammar that only allowed well formed
    record types, so we didn't have to add a separate check.

    We'd like to set things up so that that whenever [has_type Gamma t
    T] holds, we also have [well_formed_ty T].  That is, [has_type]
    never assigns ill-formed types to terms.  In fact, we prove this
    theorem below.

    However, we don't want to clutter the definition of [has_type]
    with unnecessary uses of [well_formed_ty].  Instead, we place
    [well_formed_ty] checks only where needed - where an inductive
    call to [has_type] won't already be checking the well-formedness
    of a type.

    For example, we check [well_formed_ty T] in the [T_Var] case,
    because there is no inductive [has_type] call that would
    enforce this.  Similarly, in the [T_Abs] case, we require a
    proof of [well_formed_ty T11] because the inductive call to
    [has_type] only guarantees that [T12] is well-formed.

    In the rules you must write, the only necessary [well_formed_ty]
    check comes in the [tm_nil] case.  *)

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

Hint Constructors has_type.

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

(* ###################################################################### *)
(** ** Examples *)

(** **** Exercise: 2 stars (examples) *)
(** Finish the proofs. *)

(** Feel free to use Coq's automation features in this proof.
    However, if you are not confident about how the type system works,
    you may want to carry out the proof first using the basic
    features ([apply] instead of [eapply], in particular) and then
    perhaps compress it using automation. *)

Lemma typing_example_2 :
  has_type empty
    (tm_app (tm_abs a (ty_rcons i1 (ty_arrow A A)
                      (ty_rcons i2 (ty_arrow B B)
                       ty_rnil))
              (tm_proj (tm_var a) i2))
            (tm_rcons i1 (tm_abs a A (tm_var a))
            (tm_rcons i2 (tm_abs a B (tm_var a))
             tm_rnil)))
    (ty_arrow B B).
Proof.
  (* FILL IN HERE *) Admitted.

(** Before starting to prove this fact (or the one above!), make sure
    you understand what it is saying. *)

Example typing_nonexample :
  ~ exists T,
      has_type (extend empty a (ty_rcons i2 (ty_arrow A A)
                                ty_rnil))
               (tm_rcons i1 (tm_abs a B (tm_var a)) (tm_var a))
               T.
Proof.
  (* FILL IN HERE *) Admitted.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    has_type (extend empty y A)
           (tm_app (tm_abs a (ty_rcons i1 A ty_rnil)
                     (tm_proj (tm_var a) i1))
                   (tm_rcons i1 (tm_var y) (tm_rcons i2 (tm_var y) tm_rnil)))
           T.
Proof.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same as for the pure simply typed lambda-calculus,
    but we need to add some technical lemmas involving records. *)

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

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

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; auto.
Qed.

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...
Qed.

(* ###################################################################### *)
(** *** Field Lookup *)

(** Lemma: If [empty |- v : T] and [ty_lookup i T] returns [Some Ti],
     then [tm_lookup i v] returns [Some ti] for some term [ti] such
     that [has_type empty ti Ti].

    Proof: By induction on the typing derivation [Htyp].  Since
      [ty_lookup i T = Some Ti], [T] must be a record type, this and
      the fact that [v] is a value eliminate most cases by inspection,
      leaving only the [T_RCons] case.

      If the last step in the typing derivation is by [T_RCons], then
      [t = tm_rcons i0 t tr] and [T = ty_rcons i0 T Tr] for some [i0],
      [t], [tr], [T] and [Tr].

      This leaves two possiblities to consider - either [i0 = i] or
      not.

      - If [i = i0], then since [ty_lookup i (ty_rcons i0 T Tr) = Some
        Ti] we have [T = Ti].  It follows that [t] itself satisfies
        the theorem.

      - On the other hand, suppose [i <> i0].  Then
[[
        ty_lookup i T = ty_lookup i Tr
]]
        and
[[
        tm_lookup i t = tm_lookup i tr,
]]
        so the result follows from the induction hypothesis. [] *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  ty_lookup i T = Some Ti ->
  exists ti, tm_lookup i v = Some ti /\ has_type empty ti Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Htyp) Case; subst; try solve by inversion...
  Case "T_RCons".
    simpl in Hget. simpl. destruct (beq_id i i0).
    SCase "i is first".
      simpl. inversion Hget. subst.
      exists t...
    SCase "get tail".
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

(* ###################################################################### *)
(** *** Progress *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  has_type_cases (induction Ht) Case; intros HeqGamma; subst.
  Case "T_Var".
    (* The final rule in the given typing derivation cannot be [T_Var],
       since it can never be the case that [empty |- x : T] (since the
       context is empty). *)
    inversion H.
  Case "T_Abs".
    (* If the [T_Abs] rule was the last used, then [t = tm_abs x T11 t12],
       which is a value. *)
    left...
  Case "T_App".
    (* If the last rule applied was T_App, then [t = t1 t2], and we know
       from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tm_abs x T11 t12], since abstractions are the only values
         that can have an arrow type.  But
         [(tm_abs x T11 t12) t2 ==> subst x t2 t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists (subst x t2 t12)...
      SSCase "t2 steps".
        (* If [t1] is a value and [t2 ==> t2'], then [t1 t2 ==> t1 t2']
           by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...
    SCase "t1 steps".
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2] by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tm_app t1' t2)...
  Case "T_Proj".
    (* If the last rule in the given derivation is [T_Proj], then
       [t = tm_proj t i] and
           [empty |- t : (ty_rcd Tr)]
       By the IH, [t] either is a value or takes a step. *)
    right. destruct IHHt...
    SCase "rcd is value".
      (* If [t] is a value, then we may use lemma
         [lookup_field_in_value] to show [tm_lookup i t = Some ti] for
         some [ti] which gives us [tm_proj i t ==> ti] by [ST_ProjRcd]
         *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H) as [ti [Hlkup _]].
      exists ti...
    SCase "rcd_steps".
      (* On the other hand, if [t ==> t'], then [tm_proj t i ==> tm_proj t' i]
         by [ST_Proj1]. *)
      destruct H0 as [t' Hstp]. exists (tm_proj t' i)...
  Case "T_RNil".
    (* If the last rule in the given derivation is [T_RNil], then
       [t = tm_rnil], which is a value. *)
    left...
  Case "T_RCons".
    (* If the last rule is [T_RCons], then [t = tm_rcons i t tr] and
         [empty |- t : T]
         [empty |- tr : Tr]
       By the IH, each of [t] and [tr] either is a value or can take
       a step. *)
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2; try reflexivity.
      SSCase "tail is a value".
      (* If [t] and [tr] are both values, then [tm_rcons i t tr]
         is a value as well. *)
        left...
      SSCase "tail steps".
        (* If [t] is a value and [tr ==> tr'], then
           [tm_rcons i t tr ==> tm_rcons i t tr'] by
           [ST_Rcd_Tail]. *)
        right. destruct H2 as [tr' Hstp].
        exists (tm_rcons i t tr')...
    SCase "head steps".
      (* If [t ==> t'], then
         [tm_rcons i t tr ==> tm_rcons i t' tr]
         by [ST_Rcd_Head]. *)
      right. destruct H1 as [t' Hstp].
      exists (tm_rcons i t' tr)...  Qed.

(* ###################################################################### *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (tm_proj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (tm_rcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (tm_rcons i ti 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 y Hafi.
    unfold extend. remember (beq_id x y) as e.
    destruct e...
  Case "T_App".
    apply T_App with T1...
  Case "T_RCons".
    apply T_RCons...  Qed.

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

(* ###################################################################### *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma (subst x v t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- (subst x v t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tm_var, tm_abs, tm_rcons.
     The former aren't automatic because we must reason about how the
     variables interact. In the case of tm_rcons, we must do a little
     extra work to show that substituting into a term doesn't change
     whether it is a record term. *)
  tm_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tm_var".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- subst x v y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [subst x v y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H0. rewrite <- beq_id_refl in H0.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H0. rewrite <- Heqe in H0...
  Case "tm_abs".
    rename i into y. rename t into T11.
    (* If [t = tm_abs y T11 t0], then we know that
         [Gamma,x:U |- tm_abs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- subst x v t0 S].

       We can calculate that
         subst x v t = tm_abs y T11 (if beq_id x y
                                      then t0
                                      else subst x v t0)
       And we must show that [Gamma |- subst x v t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else subst x v t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- subst x v t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
  Case "tm_rcons".
    apply T_RCons... inversion H7; 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.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]) or follow directly from the IH
     ([T_RCons]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tm_abs x T11 t12]
         and
           [t2 = v2].  We must show that [empty |- subst x v2 t12 : T2].
         We know by assumption that
             [empty |- tm_abs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Proj".
  (* If the last rule was [T_Proj], then [t = tm_proj t1 i].  Two rules
     could have caused [t ==> t']: [T_Proj1] and [T_ProjRcd].  The typing
     of [t'] follows from the IH in the former case, so we only
     consider [T_ProjRcd].

     Here we have that [t] is a record value.  Since rule T_Proj was
     used, we know [has_type empty t Tr] and [ty_lookup i Tr = Some
     Ti] for some [i] and [Tr].  We may therefore apply lemma
     [lookup_field_in_value] to find the record element this
     projection steps to. *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  Case "T_RCons".
  (* If the last rule was [T_RCons], then [t = tm_rcons i t tr] for
     some [i], [t] and [tr] such that [record_tm tr].  If the step is
     by [ST_Rcd_Head], the result is immediate by the IH.  If the step
     is by [ST_Rcd_Tail], [tr ==> tr2'] for some [tr2'] and we must also
     use lemma [step_preserves_record_tm] to show [record_tm tr2']. *)
    apply T_RCons... eapply step_preserves_record_tm...
Qed.
(** [] *)

End STLCExtendedRecords.


(** Various checks for coqdoc

- symbols should not be inlined in string g
- links to both kinds of notations in a' should work to the right notation
- with utf8 option, forall must be unicode
- splitting between symbols and ident should be correct in a' and c
- ".." should be rendered correctly
*)

Require Import String.

Definition g := "dfjkh""sdfhj forall <> * ~"%string.

Definition a (b: nat) := b.

Definition f := forall C:Prop, C.

Notation "n ++ m" := (plus n m).

Notation "n ++ m" := (mult n m). (* redefinition *)

Notation "n ** m" := (plus n m) (at level 60).

Notation "n ▵ m" := (plus n m) (at level 60).

Notation "n '_' ++ 'x' m" := (plus n m) (at level 3).

Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : x = x :>A

where "x = y :> A" := (@eq A x y) : type_scope.

Definition eq0 := 0 = 0 :> nat.

Notation "( x # y ; .. ; z )" := (pair .. (pair x y) .. z).

Definition b_α := ((0#0;0) , (0 ** 0)).

Notation h := a.

  Section test.

    Variables b' b2: nat.

    Notation "n + m" := (n ▵ m) : my_scope.

    Delimit Scope my_scope with my.

    Notation l := 0.

    Definition α := (0 + l)%my.

    Definition a' b := b'++0++b2 _ ++x b.

    Definition c := {True}+{True}.

    Definition d := (1+2)%nat.

    Lemma e : nat + nat.
    Admitted.

  End test.

  Section test2.

    Variables b': nat.

    Section test.

      Variables b2: nat.

      Definition a'' b := b' ++ O ++ b2 _ ++ x b + h 0.

    End test.

  End test2.

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)

(** skip *)