(* This module defines two notions of inverse for a function of type
   [nat -> nat] which is monotonic and tends towards infinity. *)

(* We define a lower inverse [betaf] and an upper inverse [alphaf].
   [betaf y] is less than or equal to [alphaf y]. They differ by at
   most one, and they are equal when [y] is in the image of [f]. *)

From TLC Require Import LibTactics LibRelation LibMin.
From iris_time.union_find.math Require Import LibFunOrd LibNatExtra
  Filter FilterTowardsInfinity TLCBuffer.

Section Inverse.

(* -------------------------------------------------------------------------- *)

(* Assumptions. *)

Variable f : nat -> nat.

Variable f_tends_to_infinity:
  limit towards_infinity towards_infinity f.

Variable f_monotonic:
  monotonic le le f.

Variable f_strictly_monotonic:
  monotonic lt lt f.

(* We note that, if [f] is strictly monotonic, then [f] is monotonic.
   So, the two assumptions above might seem redundant. Nevertheless,
   it is useful to state them separately, as some lemmas need only
   the weaker hypothesis [f_monotonic], while some lemmas need the
   stronger hypothesis [f_strictly_monotonic]. *)

(* -------------------------------------------------------------------------- *)

(* Auxiliary lemmas, used in the following. *)

Lemma alphaf_existence:
  forall y,
  exists x, y <= f x.
Proof using f_tends_to_infinity.
  intros.
  generalize (exploit_tends_towards_infinity f_tends_to_infinity y).
  intros [ ? ? ]. eauto.
Qed.

Lemma betaf_bound:
  forall y,
  exists x,
  lower_bound (inverse le) (fun x => f x <= y) x.
Proof using f_tends_to_infinity.
  intros.
  (* Since [f] tends towards infinity, there exists a threshold [x0]
     beyond which this function exceeds [y]. *)
  generalize (exploit_tends_towards_infinity f_tends_to_infinity (y + 1)).
  intros [ x0 hx0 ].
  (* Thus, [f x <= y] implies [x < x0]. *)
  unfold lower_bound, inverse.
  eexists x0.
  intros x ?.
  destruct (Compare_dec.le_gt_dec x x0); [ assumption | ].
  forwards: hx0 x. lia. lia.
Qed.

(* -------------------------------------------------------------------------- *)

(* Because [f] tends towards infinity, for every [y], there exists a least
   [x] such that [f x] is at least [y]. We refer to it as [alphaf y]. *)

Definition alphaf y :=
  MMin (fun x => y <= f x).

(* -------------------------------------------------------------------------- *)

(* By definition, [alphaf y] is the least [x] such that [y <= f x] holds.
   Because [f] is monotonic, this property holds for all [x] above [alphaf y].
   Thus, [y <= f x] is equivalent to [alphaf y <= x]. In that sense, [alphaf]
   is an inverse of [f]. *)

Lemma alphaf_spec_direct:
  forall y x,
  alphaf y <= x ->
  y <= f x.
Proof using f_monotonic f_tends_to_infinity.
  intros.
  transitivity (f (alphaf y)).
  (* The first sub-goal holds by definition of [alphaf]. *)
  mmin_spec (alphaf y).
  eauto using alphaf_existence.
  (* The second sub-goal holds by monotonicity of [f]. *)
  eauto with monotonic.
Qed.

Lemma alphaf_spec_direct_contrapositive:
  forall y x,
  f x < y ->
  x < alphaf y.
Proof using f_tends_to_infinity f_monotonic.
  intros. prove_lt_lt_by_contraposition. eauto using alphaf_spec_direct.
Qed.

Lemma alphaf_spec_reciprocal:
  forall y x,
  y <= f x ->
  alphaf y <= x.
Proof using f_tends_to_infinity.
  intros.
  (* The goal holds by definition of [alphaf]. *)
  mmin_spec (alphaf y).
  eauto using alphaf_existence.
  eapply minimality. assumption.
Qed.

Lemma alphaf_spec_reciprocal_contrapositive:
  forall y x,
  x < alphaf y ->
  f x < y.
Proof using f_tends_to_infinity.
  intros. prove_lt_lt_by_contraposition. eauto using alphaf_spec_reciprocal.
Qed.

Lemma alphaf_spec:
  forall y x,
  (alphaf y <= x <-> y <= f x).
Proof using f_tends_to_infinity f_monotonic.
  split; eauto using alphaf_spec_direct, alphaf_spec_reciprocal.
Qed.

Lemma f_alphaf:
  forall y,
  y <= f (alphaf y).
Proof using f_tends_to_infinity f_monotonic.
  eauto using alphaf_spec_direct.
Qed.

Lemma alphaf_f:
  forall x,
  alphaf (f x) <= x.
    (* If [f] is strictly monotonic, there is equality. See below. *)
Proof using f_tends_to_infinity f_monotonic.
  eauto using alphaf_spec_reciprocal.
Qed.

Lemma alphaf_f_exact:
  forall x,
  alphaf (f x) = x.
Proof using f_tends_to_infinity f_monotonic f_strictly_monotonic.
  intros.
  (* If this equality does not hold, then, by the previous lemma,
     [alphaf (f x)] must be less than [x]. *)
  destruct (Nat.eq_decidable (alphaf (f x)) x); [ assumption | false ].
  assert (h1: alphaf (f x) < x).
    { forwards: alphaf_f x. lia. }
  (* By exploiting the fact that [f] is strictly monotonic and
     the lemma [f_alphaf], we find [f x < f x]. Contradiction. *)
  forwards h2: f_strictly_monotonic h1.
  forwards h3: f_alphaf (f x).
  lia.
Qed.

(* [alphaf] is monotonic. *)

Lemma alphaf_monotonic:
  monotonic le le alphaf.
Proof using f_tends_to_infinity f_monotonic f_strictly_monotonic.
  intros x y ?.
  eapply alphaf_spec_reciprocal.
  rewrite <- f_alphaf.
  assumption.
Qed.

(* -------------------------------------------------------------------------- *)

(* Almost symmetrically, if [f 0 <= y] holds, then there exists a largest [x]
   such that [f x] is bounded by [y]. We refer to it as [betaf y]. Because
   [f] is monotonic, this property holds for all [x] below [betaf y]. Thus,
   [f x <= y] is equivalent to [x <= betaf y]. In that sense, [betaf] is an
   inverse of [f]. *)

Definition betaf y :=
  MMax (fun x => f x <= y).

Lemma betaf_spec_direct:
  forall y x,
  f 0 <= y ->
  x <= betaf y ->
  f x <= y.
Proof using f_tends_to_infinity f_monotonic.
  intros.
  transitivity (f (betaf y)).
  (* The first sub-goal holds by monotonicity of [f]. *)
  eauto with monotonic.
  (* The second sub-goal holds by definition of [betaf]. *)
  mmin_spec (betaf y).
    eauto.
    eauto using betaf_bound.
Qed.

Lemma betaf_spec_direct_contrapositive:
  forall y x,
  f 0 <= y ->
  y < f x ->
  betaf y < x.
Proof using f_tends_to_infinity f_monotonic.
  intros. prove_lt_lt_by_contraposition. eauto using betaf_spec_direct.
Qed.

Lemma betaf_spec_direct_contrapositive_le:
  forall y x,
  f 0 <= y ->
  y < f (1 + x) ->
  betaf y <= x.
Proof using f_tends_to_infinity f_monotonic.
  intros.
  cut (betaf y < 1 + x). lia.
  eauto using betaf_spec_direct_contrapositive.
Qed.

Lemma betaf_spec_reciprocal:
  forall y x,
  f x <= y ->
  x <= betaf y.
Proof using f_tends_to_infinity.
  intros.
  (* The goal holds by definition of [betaf]. *)
  mmin_spec (betaf y).
    eauto. (* [f 0 <= y] not needed, as [f x <= y] implies the desired existence *)
    eauto using betaf_bound.
  eapply minimality. assumption.
Qed.

Lemma betaf_spec_reciprocal_contrapositive:
  forall y x,
  betaf y < x ->
  y < f x.
Proof using f_tends_to_infinity.
  intros. prove_lt_lt_by_contraposition. eauto using betaf_spec_reciprocal.
Qed.

Lemma betaf_spec:
  forall y x,
  f 0 <= y ->
  (x <= betaf y <-> f x <= y).
Proof using f_tends_to_infinity f_monotonic.
  split; eauto using betaf_spec_direct, betaf_spec_reciprocal.
Qed.

Lemma f_betaf:
  forall y,
  f 0 <= y ->
  f (betaf y) <= y.
Proof using f_tends_to_infinity f_monotonic.
  eauto using betaf_spec_direct.
Qed.

Lemma betaf_f:
  forall x,
  x <= betaf (f x).
    (* If [f] is strictly monotonic, there is equality. See below. *)
Proof using f_tends_to_infinity.
  eauto using betaf_spec_reciprocal.
Qed.

Lemma betaf_f_exact:
  forall x,
  x = betaf (f x).
Proof using f_tends_to_infinity f_strictly_monotonic f_monotonic.
  intros.
  (* If this equality does not hold, then, by the previous lemma,
     [x] must be less than [betaf (f x)]. *)
  destruct (Nat.eq_decidable x (betaf (f x))); [ assumption | false ].
  assert (h1: x < betaf (f x)).
    { forwards: betaf_f x. lia. }
  (* By exploiting the fact that [f] is strictly monotonic and
     the lemma [f_betaf], we find [f x < f x]. Contradiction. *)
  forwards h2: f_strictly_monotonic h1.
  forwards h3: f_betaf (f x).
    eauto with monotonic lia.
  lia.
Qed.

(* [betaf] is monotonic. *)

Lemma betaf_monotonic:
  monotonic (fun x y => f 0 <= x <= y) le betaf.
Proof using f_tends_to_infinity f_monotonic.
  intros x y ?.
  eapply betaf_spec_reciprocal.
  rewrite f_betaf by tauto.
  tauto.
Qed.

(* -------------------------------------------------------------------------- *)

(* [alphaf x y] and [betaf x y] are related as follows. *)

(* Because [f] is strictly monotonic, for a fixed [y], there is at most one
   point [x] where [f x = y] holds. This implies that, if [betaf y] is
   defined, then [betaf y] is less than or equal to [alphaf y]. *)

Lemma betaf_le_alphaf:
  forall y,
  f 0 <= y ->
  betaf y <= alphaf y.
Proof using f_tends_to_infinity f_strictly_monotonic f_monotonic.
  intros.
  (* Because [f] is strictly monotonic, it suffices to prove that
     [f (betaf y)] is less than or equal to [f (alphaf y)]. *)
  eapply monotonic_lt_lt_implies_inverse_monotonic_le_le; [ eapply f_strictly_monotonic | ].
  (* The proof is now easy: [y] is between these numbers. *)
  eauto 3 using Nat.le_trans, f_betaf, f_alphaf.
Qed.

(* In the above lemma, if [y] is of the form [f x], then we have equality
   between [betaf y] and [alphaf y], and both are equal to [x]. *)

Lemma betaf_le_alphaf_equality:
  forall y x,
  f x = y ->
  betaf y = alphaf y /\ alphaf y = x.
Proof using f_tends_to_infinity f_strictly_monotonic f_monotonic.
  intros. subst.
  forwards: alphaf_f x.
  forwards: betaf_f x.
  forwards: betaf_le_alphaf (f x).
    { eauto with monotonic lia. }
  split; lia.
Qed.

(* The converse of the above property holds. That is, we have equality
   between [betaf y] and [alphaf y] only if [y] is in the image of [f]. *)

Lemma betaf_le_alphaf_equality_converse:
  forall y x,
  f 0 <= y ->
  betaf y = alphaf y ->
  alphaf y = x ->
  f x = y.
Proof using f_tends_to_infinity f_monotonic.
  introv ? h1 h2.
  forwards h3: f_alphaf y.
  forwards h4: f_betaf y. assumption.
  rewrite h1 in h4. clear h1.
  rewrite h2 in h3, h4. clear h2.
  lia.
Qed.

(* [betaf y] and [alphaf y] differ by at most one. *)

Lemma betaf_alphaf_differ_by_at_most_one:
  forall y,
  alphaf y <= 1 + betaf y.
Proof using f_tends_to_infinity.
  intros.
  (* If the goal does not hold, then there exists [z] which is
     greater than [betaf y] and less than [alphaf y]. *)
  destruct (Compare_dec.le_gt_dec (alphaf y) (1 + betaf y)); [ assumption | false ].
  assert (zz: exists z, betaf y < z < alphaf y).
    { exists (betaf y + 1). lia. }
  destruct zz as [ z [ hz1 hz2 ]].
  (* This [z] has the properties [y < f z] and [f z < y]. Contradiction. *)
  forwards: betaf_spec_reciprocal_contrapositive. eexact hz1.
  forwards: alphaf_spec_reciprocal_contrapositive. eexact hz2.
  lia.
Qed.

(* Because [f] is monotonic, [y < z] implies [betaf y < alphaf z]. *)

Lemma alphaf_lt_betaf:
  forall y z,
  f 0 <= y ->
  y < z ->
  betaf y < alphaf z.
Proof using f_tends_to_infinity f_monotonic.
  intros.
  (* Because [f] is monotonic, it suffices to prove that
     [f (betaf y)] is less than [f (alphaf z)]. *)
  eapply monotonic_le_le_implies_inverse_monotonic_lt_lt.
    eexact f_monotonic.
  (* The proof is now easy: [y < z] are between these numbers. *)
  eauto 4 using Nat.le_lt_trans, Nat.lt_le_trans, f_betaf, f_alphaf.
Qed.

(* [betaf] tends to infinity. *)

Lemma betaf_tends_to_infinity:
  limit towards_infinity towards_infinity betaf.
Proof using f_tends_to_infinity.
  eapply prove_tends_towards_infinity. intro x.
  exists (f x). intros y h.
  eauto using betaf_spec_reciprocal.
Qed.

(* TEMPORARY show that [alphaf] tends to infinity too
   using betaf_le_alphaf
   and a generic proof that if f tends to infinity and f <= g then g tends to infinity *)

End Inverse.

Hint Resolve alphaf_monotonic betaf_monotonic : monotonic typeclass_instances.


Require Import Reals.
Local Open Scope R_scope.
From ValidSDP Require Import validsdp.
Require Import Psatz.

Let p (x0 x1 x2 x3 x4 x5 : R) :=
  0
  - (x0 * x3 * (0 - x0 + x1 + x2 - x3 + x4 + x5)
     + x1 * x4 * (x0 - x1 + x2 + x3 - x4 + x5)
     + x2 * x5 * (x0 + x1 - x2 + x3 + x4 - x5) - x1 * x2 * x3 - x0 * x2 * x4
     - x0 * x1 * x5 - x3 * x4 * x5).

Let p' (x0 x1 x2 x3 x4 x5 : R) :=
  (0 - x1) * x2 - x0 * x3 + x1 * x4 + x2 * x5 - x4 * x5
  + x0 * (0 - x0 + x1 + x2 - x3 + x4 + x5).

Let b1 (x0 x1 x2 x3 x4 x5 : R) :=
  (x0 - 4) * (63504/10000 - x0).

Let b2 (x0 x1 x2 x3 x4 x5 : R) :=
  (x1 - 4) * (63504/10000 - x1).

Let b3 (x0 x1 x2 x3 x4 x5 : R) :=
  (x2 - 4) * (63504/10000 - x2).

Let b4 (x0 x1 x2 x3 x4 x5 : R) :=
  (x3 - 4) * (63504/10000 - x3).

Let b5 (x0 x1 x2 x3 x4 x5 : R) :=
  (x4 - 90601/10000) * (254016/10000 - x4).

Let b6 (x0 x1 x2 x3 x4 x5 : R) :=
  (x5 - 4) * (90601/10000 - x5).

Theorem alternative (x0 x1 x2 x3 x4 x5 : R) :
  b1 x0 x1 x2 x3 x4 x5 >= 0 ->
  b2 x0 x1 x2 x3 x4 x5 >= 0 ->
  b3 x0 x1 x2 x3 x4 x5 >= 0 ->
  b4 x0 x1 x2 x3 x4 x5 >= 0 ->
  b5 x0 x1 x2 x3 x4 x5 >= 0 ->
  b6 x0 x1 x2 x3 x4 x5 >= 0 ->
  (p x0 x1 x2 x3 x4 x5 > 0
   \/ p' x0 x1 x2 x3 x4 x5 > 0).
Proof.
intros H1 H2 H3 H4 H5 H6.
case (Rlt_or_le 0 (p x0 x1 x2 x3 x4 x5)) => Hp; [now left|right].
revert H1 H2 H3 H4 H5 H6 Hp.
unfold b1, b2, b3, b4, b5, b6, p, p'.
validsdp.
Qed.


Require Import List.
Require Import Omega.
Require Import Tactics.
Require Import VerdiTactics.
Require Import Setoid.
Require Import Classes.RelationClasses.
Import ListNotations.

Set Implicit Arguments.

Section lists.

  Hint Rewrite app_nil_r.

  Ltac deex :=
    match goal with
    | [ H: exists varname, _ |- _ ] =>
      let newvar := fresh varname in
      destruct H as (newvar, H); intuition (subst_max)
    end.

  Lemma skipn_app : forall T (a b : list T),
    skipn (length a) (a ++ b) = b.
  Proof.
    induction a; firstorder.
  Qed.

  Lemma firstn_all: forall A (l : list A) n,
    length l <= n -> firstn n l = l.
  Proof.
    unfold firstn; induction l; destruct n; intros; firstorder.
    rewrite IHl; firstorder.
  Qed.

  Lemma skipn_all: forall T n (l : list T),
    length l <= n -> skipn n l = nil.
  Proof.
    unfold skipn; induction n; destruct l; intros; auto.
    inversion H.
    apply IHn; firstorder.
  Qed.

  Lemma cons_nil_app : forall A l r (a : A),
    (l ++ (a :: nil)) ++ r = l ++ a :: r.
  Proof.
    intros.
    rewrite app_assoc_reverse.
    simpl; auto.
  Qed.

  Hint Resolve cons_nil_app.

  Lemma firstn_app : forall T n (a b: list T),
    firstn n (a ++ b) = firstn n a ++ firstn (n - length a) b.
  Proof.
    induction n; intuition.
    destruct a; cbn; [ | rewrite IHn ]; reflexivity.
  Qed.

  (* from coq-ext-lib *)
  Lemma firstn_app_R : forall T n (a b : list T),
    length a <= n ->
    firstn n (a ++ b) = a ++ firstn (n - length a) b.
  Proof.
    induction n; destruct a; simpl in *; intros; auto.
    exfalso; omega.
    f_equal. eapply IHn; eauto. omega.
  Qed.

  Lemma firstn_app_r : forall T i (b a : list T),
    firstn (length a + i) (a ++ b) = a ++ (firstn i b).
  Proof.
    intros. rewrite firstn_app_R.
    f_equal. f_equal. omega.
    omega.
  Qed.

  Lemma firstn_app_L : forall T n (a b : list T),
    n <= length a ->
    firstn n (a ++ b) = firstn n a.
  Proof.
    induction n; destruct a; simpl in *; intros; auto.
    exfalso; omega.
    f_equal. eapply IHn; eauto. omega.
  Qed.

  Lemma skipn_app_R : forall T n (a b : list T),
    length a <= n ->
    skipn n (a ++ b) = skipn (n - length a) b.
  Proof.
    induction n; destruct a; simpl in *; intros; auto.
    exfalso; omega.
    eapply IHn. omega.
  Qed.

  Lemma skipn_app_r : forall T i (b a : list T),
    skipn (length a + i) (a ++ b) = skipn i b.
  Proof.
    intros. rewrite skipn_app_R.
    f_equal. f_equal. omega.
    omega.
  Qed.

  Lemma skipn_app_L : forall T n (a b : list T),
    n <= length a ->
    skipn n (a ++ b) = (skipn n a) ++ b.
  Proof.
    induction n; destruct a; simpl in *; intros; auto.
    exfalso; omega.
    eapply IHn. omega.
  Qed.

  Lemma skipn_length: forall A n (l : list A),
    n <= length l
    -> length (skipn n l) = length l - n.
  Proof.
    induction n; destruct l; intros; firstorder.
  Qed.

  Lemma skipn_skipn : forall T a (ls : list T) b,
    skipn b (skipn a ls) = skipn (b + a) ls.
  Proof.
    induction a; simpl; intros.
    rewrite Plus.plus_0_r. auto.
    rewrite Plus.plus_comm. simpl. destruct ls; auto. destruct b; auto.
    rewrite IHa. rewrite Plus.plus_comm. auto.
  Qed.

  Definition concat A (l: list (list A)) : list A := fold_right (@app A) [] l.

  Definition repeat_list A n (l: list A) : list A := concat (repeat l n).

  Lemma repeat_list_app : forall A n m (l: list A),
    repeat_list n l ++ repeat_list m l = repeat_list (n + m) l.
  Proof.
    unfold repeat_list.
    induction n; crush.
  Qed.

  Lemma repeat_list_chop_last : forall A n (l: list A),
    0 < n -> repeat_list n l = repeat_list (n - 1) l ++ l.
  Proof.
    intros.
    remember (n - 1) as m.
    replace n with (S m) in * by omega.
    clear n Heqm.
    unfold repeat_list.
    clear H.
    induction m. simpl. apply app_nil_r.
    simpl in *. rewrite IHm. rewrite app_assoc. rewrite IHm. reflexivity.
  Qed.

  Lemma repeat_list_tail: forall A n (l: list A),
    0 < n -> repeat_list n l = l ++ repeat_list (n - 1) l.
  Proof.
    unfold repeat_list.
    intros.
    remember (n - 1) as m.
    replace n with (S m) in * by omega.
    reflexivity.
  Qed.

  Lemma repeat_repeat : forall A n m (l: list A),
    repeat_list n (repeat_list m l) = repeat_list (n * m) l.
  Proof.
    induction n; intuition.
    simpl. rewrite <- repeat_list_app.
    cbn. f_equal. apply IHn.
  Qed.

  Inductive suffix A : list A -> list A -> Prop :=
  | suf_refl : forall l, suffix l l
  | suf_cons : forall c l' l, suffix l' l -> suffix l' (c::l).
  Hint Constructors suffix.

  Inductive prefix A : list A -> list A -> Prop :=
  | pre_nil : forall l, prefix [] l
  | pre_cons : forall c l' l, prefix l' l -> prefix (c::l') (c::l).
  Hint Constructors prefix.

  Lemma suffix_app: forall A (l l': list A), suffix l (l' ++ l).
  Proof.
    induction l'; crush.
  Qed.
  Hint Resolve suffix_app.

  Lemma suffix_defn: forall A (l l2: list A),
    suffix l2 l <-> exists l', l = l' ++ l2.
  Proof.
    intuition.
    + induction H. eexists. instantiate (1 := nil). reflexivity.
      destruct IHsuffix. eexists.
      rewrite H0. rewrite app_comm_cons. reflexivity.
    + destruct H. crush.
  Qed.
  Hint Resolve suffix_defn.

  Lemma prefix_app: forall A (l l': list A), prefix l (l ++ l').
  Proof.
    induction l; crush.
  Qed.
  Hint Resolve prefix_app.

  Lemma prefix_defn: forall A (l l': list A),
    prefix l' l <-> exists l'', l = l' ++ l''.
  Proof.
    intuition.
    + induction H. eexists. reflexivity.
      destruct IHprefix. eexists.
      rewrite H0. reflexivity.
    + destruct H. crush.
  Qed.
  Hint Resolve prefix_defn.

  Instance prefix_trans {A}: Transitive (@prefix A).
  Proof.
    unfold Transitive.
    intros.
    apply prefix_defn. apply prefix_defn in H. apply prefix_defn in H0.
    repeat deex. eexists. rewrite <- app_assoc. reflexivity.
  Qed.

  Lemma skipn_suffix: forall A n (l: list A), suffix (skipn n l) l.
  Proof.
    induction n; crush.
    destruct l; crush.
  Qed.

  Lemma firstn_prefix: forall A n (l: list A), prefix (firstn n l) l.
  Proof.
    induction n; crush.
    destruct l; crush.
  Qed.

  Inductive sublist A : list A -> list A -> Prop :=
  | subl_prefix : forall l' l, prefix l' l -> sublist l' l
  | subl_cons : forall c l' l, sublist l' l -> sublist l' (c::l).
  Hint Constructors sublist.

  Lemma sublist_app : forall A (l l' l'': list A), sublist l (l' ++ l ++ l'').
  Proof.
    induction l'; crush.
  Qed.
  Hint Resolve sublist_app.

  Lemma sublist_defn : forall A (l l': list A),
    sublist l' l <-> exists l2 l3, l = l2 ++ l' ++ l3.
  Proof.
    intuition.
    + induction H.
      apply prefix_defn in H.
      deex. repeat eexists. rewrite app_nil_l. reflexivity.
      repeat deex. repeat eexists. rewrite app_comm_cons. reflexivity.
    + repeat deex. auto.
  Qed.
  Hint Resolve sublist_defn.

  Instance sublist_trans {A}: Transitive (@sublist A).
  Proof.
    unfold Transitive.
    intros.
    apply sublist_defn. apply sublist_defn in H. apply sublist_defn in H0.
    repeat deex. repeat eexists. do 2 rewrite <- app_assoc. rewrite app_assoc. reflexivity.
  Qed.

  Inductive divides A : list A -> list A -> Prop :=
  | div_0 : forall l, divides l []
  | div_cons : forall l' l, divides l' l -> divides l' (l' ++ l).
  Hint Constructors divides.

  Notation "( x | y )" := (divides x y) (at level 0).

  Lemma divides_id : forall A (l: list A), (l | l).
  Proof.
    intros.
    replace l with (l ++ []) at 2 by (apply app_nil_r).
    auto.
  Qed.
  Hint Resolve divides_id.

  Inductive repetition A : list A -> list A -> Prop :=
  | rep_2 : forall l, repetition l (l ++ l)
  | rep_cons : forall l' l, repetition l' l -> repetition l' (l' ++ l).
  Hint Constructors repetition.

  Inductive repeating A : list A -> Prop :=
  | rep : forall l' l, repetition l' l -> repeating l.
  Hint Constructors repeating.

  Lemma repeating_repeat_list: forall A n (l: list A), n > 1 -> repeating (repeat_list n l).
  Proof.
    econstructor. instantiate (1 := l).
    revert H.
    induction n; crush.
    unfold repeat_list. simpl.
    inversion H. simpl. autorewrite with core.
    econstructor. constructor.
    crush.
  Qed.
  Hint Resolve repeating_repeat_list.

  Lemma repeating_defn : forall A (l: list A),
    repeating l <-> exists l' n, 1 < n /\ l = repeat_list n l'.
  Proof.
    intuition.
    - destruct H.
      exists l'.
      induction H.
      + repeat eexists. instantiate (1 := 2). omega.
        unfold repeat_list.
        simpl. autorewrite with core. reflexivity.
      + repeat deex.
        exists (1 + n). crush.
    - repeat deex. auto.
  Qed.

  Lemma divides_defn : forall A (l l': list A),
    divides l' l <-> exists n, l = repeat_list n l'.
  Proof.
    intuition.
    + induction H.
      - exists 0; cbn; intuition.
      - deex.
        exists (S n).
        intuition.
    + deex. induction n.
      - constructor.
      - cbn. constructor. apply IHn.
  Qed.

  Instance divides_trans {A}: Transitive (@divides A).
  Proof.
    unfold Transitive.
    intros.
    apply divides_defn. apply divides_defn in H. apply divides_defn in H0.
    repeat deex. exists (n * n0).
    apply repeat_repeat.
  Qed.

  Fixpoint chop_last A (l: list A) :=
    match l with
    | [] => []
    | [x] => []
    | x :: xs => x :: chop_last xs
    end.

  Lemma chop_last_last: forall A l (c: A),
    chop_last (l ++ [c]) = l.
  Proof.
    induction l.
    auto.
    intros; simpl. rewrite IHl.
    remember (l ++ [c]) as lc.
    destruct lc. induction l; discriminate. trivial.
  Qed.
  Hint Resolve chop_last_last.

  Lemma chop_last_parts: forall A (l l': list A),
    0 < length l -> chop_last l = l' <-> exists c, l = l' ++ [c].
  Proof.
    intuition.
    + subst.
      induction l. crush.
      destruct l. eexists. crush.
      destruct IHl. simpl. omega.
      eexists. rewrite H0 at 1. reflexivity.
    + deex. crush.
  Qed.

  Lemma tl_parts: forall A (l l': list A),
    0 < length l -> tl l = l' <-> exists c, l = c :: l'.
  Proof.
    intuition.
    + subst.
      induction l. crush.
      destruct l. eexists. crush.
      destruct IHl. simpl. omega.
      eexists. rewrite H0 at 1. crush.
    + deex. crush.
  Qed.

  Lemma tail_app: forall A (l l': list A),
    length l > 0 -> tail (l ++ l') = tail l ++ l'.
  Proof.
    intros.
    destruct l; intuition.
    cbn in *. omega.
  Qed.

  Lemma chop_last_app: forall A (l l': list A),
    0 < length l' -> chop_last (l ++ l') = l ++ chop_last l'.
  Proof.
    induction l; intuition.
    destruct l'. cbn in *. omega.
    induction l; crush.
  Qed.

  Lemma length_tl: forall A (l: list A), length (tl l) = length l - 1.
  Proof.
    induction l; crush.
  Qed.
  Hint Rewrite length_tl.

  Lemma length_chop_last: forall A (l: list A), length (chop_last l) = length l - 1.
    induction l; crush.
    destruct l; crush.
  Qed.
  Hint Rewrite length_chop_last.

  Lemma length_repeat : forall A n (l: list A),
    length (repeat_list n l) = n * length l.
  Proof.
    induction n; intuition.
    unfold repeat_list in *. simpl. rewrite app_length.
    rewrite IHn. omega.
  Qed.
  Hint Rewrite length_repeat.

  Lemma length_repeating : forall A (l: list A),
    repeating l -> length l = 0 \/ 2 <= length l.
  Proof.
    intros.
    apply repeating_defn in H.
    destruct l; intuition.
    right. repeat deex. rewrite H1.
    rewrite length_repeat.
    destruct l'.
    assert (length (@repeat_list A n []) = 0).
    rewrite length_repeat. auto.
    destruct (repeat_list n []); discriminate.
    simpl. rewrite Nat.mul_succ_r. rewrite plus_comm. remember (n + n * length l') as tl.
    destruct tl. destruct n; intuition.
    discriminate.
    etransitivity. instantiate (1 := n). omega. rewrite Heqtl. apply le_plus_l.
  Qed.

  Lemma repeat_list_prefix: forall A (l: list A) n m,
    n <= m -> prefix (repeat_list n l) (repeat_list m l).
  Proof.
    intros.
    replace m with (n + (m - n)) by omega.
    remember (m - n) as m'.
    clear m H Heqm'.
    induction n. constructor.
    unfold repeat_list in *; simpl.
    apply prefix_defn. apply prefix_defn in IHn.
    repeat deex. eexists. crush.
  Qed.
  Hint Resolve repeat_list_prefix.

  Lemma equal_length_prefix: forall A (l' l: list A),
    length l = length l' -> prefix l' l -> l' = l.
  Proof.
    induction l'; destruct l; crush.
    inversion H0. subst.
    erewrite IHl'; eauto.
  Qed.

  Lemma firstn_app_r': forall A n (l l': list A),
    length l <= n -> firstn n (l ++ l') = l ++ firstn (n - length l) l'.
  Proof.
    intros.
    replace n with (length l + (n - length l)) by omega.
    rewrite firstn_app_r.
    f_equal. f_equal. omega.
  Qed.

  Lemma firstn_firstn : forall A (l:list A) n1 n2, firstn n1 (firstn n2 l) = firstn (Nat.min n1 n2) l.
  Proof.
    induction l.
    + intros.
      destruct n1; destruct n2; reflexivity.
    + intros.
      destruct n1.
      * simpl. reflexivity.
      * destruct n2.
        simpl.
        reflexivity.
        simpl.
        rewrite IHl.
        reflexivity.
  Qed.

  Lemma divides_repeat_list : forall A n (l: list A),
    divides l (repeat_list n l).
  Proof.
    induction n.
    - constructor.
    - cbn. constructor. apply IHn.
  Qed.

  Lemma divides_app : forall A (l' l1 l2: list A),
    divides l' l1 -> divides l' l2 -> divides l' (l1 ++ l2).
  Proof.
    intros.
    induction H; intuition.
    rewrite <- app_assoc. constructor. auto.
  Qed.

  Lemma divides_subtract : forall A (l' l1 l2: list A),
    divides l' l1 -> divides l' (l1 ++ l2) -> divides l' l2.
  Proof.
    intros.
    induction H; intuition.
    apply IHdivides.
    inversion H0.
    destruct l', l, l2; try discriminate. auto.
    subst.
    rewrite <- app_assoc in *.
    find_apply_lem_hyp app_inv_head.
    subst.
    auto.
  Qed.

  Lemma divides_repeating: forall A (l: list A),
    (exists l', divides l' l /\ length l' < length l) -> repeating l.
  Proof.
    intuition.
    deex.
    apply repeating_defn.
    find_apply_lem_hyp divides_defn.
    deex.
    exists l'. exists n.
    split; auto.
    destruct n.
    cbn in H1. omega.
    destruct n.
    cbn in H1. rewrite app_nil_r in H1. omega.
    omega.
  Qed.

  Theorem strong_induction: forall P : nat -> Prop,
    (forall n, (forall k, (k < n -> P k)) -> P n) ->
    forall n, P n.
  Proof.
    intros.
    apply H.
    induction n; intros.
    + solve_by_inversion.
    + destruct (lt_dec k n); auto.
      replace k with n by omega.
      auto.
  Qed.

  Ltac lengths :=
    repeat rewrite skipn_length by lengths;
    repeat rewrite firstn_length by lengths;
    repeat rewrite app_length;
    repeat rewrite Nat.min_id;
    repeat rewrite Nat.min_l by lengths;
    repeat rewrite Nat.min_r by lengths;
    omega.

  Lemma rot_eq_repeating: forall A (a b: list A),
    0 < length a -> 0 < length b -> a ++ b = b ++ a -> repeating (a ++ b).
  Proof.
    intros. apply divides_repeating.
    remember (length a + length b) as n.
    remember (length b) as m.
    assert (exists l', (l' | (a ++ b)) /\ (l' | b) /\ length l' < length (a ++ b)).
    revert a b Heqn H H0 H1 Heqm.
    generalize dependent m.
    induction n using strong_induction.
    induction m using strong_induction.
    intuition.
    destruct (Nat.eq_dec (length a) (length b)).
    2: destruct (lt_dec (length b) (length a)).
    + apply (f_equal (firstn (length a))) in H3.
      do 2 rewrite firstn_app_L in * by lengths.
      rewrite firstn_all in * by lengths.
      rewrite e in *.
      rewrite firstn_all in * by lengths.
      exists a. subst. intuition.
      lengths.
    + rename H3 into Heq.
      generalize Heq; intro Heq2.
      apply (f_equal (skipn (length b))) in Heq.
      do 2 rewrite skipn_app_L in Heq by lengths.
      rewrite skipn_all with (l := b) in Heq by lengths.
      cbn in Heq.
      apply (f_equal (firstn (length b))) in Heq2.
      do 2 rewrite firstn_app_L in Heq2 by lengths.
      rewrite firstn_all with (l := b) in Heq2 by lengths.

      edestruct H with (m := length b) (b := b) (a := skipn (length b) a); trivial; try rewrite skipn_length; try lengths.
      rewrite Heq. rewrite <- Heq2 at 1. rewrite firstn_skipn. reflexivity.

      exists x.
      intuition.
      apply divides_app; auto.
      congruence.
      rewrite app_length in H6.
      rewrite skipn_length in H6 by lengths.
      lengths.
    + rename H3 into Heq.
      edestruct H0 with (b := a) (a := b); trivial; try lengths.
      congruence.

      exists x.
      intuition.
      rewrite Heq; auto.
      eapply divides_subtract; eauto.
      rewrite Heq; auto.
      rewrite Heq; auto.
    + deex. exists l'. intuition.
  Qed.
  Hint Resolve rot_eq_repeating.

  Theorem repeating_in_self : forall A (l: list A),
    repeating l <-> sublist l (chop_last (tail (l ++ l))).
  Proof.
    intuition.
    + destruct (length_repeating H). destruct l; crush.
      apply repeating_defn in H. repeat deex.
      rewrite repeat_list_app.
      remember (repeat_list n l') as rl.
      rewrite repeat_list_tail by omega.
      destruct l'. subst. rewrite length_repeat in *. rewrite Nat.mul_0_r in H0. omega.
      rewrite tail_app by (simpl; omega).
      rewrite chop_last_app.
      rewrite repeat_list_chop_last by omega.
      rewrite chop_last_app by (simpl; omega).
      etransitivity; [ | apply sublist_defn; repeat eexists ].
      constructor. crush.
      autorewrite with core. simpl.
      remember (n + n - 1) as fa.
      destruct fa; crush.
    + destruct l. econstructor. replace (@nil A) with (@repeat_list A 2 []) by auto. constructor.
      apply sublist_defn in H.
      repeat deex.
      apply chop_last_parts in H. deex.
      2: destruct l; simpl; omega.
      apply tl_parts in H. deex.
      2: destruct l; simpl; omega.
      repeat rewrite app_comm_cons in H.
      remember (c0 :: l2) as l'.
      rename l into ltail.
      remember (a :: ltail) as l.
      assert (0 < length l' < length l). {
        generalize (f_equal (@length A) H).
        autorewrite with core. repeat rewrite app_length. simpl. intros.
        assert (length l > 0) by (destruct l; cbn in *; omega).
        split; subst; simpl in *; omega.
      }
      generalize (f_equal (@skipn A (length l')) H).
      repeat rewrite <- app_assoc.
      rewrite skipn_app. rewrite skipn_app_L by omega.
      intro Hs.
      generalize (f_equal (@firstn A (length l)) Hs).
      rewrite firstn_app with (a := l) by auto.
      rewrite firstn_app_r' by (repeat rewrite skipn_length by omega; omega).
      repeat rewrite skipn_length by omega. replace (length l - (length l - length l')) with (length l') by omega.
      replace (length l - length l) with 0 by omega. rewrite firstn_all with (n := length l) by auto. rewrite app_nil_r.
      intros. rewrite <- H1. eapply rot_eq_repeating; eauto.
      lengths.
      lengths.
      rewrite firstn_skipn. auto.
  Qed.

End lists.


Require Import List Lia.
Require Import tree.

Implicit Type X Y : Type.

Definition Fresh X := nat -> X * nat.

Section Monad.
  Variable X Y : Type.
  Implicit Type x : X.
  Implicit Type m : Fresh X.
  Implicit Type f: X -> Fresh Y.

Definition ret (x: X): Fresh X :=
  fun n => (x, n).
Definition bind (m: Fresh X)(f: X -> Fresh Y): Fresh Y :=
  fun n => let (x, n') := m n in f x n'.
Definition gensym (tt: unit): Fresh nat :=
  fun n => (n, 1+n).

End Monad.

Arguments ret [_] x.
Arguments bind [_][_] m f.

Notation "'do' x '<-' e1 ';' e2" :=
  (bind e1 (fun x => e2)) (x name, at level 50).

Fixpoint label {X} (t: Tree X): Fresh (Tree nat) :=
  match t with
  | Leaf _ =>
    do n <- gensym tt;
    ret (Leaf n)
  | Node l r =>
    do l <- label l;
    do r <- label r;
    ret (Node l r)
  end.

Definition interval a b := seq a (1 + b - a).

Fixpoint flatten {X} (t : Tree X) : list X :=
  match t with
  | Leaf e => e :: nil
  | Node l r => flatten l ++ flatten r
  end.

Section Bind_Inversion.
Variable X Y : Type.
Implicit Type m: Fresh X.
Implicit Type f: X -> Fresh Y.
Implicit Type y: Y.
Implicit Type n: nat.

Remark bind_inversion: forall m f y n1 n3,
    (do x <- m; f x) n1 = (y, n3) ->
    exists v n2, m n1 = (v, n2) /\ f v n2 = (y, n3).
Proof.
  intros until n3. unfold bind. destruct (m n1). eauto.
Qed.

End Bind_Inversion.

Ltac monadInv H :=
  match type of H with
  | ((_,_) = (_,_)) => inversion H; clear H; try subst
  | (ret _ _ = (_,_)) =>
    inversion H; clear H; try subst
  | (gensym _ _ = (_,_)) =>
    unfold gensym in H; inversion H; clear H; try subst
  | (bind ?F ?G ?Z = (?X,?Z')) =>
    let x := fresh "x" in
    let z := fresh "z" in
    let I1 := fresh "I" in
    let I2 := fresh "I" in
    destruct (bind_inversion _ _ F G X Z Z' H) as [x [z [I1 I2]]];
    clear H;
    try (monadInv I1);
    try (monadInv I2)
  | (?F _ _ = (_,_)) =>
    ((progress simpl in H) || unfold F in H); monadInv H
  end.

Implicit Type ft: Tree nat.

Section LabelSpec.
Variable X: Type.
Implicit Type t: Tree X.

Lemma label_spec : forall t n ft n',
    label t n = (ft, n') -> n < n' /\ flatten ft = interval n (n'-1).
Proof.
  induction t; intros.
  - apply bind_inversion in H as [t1' [n2 [Fresh Ret]]]. inversion Fresh. inversion Ret. subst.
    split. lia. simpl. unfold interval. rewrite PeanoNat.Nat.sub_0_r.
    rewrite PeanoNat.Nat.sub_succ_l; auto. rewrite <- Minus.minus_diag_reverse. auto.
  - simpl in H. apply bind_inversion in H as [t1' [n2 [Label1 EQ]]].
    apply bind_inversion in EQ as [t2' [n3 [Label2 EQ]]]. inversion EQ. subst.
    apply IHt1 in Label1 as [P0 P1]. apply IHt2 in Label2 as [P2 P3]. split. lia. simpl.
    rewrite P1,P3. unfold interval.
    assert (n + (1 + (n2 - 1) - n) = n2) by lia.
    epose (seq_app (1 + (n2 - 1) - n) (1 + (n' - 1) - n2) n).
    rewrite H in e. rewrite <- e. f_equal. lia.
Qed.

End LabelSpec.

Lemma NoDupTree : forall n ft n', flatten ft = interval n n' -> NoDup (flatten ft).
Proof.
  intros n t n' P1.
  rewrite P1. unfold interval. apply seq_NoDup.
Qed.

Section Relabel.

Variable X: Type.
Implicit Type t: Tree X.

Definition relabel (t: Tree X): Tree nat := fst (label t 0).

Lemma relabel_spec : forall t ft, relabel t = ft -> NoDup (flatten ft).
Proof.
intros.
eapply NoDupTree.
eapply label_spec.
unfold relabel in H.
rewrite <-H.
eapply surjective_pairing.
Qed.

End Relabel.


Require Import XRdefinitions.

Fixpoint pow (r:R) (n:nat) : R :=
  match n with
    | O => R1
    | S n => Rmult r (pow r n)
  end.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Representable.Hom_Func.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatIso.

(** A functor F : C → Type_Cat is representable if F is naturaly isomorphic to
Hom_C(x, -) for some x : C. In this case, we say F is represented by x. *)
Section Representable.
  Context {C : Category} (F : (C --> Type_Cat)%functor).

  Record Representable : Type :=
    {
      representer : C;
      representation_Iso :
        (F ≃ @Fix_Bi_Func_1 (C^op) _ _ representer (Hom_Func C))%natiso
    }.

End Representable.

Arguments representer {_ _} _.
Arguments representation_Iso {_ _} _.

Definition CoRepresentable {C : Category} (F : (C^op --> Type_Cat)%functor) :=
  @Representable (C^op) F.


From Coq Require Import Classical_Prop.
From Coq Require Import Classical_sets.
From ZornsLemma Require Export EnsemblesSpec EnsemblesTactics.
From ZornsLemma Require Import Image ImageImplicit.
From ZornsLemma Require Import EnsemblesImplicit.
From Coq Require Export Ensembles.
Set Implicit Arguments.

Section Families.

Variable T:Type.
Definition Family := Ensemble (Ensemble T).
Variable F:Family.

Inductive FamilyUnion: Ensemble T :=
  | family_union_intro: forall (S:Ensemble T) (x:T),
    In F S -> In S x -> In FamilyUnion x.

Inductive FamilyIntersection: Ensemble T :=
  | family_intersection_intro: forall x:T,
    (forall S:Ensemble T, In F S -> In S x) ->
    In FamilyIntersection x.

End Families.

Section FamilyFacts.

Variable T:Type.

Lemma empty_family_union: FamilyUnion (@Empty_set (Ensemble T)) =
                          Empty_set.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
- destruct H.
  contradiction H.
- contradiction H.
Qed.

Lemma empty_family_intersection:
  FamilyIntersection (@Empty_set (Ensemble T)) = Full_set.
Proof.
apply Extensionality_Ensembles.
unfold Same_set.
unfold Included.
intuition.
constructor.
intros.
contradiction H0.
Qed.

(* unions and intersections of subfamilies *)

Lemma subfamily_union: forall F G:Family T, Included F G ->
  Included (FamilyUnion F) (FamilyUnion G).
Proof.
unfold Included.
intros.
destruct H0.
apply family_union_intro with S.
- apply H.
  assumption.
- assumption.
Qed.

Lemma subfamily_intersection: forall F G:Family T, Included F G ->
  Included (FamilyIntersection G) (FamilyIntersection F).
Proof.
unfold Included.
intros.
constructor.
destruct H0.
intros.
apply H0.
apply H.
assumption.
Qed.

Lemma Complement_FamilyIntersection: forall F:Family T,
    Complement (FamilyIntersection F) =
    FamilyUnion [ S:Ensemble T |
                  In F (Complement S)].
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- apply NNPP.
  red; intro.
  red in H; red in H.
  contradict H.
  constructor. intros.
  apply NNPP.
  red; intro.
  contradict H0.
  exists (Complement S).
  + constructor. rewrite Complement_Complement. assumption.
  + assumption.
- destruct H.
  red; red; intro.
  destruct H1.
  destruct H.
  pose proof (H1 _ H).
  contradiction.
Qed.

Lemma Complement_FamilyUnion: forall F:Family T,
    Complement (FamilyUnion F) =
    FamilyIntersection [ S:Ensemble T |
                         In F (Complement S) ].
Proof.
intros.
apply Extensionality_Ensembles; split; red; intros.
- constructor. intros.
  destruct H0.
  apply NNPP. red; intro.
  red in H; red in H. contradict H.
  exists (Complement S); assumption.
- red; red. intro.
  destruct H.
  destruct H0.
  specialize (H (Complement S)).
  apply H.
  2: { assumption. }
  constructor. rewrite Complement_Complement.
  assumption.
Qed.

Lemma union_as_family_union (U V : Ensemble T) :
  Union U V = FamilyUnion (Couple U V).
Proof.
  extensionality_ensembles_inv; subst.
  - exists U; firstorder.
  - exists V; firstorder.
  - left. assumption.
  - right. assumption.
Qed.

Lemma family_union_singleton
  (S : Ensemble T) :
  FamilyUnion (Singleton S) = S.
Proof.
now extensionality_ensembles;
  try econstructor.
Qed.
End FamilyFacts.

Lemma image_family_union (X Y : Type) (F : Family X) (f : X -> Y) :
  Im (FamilyUnion F) f = FamilyUnion (Im F (fun U => Im U f)).
Proof.
apply Extensionality_Ensembles; split; red; intros.
- inversion_clear H. subst.
  inversion_clear H0.
  exists (Im S f).
  { exists S; auto. }
  apply Im_def.
  assumption.
- inversion_clear H.
  inversion_clear H0.
  subst.
  inversion_clear H1.
  subst.
  apply Im_def.
  exists x0; auto.
Qed.

Lemma family_intersection_add {X : Type} (F : Family X) (U : Ensemble X) :
  FamilyIntersection (Add F U) = Intersection (FamilyIntersection F) U.
Proof.
apply Extensionality_Ensembles; split; red; intros; constructor.
- constructor. destruct H.
  intros. apply H. left. assumption.
- destruct H. apply H. right. reflexivity.
- intros. destruct H. destruct H.
  destruct H0.
  + apply H. assumption.
  + inversion H0; subst; clear H0.
    assumption.
Qed.

Lemma family_union_union {X : Type} (F G : Family X) :
  FamilyUnion (Union F G) =
    Union (FamilyUnion F) (FamilyUnion G).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - inversion H; subst; clear H.
    destruct H0; [left|right]; exists x0; auto.
  - destruct H, H; exists S; auto; [left|right]; auto.
Qed.

Lemma family_union_empty_sets (X : Type) (F : Family X) :
  (forall U, In F U -> U = Empty_set) <->
  FamilyUnion F = Empty_set.
Proof.
split.
- intros. extensionality_ensembles.
  rewrite <- (H S); auto.
- intros. extensionality_ensembles.
  rewrite <- H. exists U; assumption.
Qed.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum rat poly.
From mathcomp Require Import closed_field polyrcf matrix mxalgebra mxpoly zmodp.
From mathcomp Require Import realalg complex fingroup perm.
From mathcomp.analysis Require Import forms.
From mathcomp Require Import interval reals.

Require Import ssr_ext euclidean vec_angle frame rot quaternion.

(******************************************************************************)
(*                            Octonions                                       *)
(*                                                                            *)
(* This file develops the theory of quaternions. It defines the type of       *)
(* octonions and that octionions form a ZmodType and a LmodType. It also      *)
(* defines the multiple that is neither commutative nor associative           *)
(*                                                                            *)
(*       oct R == type of octonions over the ringType R                       *)
(*         x.1 == left part of the octonion x                                 *)
(*         x.2 == right part of the octonion x                                *)
(*        x^*o == conjugate of octonion x                                     *)
(*      x *o y == product of two octonions                                    *)
(* x \is realo == x is a real ie only the real part of the left quaternion    *)
(*                is not zero                                                 *)
(*      normo x == the norm of the octonion                                   *)
(*                                                                            *)
(******************************************************************************)

Reserved Notation "x %:ol" (at level 2, format "x %:ol").
Reserved Notation "x %:or" (at level 2, format "x %:or").
Reserved Notation "x '^*o'" (at level 2, format "x '^*o'").
Reserved Notation "a *o b" (at level 40, left associativity, format "a  *o  b").

Declare Scope oct_scope.

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

Local Open Scope ring_scope.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Section octonion0.
Variable R : ringType.

Record oct := mkOct {octl : quat R ; octr : quat R }.

Local Notation "x %:ol" := (mkOct x%quat 0).
Local Notation "x %:or" := (mkOct 0 x%quat).

Coercion pair_of_oct (a : oct) := let: mkOct a0 a1 := a in (a0, a1).
Let oct_of_pair (x : quat R * quat R) :=
  let: (x0, x1) := x in mkOct x0 x1.

Lemma oct_of_pairK : cancel pair_of_oct oct_of_pair.
Proof. by case. Qed.

Definition oct_eqMixin := CanEqMixin oct_of_pairK.
Canonical Structure oct_eqType := EqType oct oct_eqMixin.
Definition oct_choiceMixin := CanChoiceMixin oct_of_pairK.
Canonical Structure oct_choiceType := ChoiceType oct oct_choiceMixin.

Lemma eq_oct (a b : oct) : (a == b) = (a.1 == b.1) && (a.2 == b.2).
Proof.
case: a b => [a0 a1] [b0 b1] /=.
apply/idP/idP => [/eqP [ -> ->]|/andP[/eqP -> /eqP -> //]]; by rewrite !eqxx.
Qed.

Definition addo (a b : oct) := nosimpl (mkOct (a.1 + b.1) (a.2 + b.2)).

Lemma addoC : commutative addo.
Proof. move=> *; congr mkOct; by rewrite addrC. Qed.

Lemma addoA : associative addo.
Proof. move=> *; congr mkOct; by rewrite addrA. Qed.

Lemma add0o : left_id 0%:ol addo.
Proof. case=> *; by rewrite /addo /= 2!add0r. Qed.

Definition oppo (a : oct) := nosimpl (mkOct (- a.1) (- a.2)).

Lemma addNo : left_inverse 0%:ol oppo addo.
Proof. move=> *; congr mkOct; by rewrite addNr. Qed.

Definition oct_ZmodMixin := ZmodMixin addoA addoC add0o addNo.
Canonical oct_ZmodType := ZmodType oct oct_ZmodMixin.

Lemma addoE (a b : oct) : a + b = addo a b. Proof. done. Qed.

Lemma oppoE (a : oct) : - a = oppo a. Proof. done. Qed.

Lemma octE (a : oct) : a = (a.1)%:ol + (a.2)%:or.
Proof. by apply/eqP; rewrite eq_oct /= !(add0r,addr0) !eqxx. Qed.

Lemma oct_leftE (a b : quat R) : (a%:ol == b%:ol) = (a == b).
Proof. by apply/idP/idP => [/eqP[] ->|/eqP -> //]. Qed.

Lemma oct_leftN (x: quat R) : (-x)%:ol = -(x%:ol).
Proof. by rewrite oppoE /oppo /= oppr0. Qed.

Lemma oct_rightN (x: quat R) : (-x)%:or = -(x%:or).
Proof. by rewrite oppoE /oppo /= oppr0. Qed.

Lemma oct_leftD (x y : quat R) : (x + y)%:ol = x%:ol + y%:ol.
Proof. by rewrite addoE /addo /= add0r. Qed.

Lemma oct_rightD (x y : quat R) : (x + y)%:or = x%:or + y%:or.
Proof. by rewrite addoE /addo /= addr0. Qed.

Lemma oct_leftB (x y : quat R) : (x - y)%:ol = x%:ol - y%:ol.
Proof. by rewrite oct_leftD oct_leftN. Qed.

Lemma oct_rightB (x y : quat R) : (x - y)%:or = x%:or - y%:or.
Proof. by rewrite oct_rightD oct_rightN. Qed.

End octonion0.

Delimit Scope oct_scope with oct.
Local Open Scope oct_scope.

Notation "x %:or" := (mkOct 0 x) : oct_scope.
Notation "x %:ol" := (mkOct x 0) : oct_scope.

Section octonion.

Variable R : comRingType.

Definition mulo (a b : oct R) := nosimpl
  (mkOct (a.1 * b.1 - ((b.2)^*q)%quat * a.2)
         (b.2 * a.1 + a.2 * ((b.1)^*q)%quat)).

Lemma mulo1 : right_id 1%:ol mulo.
Proof.
by case=> a a'; rewrite /mulo /= !quat_realC !mul0r !mulr1 subr0 add0r.
Qed.

Lemma mul1o : left_id 1%:ol mulo.
Proof.
by case=> a a'; rewrite /mulo /=; congr mkOct; Simp.r => /=.
Qed.

Lemma mulor1 : right_id 1%:ol mulo.
Proof.
case=> a a'; rewrite /mulo /=; congr mkOct.
  by rewrite linear0 mul0r subr0 mulr1.
by rewrite quat_realC mulr1 mul0r add0r.
Qed.

Lemma mulo1r : left_id 1%:ol mulo.
Proof.
case=> a a'; rewrite /mulo /=; congr mkOct.
  by rewrite mulr0 subr0 mul1r.
by rewrite mulr1 mul0r addr0.
Qed.

Lemma mulo0r : left_zero 0%:ol mulo.
Proof.
case=> a a'; rewrite /mulo /=; congr mkOct.
  by rewrite mul0r mulr0 subrr.
by rewrite mul0r mulr0 addr0.
Qed.

Lemma mulor0 : right_zero 0%:ol mulo.
Proof.
case=> a a'; rewrite /mulo /=; congr mkOct.
  by rewrite linear0 mul0r mulr0 subrr.
by rewrite linear0 mul0r mulr0 addr0.
Qed.

Lemma muloDl : left_distributive mulo +%R.
Proof.
move=> [a a'] [b b'] [c c']; rewrite /mulo /=; congr mkOct => /=.
  rewrite !(mulrDl, mulrDr) -!addrA; congr (_ + _).
  by rewrite addrCA opprD.
rewrite !(mulrDl, mulrDr) -!addrA; apply: f_equal2; first by [].
by rewrite addrCA.
Qed.

Lemma muloDr : right_distributive mulo (+%R).
Proof.
move=> [a a'] [b b'] [c c']; rewrite /mulo /=; congr mkOct => /=.
  rewrite !(mulrDl, mulrDr, linearD) /= -!addrA; congr (_ + _).
  by rewrite addrCA.
rewrite !(mulrDl, mulrDr, linearD) /= -!addrA; apply: f_equal2; first by [].
by rewrite addrCA.
Qed.

Lemma oneq_neq0 : 1%:ol != 0 :> oct R.
Proof. apply/eqP => -[]; apply/eqP. exact: oner_neq0. Qed.

Local Notation "a *o b" := (mulo a b).

Lemma muloNl (x y : oct R) : (- x) *o y = - (x *o y).
Proof.
case: x => [x1 x2]; case: y => [y1 y2]; congr mkOct => /=.
  by rewrite opprD !mulrN !mulNr.
by rewrite opprD !mulrN !mulNr.
Qed.

Lemma muloNr (x y : oct R) : x *o (- y) = - (x *o y).
Proof.
case: x => [x1 x2]; case: y => [y1 y2]; congr mkOct => /=.
  by rewrite linearN /= opprD !mulrN !mulNr.
by rewrite linearN /= opprD !mulrN !mulNr.
Qed.

Lemma muloBl x y z : (x - y) *o z = x *o z - y *o z.
Proof. by rewrite muloDl muloNl. Qed.

Lemma muloBr x y z : z *o (x - y) = z *o x - z *o y.
Proof. by rewrite muloDr muloNr. Qed.

(* Alternative algebra *)

Lemma muloAlt1 a b : (a *o a) *o  b = a *o (a *o b).
Proof.
case: a => [a0 a1]; case: b => [b0 b1]; apply: (f_equal2 (@mkOct _)) => /=.
  rewrite !{1}(mulrBr, mulrDr, mulrBl, mulrDl, mulrA, linearD) /=
              !{1}conjqM ?{1}conjqI {1}[RHS]addrA {1}[LHS]addrA.
  rewrite -!{1}addrA; apply: f_equal2; first by []. (* congr take time *)
  rewrite addrC !addrA; apply: f_equal2; last first.
    by rewrite realq_comm ?mulrA // conjq_comm realq_conjM.
  by rewrite -opprD -mulrDr -realq_comm ?realq_conjD // mulrDl opprD !mulrA.
rewrite !{1}(mulrBr, mulrDr, mulrBl, mulrDl, mulrA, linearD) /=
              !{1}conjqM ?{1}conjqI !{1}addrA.
rewrite -!addrA linearN /= !conjqM !conjqI !mulrN !mulrA; congr (_ + _).
rewrite -mulrA conjq_comm -[b1 * _]realq_comm ?realq_conjM //.
rewrite addrC !addrA; apply: f_equal2; last by [].
by rewrite -!mulrDl -!mulrDr -mulrA (realq_comm _ (realq_conjD _)) mulrA.
Qed.

Lemma muloAlt2 a b : (a *o b) *o a = a *o (b *o a).
Proof.
case: a => [a0 a1]; case: b => [b0 b1]; apply: (f_equal2 (@mkOct _)) => /=.
  rewrite !{1}(mulrBr, mulrDr, mulrBl, mulrDl, mulrA, linearD) /=
              !conjqM ?conjqI [LHS]addrA [RHS]addrA.
  rewrite [RHS]addrC !{1}addrA; apply: f_equal2; last first.
    by rewrite conjq_comm (realq_comm _ (realq_conjM _)) -conjq_comm mulrA.
  rewrite [X in _ = X - _]addrC -!{1}addrA; apply: f_equal2; first by [].
  rewrite -!opprD -mulrDl realq_comm ?mulrDr ?mulrA //.
  by rewrite -{2}[b1]conjqI -conjqM realq_conjD.
rewrite !{1}(mulrBr, mulrDr, mulrBl, mulrDl, mulrA, linearD) /=
        !conjqM ?conjqI !{1}addrA.
rewrite -!addrA linearN /= !conjqM !conjqI !mulrN !mulrA {1}addrA.
rewrite [X in X + _ = _]addrC !{1}addrA [RHS]addrC -!{1}addrA.
apply: f_equal2; first by [].
rewrite [LHS]addrC [RHS]addrC -!{1}addrA; congr (_ + _).
  by rewrite -mulrA -conjq_comm mulrA.
rewrite -2!{1}mulrA -mulrDr -conjqM -2!{1}mulrA -mulrDr.
by rewrite addrC conjq_addMC addrC conjqM.
Qed.

Local Notation "`il" := (`i%quat)%:ol.
Local Notation "`ir" := (`i%quat)%:or.
Local Notation "`jl" := (`j%quat)%:ol.
Local Notation "`jr" := (`j%quat)%:or.
Local Notation "`kl" := (`k%quat)%:ol.
Local Notation "`kr" := (`k%quat)%:or.

Lemma oct_leftM (x y : quat R) : (x * y)%:ol = x%:ol *o y%:ol.
Proof. by congr mkOct; rewrite ?(linear0, mul0r, addr0). Qed.

Lemma ililN1 : `il *o `il = - 1%:ol.
Proof. by rewrite -oct_leftM iiN1 oct_leftN. Qed.

Lemma irirN1 : `ir *o `ir = - 1%:ol.
Proof.
congr mkOct; rewrite /= !(conjqI, linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr iiN1 opprK.
Qed.

Lemma ilirN1 : `il *o `ir = - 1%:or.
Proof.
by congr mkOct; rewrite /= !(iiN1, linear0, mul0r, mulr0, add0r, addr0).
Qed.

Lemma iril1 : `ir *o `il = 1%:or.
Proof.
congr mkOct; rewrite /= !(iiN1, linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN iiN1 opprK.
Qed.

Lemma iljlkl : `il *o `jl = `kl.
Proof. by rewrite -oct_leftM ijk. Qed.

Lemma irjrkl : `ir *o `jr = - `kl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr jiNk opprK.
Qed.

Lemma iljrkl : `il *o `jr = - `kr.
Proof.
by congr mkOct; rewrite /= !(linear0, jiNk, mul0r, mulr0, add0r, addr0).
Qed.

Lemma irjlkl : `ir *o `jl = - `kr.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN ijk.
Qed.

Lemma ilklNjl : `il *o `kl = - `jl.
Proof. by rewrite -oct_leftM ikNj oct_leftN. Qed.

Lemma irkrNjl : `ir *o `kr = `jl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr kij opprK.
Qed.

Lemma ilkrNjl : `il *o `kr = `jr.
Proof.
by congr mkOct; rewrite /= !(linear0, kij, mul0r, mulr0, add0r, addr0).
Qed.

Lemma irklNjl : `ir *o `kl = `jr.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN ikNj opprK.
Qed.

Lemma ilorir : `il *o (1%:or) = `ir.
Proof.
by congr mkOct; rewrite /= !(linear0, mul0r, mulr0, mul1r, add0r, addr0).
Qed.

Lemma orilNir : (1%:or) *o `il = - `ir.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mul1r.
Qed.

Lemma irorNil : `ir *o (1%:or) = -`il.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_realC mul1r.
Qed.

Lemma oriril : (1%:or) *o `ir = `il.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulr1 opprK.
Qed.

Lemma jlilNkl : `jl *o `il = - `kl.
Proof. by rewrite -oct_leftM jiNk oct_leftN. Qed.

Lemma jrirNkl : `jr *o `ir = `kl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr ijk opprK.
Qed.

Lemma jlirNkl : `jl *o `ir = `kr.
Proof.
by congr mkOct; rewrite /= !(linear0, ijk, mul0r, mulr0, add0r, addr0).
Qed.

Lemma jrilNkl : `jr *o `il = `kr.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN jiNk opprK.
Qed.

Lemma jljlN1 : `jl *o `jl = - 1%:ol.
Proof. by rewrite -oct_leftM jjN1 oct_leftN. Qed.

Lemma jrjrN1 : `jr *o `jr = - 1%:ol.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr jjN1 opprK.
Qed.

Lemma jljrN1 : `jl *o `jr = - 1%:or.
Proof.
by congr mkOct; rewrite /= !(linear0, jjN1, mul0r, mulr0, add0r, addr0).
Qed.

Lemma jrjlN1 : `jr *o `jl = 1%:or.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN jjN1 opprK.
Qed.

Lemma jlklNil : `jl *o `kl = `il.
Proof. by rewrite -oct_leftM jkNi. Qed.

Lemma jrkrNil : `jr *o `kr = - `il.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr kjNi opprK.
Qed.

Lemma jlkrNil : `jl *o `kr = - `ir.
Proof.
by congr mkOct; rewrite /= !(linear0, kjNi, mul0r, mulr0, add0r, addr0).
Qed.

Lemma jrklNil : `jr *o `kl = - `ir.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN jkNi.
Qed.

Lemma jlorjr : `jl *o (1%:or) = `jr.
Proof.
by congr mkOct; rewrite /= !(linear0, mul0r, mulr0, mul1r, add0r, addr0).
Qed.

Lemma orjlNjr : (1%:or) *o `jl = - `jr.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mul1r.
Qed.

Lemma jrorNjl : `jr *o (1%:or) = -`jl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_realC mul1r.
Qed.

Lemma orjrjl : (1%:or) *o `jr = `jl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulr1 opprK.
Qed.

Lemma klilNkl : `kl *o `il = `jl.
Proof. by rewrite -oct_leftM kij. Qed.

Lemma krirNjl : `kr *o `ir = - `jl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr ikNj opprK.
Qed.

Lemma klirNjl : `kl *o `ir = - `jr.
Proof.
by congr mkOct; rewrite /= !(linear0, ikNj, mul0r, mulr0, add0r, addr0).
Qed.

Lemma krilNjl : `kr *o `il = - `jr.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN kij.
Qed.

Lemma kljlNil : `kl *o `jl = - `il.
Proof. by rewrite -oct_leftM kjNi oct_leftN. Qed.

Lemma krjril : `kr *o `jr = `il.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr jkNi opprK.
Qed.

Lemma kljrir : `kl *o `jr = `ir.
Proof.
by congr mkOct; rewrite /= !(linear0, jkNi, mul0r, mulr0, add0r, addr0).
Qed.

Lemma krjlir : `kr *o `jl = `ir.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN kjNi opprK.
Qed.

Lemma klklNor : `kl *o `kl = - 1%:ol.
Proof. by rewrite -oct_leftM kkN1 oct_leftN. Qed.

Lemma krkrNor : `kr *o `kr = - 1%:ol.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulNr kkN1 opprK.
Qed.

Lemma klkrNor : (`k%quat)%:ol *o (`k%quat)%:or = -1%:or.
Proof.
by congr mkOct; rewrite /= !(linear0, kkN1, mul0r, mulr0, add0r, addr0).
Qed.

Lemma krklNor : (`k%quat)%:or *o (`k%quat)%:ol = 1%:or.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulrN kkN1 opprK.
Qed.

Lemma klorkr : `kl *o (1%:or) = `kr.
Proof.
by congr mkOct; rewrite /= !(linear0, mul0r, mulr0, mul1r, add0r, addr0).
Qed.

Lemma orklNir : (1%:or) *o `il = - `ir.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mul1r.
Qed.

Lemma krorNkl : `kr *o (1%:or) = -`kl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_realC mul1r.
Qed.

Lemma orkrkl : (1%:or) *o `kr = `kl.
Proof.
congr mkOct; rewrite /= !(linear0, mul0r, mulr0, add0r, addr0) //.
by rewrite quat_vectC mulr1 opprK.
Qed.

Definition scaleoct k (a : oct R) := mkOct (k *: a.1) (k *: a.2).

Lemma scaleoctA a b w : scaleoct a (scaleoct b w) = scaleoct (a * b) w.
Proof. by rewrite /scaleoct /=; congr mkOct; rewrite scalerA. Qed.

Lemma scaleoct1 : left_id 1 scaleoct.
Proof.
by move=> q; rewrite /scaleoct !scale1r; apply/eqP; rewrite eq_oct /= !eqxx.
Qed.

Lemma scaleoctDr : @right_distributive R (oct R) scaleoct +%R.
Proof. move=> a b c; by rewrite /scaleoct /= !scalerDr. Qed.

Lemma scaleoctDl w : {morph (scaleoct^~ w : R -> oct R) : a b / a + b}.
Proof. by move=> m n; rewrite /scaleoct !scalerDl; congr mkOct. Qed.

Definition oct_lmodMixin := LmodMixin scaleoctA scaleoct1 scaleoctDr scaleoctDl.
Canonical oct_lmodType := Eval hnf in LmodType R (oct R) oct_lmodMixin.

Lemma scaleoctE (k : R) (a : oct R) :
  k *: a = k *: (a .1) %:ol + k *: (a .2) %:or.
Proof. by apply/eqP; rewrite eq_oct //=; Simp.r. Qed.

Lemma oct_leftZ (k : R) (x : quat R) : (k *: x)%:ol = k *: x%:ol.
Proof. by congr mkOct; rewrite scaler0. Qed.

Lemma oct_rightZ (k : R) (x : quat R) : (k *: x)%:or = k *: x%:or.
Proof. by congr mkOct; rewrite scaler0. Qed.

Lemma octAl k (a b : oct R) : k *: (a *o b) = k *: a *o b.
Proof.
case: a b => [a0 a1] [b0 b1]; congr mkOct => /=.
  by rewrite scalerBr quatAl quatAr.
rewrite scalerDr !quatAr; congr (_ + _).
by rewrite -quatAr quatAl.
Qed.

Lemma octAr k (a b : oct R) : k *: (a *o b) = a *o (k *: b).
Proof.
case: a b => [a0 a1] [b0 b1]; congr mkOct => /=.
  by rewrite scalerBr !linearZ /= scalerN -!quatAr -!quatAl.
by rewrite scalerDr !linearZ /= -!quatAr -!quatAl.
Qed.

Local Open Scope quat_scope.

Definition conjo (a : oct R) :=
  nosimpl (mkOct (a.1 + (a.1)^*q -a.1) (- a.2)).

Local Notation "x '^*o'" := (conjo x).

Lemma conjo_linear : linear conjo.
Proof.
move=> /= k [a0 a1] [b0 b1] /=; rewrite [in LHS]/conjo /= [in RHS]/conjo /=.
congr mkOct => /=; last by rewrite scalerN opprD.
rewrite !(linearD, linearZ) /= !scalerN -!addrA; congr (_ + _).
rewrite addrC -!addrA; congr (_ + _).
by rewrite addrCA !addrA subrK [_ + b0 + _]addrC addrA addrK addrC.
Qed.

Canonical conjo_is_additive := Additive conjo_linear.
Canonical conjo_is_linear := AddLinear conjo_linear.

Lemma conjoI a : (a^*o)^*o = a.
Proof.
case: a => a0 a1; congr mkOct => /=; last by rewrite opprK.
by rewrite [a0 + _]addrC addrK conjqI [_ + a0]addrC addrK.
Qed.

Lemma conjo0 : (0%:ol)^*o = 0.
Proof. by congr mkOct; rewrite oppr0 //= linear0 !add0r. Qed.

Lemma conjoxxE (a : oct R) :
  a *o a^*o = (a.1 * a.1^*q + a.2 * a.2^*q)%:ol.
Proof.
case: a => a0 a1; congr mkOct => /=; last first.
  by rewrite [a0 + _]addrC addrK conjqI addrC mulNr subrr.
by rewrite [a0 + _]addrC addrK linearN /= mulNr opprK conjq_comm.
Qed.

Lemma conjo_comm (a : oct R) : a^*o *o a = a *o a^*o.
Proof.
case: a => a0 a1; apply: (f_equal2 (@mkOct _)) => /=.
  rewrite !(mulrBl, mulrBr, mulrDr, mulrDl, linearN, mulNr, mulrN, opprK) /=.
  by rewrite conjq_comm.
rewrite !(linearB, linearD) /=.
rewrite !(mulrBl, mulrBr, mulrDr, mulrDl, linearN, mulNr, mulrN, opprK) /=.
rewrite [a1 * _ + _]addrC addrK subrr conjqI [_ + _ * a0]addrC addrK.
by rewrite addrC subrr.
Qed.

Lemma conjo_comm2 (a b : oct R) :
  b^*o *o a + a^*o *o b = a *o b^*o + b *o a^*o.
Proof.
apply: (addIr (a *o a ^*o + b *o b ^*o)).
rewrite [RHS]addrAC !{1}addrA -muloDr.
rewrite -[RHS]addrA -[X in _ = _ + X]muloDr -muloDl -linearD /=.
rewrite addrC !addrA -conjo_comm -muloDr -addrA -conjo_comm.
rewrite -muloDr -muloDl.
rewrite -linearD /= [b + a]addrC.
by apply: conjo_comm.
Qed.

Lemma conjoM a b : (a *o b)^*o = b^*o *o a^*o.
Proof.
case: a b => [a0 a1] [b0 b1]; congr mkOct => /=; last first.
  rewrite !(linearB, linearD, mulrBl, mulrDl, mulrBr, mulrDr) /= conjqI.
rewrite !(mulNr, opprK) [-(a1 * _) - _]addrC {1}subrK.
rewrite [_ - b1 * _]addrC subrK; first by rewrite addrC.
rewrite !(linearN, linearB, mulrBl, mulrDl, mulrBr, mulrDr) /=
          !conjqM /= !conjqI opprK.
rewrite [b0 * _ + _]addrC addrK [_ * a0 + _]addrC addrK.
rewrite opprD opprK subrK [_ + _ * a0^*q]addrC addrK.
rewrite [_ - _ * a1 + _]addrC -!addrA; congr (_ + _).
by rewrite [-(_ * b0) + _]addrC !addrA subrK addrK mulNr mulrN opprK.
Qed.

(* This part from altermate algebra -> Moufang equations comes from           *)
(* An Introduction to Nonassociative Algebras, by Schafer                     *)

Lemma muloAlt3 a b : (b *o a) *o a = b *o (a *o a).
Proof.
rewrite -[LHS]conjoI conjoM [(b *o a)^*o]conjoM -muloAlt1.
by rewrite -2!conjoM conjoI.
Qed.

Definition associator x y z := (x *o y) *o z - x *o (y *o z).
Local Notation "`a[ x , y , z ]" := (associator x y z).

Lemma associatorDl x1 x2 y z :
  `a[x1 + x2, y, z] = `a[x1, y, z] + `a[x2, y, z].
Proof.
by rewrite /associator !muloDl opprD !addrA [X in X + _ = _]addrAC.
Qed.

Lemma associatorDm x1 x2 y z :
  `a[y, x1 + x2, z] = `a[y, x1, z] + `a[y, x2, z].
Proof.
rewrite /associator !(muloDl, muloDr) !opprD {1}addrA.
by rewrite [X in X + _ = _]addrAC {1}[RHS]addrA.
Qed.

Lemma associatorDr x1 x2 y z :
  `a[y, z, x1 + x2] = `a[y, z, x1] + `a[y, z, x2].
Proof.
rewrite /associator !(muloDl, muloDr) !opprD {1}addrA.
by rewrite [X in X + _ = _]addrAC {1}[RHS]addrA.
Qed.

Lemma associatorP1 x y : `a[x, x, y] =  0.
Proof. by rewrite /associator muloAlt1 subrr. Qed.

Lemma associatorP2 x y : `a[x, y, y] =  0.
Proof. by rewrite /associator muloAlt3 subrr. Qed.

Lemma associator_swap x y z : `a[x, y, z] =  - `a[y, x, z].
Proof.
apply: subr0_eq; rewrite opprK.
have H := associatorP1 (x + y) z.
by rewrite !associatorDl !associatorDm !associatorP1
            {1}add0r addrA {1}addr0 in H.
Qed.

Lemma associator_rot x y z : `a[x, y, z] =  `a[z, x, y].
Proof.
rewrite [RHS]associator_swap.
apply: subr0_eq; rewrite opprK.
have H := associatorP2 x (y + z).
by rewrite !associatorDr !associatorDm !associatorP2
            {1}add0r addrA {1}addr0 addrC in H.
Qed.

(* Moufang equality *)

Lemma mulo_moufang1 x a y : x *o a *o x *o y = x *o (a *o (x *o y)).
Proof.
apply: subr0_eq.
apply: etrans (_ : `a[x *o a, x, y] + `a[x, a, x *o y] = 0).
  by rewrite /associator {1}addrA subrK.
rewrite associator_swap [X in _ + X = _]associator_rot
                        [X in _ + X = _]associator_swap /associator.
rewrite -{1}muloAlt1 -{1}muloAlt1 {1}opprD {1}opprK {1}opprD opprK {1}addrA.
rewrite -{1}[X in X + _ = _]addrAC.
have -> : - (x *o x *o a *o y) - x *o  x *o y *o a  =
             -`a[x *o x, a, y] - `a[x *o x, y, a] -
               x *o x *o (a *o y) - x *o x *o (y *o a).
  rewrite /associator {1}opprD opprK {1}opprD opprK.
  rewrite [X in _ = X - _]addrC {1}[X in _ = X - _]addrA.
  rewrite {1}[X in _ = X - _]addrA {1}addrK.
  by rewrite [X in _ = X - _]addrC addrK.
rewrite associator_rot associator_swap opprK {1}[X in X - _ - _ + _ + _]subrr.
rewrite sub0r.
rewrite [X in - X - _ + _ + _ = _]muloAlt1 [X in _ - X + _ + _ = _]muloAlt1.
rewrite -{1}addrA addrC {1}addrA.
rewrite -[X in _ + X + _ = _]muloNr -[X in _ + X = _]muloNr.
rewrite -3!{1}muloDr.
rewrite [X in _ *o (X - _)]addrAC -{1}addrA -/(associator _ _ _)
         -/(associator _ _ _) associator_rot associator_swap addrC subrr.
by rewrite mulor0.
Qed.

Lemma mulo_moufang3 x a y : (x *o y) *o (a *o x) = x *o (y *o a) *o x.
Proof.
apply: subr0_eq.
apply: etrans (_ : `a[x, y, a *o x] +
                     x *o (y *o (a *o x) - (y *o a) *o x) = 0).
  by rewrite /associator muloBr addrA subrK -{1}muloAlt2 .
rewrite -opprB -/(associator _ _ _).
rewrite associator_rot associator_swap {1}/associator {1}opprD opprK.
rewrite -{1}addrA -muloDr.
rewrite -muloAlt2 mulo_moufang1 -muloNr -muloDr.
rewrite {1}addrA [- _ + _]addrC -/(associator _ _ _).
by rewrite associator_rot subrr mulor0.
Qed.

Definition realo := [qualify x : oct R | (x.1 \is realq) && (x.2 == 0)].
Fact realo_key : pred_key realo. Proof. by []. Qed.
Canonical realo_keyed := KeyedQualifier realo_key.

Lemma realo_comm (a b : oct R) : a \is realo -> a *o b = b *o a.
Proof.
rewrite !qualifE; case: a => [[a0 a1] a2]; case: b => [b1 b2].
rewrite /= => /andP[/eqP-> /eqP->]; apply: (f_equal2 (@mkOct _)) => /=.
  by rewrite mulr0 subr0 linear0 mul0r subr0 realq_comm // realq_real.
by rewrite !mul0r addr0 add0r quat_realC.
Qed.

Lemma realo_real (a : quat R) : a \is realq -> a%:ol \is realo.
Proof. by rewrite !qualifE /= eqxx andbT. Qed.

Lemma realoE (a : oct R) : a \is realo -> a = (a.1.1%:q%quat)%:ol.
Proof.
by rewrite !qualifE; case: a => [[a0 a1] a2] /= /andP[/eqP-> /eqP->].
Qed.

Lemma realoMEl (a b : oct R) : a \is realo -> a *o b = a.1.1 *: b.
Proof.
move=> /realoE {1}->; congr mkOct; rewrite /= (mul0r, mulr0).
  by rewrite quat_algE -scalerAl mul1r subr0.
by rewrite quat_algE -scalerAr mulr1 addr0.
Qed.

Lemma realoMEr (a b : oct R) : a \is realo -> b *o a = a.1.1 *: b.
Proof.
move=> /realoE {1}->; congr mkOct; rewrite /= ?linear0 (mul0r, mulr0).
  by rewrite quat_algE -scalerAr mulr1 subr0.
by rewrite quat_realC quat_algE -scalerAr mulr1 add0r.
Qed.

Lemma realoMAl (a b c : oct R) : a \is realo -> a *o (b *o c) = (a *o b) *o c.
Proof.
by move=> aR; rewrite (realoMEl _ aR) octAl - (realoMEl _ aR).
Qed.

Lemma realoMAm (a b c : oct R) : b \is realo -> a *o (b *o c) = (a *o b) *o c.
Proof.
by move=> bR; rewrite (realoMEl _ bR) -octAr octAl -(realoMEr _ bR).
Qed.

Lemma realoMAr (a b c : oct R) : c \is realo -> a *o (b *o c) = (a *o b) *o c.
Proof.
by move=> cR; rewrite (realoMEr _ cR) -octAr -(realoMEr _ cR).
Qed.

Lemma realo_conjD (a : oct R) : a + a^*o \is realo.
Proof. by rewrite !qualifE /= !subrr sub0r subrr eqxx /=. Qed.

Lemma realo_conjM (a : oct R) : a *o a^*o \is realo.
Proof.
rewrite !qualifE; case: a => a0 a1; apply/andP => /=; split;
    rewrite !(mulrBl, mulrBr, mulrDr, mulrDl, linearN, mulNr, mulrN, opprK) /=;
    last first.
  by rewrite [a0 + _]addrC addrK conjqI addrC subrr.
rewrite [- _ *: a1.2 + _]addrC !scaleNr !subrr addrK !sub0r !scalerN  add0r.
rewrite [- _ + _]addrC subrr add0r linearN /=.
by rewrite !rv3LieAlgebra.liexx subr0 oppr0.
Qed.

End octonion.

Arguments realo {R}.

Notation "x '^*o'" := (conjo x) : oct_scope.
Notation "a *o b" := (mulo a b) : oct_scope.

Section octonion1.
Variable R : realType.

Definition sqro (a : oct R) := sqrq a.1 + sqrq a.2.

Lemma sqro0 : sqro 0 = 0.
Proof.
by apply/eqP; rewrite /sqro paddr_eq0 ?sqrq_ge0 // sqrq_eq0 eqxx.
Qed.

Lemma sqro_ge0 x : 0 <= sqro x.
Proof. by rewrite addr_ge0 // sqrq_ge0. Qed.

Lemma sqro_eq0 a : (sqro a == 0) = (a == 0).
Proof.
by rewrite /sqro paddr_eq0 ?sqrq_ge0// !sqrq_eq0 eq_oct.
Qed.

Lemma sqroN (a : oct R) : sqro (- a) = sqro a.
Proof. by rewrite /sqro !sqrqN. Qed.

Lemma sqro_conj (a : oct R) : sqro (a^*o) = sqro a.
Proof. by rewrite /sqro /conjo /= [a.1 + _]addrC addrK sqrq_conj sqrqN. Qed.

Lemma conjoZ k (a : oct R) : (k *: a) ^*o = k *: a ^*o.
Proof.
by congr mkOct; rewrite ?scalerN // !conjqZ /= -scalerDr -scalerBr.
Qed.

Lemma conjoP (a : oct R) : a *o a^*o = ((sqro a)%:q%quat)%:ol.
Proof.
rewrite /mulo /=; congr mkOct.
  rewrite [a.1 + _]addrC addrK linearN /= mulNr opprK conjq_comm !conjqP.
  by rewrite -quat_realD.
by rewrite [a.1 + _]addrC addrK conjqI addrC mulNr subrr.
Qed.

Local Notation "`il" := (`i%quat)%:ol.
Local Notation "`ir" := (`i%quat)%:or.
Local Notation "`jl" := (`j%quat)%:ol.
Local Notation "`jr" := (`j%quat)%:or.
Local Notation "`kl" := (`k%quat)%:ol.
Local Notation "`kr" := (`k%quat)%:or.

Local Open Scope quat_scope.

Lemma conjoE (a : oct R) :
  a^*o =
    - (1 / 6%:R) *: (a + `il *o a *o `il + `jl *o a *o `jl + `kl *o a *o `kl
                       + 1%:or *o a *o 1%:or
                       + `ir *o a *o `ir + `jr *o a *o `jr + `kr *o a *o `kr).
Proof.
rewrite (_  : - (1/6%:R) = ((1/3%:R) * -(1/2%:R))); last first.
  by rewrite mulrN !mulrA mulr1 -mulrA -invfM -natrM.
rewrite -3!addrA scalerDr.
apply/eqP; rewrite eq_oct; apply/andP; split; apply/eqP.
  rewrite [in LHS]/= scaleoctE /=.
  rewrite !{1}(linear0, mul0r, mulr0, sub0r, add0r, subr0).
  rewrite [a.1 + _^*q]addrC addrK -scalerA addr0 -conjqE !mulrA !conjq_comm.
  rewrite !conjqP /sqrq /= norm0 !expr0n  expr1n /= !add0r !addr0.
  rewrite !normeE !mul1r expr1n mul1r -3!opprD addrA -!mulr2n scalerN.
  rewrite -mulrnA -scaler_nat !scalerA -scalerBl.
  rewrite -{1}[3%:R^-1]mulr1 -mulrA -mulrBr natrM mulrA mulNr.
  rewrite  mulVf ?(eqr_nat _ _ 0) //.
  by rewrite mulNr opprK mul1r -(natrD _ 1) mulVf ?(eqr_nat _ _ 0) // scale1r.
rewrite [in LHS]/= scaleoctE /=.
rewrite !{1}(linear0, mul0r, mulr0, sub0r, add0r, subr0).
apply: etrans (_ : -(2%:R / 3%:R) *: a.2 + -(1 / 3%:R) *: a.2 = _).
  rewrite -scalerDl -opprD -mulrDl -(natrD _ _ 1) mulfV ?scaleN1r //.
  by rewrite (eqr_nat _ _ 0).
congr (_ + _).
  rewrite 3!addr0 -scalerA -!{1}mulrA !{1}conjqP /sqrq !normeE /=
          !expr0n !expr1n /=.
  rewrite !add0r !mul1r !mulr1 mulrC -mulrN -scalerA.
  rewrite -addrA -!mulr2n -mulrnA -scaler_nat !scalerA natrM mulrA.
  by rewrite !mulrN !mulNr divfK // (eqr_nat _ 2 0).
rewrite -{1}[a.2]conjqI conjqE -scalerA scaleNr -scalerN; congr (_ *: _).
rewrite -scalerN; congr (_ *: _); rewrite !opprD.
rewrite !(mulNr, mulrN) 4!mulrA mul1r mulr1.
set x := _^*q; set u := _ * _ * _; set v := _ * _ * _; set w := _ * _ * _.
move: x u v w => *.
by rewrite !{1}[_ + 0]addr0 -!{1}opprD 2!{1}addrA.
Qed.

Lemma conjo_scalar (a : oct R) :
  (a.1.1)%:q%quat%:ol = (1 / 2%:R) *: (a + a^*o).
Proof.
rewrite /conjo [a.1 + _]addrC addrK addoE.
have {2}->/= : a = mkOct a.1 a.2 by case: a.
by rewrite /addo /= subrr conjq_scalar oct_leftZ.
Qed.

Definition invo (a : oct R) : oct R := (1 / sqro a) *: (a ^*o).

Lemma mulVo a : a !=0 -> invo a *o a = 1%:ol.
Proof.
move => aNZ.
rewrite /invo -octAl conjo_comm conjoP.
congr mkOct => /=; last by rewrite scaler0.
by rewrite -quat_realZ mul1r mulVf // sqro_eq0.
Qed.

Lemma muloV a : a != 0 -> a *o invo a = 1%:ol.
Proof.
move => aNZ.
rewrite /invo -octAr conjoP.
congr mkOct => /=; last by rewrite scaler0.
by rewrite -quat_realZ mul1r mulVf // sqro_eq0.
Qed.

Lemma realo_realq (x : R) : x%:q%quat%:ol \in realo.
Proof. by apply/realo_real/realq_real. Qed.

Lemma conjoMA (a b : oct R) :
  (a *o b) *o (a *o b)^*o = a *o (b *o b ^*o) *o a^*o.
Proof.
rewrite conjoM -[a^*o](addrK a) [a ^*o + _]addrC (realoE (realo_conjD _)).
set x := _%:ol.
rewrite !{1}muloBr {1}mulo_moufang3.
rewrite {1}(realoMAr _ _ (realo_realq _)) -/x.
rewrite -{1 3}[b^*o](addrK b) [b ^*o + _]addrC (realoE (realo_conjD _)).
set y := _%:ol.
rewrite !{1}muloBr {1}muloAlt3.
by rewrite {1}(realoMAr _ _ (realo_realq _)).
Qed.

Lemma sqroM a b : sqro (a *o b) = sqro a * sqro b.
Proof.
have F (x y : R) : (x%:q = y%:q -> x = y)%quat by case.
apply: F.
have F (x y : quat R) : (x%:ol = y%:ol -> x = y)%quat by case.
apply: F.
rewrite quat_realM oct_leftM -!conjoP conjoMA.
rewrite -{1}(realoMAm _ _ (realo_conjM _)).
rewrite {1}(realo_comm _ (realo_conjM _)).
by rewrite {1}(realoMAr _ _ (realo_conjM _)).
Qed.

Lemma sqroZ k a : sqro (k *: a) = k ^+ 2 * sqro a.
Proof.
have F (x y : R) : (x%:q = y%:q -> x = y)%quat by case.
apply: F.
have F (x y : quat R) : (x%:ol = y%:ol -> x = y)%quat by case.
apply: F.
rewrite -!conjoP -octAl conjoZ octAr scalerA -octAr -expr2.
by rewrite quat_realZ oct_leftZ -conjoP.
Qed.

Lemma oct_integral (x y : oct R) : (x *o y == 0) = ((x == 0) || (y == 0)).
Proof.
case: (x =P 0) => [->|/eqP xNZ] /=; first by rewrite mulo0r eqxx.
apply/eqP/eqP => [xyZ|->]; last by rewrite mulor0.
rewrite -[y]mulo1r -(@mulVo x) // /invo -2!{1}octAl.
rewrite -[x^*o](addrK x) [x ^*o + _]addrC (realoE (realo_conjD _)).
set a := _%:ol.
rewrite 2!muloBl muloAlt1 -(realoMAl  _ _ (realo_realq _)) -/a.
by rewrite -muloBl xyZ mulor0 scaler0.
Qed.

Definition normo (a : oct R) : R := Num.sqrt (sqro a).

Lemma normo0 : normo 0 = 0.
Proof. by rewrite /normo sqro0 sqrtr0. Qed.

Lemma normoc a : normo a ^*o = normo a.
Proof. by rewrite /normo sqro_conj. Qed.

Lemma normoE a : (normo a ^+ 2)%:q%quat%:ol = a ^*o *o a.
Proof.
rewrite -normoc /normo sqr_sqrtr ?sqro_ge0 //.
by rewrite -conjoP conjoI.
Qed.

Lemma normo_ge0 a : 0 <= normo a.
Proof. by apply sqrtr_ge0. Qed.

Lemma normo_eq0 a : (normo a == 0) = (a == 0).
Proof.
rewrite /normo sqrtr_eq0 -sqro_eq0.
by case: ltrgt0P (sqro_ge0 a).
Qed.

Lemma normoM (a b : oct R) : normo (a *o b) = normo a * normo b.
Proof. by rewrite /normo sqroM sqrtrM // sqro_ge0. Qed.

Lemma normoZ (k : R) (a : oct R) : normo (k *: a) = `|k| * normo a.
Proof.
by rewrite /normo sqroZ sqrtrM ?sqr_ge0 // sqrtr_sqr.
Qed.

Lemma normoV (a : oct R) : normo (invo a) = normo a / sqro a.
Proof.
rewrite /invo normoZ normoc ger0_norm.
  by rewrite mulrC mul1r.
by rewrite mul1r invr_ge0 sqro_ge0.
Qed.

End octonion1.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Cat.Cat.
Require Import NatTrans.NatTrans NatTrans.Operations.

(** The category of functors.

– Objects: functors from C to C'
– Arrows: natural transformations
*)
Program Definition Func_Cat (C C' : Category) : Category :=
{|
  Obj := (C –≻ C')%functor;

  Hom := NatTrans;

  compose := @NatTrans_compose _ _;

  id := @NatTrans_id _ _;

  assoc := fun _ _ _ _ _ _ _ => @NatTrans_compose_assoc _ _ _ _ _ _ _ _ _;

  assoc_sym := fun _ _ _ _ _ _ _ => inverse (@NatTrans_compose_assoc _ _ _ _ _ _ _ _ _);

  id_unit_right := @NatTrans_id_unit_right _ _;

  id_unit_left := @NatTrans_id_unit_left _ _;

  Hom_HSet := NatTrans_HSet
|}.

Section Opposite_Func_Cat.
  Context (C D : Category).

  (** Functor from functor category to its opposite. Maps each functor to its opposite. *)
  Program Definition Op_Func_Cat_to_Func_Cat_Op : ((Func_Cat C D)^op –≻ (Func_Cat (C^op) (D^op)))%functor :=
    {|
      FO := Opposite_Functor;
      FA := fun _ _ => Opposite_NatTrans;
      F_id := fun _ => NatTrans_id_Op _;
      F_compose := fun _ _ _ _ _ => NatTrans_compose_Op _ _
    |}.

  (** Functor from the opposite of a functor category to it. Maps each functor to its opposite. *)
  Program Definition Func_Cat_Op_to_Op_Func_Cat : ((Func_Cat (C^op) (D^op)) –≻ (Func_Cat C D)^op)%functor :=
    {|
      FO := Opposite_Functor;
      FA := fun _ _ => Opposite_NatTrans;
      F_id := fun F => NatTrans_id_Op F;
      F_compose := fun _ _ _ N N' => NatTrans_compose_Op N N'
    |}.

(*
  (** The opposite of the category of functors from C to D is naturally isomorphic to the category of functors from C^op to D^op. *)
  Program Definition Func_Cat_Op_Iso : (((Func_Cat C D)^op)%category ≃≃ (Func_Cat (C^op) (D^op)) ::> Cat) %isomorphism :=
    {|
      iso_morphism := Op_Func_Cat_to_Func_Cat_Op;
      inverse_morphism := Func_Cat_Op_to_Op_Func_Cat
    |}.
*)
End Opposite_Func_Cat.


Require Import Arith.
Require Import Iterates F_alpha E0.
Require Import ArithRing Lia   Max.
Import Exp2.
Require Import Compat815.
Open Scope nat_scope.

Lemma LF3 : dominates_from 2 (F_ 3) (fun  n => iterate exp2 n n).
Proof.
  generalize (LF3_2); intros H n Hn; eapply Nat.le_lt_trans.
  -  apply  iterate_le_n_Sn;  intro x; generalize (exp2_gt_id x); lia.
  -  now apply H.
Qed.

 (** * Proof that F_alpha  (S n) > exp2 (F_ alpha n) for alpha >= 3 and
    n >= 2  (by induction over alpha) *)

Section S1.

  Let P alpha := forall n, 2 <= n -> exp2 (F_ alpha n) <= F_ alpha (S n).

  Remark F_3_eqn : forall n, F_ 3  n = iterate (F_ 2) (S n) n.
  Proof.
    intro n; ochange (E0fin 3)  (E0succ (E0fin 2)); now rewrite F_succ_eqn.
  Qed.

  (** ** Base case *)

  Lemma P_3 : P 3.
  Proof.
    intros n H; rewrite (F_3_eqn (S n)); rewrite iterate_S_eqn.
    rewrite F_3_eqn.
    transitivity (exp2 (iterate (F_ 2) (S n) (S n))).
    -   apply PeanoNat.Nat.lt_le_incl; apply exp2_mono.
        apply iterate_mono; auto.
        + apply F_alpha_mono.
        + intro n0; apply (F_alpha_gt (E0fin 2) n0).
    -  specialize (LF2_0 (iterate (F_ 2) (S n) (S n))); intro H0.
       remember (iterate (F_ 2) (S n) (S n)) as N.
       transitivity ((fun i : nat => (exp2 i * i)%nat) N).
       +   assert (0 < N).
           {  rewrite HeqN; cbn; apply F_alpha_positive. }

           rewrite PeanoNat.Nat.mul_comm.
           (** deprecated, not replaced yet *)
           destruct (Compat815.mult_O_le (exp2 N) N).
             auto.
           * lia.
       * apply H2.
       + apply PeanoNat.Nat.lt_le_incl,  LF2.
  Qed.

  (** Successor case *)

  Section Successor.

    Variable alpha: E0.
    Hypothesis H_alpha : P alpha.

    Remark R1: forall n, 2 <= n ->
                         forall p, n < p ->
                                   exp2 (F_ alpha n) <= F_ alpha p.
    Proof.
      induction 2.
      - apply H_alpha; auto.
      - transitivity (F_ alpha m);auto.
        + apply mono_weak.
          * apply F_alpha_mono.
          * auto with arith.
    Qed.

    Section S2.
      Variable n : nat.
      Hypothesis Hn : 2 <= n.

      Remark R3 :
        F_ (E0succ alpha) (S n)= F_ alpha (iterate (F_ alpha) (S n) (S n)).
      Proof.
        rewrite F_succ_eqn; now rewrite iterate_S_eqn.
      Qed.

      Remark R3' : F_ (E0succ alpha) n = iterate (F_ alpha) (S n) n.
      Proof.
        now rewrite F_succ_eqn.
      Qed.

      Remark R4 : F_ (E0succ alpha) n < iterate (F_ alpha) (S n) (S n).
      Proof.
        rewrite F_succ_eqn; apply iterate_mono; auto with arith.
        - apply F_alpha_mono.
        - intro; apply F_alpha_gt.
      Qed.

      Lemma L2 : exp2 (F_ (E0succ alpha)  n) <= (F_ (E0succ alpha) (S n)).
      Proof.
        assert (H: 2 <= (F_ (E0succ alpha) n)).
        {
          apply Nat.le_lt_trans with n.
          - lia.
          - apply F_alpha_gt.
        }
        assert (H0: F_ (E0succ alpha) n < iterate (F_ alpha) (S n) (S n)).
        {
          rewrite F_succ_eqn;  apply iterate_mono; auto.
          - apply F_alpha_mono.
          - intro; apply F_alpha_gt.
        }
        generalize(R1 (F_ (E0succ alpha) n) H
                      (iterate (F_ alpha) (S n) (S n)) H0); intro H1;
          rewrite <- R3 in H1.
        transitivity ( exp2 (F_ alpha (F_ (E0succ alpha) n))); [| auto].
        -  apply PeanoNat.Nat.lt_le_incl; apply exp2_mono.
           apply F_alpha_gt.
      Qed.

    End S2.

    Lemma L3 : P (E0succ alpha).
    Proof.
      unfold P; intros;  now apply L2.
    Qed.

  End Successor.

  (** ** Limit case *)

  Section Limit.
    Variable lambda : E0.
    Hypothesis Hlambda : E0limit lambda.
    Hypothesis IHlambda :
      forall alpha, E0fin 3 o<= alpha -> alpha o< lambda -> P alpha.

    Remark R5: forall beta, 3 o<= beta -> beta o< lambda ->
                            forall n, 2 <= n ->
                                      forall p, n < p ->
                                                exp2 (F_ beta n) <= F_ beta p.
    Proof.
      induction 4.
      - apply IHlambda; auto.
      - transitivity (F_ beta m);auto.
        + apply mono_weak.
          * apply F_alpha_mono.
          * auto with arith.
    Qed.

    Section S3.
      Variable n: nat.
      Hypothesis Hn : 2 <= n.

      (* TODO: simplify this proof ! *)
      Lemma L04 : forall beta:T1,
          T1limit beta ->
          forall n, leq lt  (\F (S n)) (Canon.canon beta (S n)).
      Proof.
        destruct beta.
        -  discriminate.
        -  cbn.
           destruct beta1.
           + discriminate.
           + destruct beta2.
             * destruct n0.
               -- cbn.
                  destruct beta1_1; cbn.
                  ++ destruct n1.
                     ** reflexivity.
                     ** intros; apply lt_incl_le.
                        apply head_lt; auto with T1.
                  ++  destruct (pred beta1_2).
                      ** intros; apply lt_incl_le; apply head_lt;
                         auto with T1.
                      **  intros; apply lt_incl_le; apply head_lt.
                          { destruct  n1;cbn.
                            destruct beta1_2; cbn.
                            - destruct beta1_1_1; cbn.
                              + destruct n0; cbn; auto with T1.
                              + destruct (pred beta1_1_2); cbn; auto with T1.
                          -  destruct n0; cbn; auto with T1.
                          - destruct beta1_2; auto with T1.
                            + destruct beta1_1_1.
                              * destruct n0; cbn; auto with T1.
                              * destruct (pred beta1_1_2); cbn; auto with T1.
                          }
               -- intros;apply lt_incl_le.
                  destruct (pred (cons beta1_1 n1 beta1_2)).
                  ++  apply head_lt; auto with T1.
                  ++ apply head_lt; auto with T1.
             * intros; apply lt_incl_le.
               destruct n0.
               --  apply head_lt; auto with T1.
               --  apply head_lt; auto with T1.
      Qed.

      Lemma L04' : forall beta, E0limit beta ->
                                forall n, (S n) o<=
                                          (Canon.Canon beta (S n)).
      Proof.
        destruct beta; unfold E0limit.
        cbn;  intros; rewrite Le_iff; split.
        - apply  (@E0.cnf_ok (E0finS n0)).
        - cbn; split.
          + apply L04; auto.
          + cbn; apply Canon.nf_canon; auto.
      Qed.

      Lemma L4 : exp2 (F_ lambda n) <= F_ lambda (S n).
      Proof.
        repeat rewrite (F_lim_eqn lambda); auto.
        transitivity (exp2 (F_ (Canon.Canon lambda (S n))  n)).
        -  apply PeanoNat.Nat.lt_le_incl; apply exp2_mono.
           apply F_mono_l_0 with 0.
           + apply Paths.Canon_mono1; auto.
           + apply Paths.Cor12_E0 with (i := 0); auto.
             * apply   Paths.Canon_mono1; auto.
             * destruct n.
               -- lia.
               -- apply (@Paths.KS_thm_2_4_E0 _ Hlambda n0 (S n0)).
                  auto with arith.
           + auto with arith.
        - apply R5; auto.
          + generalize (L04' lambda Hlambda); intro H; specialize (H n).
            eapply E0.Le_trans with (S n).
            * rewrite Le_iff. split.
              -- now compute.
              -- split.
                 ++ cbn; destruct (Compat815.le_lt_or_eq _ _ Hn).
                    **  apply lt_incl_le;  now apply finite_lt.
                    **  subst n;  apply Comparable.le_refl.
                 ++   cbn; apply nf_FS.
            *  assumption.
          + apply Canon.Canon_lt.
            apply Limit_not_Zero; auto.
      Qed.

    End S3.
  End Limit.

  Lemma L alpha :  3 o<= alpha -> P alpha.
  Proof.
      pattern alpha; eapply well_founded_induction with E0lt.
    - apply E0lt_wf.
    - clear alpha; intro alpha.  intros IHalpha Halpha.
      destruct (Zero_Limit_Succ_dec  alpha) as [[H1 | H1] | H1].
      +  subst; rewrite Le_iff in Halpha.
         decompose [and] Halpha. cbn in Halpha. destruct Halpha
           as [H1 [H2 H3]].
         rewrite le_lt_eq in H2; destruct H2; try discriminate.
      + red; intros;  eapply L4; auto.
      + destruct H1; subst alpha.
        assert (H: 3 o<= x \/ x = E0fin 2).
        { destruct (le_lt_eq_dec Halpha).
          - left; destruct (E0_Lt_Succ_inv e).
            + apply Lt_Le_incl; auto.
            + subst; apply Le_refl.
          - right;  revert e; ochange (E0fin 3) (E0succ 2).
            intro; symmetry ; now apply Succ_inj.
        }
        destruct H.
        *   apply L3; apply IHalpha; auto.
            -- apply Lt_Succ; auto.
        * subst x; ochange (E0succ 2) (E0fin 3); apply P_3.
  Qed.

End S1.

Theorem F_alpha_Sn alpha : 3 o<= alpha ->
                   forall n, 2 <= n -> exp2 (F_ alpha n) <= F_ alpha (S n).
Proof. apply L. Qed.

(** What happens if alpha is less than 3, or n less than 2 ? *)

Goal  F_ 2 3 = 63.
  ochange (E0fin 2) (E0succ (E0fin 1)).
  rewrite F_succ_eqn.
  cbn.
  repeat rewrite LF1.
  reflexivity.
  Qed.

Goal  F_ 2 2 = 23.

  ochange (E0fin 2) (E0succ (E0fin 1)).
  rewrite F_succ_eqn.
  cbn.
  repeat rewrite LF1.
  reflexivity.
Qed.

Goal  F_ 3 1 = 2047.
  ochange (E0fin 3) (E0succ (E0succ (E0fin 1))).
  repeat rewrite F_succ_eqn.
  cbn.
  repeat rewrite F_succ_eqn. cbn.
  repeat rewrite LF1.
  rewrite iterate_S_eqn. cbn.
  repeat rewrite LF1.
  compute.
  reflexivity.
Qed.


Require Import PolSBase.

Section PolFactorSimpl.

(* The set of the coefficient usually Z or better Q *)
Variable C : Set.

(* Usual operations *)
Variable Cplus : C -> C ->  C.
Variable Cmul : C -> C ->  C.
Variable Cop : C ->  C.

(* Constant *)
Variable C0 : C.
Variable C1 : C.

(* Test to 1 *)
Variable isC1 : C ->  bool.

(* Test to 0 *)
Variable isC0 : C ->  bool.

(* Test if positive *)
Variable isPos : C ->  bool.

(* Divisibility *)
Variable Cdivide : C -> C ->  bool.

(* Division *)
Variable Cdiv : C -> C ->  C.

(* Gcd *)
Variable Cgcd: C -> C -> C.

(* Test if the difference of two terms is zero *)
Definition is_eq :=  fun x y =>
  let r :=  simpl C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEsub x y) in
   match r with
     PEc c  => isC0 c
  |  _          => false
  end.
(*
Axiom is_eq: (PExpr C) -> (PExpr C) -> bool.
*)

(* Test if the sum of two term is zero *)

Definition is_op :=  fun x y =>
  let r :=  simpl C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (PEadd x y) in
   match r with
     PEc c  => isC0 c
  |  _          => false
  end.

(*
Axiom is_op: (PExpr C) -> (PExpr C) -> bool.
*)

Definition test_in :=
   fun x y =>
        match x, y with
          PEc c1, PEc c2 =>  if (isC1 (Cgcd c1 c2)) then false else true
         | _ , _ => match (is_eq x y) with true => true | false => is_op x y end
        end.

(* Return the first factor of a sum *)
Fixpoint first_factor (e: PExpr C) : PExpr C :=
match e with
  PEadd e1 _  =>  first_factor e1
| PEsub e1 _  =>  first_factor e1
| PEopp e1     =>  first_factor e1
| _                    =>  e
end.

(* Split a product in list of products *)
Fixpoint split_factor (e: PExpr C) : list (PExpr C) :=
match e with
  PEmul e1 e2  =>  (split_factor e1)++(split_factor e2)
| PEopp e1        =>  match  (split_factor e1) with (_::nil) => e::nil | l1 => l1 end
| _                    =>  e::nil
end.

(* Split a product in list of products *)
Fixpoint split_factors (e: PExpr C) : list (list (PExpr C)) :=
match e with
  PEadd e1 e2  =>  (split_factors e1)++(split_factors e2)
| PEsub e1 e2  =>  (split_factors e1)++(split_factors e2)
| PEopp e1        =>  match  (split_factors e1) with ((_::nil)::nil) => (e::nil)::nil | l1 => l1 end
| _                    =>  (split_factor e)::nil
end.

(* Application on an optional type *)
Definition oapp:=
   fun (A B:Set) (a: A) (f: A -> B -> B) (l: option B) =>
       match l with Some l1 => Some (f a l1) | _ => None end.

Let ocons := fun  x => oapp _ _ x (@cons (PExpr C)).

(* Remove an element in a list *)
Fixpoint remove_elem (e: PExpr C) (l: list (PExpr C)) {struct l}: option (list (PExpr C)) :=
match l with
   nil   =>  None
| cons e1 l1  =>  if (test_in e e1) then Some l1 else (ocons e1 (remove_elem e l1))
end.

Let oconst := fun (A:Set) x =>  oapp _ _ x (fun x (y: A * list (PExpr C)) => let (v1,l1) := y in (v1, x::l1)).

(* Remove a constant in a list *)
Fixpoint remove_constant (c: C) (l: list (PExpr C)) {struct l}: option (C * list (PExpr C)) :=
match l with
   nil   =>  None
| cons (PEc c1)  l1  =>  if (isC1 (Cgcd c c1)) then oconst  _ (PEc c1) (remove_constant c l1)
                                                                             else Some (Cgcd c c1, cons (PEc (Cdiv c (Cgcd c c1))) l1)
| cons c1 l1 => oconst _  c1 (remove_constant c l1)
end.

(* Strip the element that are not in the list *)

Fixpoint strip (l1 l2: list (PExpr C)) {struct l1} : list (PExpr C) :=
match l1 with
  nil => nil
| cons (PEc c) l3 => match remove_constant c l2 with
                                     None => strip l3 l2
                                  | Some (c1, l4) => cons (PEc c1) (strip l3 l4)
                                   end
| cons e l3 =>  match remove_elem e l2 with
                                     None => strip l3 l2
                                  | Some l4 => cons e (strip l3 l4)
                           end
end.

(* iter strip for all the element l2 *)
Fixpoint delta (l1: list (PExpr C))  (l2:  list (list (PExpr C))) {struct l2} : list (PExpr C) :=
match l2 with
nil => l1
| cons l l4 => match strip l1 l with
                         nil  => nil
                       | l3 => delta l3 l4
                      end
end.

Let mkMul := mkPEmul C Cmul Cop C0 isC1 isC0.
Let mkOpp := mkPEopp  C Cop.
Let mkAdd := mkPEadd C Cplus Cmul Cop C0 isC1 isC0 isPos.
Let mkSub := mkPEsub C Cplus Cmul Cop C0 isC1 isC0 isPos.

(* Remove an element in a list *)
Fixpoint subst_elem (e: PExpr C) (l: list (PExpr C)) {struct l}: option (bool * list (PExpr C)) :=
match l with
   nil   =>  None
| cons e1 l1  =>  if is_eq e e1 then Some (true, l1) else
                             if is_op e e1 then Some (false, l1) else  (oconst _ e1 (subst_elem e l1))
end.

(* Remove a constant in a list *)
Fixpoint subst_constant (c: C) (l: list (PExpr C)) {struct l}: option (C * list (PExpr C)) :=
match l with
   nil   =>  None
| cons (PEc c1)  l1  =>  if (Cdivide c1 c) then  Some (Cdiv c c1,  l1)
                                                                      else oconst _ (PEc c1) (subst_constant c l1)
| cons e1 l1 => oconst _ e1 (subst_constant c l1)
end.

(* Split a product in list of products *)
Fixpoint subst_one_factor (e: PExpr C) (l: list (PExpr C)) {struct e}: PExpr C * list (PExpr C) :=
match e with
  PEmul e1 e2  => let (e3, l1) := subst_one_factor e1 l in
                                let (e4, l2) := subst_one_factor e2 l1 in
                                  (mkMul e3 e4, l2)
| PEopp e1        =>  let (e3, l1) := subst_one_factor e1 l in
                                     (mkOpp e3, l1)
| PEc c               => match subst_constant c l with
                                     None => (e, l)
                                 |   Some (c1, l1) => (PEc c1, l1)
                                 end
| _ =>  match subst_elem e l with
              None => (e, l)
           | Some (true, l1) => (PEc C1, l1)
           | Some (false, l1) => (PEc (Cop C1), l1)
           end
end.

(* Return the first factor of a sum *)
Fixpoint subst_factor (l: list (PExpr C)) (e: PExpr C) {struct e} : PExpr C :=
match e with
  PEadd e1 e2  =>  mkAdd (subst_factor l e1) (subst_factor l e2)
| PEsub e1 e2=>  mkSub (subst_factor l e1) (subst_factor l e2)
| PEopp e1  =>   mkOpp (subst_factor l e1)
| _                 => fst (subst_one_factor e l)
end.

Definition get_delta := fun e => match split_factors e with
                                                        l1::l => delta l1 l
                                                      | _ => nil
                                                      end.

Fixpoint mkProd (l: (list (PExpr C))) {struct l} : (PExpr C) :=
   match l with
      nil => (PEc C1)
  | e::nil => e
  | e::l1 => mkMul e (mkProd l1)
  end.

Fixpoint find_trivial_factor (e: PExpr C) (l: list (list (PExpr C))) {struct l}: PExpr C :=
  match l with
     l1::ll2 => let e1 := mkProd l1 in
                     let e2 := simpl C Cplus Cmul Cop C0 C1 isC1 isC0 isPos Cdivide Cdiv (mkSub e e1) in
                     match subst_elem e2 l1 with
                       None => find_trivial_factor e ll2
                     | Some (true, l2) =>  PEmul e2 (mkAdd (mkProd l2) (PEc C1))
                     | Some (false, l2) =>   PEmul e2 (mkSub (PEc C1) (mkProd l2))
                     end
|   _ => (PEmul (PEc C1) e)
    end.

Definition isPC1 := fun x => match x with (PEc c) => (isC1 c) | _ => false end.
Definition isPC0 := fun x => match x with (PEc c) => (isC0 c) | _ => false end.

Fixpoint factor (e:  PExpr C) : PExpr C :=
  let e1 := match e with
     PEmul e1 e2  => PEmul (factor e1) (factor e2)
|     PEadd e1 e2  => PEadd (factor e1) (factor e2)
|     PEsub e1 e2  => PEsub (factor e1) (factor e2)
|     PEopp e1        =>  PEopp (factor e1)
| _ => e end in
     let e2 := get_delta e1 in
                                   if (isPC1 (mkProd e2)) then
                                     find_trivial_factor e1 (split_factors e1)
                                   else
                                     (PEmul (mkProd e2) (subst_factor e2 e1)).

Definition factor_sub := fun f =>
 let e := match f with
     PEmul e1 e2  => PEmul (factor e1) (factor e2)
|     PEadd e1 e2  => PEadd (factor e1) (factor e2)
|     PEsub e1 e2  => PEsub (factor e1) (factor e2)
|     PEopp e1        =>  PEopp (factor e1)
| _ => f end in
  match e with
    PEsub e1 e2 =>
           if (isPC0 e1)  then
               let d1 :=  (get_delta e2) in
                  PEmul (mkProd d1) (PEsub (PEc C0) (subst_factor d1 e2))
          else if (isPC0 e2) then
               let d1 := (get_delta e1) in
                  PEmul (mkProd d1) (PEsub (subst_factor d1 e2) (PEc C0))
         else
               let d := get_delta e in
                  (PEmul (mkProd d)
                    (PEsub (subst_factor d e1)
                                       (subst_factor d e2)))
    |  _   => let d := get_delta e in
                  (PEmul (mkProd d) (subst_factor d e))
  end.

Definition factor_sub_val := fun e d1 =>
  let d2 := split_factor d1 in
  match e with
    PEsub e1 e2 =>
           if (isPC0 e1)  then
                  PEmul d1 (PEsub (PEc C0) (subst_factor d2 e2))
          else if (isPC0 e2) then
                  PEmul d1 (PEsub (subst_factor d2 e2) (PEc C0))
         else
                  (PEmul d1
                    (PEsub (subst_factor d2 e1)
                                       (subst_factor d2 e2)))
    |  _   => (PEmul d1 (subst_factor d2 e))
  end.

End PolFactorSimpl.


Require Import Iron.Language.Simple.Step.
Require Import Iron.Language.Simple.Ty.
Require Import Iron.Language.Simple.Exp.

(* A closed, well typed expression is either a value or can
   take a step in the evaluation. *)
Theorem progress
 :  forall x t
 ,  TYPE nil x t
 -> value x \/ (exists x', STEP x x').
Proof.
 intros.
 remember (@nil ty) as tyenv.
 induction H; subst.

 - burn.

 - left. burn.

 - right.
   assert (@nil ty = nil). burn. rip.

   destruct IHTYPE1.
   destruct IHTYPE2.

    have (exists t x, x1 = XLam t x).
     destruct H4 as [t11].
     destruct H4 as [x11].
     subst.
    exists (substX 0 x2 x11). burn.

    destruct H3 as [x2'].
    exists (XApp x1 x2').
    lets D: EsContext XcApp2; burn.

    destruct H2 as [x1'].
    exists (XApp x1' x2).
    lets D: EsContext XcApp1; burn.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.bachmann_s_lotschnittaxiom_variant.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section bachmann_s_lotschnittaxiom_weak_inverse_projection_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Formalization of a proof from Bachmann's article "Zur Parallelenfrage" *)

Lemma bachmann_s_lotschnittaxiom__weak_inverse_projection_postulate :
  bachmann_s_lotschnittaxiom -> weak_inverse_projection_postulate.
Proof.
rewrite bachmann_s_lotschnittaxiom_aux.
intros lotschnitt A B C D E F P Q HAcute HPer HSuma HOut HPQ HPerP HCop.
suma.assert_diffs.
assert (HNCol : ~ Col A B C).
{ intro HCol.
  apply (per_not_col D E F); auto.
  apply (col2_suma__col A B C A B C); assumption.
}
assert (HNCol1 : ~ Col B C P) by (intro; apply HNCol; ColR).
destruct (l10_6_existence_spec B C P) as [P' HP']; trivial.
assert (HP'1 : Reflect P P' B C) by (apply is_image_is_image_spec; auto).
assert (HNCol2 : ~ Col B C P') by (apply osym_not_col with P; trivial).
destruct (l10_6_existence_spec B C Q) as [Q' HQ']; trivial.
assert (HQ'1 : Reflect Q Q' B C) by (apply is_image_is_image_spec; auto).
assert_diffs.
assert (P' <> Q').
 intro; subst Q'; assert (P = Q) by (apply (l10_2_uniqueness B C P'); assumption); auto.
assert (HCongA : CongA C B P' A B C).
  apply l11_10 with C P' P C; Out.
  apply conga_sym, conga_left_comm, reflectl__conga; auto.
  apply is_image_spec_rev, HP'.
assert (HTS : TS B C P P').
  repeat split; Col; destruct HP' as [[X [HX1 HX2]] _]; exists X; split; [Col|Between].
apply l6_6 in HOut.
assert (Coplanar P' C A B) by (apply col2_cop__cop with P B; Col; Cop).
assert (Coplanar B P P' Q) by CopR.
assert (HPer1 : Per A B P').
{ apply l11_17 with D E F; trivial.
  apply (suma2__conga A B C A B C); trivial.
  apply conga3_suma__suma with A B C C B P' A B P'; CongA.
  exists P'; repeat (split; try (apply conga_refl; auto)); [|Cop].
  apply l9_9, l9_5 with P B; Col.
}
assert (HNCol3 : ~ Col A B P') by (apply per_not_col; auto).
assert (HNCol4 : ~ Col B P' P) by (intro; apply HNCol3; ColR).
assert (HPerp1 : Perp A B B P') by (apply per_perp; auto).
assert (HPerp2 : Perp A B P Q) by (apply perp_left_comm, perp_col with P; Col; apply per_perp; auto).
assert (HPerp3 : Perp B P' P' Q').
  apply per_perp; auto; apply image_spec_preserves_per with B P Q B C; trivial; apply col__refl; Col.
assert (HNCol5 : ~ Col P' P Q).
  apply (par_not_col B P'); Col.
  apply par_not_col_strict with P; Col.
  apply l12_9 with A B; Perp; CopR.
assert (HI := HPerp2); destruct HI as [I [_ [_ [HCol1 [HCol2 _]]]]].
destruct (lotschnitt A B B P' P Q P' Q' B P P') as [Y [HY1 HY2]]; Col; Cop.
  {
  elim (col_dec B C Q); intro; [|CopR].
  assert (Q = Q'); [|treat_equalities; Cop].
  apply col_image_spec__eq with B C; Col.
  }

exists Y; split; trivial.
apply col_one_side_out with A.
  apply col_permutation_1, intersection_with_image_gen with P Q P' Q'; Col.
apply invert_one_side, one_side_transitivity with P'.
- apply cop_nts__os; Col; Cop.
  apply (conga_sams_nos__nts A B C A B C P'); SumA.
  apply l9_9, l9_5 with P B; Col.
- apply l12_6, par_strict_col_par_strict with Q'; Col.
    intro; subst; apply HNCol5; Col.
  apply par_not_col_strict with P'; Col.
  apply l12_9 with B P'; Perp; Cop.
  elim (col_dec B C Q); intro; [|CopR].
  assert (Q = Q'); [|treat_equalities; CopR].
  apply col_image_spec__eq with B C; Col.
Qed.

End bachmann_s_lotschnittaxiom_weak_inverse_projection_postulate.