(* Power_series.v *)

Require Import Utf8.
Require Import QArith.
Require Import NPeano.

Require Import Misc.
Require Import NbarM.
Require Import Field2.
Require Import Fsummation.

Set Implicit Arguments.

Record power_series α := series { terms : nat → α }.

Notation "s .[ i ]" := (@terms _ s i) (at level 1).

Definition series_0 {α} {r : ring α} :=
  {| terms i := 0%K |}.

Definition series_const α {R : ring α} c :=
  {| terms i := if zerop i then c else 0%K |}.
Definition series_1 {α} {R : ring α} :=
  series_const (1%K).

Declare Scope series_scope.
Delimit Scope series_scope with ser.
Notation "0" := series_0 : series_scope.
Notation "1" := series_1 : series_scope.

Inductive eq_series {α} {r : ring α} :
    power_series α → power_series α → Prop :=
  eq_series_base : ∀ s₁ s₂,
    (∀ i, (s₁.[i] = s₂.[i])%K)
    → eq_series s₁ s₂.

Notation "a = b" := (eq_series a b) : series_scope.
Notation "a ≠ b" := (¬ eq_series a b) : series_scope.

Theorem eq_series_refl {α} {r : ring α} : reflexive _ eq_series.
Proof.
intros s.
constructor; reflexivity.
Qed.

Theorem eq_series_sym {α} {r : ring α} : symmetric _ eq_series.
Proof.
intros s₁ s₂ H.
inversion H; subst.
constructor.
intros i; symmetry; apply H0.
Qed.

Theorem eq_series_trans {α} {r : ring α} : transitive _ eq_series.
Proof.
intros s₁ s₂ s₃ H₁ H₂.
inversion H₁; inversion H₂; subst.
constructor.
etransitivity; [ apply H | apply H2 ].
Qed.

Add Parametric Relation α (r : ring α) : (power_series α) eq_series
 reflexivity proved by eq_series_refl
 symmetry proved by (eq_series_sym (r := r))
 transitivity proved by (eq_series_trans (r := r))
 as eq_series_rel.

(* *)

Theorem fold_series_const : ∀ α (r : ring α) c,
  {| terms := λ i, if zerop i then c else 0%K |} =
  series_const c.
Proof. reflexivity. Qed.

(* series_add *)

Definition series_add {α} {r : ring α} s₁ s₂ :=
  {| terms i := (s₁.[i] + s₂.[i])%K |}.

Definition series_opp {α} {r : ring α} s :=
  {| terms i := (- s.[i])%K |}.

Notation "a + b" := (series_add a b) : series_scope.
Notation "a - b" := (series_add a (series_opp b)) : series_scope.
Notation "- a" := (series_opp a) : series_scope.

Section theorems_add.

Variable α : Type.
Variable r : ring α.

Theorem series_add_comm : ∀ s₁ s₂, (s₁ + s₂ = s₂ + s₁)%ser.
Proof.
intros s₁ s₂.
constructor; intros i; simpl.
rewrite rng_add_comm; reflexivity.
Qed.

Theorem series_add_assoc : ∀ s₁ s₂ s₃,
  (s₁ + (s₂ + s₃) = (s₁ + s₂) + s₃)%ser.
Proof.
intros s₁ s₂ s₃.
unfold series_add; simpl.
constructor; intros i; simpl.
rewrite rng_add_assoc; reflexivity.
Qed.

Theorem series_nth_series_0 : ∀ i, (0%ser .[i])%K = 0%K.
Proof. reflexivity. Qed.

Theorem series_add_0_l : ∀ s, (0 + s = s)%ser.
Proof.
intros s.
constructor; intros i; simpl.
rewrite rng_add_0_l; reflexivity.
Qed.

Theorem series_add_opp_r : ∀ s, (s - s = 0)%ser.
Proof.
intros s.
constructor; intros i; simpl.
apply rng_add_opp_r.
Qed.

Theorem series_add_opp_l : ∀ s, (- s + s = 0)%ser.
Proof.
intros s.
rewrite series_add_comm.
apply series_add_opp_r.
Qed.

End theorems_add.

(* series_mul *)

Definition convol_mul {α} {r : ring α} a b k :=
  Σ (i = 0, k), (a.[i] * b.[k-i])%K.

Definition series_mul {α} {r : ring α} a b :=
  {| terms k := convol_mul a b k |}.

Notation "a * b" := (series_mul a b) : series_scope.

Add Parametric Morphism α (R : ring α) : series_mul
  with signature eq_series ==> eq_series ==> eq_series
  as series_mul_morph.
Proof.
intros a b Hab c d Hcd.
constructor; intros k; simpl.
unfold convol_mul.
apply summation_compat; intros i Hi.
inversion Hab; subst.
inversion Hcd; subst.
rewrite H, H0; reflexivity.
Qed.

Section misc_theorems.

Variable α : Type.
Variable r : ring α.

Theorem convol_mul_comm : ∀ a b i,
  (convol_mul a b i = convol_mul b a i)%K.
Proof.
intros a b k.
unfold convol_mul.
rewrite summation_rtl.
apply summation_compat; intros i Hi.
rewrite Nat.add_0_r.
rewrite Nat_sub_sub_distr; [ idtac | destruct Hi; auto ].
rewrite Nat.add_comm, Nat.add_sub, rng_mul_comm; reflexivity.
Qed.

Theorem series_mul_comm : ∀ a b, (a * b = b * a)%ser.
Proof.
intros a b.
constructor; intros k; simpl.
apply convol_mul_comm.
Qed.

Theorem convol_mul_0_l : ∀ a i, (convol_mul 0%ser a i = 0)%K.
Proof.
intros a k.
unfold convol_mul.
apply all_0_summation_0; intros i Hi.
rewrite series_nth_series_0.
rewrite rng_mul_0_l; reflexivity.
Qed.

Theorem series_mul_0_l : ∀ s, (0 * s = 0)%ser.
Proof.
intros s.
constructor; intros k.
unfold series_mul; simpl.
apply convol_mul_0_l.
Qed.

Theorem series_mul_1_l : ∀ s, (1 * s = s)%ser.
Proof.
intros s.
constructor; intros k; simpl.
unfold convol_mul; simpl.
rewrite summation_only_one_non_0 with (v := O).
 rewrite Nat.sub_0_r; simpl.
 apply rng_mul_1_l.

 split; [ reflexivity | apply Nat.le_0_l ].

 intros i Hik Hi.
 destruct i; [ exfalso; apply Hi; reflexivity | simpl ].
 apply rng_mul_0_l.
Qed.

Theorem series_mul_assoc : ∀ a b c,
  (a * (b * c) = (a * b) * c)%ser.
Proof.
intros a b c.
constructor; intros k; simpl.
unfold convol_mul; simpl.
unfold convol_mul; simpl.
symmetry.
rewrite summation_mul_comm.
rewrite <- summation_summation_mul_swap.
rewrite <- summation_summation_mul_swap.
rewrite summation_summation_exch.
rewrite summation_summation_shift.
apply summation_compat; intros i Hi.
apply summation_compat; intros j Hj.
rewrite rng_mul_comm, rng_mul_assoc.
rewrite Nat.add_comm, Nat.add_sub.
rewrite Nat.add_comm, Nat.sub_add_distr.
reflexivity.
Qed.

Theorem series_nth_add : ∀ a b i,
  (((a + b)%ser) .[i] = a.[i] + b.[i])%K.
Proof. reflexivity. Qed.

Theorem convol_mul_add_distr_l : ∀ a b c i,
  (convol_mul a (b + c)%ser i = convol_mul a b i + convol_mul a c i)%K.
Proof.
intros a b c k.
unfold convol_mul.
rewrite <- summation_add_distr.
apply summation_compat; intros i Hi.
rewrite series_nth_add.
rewrite rng_mul_add_distr_l.
reflexivity.
Qed.

Theorem series_mul_add_distr_l : ∀ a b c,
  (a * (b + c) = a * b + a * c)%ser.
Proof.
intros a b c.
constructor; intros k; simpl.
apply convol_mul_add_distr_l.
Qed.

End misc_theorems.

Add Parametric Morphism α (R : ring α) : series_add
  with signature eq_series ==> eq_series ==> eq_series
  as series_add_morph.
Proof.
intros s₁ s₂ Heq₁ s₃ s₄ Heq₂.
inversion Heq₁; subst.
inversion Heq₂; subst.
constructor; intros i; simpl.
rewrite H, H0; reflexivity.
Qed.

Add Parametric Morphism α (R : ring α) : (@terms α)
  with signature eq_series ==> eq ==> rng_eq
  as series_nth_morph.
Proof.
intros s₁ s₂ Heq i.
inversion Heq; subst.
apply H.
Qed.

Section other_theorems.

Variable α : Type.
Variable r : ring α.

Theorem series_add_compat_l : ∀ a b c,
  (a = b)%ser
  → (c + a = c + b)%ser.
Proof.
intros a b c Hab.
rewrite Hab.
reflexivity.
Qed.

Theorem series_mul_compat_l : ∀ a b c,
  (a = b)%ser
  → (c * a = c * b)%ser.
Proof.
intros a b c Hab.
rewrite Hab.
reflexivity.
Qed.

Theorem series_mul_add_distr_r : ∀ a b c,
  ((a + b) * c = a * c + b * c)%ser.
Proof.
intros a b c.
rewrite series_mul_comm, series_mul_add_distr_l.
rewrite series_mul_comm.
apply series_add_compat_l.
apply series_mul_comm.
Qed.

End other_theorems.

Fixpoint term_inv {α} {r : ring α} {f : field r} c s n :=
  match n with
  | O => ¹/ (s.[0])%K
  | S n₁ =>
      match c with
      | O => 0%K
      | S c₁ =>
          (- ¹/ (s.[0]) *
           Σ (i = 0, n₁), s.[S i] * term_inv c₁ s (n₁ - i)%nat)%K
      end
  end.

Definition series_inv {α} {r : ring α} {f : field r} s :=
  {| terms i := term_inv (S i) s i |}.

Notation "¹/ a" := (series_inv a) : series_scope.

Section theorems_again.

Variable α : Type.
Variable R : ring α.
Variable K : field R.

Theorem term_inv_iter_enough : ∀ a i j k,
  k ≤ i → k ≤ j → (term_inv i a k = term_inv j a k)%K.
Proof.
intros a i j k Hki Hkj.
revert j k Hki Hkj.
induction i; intros.
 apply Nat.le_0_r in Hki; subst k.
 destruct j; reflexivity.

 simpl.
 destruct k; simpl.
  destruct j; reflexivity.

  destruct j.
   apply Nat.nle_succ_0 in Hkj; contradiction.

   simpl.
   apply rng_mul_compat_l.
   apply summation_compat; intros l (Hl, Hlj).
   apply rng_mul_compat_l.
   destruct l.
    rewrite Nat.sub_0_r.
    apply IHi; apply Nat.succ_le_mono; assumption.

    apply IHi; [ fast_omega Hki | fast_omega Hkj ].
Qed.

Theorem term_inv_nth_gen_formula : ∀ k a a' i,
  (a.[0] ≠ 0)%K
  → a' = series_inv a
    → (S k - i ≠ 0)%nat
      → (a'.[S k - i] =
         - a'.[0] *
         Σ (j = 1, S k - i),
         a.[j] * term_inv (S k) a (S k - i - j))%K.
Proof.
(* à revoir... *)
intros k a a' i Ha Ha' Hki.
rewrite Ha'.
remember minus as g; simpl; subst g.
destruct (zerop (S k - i)) as [| H₁]; [ contradiction | idtac ].
remember (S k - i)%nat as ki eqn:Hki₂.
destruct ki.
 exfalso; apply Hki; reflexivity.

 clear H₁.
 apply rng_mul_compat_l.
 rewrite summation_succ_succ.
 apply summation_compat; intros j Hj.
 apply rng_mul_compat_l.
 remember minus as g; simpl; subst g.
 rewrite Nat.sub_succ.
 remember (ki - j)%nat as n eqn:Hn.
 destruct n.
  reflexivity.

  apply rng_mul_compat_l.
  apply summation_compat; intros l Hl.
  apply rng_mul_compat_l.
  apply term_inv_iter_enough; [ fast_omega Hl Hn | idtac ].
  rewrite <- Nat.sub_succ, Hki₂ in Hn.
  rewrite <- Nat.sub_succ, Hn.
  rewrite <- Nat.sub_add_distr.
  rewrite Nat.add_succ_l.
  rewrite Nat_sub_sub_comm, Nat.sub_succ.
  rewrite <- Nat.sub_add_distr.
  apply Nat.le_sub_l.
Qed.

Theorem term_inv_nth_formula : ∀ k a a',
  (a.[0] ≠ 0)%K
  → a' = series_inv a
    → (a'.[S k] =
       - a'.[0] * Σ (i = 1, S k), a.[i] * a'.[S k - i])%K.
Proof.
intros k a a' Ha Ha'.
pose proof (term_inv_nth_gen_formula k O Ha Ha') as H.
rewrite Nat.sub_0_r in H.
rewrite H; [ idtac | intros HH; discriminate HH ].
apply rng_mul_compat_l.
apply summation_compat; intros i Hi.
apply rng_mul_compat_l.
rewrite Ha'.
remember minus as g; simpl; subst g.
remember (S k - i)%nat as n eqn:Hn.
destruct n.
 reflexivity.

 apply rng_mul_compat_l.
 apply summation_compat; intros j Hj.
 apply rng_mul_compat_l.
 apply term_inv_iter_enough; fast_omega Hn Hj.
Qed.

Theorem convol_mul_inv_r : ∀ k a a',
  (a.[0] ≠ 0)%K
  → a' = series_inv a
    → (convol_mul a a' (S k) = 0)%K.
Proof.
intros k a a' Ha Ha'.
unfold convol_mul.
pose proof (term_inv_nth_formula k Ha Ha') as Hi.
apply rng_mul_compat_l with (c := a.[0]%K) in Hi.
symmetry in Hi.
rewrite rng_mul_assoc in Hi.
rewrite rng_mul_opp_r in Hi.
rewrite Ha' in Hi.
assert (a.[0] * (¹/ a%ser) .[ 0] = 1)%K as H.
 simpl; rewrite fld_mul_inv_r; [ reflexivity | auto ].

 rewrite H in Hi; clear H.
 rewrite rng_mul_opp_l, rng_mul_1_l in Hi.
 rewrite <- Ha' in Hi.
 eapply rng_add_compat_r in Hi.
 rewrite rng_add_opp_l in Hi.
 symmetry in Hi.
 rewrite summation_split_first; [ idtac | apply Nat.le_0_l ].
 rewrite Nat.sub_0_r; auto.
Qed.

Theorem series_mul_inv_r : ∀ a,
  (a.[0] ≠ 0)%K
  → (a * ¹/ a = 1)%ser.
Proof.
intros a Ha.
constructor; intros i; simpl.
destruct i; simpl.
 unfold convol_mul; simpl.
 rewrite summation_only_one; simpl.
 rewrite fld_mul_inv_r; [ reflexivity | assumption ].

 apply convol_mul_inv_r; [ assumption | reflexivity ].
Qed.

End theorems_again.

Definition series_ring α {R : ring α} : ring (power_series α) :=
  {| rng_zero := series_0;
     rng_one := series_1;
     rng_add := series_add;
     rng_mul := series_mul;
     rng_opp := series_opp;
     rng_eq := eq_series;
     rng_eq_refl := eq_series_refl;
     rng_eq_sym := eq_series_sym (r := R);
     rng_eq_trans := eq_series_trans (r := R);
     rng_add_comm := series_add_comm R;
     rng_add_assoc := series_add_assoc R;
     rng_add_0_l := series_add_0_l R;
     rng_add_opp_l := series_add_opp_l R;
     rng_add_compat_l := @series_add_compat_l α R;
     rng_mul_comm := series_mul_comm R;
     rng_mul_assoc := series_mul_assoc R;
     rng_mul_1_l := series_mul_1_l R;
     rng_mul_compat_l := @series_mul_compat_l α R;
     rng_mul_add_distr_l := series_mul_add_distr_l R |}.

Canonical Structure series_ring.


(** Load required packages.  Not all of these packages are needed right away,
    but they may be useful later. **)

    Require Export Setoid List Sorted Constructive_sets Utf8_core Wf_nat
    ProofIrrelevance Permutation IndefiniteDescription ChoiceFacts
    Description ssrfun ssrbool ssreflect.

(** Math symbols for cut and paste: ∀ ∃ → ↔ ∧ ∨ ¬ ≠ ≤ ≥ ∅ ℕ ℤ ∈ ∉ ⊂ ∑ ∏ λ **)

(** Axioms for the integers. **)

Parameter Z : Set.

Parameter add mult : Z → Z → Z.
Parameter neg : Z → Z.
Parameter zero one : Z.
Notation "0" := zero.
Notation "1" := one.
Infix "+" := add.
Infix "*" := mult.
Notation "- x" := (neg x).
Notation "- 0" := (neg 0).
Notation "- 1" := (neg 1).
Definition sub a b := a + -b.
Infix "-" := sub.

Axiom A1 : ∀ a b   : Z, a + b = b + a.
Axiom A2 : ∀ a b c : Z, a + (b + c) = (a + b) + c.
Axiom A3 : ∀ a     : Z, a + 0 = a.
Axiom A4 : ∀ a     : Z, a + -a = 0.
Axiom M1 : ∀ a b   : Z, a * b = b * a.
Axiom M2 : ∀ a b c : Z, a * (b * c) = (a * b) * c.
Axiom M3 : ∀ a     : Z, a * 1 = a.
Axiom D1 : ∀ a b c : Z, (a + b) * c = a * c + b * c.

(** Some useful lemmas. **)

Lemma S1 : ∀ a b c : Z, a = b → a + c = b + c.
Proof.
intros a b c H.
rewrite H.
reflexivity.
Qed.

Lemma S2 : ∀ a b c : Z, a = b → a * c = b * c.
Proof.
intros a b c H.
rewrite H.
reflexivity.
Qed.

(** Homework assignment problems are given below. **)

(* COPY OF A1 QUESTIONS: *)

Theorem A1P1 : ∀ a : Z, 0 + a = a.
Proof.
  intros.
  rewrite A1.
  apply A3.
Qed.

Theorem A1P2 : ∀ a : Z, -a + a = 0.
Proof.
  intros.
  rewrite A1.
  apply A4.
Qed.

Theorem A1P3 : ∀ a : Z, 1 * a = a.
Proof.
  intros.
  rewrite M1.
  apply M3.
Qed.

Theorem A1P4 : ∀ a b : Z, a + b = 0 → b = -a.
Proof.
  intros.
  apply S1 with (c := -a) in H.
  rewrite A1P1 -A2 A1 -A2 A1P2 A3 in H.
  exact H.
Qed.

Theorem A1P5 : ∀ a : Z, -(-a) = a.
Proof.
  intros.
  assert (- a + a = 0).
  apply A1P2.
  apply A1P4 in H.
  symmetry.
  exact H.
Qed.

Theorem A1P6 : ∀ a : Z, 0 * a = 0.
Proof.
  intros.
  assert (0 * a + 0 * a = (0 + 0) * a).
    symmetry.
    apply D1.
  rewrite A3 in H.
  rewrite M1.
  apply S1 with (c := -(0 * a)) in H.
  rewrite -A2 in H.
  rewrite A4 in H.
  rewrite A3 in H.
  rewrite M1.
  exact H.
Qed.

Theorem A1P7 : ∀ a : Z, -1 * a = -a.
Proof.
  intros.
  assert ((1 + -1) * a = 0).
    rewrite A4.
    apply A1P6.
  rewrite D1 in H.
  rewrite M1 in H.
  rewrite M3 in H.
  apply A1P4.
  exact H.
Qed.

Theorem A1P8 : ∀ a b : Z, -a * -b = a * b.
Proof.
  intros.
  assert (∀ a0 : Z, -a0 = (-1) * a0).
    symmetry.
    apply A1P7.
  rewrite H.
  rewrite -M2.
  rewrite M1.
  rewrite -M2.
  rewrite M1.
  assert (∀ a : Z, a * -1 = -a).
    intros.
    rewrite M1.
    apply A1P7.
  rewrite H0.
  rewrite A1P5.
  apply M1.
Qed.

Theorem A1P9 : ∀ a b : Z, a + b = a → b = 0.
Proof.
  intros.
  rewrite A1 in H.
  apply S1 with (c := -a) in H.
  rewrite A4 -A2 A4 A3 in H.
  exact H.
Qed.

Parameter greater_than : Z → Z → Prop.
Infix ">" := greater_than.
Definition lesser_than b a := a > b.
Infix "<" := lesser_than.

Theorem O1: ∀ a b, a > b ↔ b < a.
Proof.
  intros.
  unfold lesser_than.
  split; trivial.
Qed.

Axiom O2: ∀ a b, (¬ a = b) ↔ (a > b ∨ a < b).
Axiom O3: ∀ a b c, a > b → ((c > 0 → a * c > b * c) ∧ (c < 0 → a * c < b * c)).

Lemma modus_tollens : ∀ p q : Prop, (p → q) → ¬ q → ¬ p.
Proof.
  intros.
  Locate "¬".
  unfold not.
  intros.
  apply H in H1.
  contradiction.
Qed.

Require Import ClassicalEpsilon.

Lemma NNPP : ∀ p, ¬ ¬ p → p.
  Proof.
  intros.
  pose proof (classic p) as H0.
  destruct H0.
  - exact H0.
  - contradiction.
Qed.

Lemma contrapositive: ∀ p q: Prop, (¬ p → ¬ q) → (q → p).
Proof.
  intros.
  pose proof (classic p).
  destruct H1.
  - exact H1.
  - apply H in H1. contradiction.
Qed.

Lemma deMorgans: ∀ p q: Prop, ¬ (p ∨ q) → (¬ q ∧ ¬ p).
Proof.
  intros.
  pose proof (classic p).
  destruct H0.
  - assert (p ∨ q). auto. contradiction.
  - pose proof (classic q). destruct H1.
    -- assert (p ∨ q). auto. contradiction.
    -- auto.
Qed.

(* the error was that A1P10 was applied but b could be 0. *)
Theorem A1P11 : ∀ a b : Z, a * b = 0 → a = 0 ∨ b = 0.
Proof.
  intros a b.
  apply contrapositive.
  intros.
  apply deMorgans in H.
  destruct H.
  apply O2 in H, H0.
  destruct H.
  - destruct H0.
    -- assert (a * b > 0 * b).
      apply (O3 a 0 b). exact H0. exact H.
      rewrite A1P6 in H1.
      apply O2. left. exact H1.
    -- assert (b * a < 0 * a).
      apply O3. exact H. exact H0.
      rewrite A1P6 M1 in H1.
      apply O2. right. exact H1.
  - destruct H0.
    -- assert (a * b < 0 * b).
      apply O3. exact H0. exact H.
      rewrite A1P6 in H1.
      apply O2. right. exact H1.
    -- assert (0 * b < a * b).
      apply O3. apply O1. exact H0. exact H.
      rewrite A1P6 in H1.
      apply O2. left. apply O1. exact H1.
Qed.

(* P12 Solutions begin here: *)

Parameter lt : Z → Z → Prop.
Infix "<" := lt.
(* Notation "a > b" := (b < a) (only parsing). *)
(* My code doesn't work with the above notation. *)

Definition gt a b := b < a.
Infix ">" := gt.

Lemma lt_and_gt: ∀ a b, a > b ↔ b < a.
Proof.
    intros.
    split; trivial.
Qed.

Lemma gt_to_lt: ∀ a b, a > b → b < a.
Proof.
    trivial.
Qed.

Lemma lt_to_gt: ∀ a b, a < b → b > a.
Proof.
    trivial.
Qed.

Definition divide (x y : Z) := ∃ z : Z, y = z * x.
Notation "( x | y )" := (divide x y).

Axiom N1: ∀ a b, (¬ a = b) ↔ (a > b ∨ a < b).
Axiom N2: ∀ a b c, a > b ∧ b > c → a > c.
Axiom N3: ∀ a b c, a > b → a + c > b + c.
Axiom N4: 1 > 0.

Theorem A2P1 : ∀ a m n x y : Z, (a | m) → (a | n) → (a | m * x + n * y).
Proof.
    unfold divide.
    intros.
    destruct H. destruct H0 as [y0].
    assert ((x0 * x + y0 * y) * a = m * x + n * y).
        rewrite D1 (M1 x0 x) -M2 -H.
        rewrite (M1 y0 y) -M2 -H0.
        by rewrite M1 (M1 y n).
    exists (x0 * x + y0 * y).
    by rewrite H1.
Qed.

Theorem A2P2: ∀ a b c : Z, (a | b) → (b | c) → (a | c).
Proof.
    unfold divide.
    intros.
    destruct H as [r]. destruct H0 as [s].
    rewrite H in H0.
    exists (s * r).
    by rewrite M2 in H0.
Qed.

Theorem A2P3 : ∀ a b : Z, a < b ∨ a = b ∨ b < a.
Proof.
    intros.
    pose proof (classic (a = b)).
    destruct H.
    - right. by left.
    - apply N1 in H. destruct H.
        -- right. by right.
        -- by left.
Qed.

(* Need induction for P4+ *)

Axiom induction: ∀ P: Z → Prop, P 1 → (∀ k, k > 0 → P k → P (k + 1)) → (∀ k, k > 0 →  P k).

Lemma C1: ∀ a b c d, a > b ∧ c > d → a + c > b + d.
Proof.
  intros.
  destruct H.
  assert (a + c > b + c).
  apply N3. exact H.
  assert (b + d < b + c).
  rewrite A1. unfold lesser_than. rewrite (A1 b c).
  apply N3. exact H0. unfold lesser_than in H2.
  apply N2 with (b := b + c).
  split; trivial.
Qed.

Lemma C2 : ∀ a b, a > b → -b > -a.
Proof.
  intros.
  apply N3 with (c := -a) in H.
  rewrite A4 in H.
  apply N3 with (c := -b) in H.
  rewrite A1P1 in H.
  rewrite A1 A2 A1P2 A1P1 in H.
  exact H.
Qed.

Lemma C3: ∀ a b, ¬ (a > b ∧ b > a).
Proof.
  intros.
  pose proof (classic (a > b ∧ b > a)).
  destruct H. destruct H.
    assert (a > a).
      apply N2 with (b := b).
      split; trivial.
    assert (¬ a = a).
      apply N1. left. exact H1.
    contradiction H2.
    reflexivity.
  exact H.
Qed.

Lemma D2 : ∀ a b c : Z, c * (a + b) = c * a + c * b.
Proof.
    intros.
    by rewrite M1 D1 M1 (M1 c b).
Qed.

Lemma C4: ∀ a b c, a > b → c > 0 → a * c > b * c.
Proof.
  intros.
  assert (a * 1 > b * 1).
    by rewrite ? M3.
  assert (∀ k: Z, a * k > b * k → a * (k + 1) > b * (k + 1)).
    intros.
    rewrite ? D2 ? M3.
    apply C1. split; trivial.
  apply (induction (λ d, a * d > b * d)).
  trivial.
  intros.
  by apply H2 in H4.
  trivial.
Qed.

Theorem A2P4 : ∀ a b c : Z, a < b → 0 < c → a * c < b * c.
Proof.
    intros.
    apply lt_and_gt.
    apply C4.
    trivial.
    trivial.
Qed.

Lemma C5: ∀ a b c, a > b → c < 0 → a * c < b * c.
    intros.
    assert (∀ x, x * -1 = -x).
        intro. by rewrite M1 A1P7.
    assert (a * -1 < b * -1).
        rewrite ? H1. by apply C2.
    assert (∀ k: Z, a * -k < b * -k → a * -(k + 1) < b * -(k + 1)).
        intros.
        rewrite ? D2 ? M3.
        unfold lesser_than.
        rewrite -A1P7.
        rewrite M1.
        assert (∀ x y z, x * (y + z) = x * y + x * z).
        intros.
        rewrite M1 D1 M1.
        assert (∀ r s t, r = s → t + r = t + s).
            intros.
            rewrite H4.
            reflexivity.
        apply H4 with (t := x * y).
        apply M1.
        rewrite H4 H4 D1 A1P7 -M2 A1P3 A1P7 M2.
        rewrite H1 M3.
        apply C1. split.
        rewrite M1 in H3. exact H3.
        apply C2. exact H.
    remember (-c) as e.
        assert (- e = c).
        rewrite -A1P7 in Heqe.
        apply S2 with (c := -1) in Heqe.
        rewrite M1 A1P7 M1 M2 A1P8 -M2 M1 M3 M1 M3 in Heqe.
        exact Heqe.
    rewrite -H4.
    apply (induction (λ d, a * - d < b * - d)).
    exact H2.
    intros.
    by apply H3 in H6.
    rewrite -H4 in H0.
    apply N3 with (c := e) in H0.
    by rewrite A1P1 A1P2 in H0.
Qed.

Theorem A2P5 : ∀ a b c : Z, a * c = b * c → c ≠ 0 → a = b.
Proof.
    intros.
    assert (¬ a = b → ¬ a * c = b * c).
      - intros.
        apply N1 in H0. destruct H0.
        -- apply N1 in H1. destruct H1.
          --- apply N1. left. by apply C4.
          --- apply N1. right. by apply C4.
        -- apply N1 in H1. destruct H1.
          --- apply N1. right. by apply C5.
          --- apply N1. left. by apply C5.
    - by apply contrapositive with (p := (a = b)) (q := (a * c = b * c)) in H1.
Qed.

Theorem A2P6 : ∀ a b c : Z, a < b → b < c → a < c.
Proof.
    intros.
    apply gt_to_lt.
    apply N2 with (b := b).
    split; trivial.
Qed.

Theorem A2P7 : ∀ a : Z, ¬ a < a.
Proof.
    unfold not.
    intros.
    assert (¬ a = a).
    apply N1. by left.
    by contradiction H0.
Qed.

Notation "2" := (1+1).

(* Some lemmas for A1P8 *)

Lemma consistency: ∀ a b : Z, a > b → ¬ (a < b).
Proof.
  intros.
  pose proof (classic (a < b)).
  destruct H0.
  - assert (a > a).
      apply (N2 a b a). split; trivial.
    apply gt_to_lt in H1.
    by pose proof (A2P7 a).
  - trivial.
Qed.

Lemma one_not_two: ¬ 1 = 2.
Proof.
  intro.
  apply S1 with (c := -1) in H.
  rewrite A4 -A2 A4 A3 in H.
  assert (¬ 0 = 1).
    apply N1. right. apply N4.
  contradiction.
Qed.

(* The following is the proof of the "step_down" lemma for A1P8. *)

Definition leq a b := a < b ∨ a = b.
Definition geq a b := (a > b ∨ a = b).
Infix "≤" := leq (at level 70).
Infix "≥" := geq (at level 70).

Lemma not_less_eq_geq: ∀ a b, ¬ a < b ↔ a ≥ b.
Proof.
  intros.
  split.
  pose proof (A2P3 a b).
  - destruct H.
    -- by intros.
    -- intros.
      destruct H.
      --- by right.
      --- by left.
  - intros.
    destruct H.
    -- unfold not. intro.
      assert (a > a).
        apply (N2 a b a).
        split; trivial.
      by apply (A2P7 a).
    -- unfold not. intro.
      pose proof N1.
      assert (a > b ∨ a < b).
        by right.
      by apply H1 in H2.
Qed.

Theorem step_up: ∀ a, a > 0 → ¬ (a < 1).
Proof.
  assert (2 > 1).
    pose proof N4.
    apply N3 with (c := 1) in H.
    by rewrite A1 A3 in H.
  apply (induction (λ n, ¬ (n < 1))).
  unfold not. intros.
  - by apply A2P7 in H0.
  - intros.
    apply not_less_eq_geq.
    apply not_less_eq_geq in H1.
    destruct H1.
    -- apply N3 with (c := 1) in H1.
      left.
      apply N2 with (b := 2).
      split; trivial.
    -- rewrite H1.
      by left.
Qed.

Theorem zero_one_consecutive: ∀ a, ¬ (0 < a ∧ a < 1).
Proof.
  unfold not.
  intros.
  destruct H.
  apply step_up in H.
  contradiction.
Qed.

Theorem discreteness_of_ints: ∀ a b, ¬ (b < a ∧ a < b + 1).
Proof.
  unfold not. intros.
  destruct H.
  pose proof (zero_one_consecutive (a - b)).
  contradiction H1.
  split.
  - apply N3 with (c := -b) in H.
    by rewrite A4 in H.
  - apply N3 with (c := -b) in H0.
    by rewrite A1 A2 (A1 (-b) b) A4 A1 A3 in H0.
Qed.

Theorem step_down: ∀ a b, a < b → (a ≤ b + -1).
Proof.
  intros.
  pose proof (A2P3 a (b + -1)).
  destruct H0.
  - by left.
  - destruct H0.
    -- by right.
    -- pose proof (discreteness_of_ints a (b + -1)).
      contradiction H1.
      split.
      --- trivial.
      --- by rewrite -A2 (A1 (-1) 1) A4 A3.
Qed.

Theorem A2P8 : ¬ (2 | 1).
Proof.
    unfold not. unfold divide. intros.
    destruct H.
    assert (x < 0 ∨ x = 0 ∨ 0 < x). apply A2P3.
    assert (¬ x < 0).
      pose proof (classic (x < 0)).
      destruct H1.
        assert (x * 2 < 0 * 2).
          apply C4. trivial.
        assert (2 > 0 + 0).
          apply (C1 1 0 1 0). split; apply N4.
        by rewrite A3 in H2.
        rewrite -H A1P6 in H2.
        apply (consistency 1 0) in H2.
        contradiction.
        apply N4.
      trivial.
    assert (¬ x = 0).
      pose proof (classic (x = 0)).
      destruct H2.
        assert (¬ 1 = 0).
          apply N1. left. apply N4.
        assert (1 = 0 * 2). by rewrite -H2.
        rewrite A1P6 in H4.
        contradiction.
      trivial.
    destruct H0.
    - contradiction.
    - destruct H0.
      -- contradiction.
      -- pose proof (A2P3 x 1).
        destruct H3.
        --- apply step_down in H3.
          destruct H3.
          ---- by rewrite A4 in H3.
          ---- by rewrite A4 in H3.
        --- destruct H3.
          ---- rewrite H3 M1 M3 in H.
            by apply one_not_two.
          ---- apply C4 with (c := 2) in H3.
            ----- rewrite (M1 1 2) M3 in H3.
              rewrite -H in H3.
              apply N3 with (c := -1) in H3.
              rewrite A4 -A2 A4 A3 in H3.
              assert (¬ 0 > 1).
                apply consistency. apply N4.
              contradiction.
            ----- pose proof (C1 1 0 1 0).
              rewrite A3 in H4. apply H4. split; apply N4.
Qed.


Require Import Coq.Lists.List.
Require Export Coq.Sets.Ensembles.
Require Import Coq.Sorting.Permutation.
Require Import Fiat.Common.
Require Import Fiat.Common.List.PermutationFacts.

Definition EnsembleListEquivalence
           {A}
           (ensemble : Ensemble A)
           (seq : list A) :=
  NoDup seq /\
  forall x, Ensembles.In _ ensemble x <-> List.In x seq.

Local Ltac perm_t :=
  repeat match goal with
           | _ => intro
           | _ => progress destruct_head_hnf and
           | _ => progress destruct_head_hnf or
           | _ => progress destruct_head_hnf Singleton
           | _ => progress split_iff
           | _ => split
           | [ H : NoDup (_::_) |- _ ] => inversion H; clear H; subst
           | [ H : ~Ensembles.In _ (Singleton _ ?a) ?x |- _ ]
             => assert (a <> x) by (intro; subst; apply H; constructor);
               clear H
           | _ => solve [ eauto ]
           | _ => congruence
         end.

Lemma Permutation_pull_to_front {T} (a : T) ls
      (H : List.In a ls)
: exists ls' : _, Permutation ls (a::ls').
Proof.
  induction ls; simpl in *; destruct_head False.
  destruct_head_hnf or; subst.
  { exists ls; reflexivity. }
  { specialize (IHls H).
    destruct IHls as [ls' H'].
    eexists (_::ls').
    etransitivity; [ apply perm_skip; exact H' | ].
    apply perm_swap. }
Qed.

Lemma EnsembleListEquivalence_Same_set U (A B : Ensemble U)
      ls
      (H : EnsembleListEquivalence A ls)
: EnsembleListEquivalence B ls <-> Same_set _ A B.
Proof.
  induction ls;
  repeat match goal with
           | _ => split
           | _ => intro
           | _ => progress destruct_head_hnf and
           | _ => progress split_iff
           | _ => progress simpl in *
           | _ => solve [ eauto ]
         end.
  Unshelve.
  assumption.
Qed.

Lemma EnsembleListEquivalence_Permutation U (A : Ensemble U)
      ls ls'
      (H : EnsembleListEquivalence A ls) (H' : EnsembleListEquivalence A ls')
: Permutation ls ls'.
Proof.
  revert A ls' H H'.
  induction ls; intros A ls' H H'.
  { destruct_head_hnf and; split_iff.
    destruct ls'; simpl in *; auto.
    specialize_all_ways.
    intuition. }
  { let H := fresh in
    let H' := fresh in
    let t := destruct_head_hnf and; split_iff; intuition in
    lazymatch goal with
      | [ |- Permutation (?a::?ls) ?ls' ]
        => assert (H : List.In a ls') by t;
          assert (H' : ~List.In a ls)
             by (intro; t;
                 match goal with
                   | [ H'' : NoDup (_::_) |- _ ]
                     => solve [ inversion H''; subst; intuition ]
                 end)
    end;
      hnf in H.
    destruct (Permutation_pull_to_front _ _ H0) as [ls'' H''].
    symmetry in H''.
    etransitivity; [ | exact H'' ].
    apply perm_skip.
    apply (IHls (Subtract _ A a)).
    { perm_t;
      specialize_all_ways;
      perm_t. }
    { pose proof (fun x => @Permutation_in _ _ _ x H'').
      symmetry in H''.
      pose proof (fun x => @Permutation_in _ _ _ x H'').
      let H := fresh in
      assert (H : NoDup (a::ls'')) by
          (eapply PermutationFacts.NoDup_Permutation_rewrite;
           try solve [ destruct_head_hnf and; eassumption ]);
        inversion H; subst; clear H.
      perm_t; specialize_all_ways; perm_t. } }
Qed.

Lemma EnsembleListEquivalence_slice :
  forall {A} a b c (ens: Ensemble A),
    EnsembleListEquivalence ens (a ++ b ++ c) ->
    EnsembleListEquivalence (fun x => ens x /\ ~ List.In x b) (a ++ c).
Proof.
  unfold EnsembleListEquivalence, Ensembles.In; simpl;
  repeat setoid_rewrite in_app_iff; intros *.
  split.
  - intros. intuition.
    eauto using NoDup_slice.
  - intros; intuition.
    + rewrite H1 in H2; intuition.
    + rewrite H1; intuition.
    + eapply NoDup_app_inv'; eauto.
    + rewrite H1; intuition.
    + eapply NoDup_app_inv'; eauto.
Qed.

Lemma ensemble_list_equivalence_set_eq_morphism {A : Type} {ens1 ens2 : A -> Prop} :
  (forall x, Ensembles.In _ ens1 x <-> Ensembles.In _ ens2 x) ->
  forall (seq : list A),
    (EnsembleListEquivalence ens1 seq <-> EnsembleListEquivalence ens2 seq).
Proof.
  intros * equiv *;
  unfold EnsembleListEquivalence, In in *;
  setoid_rewrite equiv; reflexivity.
Qed.

Lemma EnsembleListEquivalence_lift_property {TItem: Type} {P: TItem -> Prop} :
  forall (sequence: list TItem) (ensemble: TItem -> Prop),
    EnsembleListEquivalence ensemble sequence ->
    ((forall item,
        List.In item sequence -> P item) <->
     (forall item,
        Ensembles.In _ ensemble item -> P item)).
Proof.
  intros * equiv;
  destruct equiv as [NoDup_l equiv];
  setoid_rewrite equiv;
  reflexivity.
Qed.


Require Export GeoCoq.Tarski_dev.Annexes.quadrilaterals_inter_dec.

Ltac assert_all := treat_equalities; assert_cols_perm; assert_diffs; assert_congs_perm.

Section TriangleMidpointsTheorems.

Context `{TE:Tarski_euclidean}.

Lemma col_permut132 : forall A B C, Col A B C -> Col A C B.
Proof. exact col_permutation_5. Qed.

Lemma col_permut213 : forall A B C, Col A B C -> Col B A C.
Proof. exact col_permutation_4. Qed.

Lemma col_permut231 : forall A B C, Col A B C -> Col B C A.
Proof. exact col_permutation_1. Qed.

Lemma col_permut312 : forall A B C, Col A B C -> Col C A B.
Proof. exact col_permutation_2. Qed.

Lemma col_permut321 : forall A B C, Col A B C -> Col C B A.
Proof. exact col_permutation_3. Qed.

Lemma col123_124__col134 : forall P Q A B,
  P <> Q -> Col P Q A -> Col P Q B -> Col P A B.
Proof. exact col_transitivity_1. Qed.

Lemma col123_124__col234 : forall P Q A B,
  P <> Q -> Col P Q A -> Col P Q B -> Col Q A B.
Proof. exact col_transitivity_2. Qed.

Lemma triangle_mid_par_strict : forall A B C P Q,
 ~Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Par_strict A B Q P.
Proof.
intros.
Name x the symmetric of P wrt Q.
assert_all.
assert (~ Col A P C) by (intro; apply H; ColR).
assert_diffs.
assert (Parallelogram_strict A P C x) by (apply mid_plgs with Q;auto).
assert (Cong A x B P) by CongR.
assert (Par A x B P) by (assert_pars_perm; apply par_col2_par with P C; Col).
assert (HElim : Parallelogram A x B P \/ Parallelogram A x P B) by (apply par_cong_plg_2; assumption).

induction HElim.

 assert_paras_perm; assert_pars_perm.
 Name M the intersection of the diagonals (A B) and (x P) of the parallelogram H15.
 treat_equalities.
 search_contradiction.

apply par_strict_col2_par_strict with x P; Col.
assert_diffs; auto.
(*
apply ncol134_plg__pars1423; auto; intro; apply H; ColR.
*)
apply ncol123_plg__pars1423; auto; intro; apply H.
assert (P <> x) by (intro; treat_equalities; Col).
apply col_permut231; apply col123_124__col234 with P;
[| |apply col_permut231]; Col.
apply col_permut231; apply col123_124__col134 with Q; Col.
apply col_permut231; apply col123_124__col134 with x; Col.
Qed.

Lemma triangle_mid_par_strict_cong_aux : forall A B C P Q R,
 ~Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par_strict A B Q P  /\ Cong A R P Q /\ Cong B R P Q.
Proof.
intros.
Name x the symmetric of P wrt Q.
assert_all.
assert (~ Col A P C) by (intro; search_contradiction).
assert_diffs.
assert (Parallelogram_strict A P C x) by (apply mid_plgs with Q;auto).
assert_all.
assert_pars_perm.
assert (Cong A x B P) by (apply cong_transitivity with P C; Cong).
assert (Par A x B P) by (apply par_col2_par with P C; Col).
assert (HElim : Parallelogram A x B P \/ Parallelogram A x P B) by (apply par_cong_plg_2; assumption).

induction HElim.

 Name M the intersection of the diagonals (A B) and (x P) of the parallelogram H22.
 treat_equalities.
 search_contradiction.

assert_pars_perm.
assert (Par P Q A B) by (assert_diffs; apply par_col_par_2 with x; Col; Par).
split.

apply par_not_col_strict with x; Col; Par.
 intro.
 assert_cols_perm.
 apply H.
 ColR.
assert_congs_perm;split;CongR.
Qed.

Lemma triangle_par_mid : forall A B C P Q,
 ~ Col A B C ->
 Midpoint P B C ->
 Par A B Q P ->
 Col Q A C ->
 Midpoint Q A C.
Proof.
assert (H:=playfair_s_postulate_implies_midpoint_converse_postulate);
unfold midpoint_converse_postulate in H; intros; apply H with B P; Col.
unfold playfair_s_postulate.
apply parallel_uniqueness.
Qed.

Lemma triangle_mid_par_strict_cong_1 : forall A B C P Q R,
 ~Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par_strict A B Q P  /\ Cong A R P Q.
Proof.
intros.
assert (Par_strict A B Q P /\ Cong A R P Q /\ Cong B R P Q)
  by (apply triangle_mid_par_strict_cong_aux with C; assumption).
spliter.
split; assumption.
Qed.

Lemma triangle_mid_par_strict_cong_2 : forall A B C P Q R,
 ~Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par_strict A B Q P  /\ Cong B R P Q.
Proof.
intros.
assert (Par_strict A B Q P /\ Cong A R P Q /\ Cong B R P Q)
  by (apply triangle_mid_par_strict_cong_aux with C; assumption).
spliter.
split; assumption.
Qed.

Lemma triangle_mid_par_strict_cong_simp :
 forall A B C P Q,
 ~ Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Par_strict A B Q P.
Proof.
apply triangle_mid_par.
Qed.

Lemma triangle_mid_par_strict_cong : forall A B C P Q R,
 ~Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par_strict A B Q P /\ Par_strict A C P R /\ Par_strict B C Q R /\
 Cong A R P Q /\ Cong B R P Q /\ Cong A Q P R /\ Cong C Q P R /\ Cong B P Q R /\ Cong C P Q R.
Proof.
intros.
permutation_intro_in_hyps.
assert (Par_strict A B Q P /\ Cong A R P Q /\ Cong B R P Q)
  by (apply triangle_mid_par_strict_cong_aux with C; assumption).
assert (Par_strict A C R P /\ Cong A Q P R /\ Cong C Q P R)
  by (apply triangle_mid_par_strict_cong_aux with B; Col).
assert (Par_strict C B Q R /\ Cong C P R Q /\ Cong B P R Q)
  by (apply triangle_mid_par_strict_cong_aux with A; Col).
spliter.

split; trivial.
split; Par.
split; Par.
repeat split; Cong.
Qed.

Lemma triangle_mid_par_flat_cong_aux : forall A B C P Q R,
 B <> A ->
 Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par A B Q P /\ Cong A R P Q /\ Cong B R P Q.
Proof.
intros.

elim (eq_dec_points A C); intro.

  assert_all.
  split; Cong.
  perm_apply col_par.

elim (eq_dec_points B C); intro.
  assert_all.
  split; Cong.
  perm_apply col_par.

elim (eq_dec_points A P); intro.
  assert_all.
  assert (Col A B Q) by ColR.
  split.
  perm_apply col_par.
  assert_congs_perm.
  split; Cong.

Name x the symmetric of P wrt Q.

elim (eq_dec_points P x); intro.
  treat_equalities; intuition.

assert_cols.
assert (Parallelogram A P C x) by (apply mid_plg_1 with Q;auto).
assert_all.
assert_pars_perm.
assert (Cong A x B P) by (apply cong_transitivity with P C; Cong).
assert (Par A x B P) by (apply par_col2_par with P C; Col; Par).

assert (HElim : Parallelogram A x B P \/ Parallelogram A x P B) by (apply par_cong_plg_2; assumption).

induction HElim.

 Name M the intersection of the diagonals (A B) and (x P) of the parallelogram H11.
 treat_equalities.
 search_contradiction.

 assert_paras_perm.
 assert_pars_perm.
 assert (Par P Q A B) by (apply par_col_par_2 with x; Col; Par).
 assert_congs_perm.
 repeat split; Par; Cong.
Qed.

Lemma triangle_mid_par_flat_cong_1 : forall A B C P Q R,
 B <> A ->
 Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par A B Q P  /\ Cong A R P Q.
Proof.
intros.
assert (Par A B Q P /\ Cong A R P Q /\ Cong B R P Q)
  by (apply triangle_mid_par_flat_cong_aux with C; assumption).
spliter.
split; assumption.
Qed.

Lemma triangle_mid_par_flat_cong_2 : forall A B C P Q R,
 B <> A ->
 Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par A B Q P /\ Cong B R P Q.
Proof.
intros.
assert (Par A B Q P /\ Cong A R P Q /\ Cong B R P Q)
  by (apply triangle_mid_par_flat_cong_aux with C; assumption).
spliter.
split; assumption.
Qed.

Lemma triangle_mid_par_flat_cong : forall A B C P Q R,
 B <> A ->
 C <> A ->
 C <> B ->
 Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par A B Q P /\ Par A C P R /\ Par B C Q R /\
 Cong A R P Q /\ Cong B R P Q /\ Cong A Q P R /\ Cong C Q P R /\ Cong B P Q R /\ Cong C P Q R.
Proof.
intros.
permutation_intro_in_hyps.
assert (Par A B Q P /\ Cong A R P Q /\ Cong B R P Q) by (apply triangle_mid_par_flat_cong_aux with C; assumption).
assert (Par A C R P /\ Cong A Q P R /\ Cong C Q P R) by (apply triangle_mid_par_flat_cong_aux with B; Col).
assert (Par C B Q R /\ Cong C P R Q /\ Cong B P R Q) by (apply triangle_mid_par_flat_cong_aux with A; Col).
spliter.

repeat split; Cong; Par.

Qed.

Lemma triangle_mid_par_flat : forall A B C P Q,
 B <> A ->
 Col A B C ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Par A B Q P.
Proof.
intros.
elim (midpoint_existence A B); intro R; intro.
assert (HTMT := triangle_mid_par_flat_cong_aux A B C P Q R H H0 H1 H2 H3); spliter.
assumption.
Qed.

Lemma triangle_mid_par : forall A B C P Q,
 A <> B ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Par A B Q P.
Proof.
intros.

elim (col_dec A B C); intro.
  apply triangle_mid_par_flat with C; auto.

  apply par_strict_par; apply triangle_mid_par_strict with C; assumption.
Qed.

Lemma triangle_mid_par_cong : forall A B C P Q R,
 B <> A ->
 C <> A ->
 C <> B ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par A B Q P /\ Par A C P R /\ Par B C Q R /\
 Cong A R P Q /\ Cong B R P Q /\ Cong A Q P R /\ Cong C Q P R /\ Cong B P Q R /\ Cong C P Q R.
Proof.
intros.

elim (col_dec A B C); intro.
  apply triangle_mid_par_flat_cong; assumption.

  assert (HTMT := triangle_mid_par_strict_cong A B C P Q R H5 H2 H3 H4); spliter.
  repeat split; try apply par_strict_par; assumption.
Qed.

Lemma triangle_mid_par_cong_1 : forall A B C P Q R,
 C <> B ->
 Midpoint P B C ->
 Midpoint Q A C ->
 Midpoint R A B ->
 Par B C Q R /\ Cong B P Q R .
Proof.
intros.
split.
perm_apply (triangle_mid_par B C A Q R).
induction (col_dec A B C).
 assert (Par C B Q R /\ Cong B P R Q).
  apply (triangle_mid_par_flat_cong_2 C B A R Q P); Midpoint; Col.
  spliter.
  Cong.
 assert (HTMT := triangle_mid_par_strict_cong A B C P Q R H3 H0 H1 H2); spliter.
 assumption.
Qed.

End TriangleMidpointsTheorems.


Require Import
  Algebra.FrameC
  Algebra.OrderC
  CMorphisms.

Set Universe Polymorphism.
Local Open Scope Frame.

Section Congruence.
Context {A : Type} {OA : @Frame.Ops A} {FA : Frame.t OA}
        {B : Type} {OB : @Frame.Ops B} {FB : Frame.t OB}.

Variable f : A -> B.
Hypothesis f_L : L.morph (Frame.LOps (Ops := OA)) (Frame.LOps (Ops := OB)) f.
Hypothesis f_sup : forall (Ix : Type) (g : Ix -> A),
  f (Frame.sup g) == Frame.sup (fun i => f (g i)).

Definition LOpsA' : L.Ops A :=
  {| L.le := fun U V => f U <= f V
   ; L.eq :=  fun U V => f U == f V
   ; L.min := fun U V => U ∧ V
   ; L.max := fun U V => U ∨ V
  |}.

Definition OpsA' : @Frame.Ops A :=
  {| Frame.LOps := LOpsA'
  ; Frame.top := Frame.top
  ; Frame.sup := fun Ix f => Frame.sup f
  |}.

Lemma eq_le (x y : B) : x == y -> x <= y.
Proof.
  intros. rewrite X. reflexivity.
Qed.

Lemma LatticeC : L.t _ LOpsA'.
Proof.
econstructor.
- constructor.
  + constructor. intros. simpl.
    reflexivity. simpl. intros. etransitivity; eassumption.
  + unfold Proper, respectful. simpl.
    intros. rewrite X, X0. reflexivity.
  + simpl. intros. apply PO.le_antisym; assumption.
- unfold Proper, respectful. simpl. intros.
  transitivity (f x ∨ f x0).
  apply f_L. transitivity (f y ∨ f y0).
  rewrite X, X0. reflexivity.
  symmetry. apply f_L.
- simpl. intros. econstructor.
  + transitivity (f l ∨ f r). apply L.max_ok.
    apply eq_le. symmetry. apply f_L.
  + transitivity (f l ∨ f r). apply L.max_ok.
    apply eq_le. symmetry. apply f_L.
  + intros. transitivity (f l ∨ f r).
    apply eq_le. apply f_L.
    apply L.max_ok; assumption.
- unfold Proper, respectful. simpl. intros.
  transitivity (f x ∧ f x0).
  apply f_L. transitivity (f y ∧ f y0).
  rewrite X, X0. reflexivity. symmetry. apply f_L.
- intros. econstructor.
  + simpl. transitivity (f l ∧ f r).
    apply eq_le. apply f_L. apply L.min_ok.
  + simpl. transitivity (f l ∧ f r).
    apply eq_le. apply f_L. apply L.min_ok.
  + simpl. intros. transitivity (f l ∧ f r).
    apply L.min_ok; assumption. apply eq_le.
    symmetry. apply f_L.
Qed.

Instance FrameC : Frame.t OpsA'.
Proof.
econstructor.
- apply LatticeC.
- unfold PreO.top. intros. simpl. apply f_L. apply Frame.top_ok.
- unfold Proper, pointwise_relation, respectful. simpl.
  intros. transitivity (Frame.sup (fun i => f (x i))).
  apply f_sup. transitivity (Frame.sup (fun i => f (y i))).
  apply Frame.sup_proper. unfold pointwise_relation.
  assumption. symmetry. apply f_sup.
- intros. econstructor.
  + intros. simpl. apply f_L. apply Frame.sup_ok.
  + simpl. intros. transitivity (Frame.sup (fun i => f (f0 i))).
    apply eq_le. apply f_sup. apply Frame.sup_ok.
    assumption.
- simpl. intros. apply f_L. apply Frame.sup_distr.
Qed.

Lemma incl_cont : Frame.morph OA OpsA' (fun a => a).
Proof.
unshelve eapply Frame.morph_easy.
- unfold Proper, respectful. simpl. intros.
  apply f_L. assumption.
- reflexivity.
- intros. simpl. apply f_L. reflexivity.
- simpl. intros. apply f_L. reflexivity.
Qed.

End Congruence.

Section Nucleus.

Context {A : Type} `{FA : Frame.t A}.

Variable j : A -> A.

Class nucleus : Type :=
  { j_Proper : Proper (L.eq ==> L.eq) j
  ; j_meet : forall U V : A, j (U ∧ V) == j U ∧ j V
  ; j_mono : forall U, U <= j U
  ; j_idempotent : forall U, j (j U) <= j U }.

Instance j_ProperI `{nucleus} : Proper (L.eq ==> L.eq) j.
Proof. apply j_Proper. Qed.

Hypothesis j_nucleus : nucleus.

Definition LOpsAj : L.Ops A :=
  {| L.le := fun U V => j U <= j V
   ; L.eq :=  fun U V => j U == j V
   ; L.min := fun U V => j (U ∧ V)
   ; L.max := fun U V => j (U ∨ V)
  |}.

Definition OpsAj : @Frame.Ops A :=
  {| Frame.LOps := LOpsAj
  ; Frame.top := Frame.top
  ; Frame.sup := fun Ix f => j (Frame.sup f)
  |}.

Lemma j_top : j Frame.top == Frame.top.
Proof.
apply PO.le_antisym. apply Frame.top_ok.
apply j_mono.
Qed.

Lemma j_mono2 (U V : A) : U <= V -> j U <= j V.
Proof.
intros H. apply Frame.le_min. apply Frame.le_min in H.
rewrite <- j_meet. rewrite H. reflexivity.
Qed.

Lemma j_idem_eq (U : A) : j (j U) == j U.
Proof.
apply PO.le_antisym. apply j_idempotent. apply j_mono.
Qed.

Lemma j_join_le (x y x' y' : A) : j x <= j y
  -> j x' <= j y' -> j (j (x ∨ x')) <= j (j (y ∨ y')).
Proof.
intros. rewrite j_idempotent.
apply j_mono2. apply L.max_ok. rewrite j_mono.
rewrite X. apply j_mono2. apply L.max_ok.
rewrite j_mono. rewrite X0. apply j_mono2. apply L.max_ok.
Qed.

Lemma j_sup_le {Ix : Type} (f f' : Ix -> A) :
  (forall i, j (f i) <= j (f' i)) ->
  j (j (Frame.sup f)) <= j (j (Frame.sup f')).
Proof.
intros. rewrite j_idempotent. apply j_mono2.
apply Frame.sup_ok. intros. rewrite j_mono.
rewrite X. apply j_mono2. apply Frame.sup_ok.
Qed.

Lemma max_idempotent (x : A) : x ∨ x == x.
Proof.
apply PO.le_antisym; apply L.max_ok; reflexivity.
Qed.

Lemma LatticeJ : L.t _ LOpsAj.
Proof.
econstructor.
- constructor.
  + constructor. intros. simpl.
    reflexivity. simpl. intros. etransitivity; eassumption.
  + unfold Proper, respectful. simpl.
    intros. rewrite X, X0. reflexivity.
  + simpl. intros. apply PO.le_antisym; assumption.
- unfold Proper, respectful. simpl. intros.
  apply PO.le_antisym; apply j_join_le.
  rewrite X; reflexivity. rewrite X0. reflexivity.
  rewrite <- X. reflexivity. rewrite <- X0. reflexivity.
- simpl. intros. econstructor.
  + apply j_mono2. rewrite <- j_mono. apply L.max_ok.
  + apply j_mono2. rewrite <- j_mono. apply L.max_ok.
  + intros. rewrite j_join_le; try eassumption.
    rewrite max_idempotent. apply j_idempotent.
- unfold Proper, respectful. simpl. intros.
  apply j_Proper. rewrite !j_meet. apply L.min_proper; assumption.
- simpl. intros. econstructor.
  + rewrite j_idempotent. apply j_mono2. apply L.min_ok.
  + rewrite j_idempotent. apply j_mono2. apply L.min_ok.
  + intros. rewrite !j_meet, !j_idem_eq. apply L.min_ok; assumption.
Qed.

Instance FrameJ : Frame.t OpsAj.
Proof.
econstructor.
- apply LatticeJ.
- unfold PreO.top. intros. simpl. apply j_mono2. apply Frame.top_ok.
- unfold Proper, pointwise_relation, respectful. simpl.
  intros. apply PO.le_antisym; apply j_sup_le; intros;
    rewrite X; reflexivity.
- simpl. intros. econstructor.
  + intros. apply j_mono2. rewrite j_mono. apply j_mono2.
    apply Frame.sup_ok.
  + intros. rewrite j_sup_le. Focus 2. intros.
    apply X. rewrite j_idem_eq. apply j_mono2.
    apply Frame.sup_ok. intros. reflexivity.
- simpl. intros. rewrite j_meet.
  apply PO.le_antisym.
  + rewrite <- j_meet. rewrite j_idem_eq. apply j_mono2.
    transitivity (j (Frame.sup (fun i : Ix => j x ∧ j (f i)))).
    rewrite <- Frame.sup_distr. rewrite j_meet.
    apply L.min_ok. rewrite j_idem_eq.
    transitivity x. apply L.min_ok. apply j_mono.
    transitivity (j (Frame.sup f)). apply L.min_ok.
    apply j_mono2. apply Frame.sup_ok. intros.
    transitivity (j (f i)). apply j_mono.
    apply (Frame.sup_ok (fun i0 : Ix => j (f i0))).
    apply j_mono2. apply Frame.sup_ok. intros.
    rewrite <- j_meet.
    pose proof (Frame.sup_ok (fun i0 : Ix => j (x ∧ f i0))).
    apply X.
  + rewrite j_idem_eq. apply j_mono2. apply L.min_ok.
    * apply Frame.sup_ok. intros. rewrite j_meet. apply L.min_ok.
    * apply Frame.sup_ok. intros. apply j_mono2.
      transitivity (j (f i)). transitivity (f i). apply L.min_ok.
      apply j_mono. apply j_mono2. apply Frame.sup_ok.
Qed.

Lemma incl_contN : Frame.morph OA OpsAj (fun a => a).
Proof.
unshelve eapply Frame.morph_easy.
- unfold Proper, respectful. simpl. intros.
  rewrite X. reflexivity.
- reflexivity.
- intros. simpl. rewrite j_idem_eq. reflexivity.
- simpl. intros. rewrite j_idem_eq. reflexivity.
Qed.

End Nucleus.

Section OpenSubN.

Context {A : Type} `{FA : Frame.t A}.

(** We need our open [V] defining our subspace to be exponentiable.
    Impredicatively, any frame is a heyting algebra, so all objects
    are exponentiable: just take the supremum of all opens [Γ] such
    that [Γ ∧ U <= V]. But predicatively, we can't do this. But if we
    have access to a set-indexed base, then we can just take the
    supremum over the base. Here we will just assume demand that
    we are given an exponentiable open to define our subspace.
*)

Require Import Algebra.SetsC.
Local Open Scope Subset.

Definition is_implies (U V UV : A) :=
  forall Γ : A, Γ <= UV <--> Γ ∧ U <= V.

Lemma is_implies_unique (U V : A) : forall (UV UV' : A),
  is_implies U V UV -> is_implies U V UV'
  -> UV == UV'.
Proof.
unfold is_implies. intros. apply PO.le_antisym.
- apply (X0 UV). apply X. reflexivity.
- apply (X UV'). apply X0. reflexivity.
Qed.

Instance min_mono : Proper (L.le ==> L.le ==> L.le) L.min.
Proof.
unfold Proper, respectful.
intros. apply L.min_ok. rewrite <- X. apply L.min_ok.
rewrite <- X0. apply L.min_ok.
Qed.

Definition min_comm (U V : A) : U ∧ V == V ∧ U.
Proof.
apply PO.le_antisym; repeat apply L.min_ok.
Qed.

Lemma implies_meet (U X Y UX UY UXY : A)
  : is_implies U X UX -> is_implies U Y UY
  -> is_implies U (X ∧ Y) UXY
  -> UXY == UX ∧ UY.
Proof.
unfold is_implies. intros. apply PO.le_antisym.
- apply L.min_ok.
  + apply X0. transitivity (X ∧ Y).
    apply X2. reflexivity. apply L.min_ok.
  + apply X1. transitivity (X ∧ Y).
    apply X2. reflexivity. apply L.min_ok.
- apply X2. apply L.min_ok.
  + transitivity (UX ∧ U). apply min_mono.
    apply L.min_ok. reflexivity. apply X0. reflexivity.
  + transitivity (UY ∧ U). apply min_mono.
    apply L.min_ok. reflexivity. apply X1. reflexivity.
Qed.

Lemma impl_apply_le (x a b xa xb : A) :
  is_implies x a xa -> is_implies x b xb
  -> xa <= xb -> a ∧ x <= b ∧ x.
Proof.
intros. unfold is_implies in *.
apply L.min_ok. apply X0. rewrite <- X1. apply X.
  apply L.min_ok. apply L.min_ok.
Qed.

Lemma impl_apply (x a b xa xb : A) :
  is_implies x a xa -> is_implies x b xb
  -> xa == xb -> a ∧ x == b ∧ x.
Proof.
intros. apply PO.le_antisym; eapply impl_apply_le;
  try eassumption. rewrite X1. reflexivity.
rewrite <- X1. reflexivity.
Qed.

Instance is_implies_Proper : Proper (L.eq ==> L.eq ==> L.eq ==> arrow) is_implies.
Proof.
unfold Proper, respectful, arrow, is_implies.
intros. rewrite <- X1, <- X0, <- X. apply X2.
Qed.

Variable V : A.
Variable Vimpl : A -> A.
Hypothesis Vimpl_ok : forall U, is_implies V U (Vimpl U).

Instance Vimpl_Proper : Proper (L.eq ==> L.eq) Vimpl.
Proof.
unfold Proper, respectful. intros.
eapply is_implies_unique. apply Vimpl_ok.
rewrite X. apply Vimpl_ok.
Qed.

Theorem Vimpl_nucleus : nucleus Vimpl.
Proof.
econstructor.
- apply Vimpl_Proper.
- intros. eapply implies_meet; apply Vimpl_ok.
- unfold is_implies in Vimpl_ok.
  intros. apply Vimpl_ok. apply L.min_ok.
- intros. apply Vimpl_ok.
  transitivity (Vimpl U ∧ V). apply L.min_ok.
  apply (Vimpl_ok (Vimpl U) (Vimpl (Vimpl U))).
  reflexivity. apply L.min_ok. apply Vimpl_ok. reflexivity.
Qed.

Definition OpenSubOpsN : @Frame.Ops A :=
  OpsAj Vimpl.

Instance OpenSubFrameN : Frame.t OpenSubOpsN.
Proof.
  apply FrameJ. apply Vimpl_nucleus.
Qed.

Lemma open_incl_contN : Frame.morph OA OpenSubOpsN (fun a => a).
Proof.
apply incl_contN. apply Vimpl_nucleus.
Qed.

End OpenSubN.

Section OpenSub.

Context {A : Type} `{FA : Frame.t A}.

Require Import Algebra.SetsC.
Local Open Scope Subset.

Variable V : A.

Definition intV (U : A) := U ∧ V.

Lemma min_distr1 (a b c : A) :
  (a ∧ b) ∧ c == (a ∧ c) ∧ (b ∧ c).
Proof.
apply PO.le_antisym.
- repeat apply L.min_ok.
  transitivity (a ∧ b); apply L.min_ok.
  transitivity (a ∧ b); apply L.min_ok.
- repeat apply L.min_ok. transitivity (a ∧ c);
  apply L.min_ok. transitivity (b ∧ c); apply L.min_ok.
  transitivity (b ∧ c); apply L.min_ok.
Qed.

Lemma intV_L : L.morph Frame.LOps Frame.LOps intV.
Proof.
unfold intV. econstructor.
- econstructor.
  + unfold PreO.morph. intros. apply min_mono.
    assumption. reflexivity.
  + unfold Proper, respectful. intros. rewrite X. reflexivity.
- intros. rewrite !Frame.max_sup.
  rewrite min_comm. rewrite Frame.sup_distr.
  apply Frame.sup_proper. unfold pointwise_relation.
  intros. rewrite min_comm. destruct a0; reflexivity.
- intros. apply min_distr1.
Qed.

Lemma intV_sup : forall Ix (g : Ix -> A),
  intV (Frame.sup g) == Frame.sup (fun i => intV (g i)).
Proof.
unfold intV. intros. rewrite min_comm.
rewrite Frame.sup_distr. apply Frame.sup_proper.
unfold pointwise_relation; intros.
apply min_comm.
Qed.

Definition OpenSubOps : @Frame.Ops A := OpsA' intV.

Instance OpenSubFrame : Frame.t OpenSubOps.
Proof.
  apply FrameC. apply intV_L. apply intV_sup.
Qed.

Lemma open_incl_cont : Frame.morph OA OpenSubOps (fun a => a).
Proof.
apply incl_cont. apply intV_L. apply intV_sup.
Qed.

End OpenSub.

Section Pattern.

Context {A : Type} {OA : @Frame.Ops A} {FA : Frame.t OA}
        {B : Type} {OB : @Frame.Ops B} {FB : Frame.t OB}.

Variable Ix : Type.
Variable V : Ix -> A.
Variable f : Ix -> B -> A.
Variable f_cont : forall i : Ix, Frame.morph OB (OpenSubOps (V i)) (f i).

Definition f' (i : Ix) (b : B) : A := intV (V i) (f i b).

Definition union_f (b : B) : A := Frame.sup (fun i => f' i b).

Hypothesis covering : Frame.top <= union_f Frame.top.

(** This is copied. I should put it somewhere good. *)
Instance min_mono2 {Z} `{Frame.t Z} : Proper (L.le ==> L.le ==> L.le) L.min.
Proof.
unfold Proper, respectful.
intros. apply L.min_ok. rewrite <- X. apply L.min_ok.
rewrite <- X0. apply L.min_ok.
Qed.

Instance max_mono {Z} `{Frame.t Z} : Proper (L.le ==> L.le ==> L.le) L.max.
Proof.
unfold Proper, respectful.
intros. apply L.max_ok. rewrite X. apply L.max_ok.
rewrite X0. apply L.max_ok.
Qed.

Lemma f'_mono (i : Ix) (b b' : B) :
  b <= b' -> f' i b <= f' i b'.
Proof.
intros. unfold f'.
apply (f_cont i). assumption.
Qed.

Variable glue_f : Ix -> Ix -> B -> A.
Variable glue_f_cont : forall i j : Ix,
  Frame.morph OB (OpenSubOps (V i ∧ V j)) (glue_f i j).

Definition union_f2 (b : B) : A :=
  Frame.sup (fun p : (Ix * Ix) => let (i, j) := p in
  intV (V i ∧ V j) (glue_f i j b)).

Lemma min_idempotent (x : A) : x ∧ x == x.
Proof.
apply PO.le_antisym; apply L.min_ok; reflexivity.
Qed.

(** Need to talk about inclusions of open subspaces into other
    open subspaces to state gluing. Also specialization preorders would
    be nice. *)
Hypothesis gluing : forall i j : Ix,
  let Vij := V i ∧ V j in
  forall b : B, PreO.max (le := L.le (Ops := @Frame.LOps _ OA)) (f i b ∧ Vij) (f j b ∧ Vij) (glue_f i j b ∧ Vij).

Lemma union_f_same (b : B) :
  union_f b == union_f2 b.
Proof.
unfold union_f, union_f2.
apply PO.le_antisym.
- apply Frame.sup_ok. intros.
  etransitivity. Focus 2.
  apply (Frame.sup_ok (Ix := Ix * Ix)).
  instantiate (1 := (i, i)).
  simpl. unfold f', intV.
  rewrite min_idempotent.
  pose proof (gluing i i).
  simpl in X. specialize (X b).
  apply PreO.max_l in X.
  rewrite !min_idempotent in X.
  assumption.
- apply Frame.sup_ok. intros. destruct i.
  rewrite <- (max_idempotent (Frame.sup (fun i1 : Ix => f' i1 b))).
  etransitivity. Focus 2.
  apply max_mono.
  unshelve apply Frame.sup_ok. exact i.
  unshelve apply Frame.sup_ok. exact i0.
  unfold f'.
  pose proof (gluing i i0).
  simpl in X. specialize (X b).
  destruct X. clear max_l max_r.
  etransitivity. apply max_least. 3:reflexivity.
  transitivity (f i b ∧ V i).
  apply min_mono. reflexivity. apply L.min_ok.
  apply L.max_ok.
  transitivity (f i0 b ∧ V i0).
  apply min_mono. reflexivity. apply L.min_ok.
  apply L.max_ok.
Qed.

Existing Instances Frame.f_eq L.min_proper.

Theorem pattern : Frame.morph OB OA union_f.
Proof.
apply Frame.morph_easy.
- unfold Proper, respectful, union_f. intros.
  apply Frame.sup_proper. unfold pointwise_relation. intros.
  unfold f'. apply (f_cont a). assumption.
- apply PO.le_antisym. apply Frame.top_ok.
  apply covering.
- intros. apply PO.le_antisym.
  + unfold union_f. apply L.min_ok.
  apply Frame.sup_pointwise. intros i.
  exists i. apply f'_mono. apply L.min_ok.
  apply Frame.sup_pointwise. intros i.
  exists i. apply f'_mono. apply L.min_ok.
  + rewrite (union_f_same (U ∧ V0)).
    unfold union_f, union_f2.
    rewrite Frame.sup_distr. apply Frame.sup_ok.
    intros i. rewrite min_comm.
    rewrite Frame.sup_distr. apply Frame.sup_ok.
    intros j. etransitivity.
    Focus 2. apply (Frame.sup_ok (Ix := Ix * Ix)).
    instantiate (1 := (i, j)).
    simpl.
    pose proof (gluing i j) as glue. simpl in glue.
    unfold f'.
    transitivity ((f i V0 ∧ f j U) ∧ (V i ∧ V j)).
    apply L.min_ok. apply L.min_ok.
    transitivity (f i V0 ∧ V i). apply L.min_ok.
    apply L.min_ok.
    transitivity (f j U ∧ V j).
    apply L.min_ok. apply L.min_ok.
    apply L.min_ok.
    transitivity (f i V0 ∧ V i). apply L.min_ok.
    apply L.min_ok. transitivity (f j U ∧ V j).
    apply L.min_ok. apply L.min_ok.
    rewrite (min_comm (f i V0) (f j U)).
    destruct (glue V0). clear max_least max_r.
    destruct (glue U). clear max_l0 max_least.
    pose proof (glue_f_cont i j) as H.
    destruct H.
    destruct f_L. simpl in f_min.
    specialize (f_min U V0).
    unfold intV.
    unfold intV in f_min. rewrite f_min.
    rewrite (min_distr1 (f j U)).
    rewrite (min_distr1 (glue_f i j U)).
    apply min_mono. apply max_r. apply max_l.
- intros. unfold union_f. apply PO.le_antisym.
  apply Frame.sup_ok. intros.
  unfold f'.
  pose proof (Frame.f_sup (f_cont i) g).
  simpl in X.
  rewrite X. unfold intV.
  rewrite min_comm. rewrite Frame.sup_distr.
  apply Frame.sup_pointwise. intros.
  exists i0. rewrite min_comm.
  eapply (PreO.sup_ge (fun i1 : Ix => f i1 (g i0) ∧ V i1) _ (Frame.sup_ok (fun i1 : Ix => f i1 (g i0) ∧ V i1)) i).
  apply Frame.sup_ok. intros. apply Frame.sup_pointwise.
  intros.  exists i0. unfold f'.
  pose proof (PO.f_PreO (L.f_PO (Frame.f_L (f_cont i0)))) as X.
  unfold PreO.morph in X. simpl in X.
  apply X. apply Frame.sup_ok.
Qed.

End Pattern.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Nil : lst |Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.
Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (qreva x y)) (append (rev y) x).
Proof.
  induction x.
  - intros. simpl. rewrite append_nil. reflexivity.
  - intros. simpl. rewrite IHx. simpl. lfind. Admitted.