(** * Coq codes *)
(** ** Dependencies *)

Require Export RegExp.Utility.
Require Export RegExp.Definitions.
Require Export RegExp.Boolean.

(** ** [Cat] is morphism *)

Lemma Cat_morphism_s : forall s r0 r1 r0' r1',
  r0 =R= r1 -> r0' =R= r1' -> (r0 ++ r0') ~= s = (r1 ++ r1') ~= s.
Proof.
  induction s.
    (* ""%string *)
    intros r0 r1 r0' r1' H H'.  simpl.  rewrite <- (nu_morphism r0 r1 H).
    rewrite <- (nu_morphism r0' r1' H').  auto.
    (* String a s *)
    intros r0 r1 r0' r1' H H'.  simpl.  rewrite <- (nu_morphism r0 r1 H).
    destruct (nu r0).
      (* true *)
      repeat erewrite matches_Or.
      replace (r1' / a ~= s) with (r0' / a ~= s).
      replace ((r1 / a ++ r1') ~= s) with ((r0 / a ++ r0') ~= s).
      auto.
        (* proof for replace *)
        eapply IHs; try auto.  eapply derive_morphism; try auto.
        unfold ascii_eq; auto.
        (* proof for replace *)
        eapply derive_morphism; try auto.  unfold ascii_eq; auto.
      (* false *)
      eapply IHs; try auto.  eapply derive_morphism; try auto.
      unfold ascii_eq; auto.
Qed.

Add Parametric Morphism : Cat with
signature re_eq ==> re_eq ==> re_eq as Cat_mor.
Proof.
  intros x y H x0 y0 H0.  unfold re_eq.  intro s.  eapply Cat_morphism_s; auto.
Qed.

(** ** [Empty] *)
(** [Empty] corresponds to 0 in Kleene algebra. *)

Lemma Cat_left_zero_s : forall s r, (Empty ++ r) ~= s = false.
Proof.
  induction s; simpl; auto.
Qed.

Theorem Cat_left_zero : forall r, Empty ++ r =R= Empty.
Proof.
  unfold re_eq.  intros r s.  erewrite Empty_false.
  eapply Cat_left_zero_s.
Qed.

Lemma Cat_right_zero_s : forall s r, (r ++ Empty) ~= s = false.
Proof.
  induction s; intro r; simpl.
    destruct (nu r); simpl; auto.
    case_eq (nu r); intro nu_r'.
      erewrite matches_Or.  erewrite IHs.  erewrite Empty_false.  simpl; auto.
      erewrite IHs.  auto.
Qed.

Theorem Cat_right_zero : forall r, r ++ Empty =R= Empty.
Proof.
  unfold re_eq.  intros r s.  erewrite Empty_false.
  eapply Cat_right_zero_s.
Qed.

(** ** [Cat] matches concatination of strings. *)

Lemma matches_Cat : forall s s' r r',
  r ~==s -> r' ~== s' -> (r ++ r') ~== (s ++ s')%string.
Proof.
  induction s.
    (* s = ""%string *)
    induction s'.
      (* s' = ""%string *)
      simpl. intros r r' nu_r nu_r'. rewrite nu_r. rewrite nu_r'. simpl; auto.
      (* s' = String a s *)
      simpl. intros r r' nu_r Hra.  rewrite nu_r.  erewrite matches_Or.
      rewrite Hra.  destruct ((r / a ++ r') ~= s'); simpl; auto.
    (* s = String a s *)
    intros s' r r' Hr Hr'.
    replace (String a s ++ s')%string with (String a (s ++ s'))%string.
    rewrite derivation.  simpl.  case_eq (nu r); intro nu_r'.
      (* nu r' = true *)
      rewrite derivation in Hr.  erewrite matches_Or.
      specialize (IHs s' (r/a) r' Hr Hr').  rewrite IHs.  simpl; auto.
      (* nu r' = false *)
      rewrite derivation in Hr.  specialize (IHs s' (r/a) r' Hr Hr').  auto.
      (* proof for replace *)
      simpl; auto.
Qed.

(** If [Cat] matches a string, the string can be divided into two strings which match the two [RegExp] respectively. *)

Lemma divide_Cat : forall s r' r'', (r' ++ r'') ~== s ->
  {s':string & {s'':string | s = (s' ++ s'')%string /\ r' ~== s' /\ r'' ~== s'' }}.
Proof.
  induction s.
    (* s = ""%string *)
    intros r' r'' H.  exists ""%string.  exists ""%string.  simpl.
    split.  auto.  simpl in H.
    destruct (nu r'); destruct (nu r''); split; simpl; auto; inversion H.
    (* s = String a s *)
    intros r' r'' H.  simpl in H.
    case_eq (nu r'); intro nu_r'; rewrite nu_r' in H; simpl in H.
      (* nu r' = true *)
      erewrite matches_Or in H.
      case_eq ((r' / a ++ r'') ~= s); case_eq (r'' / a ~= s);
      intros Hr''_a Hr'_r''_a; simpl in H.
        (* true true -> (String a s') ++ s'' *)
        specialize (IHs (r'/a) r'' Hr'_r''_a).
        destruct IHs as [s' [s'' [H1 [H2 H3]]]].
        exists (String a s').  exists s''.
        split.  simpl.  rewrite <- H1.  auto.  split; auto.
        (* (r' / a ++ r'') ~== s *)
        specialize (IHs (r'/a) r'' Hr'_r''_a).
        destruct IHs as [s' [s'' [H1 [H2 H3]]]].
        exists (String a s').  exists s''.
        split.  simpl.  rewrite <- H1.  auto.  split; auto.
        (* r'' / a ~== s *)
        exists ""%string.  exists (String a s).
        split.  simpl.  auto.  split; simpl; auto.
        (* false false *)
        rewrite Hr''_a in H.  rewrite Hr'_r''_a in H.  simpl in H.  inversion H.
      (* nu r' = false *)
      specialize (IHs (r'/a) r'' H).
      destruct IHs as [s' [s'' [H1 [H2 H3]]]].
      exists (String a s').  exists s''.
      split.  simpl.  rewrite <- H1.  auto.  split; auto.
Defined.

Lemma divide_Cat_false : forall s r' r'', (r' ++ r'') ~!= s ->
  forall s' s'', ((s = s' ++ s'')%string -> r' ~!= s' \/ r'' ~!= s'').
Proof.
  intros s r' r'' H0.
  intros s' s''.
  case_eq (r' ~= s'); case_eq (r'' ~= s''); intros Hr''s'' Hr's' Hs; try auto.
    (* true true *)
    specialize(matches_Cat s' s'' r' r'' Hr's' Hr''s'').
    left.  rewrite <- Hs in H.  rewrite H0 in H.  discriminate H.
Qed.

(** ** [Eps] *)
(** [Eps] corresponds to 1 in Kleene algebra. *)

Lemma Cat_left_id_s : forall s r, (Eps ++ r) ~= s = r ~= s.
Proof.
  induction s.
    simpl; auto.
    simpl. intros r. erewrite matches_Or.
    erewrite Cat_left_zero_s.  simpl; auto.
Qed.

Theorem Cat_left_id : forall r, Eps ++ r =R= r.
Proof.
  unfold re_eq. intros r s. eapply Cat_left_id_s.
Qed.

Lemma Cat_right_id_s : forall s r, (r ++ Eps) ~= s = r ~= s.
Proof.
  intros s r.  case_eq (r ~= s); intro Hrs.
    (* r ~== s *)
    replace ((r ++ Eps) ~= s) with ((r ++ Eps) ~= (s ++ EmptyString)).
    eapply matches_Cat; auto.
    erewrite string_right_id.  auto.
    (* r ~!= s *)
    generalize dependent r.
    induction s.
      intros r H.  simpl in *.  rewrite H.  auto.
      intros r H.  simpl in *.  case_eq (nu r); intro nu_r'.
        (* nu r = true *)
        erewrite matches_Or.  erewrite Empty_false.
        replace (((r / a ++ Eps) ~= s) || false)%bool with ((r / a ++ Eps) ~= s).
        erewrite IHs; auto.
        destruct ((r / a ++ Eps) ~= s); auto.
        (* nu r = false *)
        erewrite IHs; auto.
Qed.

Theorem Cat_right_id : forall r, r ++ Eps =R= r.
Proof.
  unfold re_eq.  intros r s.  eapply Cat_right_id_s.
Qed.

(** ** [Cat] is associative. *)

Lemma matches_Cat_Cat_left : forall s s' s'' r r' r'',
  r ~== s -> r' ~== s' -> r'' ~== s'' ->
  ((r ++ r') ++ r'') ~== ((s ++ s') ++ s'').
Proof.
  intros s s' s'' r r' r'' H H' H''.
  repeat eapply matches_Cat; auto.
Qed.

Lemma matches_Cat_Cat_right : forall s s' s'' r r' r'',
  r ~== s -> r' ~== s' -> r'' ~== s'' ->
  (r ++ (r' ++ r'')) ~== (s ++ (s' ++ s'')).
Proof.
  intros s s' s'' r r' r'' H H' H''.
  repeat eapply matches_Cat; auto.
Qed.

Lemma Cat_assoc_s : forall s r r' r'',
  ((r ++ r') ++ r'') ~= s = (r ++ (r' ++ r'')) ~= s.
Proof.
  intros s r r' r''.  case_eq (((r ++ r') ++ r'') ~= s); intro H; symmetry.
    (* true *)
    specialize(divide_Cat s (r ++ r') r'' H).  intro H0.
    destruct H0 as [srr' [s_'' [H01 [H02 Hs_''r'']]]].
    specialize(divide_Cat srr' r r' H02).  intro H0.
    destruct H0 as [s_ [s_' [Hs_s_' [Hs_r Hs_'r']]]].
    replace s with (s_ ++ (s_' ++ s_''))%string.
    eapply matches_Cat_Cat_right; auto.
    rewrite <- string_assoc.  rewrite <- Hs_s_'.  rewrite <- H01.  auto.
    (* false *)
    specialize(divide_Cat_false s (r ++ r') r'' H). intros H0.
    case_eq ((r ++ r' ++ r'') ~= s); intro H1.
      (* true *)
      specialize(divide_Cat s r (r' ++ r'') H1). intros H2.
      destruct H2 as [s0 [s_ [Hs_ [Hrs Hs__]]]].
      specialize (divide_Cat s_ r' r'' Hs__). intros H2.
      destruct H2 as [s0' [s0'' [Hs [Hrs' Hrs'']]]].
      specialize (matches_Cat s0 s0' r r' Hrs Hrs'). intros H2.
      specialize (matches_Cat (s0 ++ s0')%string s0'' (r ++ r') r'' H2 Hrs'').
      intros H3.
      replace (((s0 ++ s0') ++ s0'')%string) with s in H3.
      rewrite H in H3.  discriminate H3.
        (* proof for replace *)
        erewrite string_assoc.  rewrite <- Hs.  rewrite <- Hs_.  auto.
      (* false *)
      auto.
Qed.

Theorem Cat_assoc : forall r r' r'', (r ++ r') ++ r'' =R= r ++ (r' ++ r'').
Proof.
  intros r r' r''.  unfold re_eq.  intro s.
  eapply Cat_assoc_s.
Qed.

(** ** [Cat] distributes to [Or]. *)

Lemma Cat_left_distr_s : forall s r r' r'',
  (r ++ (r' || r'')) ~= s = ((r ++ r') || (r ++ r'')) ~= s.
Proof.
  induction s.
    (* s = "" *)
    intros r r' r''.  simpl.
    destruct(nu r); destruct(nu r'); destruct(nu r''); auto.
    (* s = String a s *)
    intros r r' r''.  simpl.  case_eq (nu r); intro nu_r.
      (* nu r = true *)
      rewrite (matches_Or s (r / a ++ r' || r'') (r' / a || r'' / a)).
      rewrite (IHs (r / a) r' r'').
      repeat erewrite matches_Or.
      destruct ((r / a ++ r') ~= s); destruct ((r / a ++ r'') ~= s);
      destruct (r' / a ~= s); destruct (r'' / a ~= s); auto.
      (* nu r = false *)
      eapply IHs.
Qed.

Lemma Cat_left_distr : forall r r' r'',
  (r ++ (r' || r'')) =R= ((r ++ r') || (r ++ r'')).
Proof.
  unfold re_eq.  intros r r' r'' s.  eapply Cat_left_distr_s.
Qed.

Lemma Cat_right_distr_s : forall s r r' r'',
  ((r || r') ++ r'') ~= s = ((r ++ r'') || (r' ++ r'')) ~= s.
Proof.
  induction s.
    (* s = "" *)
    intros r r' r''.  simpl.
    destruct (nu r); destruct (nu r'); destruct (nu r''); auto.
    (* s = String a s *)
    intros r r' r''.  simpl.
    case_eq (nu r); intro nu_r; case_eq (nu r'); intro nu_r'; simpl.
      (* true true *)
      rewrite (matches_Or s (r / a || r' / a ++ r'') (r'' / a)).
      rewrite (IHs (r / a) (r' / a) r'').
      repeat erewrite matches_Or.
      destruct ((r / a ++ r'') ~= s); destruct ((r' / a ++ r'') ~= s);
      destruct (r'' / a ~= s); auto.
      (* true false *)
      rewrite (matches_Or s (r / a || r' / a ++ r'') (r''/a)).
      rewrite (IHs (r/a) (r'/a) r'').
      repeat erewrite matches_Or.
      destruct ((r / a ++ r'') ~= s); destruct ((r' / a ++ r'') ~= s);
      destruct (r'' / a ~= s); auto.
      (* false true *)
      rewrite (matches_Or s (r / a || r' / a ++ r'') (r''/a)).
      rewrite (IHs (r/a) (r'/a) r'').
      repeat erewrite matches_Or.
      destruct ((r / a ++ r'') ~= s); destruct ((r' / a ++ r'') ~= s);
      destruct (r'' / a ~= s); auto.
      (* false false *)
      rewrite (IHs (r/a) (r'/a) r'').
      erewrite matches_Or.  auto.
Qed.

Lemma Cat_right_distr : forall r r' r'',
  ((r || r') ++ r'') =R= ((r ++ r'') || (r' ++ r'')).
Proof.
  unfold re_eq.  intros r r' r'' s.  eapply Cat_right_distr_s.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Psatz.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.InterfaceProofs.
Require Import Crypto.LegacyArithmetic.Double.Core.
Require Import Crypto.LegacyArithmetic.Double.Proofs.Decode.
Require Import Crypto.LegacyArithmetic.Double.Proofs.SpreadLeftImmediate.
Require Import Crypto.LegacyArithmetic.Double.Proofs.RippleCarryAddSub.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Tactics.SimplifyProjections.
Require Import Crypto.Util.Notations.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Prod.
Import Bug5107WorkAround.
Import BoundedRewriteNotations.

Local Open Scope Z_scope.

Local Opaque tuple_decoder.

Lemma decode_mul_double_iff
      {n W}
      {decode : decoder n W}
      {muldw : multiply_double W}
      {isdecode : is_decode decode}
  : is_mul_double muldw
    <-> (forall x y, tuple_decoder (muldw x y) = (decode x * decode y)%Z).
Proof.
  rewrite is_mul_double_alt by assumption.
  split; intros H x y; specialize (H x y); revert H;
    pose proof (decode_range x); pose proof (decode_range y);
      assert (0 <= decode x * decode y < 2^n * 2^n) by nia;
      assert (0 <= n) by eauto using decode_exponent_nonnegative;
      autorewrite with simpl_tuple_decoder;
      simpl; intro H'; rewrite H';
        Z.rewrite_mod_small; reflexivity.
Qed.

Global Instance decode_mul_double
           {n W}
           {decode : decoder n W}
           {muldw : multiply_double W}
           {isdecode : is_decode decode}
           {ismuldw : is_mul_double muldw}
  : forall x y, tuple_decoder (muldw x y) <~=~> (decode x * decode y)%Z
  := proj1 decode_mul_double_iff _.

Section tuple2.
  Local Arguments Z.pow !_ !_.
  Local Arguments Z.mul !_ !_.

  Local Opaque ripple_carry_adc.
  Section full_from_half.
    Context {W}
            {mulhwll : multiply_low_low W}
            {mulhwhl : multiply_high_low W}
            {mulhwhh : multiply_high_high W}
            {adc : add_with_carry W}
            {shl : shift_left_immediate W}
            {shr : shift_right_immediate W}
            {half_n : Z}
            {ldi : load_immediate W}
            {decode : decoder (2 * half_n) W}
            {ismulhwll : is_mul_low_low half_n mulhwll}
            {ismulhwhl : is_mul_high_low half_n mulhwhl}
            {ismulhwhh : is_mul_high_high half_n mulhwhh}
            {isadc : is_add_with_carry adc}
            {isshl : is_shift_left_immediate shl}
            {isshr : is_shift_right_immediate shr}
            {isldi : is_load_immediate ldi}
            {isdecode : is_decode decode}.

    Local Arguments Z.mul !_ !_.

    Lemma decode_mul_double_mod x y
      : (tuple_decoder (mul_double half_n x y) = (decode x * decode y) mod (2^(2 * half_n) * 2^(2*half_n)))%Z.
    Proof using Type*.
      assert (0 <= 2 * half_n) by eauto using decode_exponent_nonnegative.
      assert (0 <= half_n) by omega.
      unfold mul_double, Let_In.
      push_decode; autorewrite with simpl_tuple_decoder; simplify_projections.
      autorewrite with zsimplify Zshift_to_pow push_Zpow.
      rewrite !spread_left_from_shift_half_correct.
      push_decode.
      generalize_decode_var.
      simpl in *.
      autorewrite with push_Zpow in *.
      repeat autorewrite with Zshift_to_pow zsimplify push_Zpow.
      rewrite <- !(Z.mul_mod_distr_r_full _ _ (_^_ * _^_)), ?Z.mul_assoc.
      Z.rewrite_mod_small.
      push_Zmod; pull_Zmod.
      apply f_equal2; [ | reflexivity ].
      Z.div_mod_to_quot_rem; nia.
    Qed.

    Lemma decode_mul_double_function x y
      : tuple_decoder (mul_double half_n x y) = (decode x * decode y)%Z.
    Proof using Type*.
      rewrite decode_mul_double_mod; generalize_decode_var.
      simpl in *; Z.rewrite_mod_small; reflexivity.
    Qed.

    Global Instance mul_double_is_multiply_double : is_mul_double mul_double_multiply.
    Proof using Type*.
      apply decode_mul_double_iff; apply decode_mul_double_function.
    Qed.
  End full_from_half.

  Section half_from_full.
    Context {n W}
            {decode : decoder n W}
            {muldw : multiply_double W}
            {isdecode : is_decode decode}
            {ismuldw : is_mul_double muldw}.

    Local Ltac t :=
      hnf; intros [??] [??];
      assert (0 <= n) by eauto using decode_exponent_nonnegative;
      assert (0 < 2^n) by auto with zarith;
      assert (forall x y, 0 <= x < 2^n -> 0 <= y < 2^n -> 0 <= x * y < 2^n * 2^n) by auto with zarith;
      simpl @Interface.mulhwhh; simpl @Interface.mulhwhl; simpl @Interface.mulhwll;
      rewrite decode_mul_double; autorewrite with simpl_tuple_decoder Zshift_to_pow zsimplify push_Zpow;
      Z.rewrite_mod_small;
      try reflexivity.

    Global Instance mul_double_is_multiply_low_low : is_mul_low_low n mul_double_multiply_low_low.
    Proof using Type*. t. Qed.
    Global Instance mul_double_is_multiply_high_low : is_mul_high_low n mul_double_multiply_high_low.
    Proof using Type*. t. Qed.
    Global Instance mul_double_is_multiply_high_high : is_mul_high_high n mul_double_multiply_high_high.
    Proof using Type*. t. Qed.
  End half_from_full.
End tuple2.


From Hammer Require Import Hammer.

Require Export Decidable.
Require Export ZAxioms.
Require Import NZProperties.

Module ZBaseProp (Import Z : ZAxiomsMiniSig').
Include NZProp Z.

Theorem pred_inj : forall n m, P n == P m -> n == m.
Proof. hammer_hook "ZBase" "ZBase.ZBaseProp.pred_inj".
intros n m H. apply succ_wd in H. now rewrite 2 succ_pred in H.
Qed.

Theorem pred_inj_wd : forall n1 n2, P n1 == P n2 <-> n1 == n2.
Proof. hammer_hook "ZBase" "ZBase.ZBaseProp.pred_inj_wd".
intros n1 n2; split; [apply pred_inj | intros; now f_equiv].
Qed.

Lemma succ_m1 : S (-1) == 0.
Proof. hammer_hook "ZBase" "ZBase.ZBaseProp.succ_m1".
now rewrite one_succ, opp_succ, opp_0, succ_pred.
Qed.

End ZBaseProp.


Variable A : Type.

Inductive Obj : Type :=
| base : A -> Obj
| terminal : Obj
| prod : Obj -> Obj -> Obj
| exp  : Obj -> Obj -> Obj
.

Coercion base : A >-> Obj.

Notation "a 'x' b" := (prod a b) (at level 32).

(* Variables a b : A. *)

(* Check (a x b). *)

Notation "a ==> b" := (exp a b)(at level 33, right associativity).

Notation "1" := terminal.

(* Check (a ==> b x 1). *)

(* This is the "type theoretic" version, which
   implicitely uses Yoneda everywhere... *)
Inductive Mor : Obj -> Obj -> Type :=
| ident : forall {a}, Mor a a
| comp  : forall {a b c}, Mor a b -> Mor b c -> Mor a c
| final : forall a, Mor a 1
| pair  : forall {g a b}, Mor g a -> Mor g b -> Mor g (a x b)
| pi_1  : forall {g a b}, Mor g (a x b) -> Mor g a
| pi_2  : forall {g a b}, Mor g (a x b) -> Mor g b
| lam   : forall {g a b}, Mor (g x a) b -> Mor g (a ==> b)
| app   : forall {g a b}, Mor g (a ==> b) -> Mor g a -> Mor g b
.

(* No notion of opp! Or indeed, Mor actions *)
Definition Psh := Obj -> Type.

(* But we can define what it means to have one! *)
Definition map_F (F : Psh) := forall a b (f : Mor a b), F b -> F a.

Definition Yoneda : Obj -> Psh :=
  fun a => (fun b => Mor b a).

Definition transport_y : forall a b (f : Mor a b),
    forall c, Yoneda a c -> Yoneda b c.
Proof.
  unfold Yoneda; intros.
  eapply comp; eauto.
Defined.

Print transport_y.

Definition map_y : forall a, map_F (Yoneda a).
Proof.
  intros.
  unfold map_F.
  unfold Yoneda.
  intros.
  exact (comp f X).
Defined.

Print map_y.

Open Scope type_scope.

Definition Nat (F G : Psh) : Type := forall a, F a -> G a.

Definition Exp : Psh -> Psh -> Psh :=
  fun F G a =>
    forall b, (Yoneda a b * F b -> G b).

Definition map_exp : forall F G, map_F F -> map_F G -> map_F (Exp F G).
Proof.
  unfold map_F.
  intros F G map_f map_g c1 c2 f.
  unfold Exp.
  intros alpha d.
  generalize (transport_y _ _ f d).
  intros y_f [g m].
  pose (h := (y_f g)).
  apply alpha; auto.
Defined.

Fixpoint obj_interp (a : Obj) : Psh :=
  match a with
  | base a => Yoneda a
  | 1 => (fun o => unit)
  | a x b => fun o => (obj_interp a o) * (obj_interp b o)
  | a ==> b => Exp (obj_interp a) (obj_interp b)
  end.

Definition map_obj_interp : forall a, map_F (obj_interp a).
Proof.
  induction a; generalize map_y; unfold map_F; simpl.
  - intros.
    eapply X; [exact f| exact X0].
  - intros.
    exact H.
  - unfold map_F in *.
    intros.
    destruct X0.
    split; [eapply IHa1; [exact f| exact o] | eapply IHa2; [exact f| exact o0]].
  - intros.
    generalize (map_exp (obj_interp a1) (obj_interp a2)).
    unfold map_F in *.
    intros.
    eapply X1; intros; eauto.
Defined.

Print map_obj_interp.

Notation "〚 a 〛" := (obj_interp a).

Definition reify_y : forall {a b}, Nat (Yoneda a) (Yoneda b) -> Mor a b.
Proof.
  intros a b; unfold Nat.
  intros transp; apply (transp _ ident).
Defined.

Definition mor_interp {a b} (f: Mor a b) : Nat 〚 a 〛 〚 b 〛.
Proof.
  induction f; unfold Nat; simpl.
  - intros a0 m; exact m.
  - intros g m.
    unfold Nat in *.
    apply IHf2.
    apply IHf1.
    exact m.
  - intros.
    exact tt.
  - intros.
    split.
    + apply IHf1.
      exact X.
    + apply IHf2; exact X.
  - unfold Nat in *; simpl in *.
    apply IHf.
  - unfold Nat in *; simpl in *.
    apply IHf.
  - unfold Exp.
    unfold Nat in *.
    simpl in *.
    intros.
    apply IHf; auto.
    destruct X0 as (m, n); split; [|exact n].
    eapply map_obj_interp; [exact m| exact X].
  - unfold Nat in *; simpl in *; unfold Exp in *.
    intros.
    eapply IHf1; [exact X|].
    split; [exact ident| apply IHf2; exact X].
Defined.

Print mor_interp.

Notation "(| f |)" := (mor_interp f).

Definition id_Nat : forall F, Nat F F.
Proof.
  unfold Nat; intros; firstorder.
Defined.

Hint Resolve id_Nat.

Definition comp_Nat : forall {F G H}, Nat F G -> Nat G H -> Nat F H.
Proof.
  unfold Nat; intros; auto.
Defined.

Print comp_Nat.

(* This should exist by fiat? *)
Definition q_q_inv {a} : Nat 〚 a 〛 (Yoneda a)
                         *
                         Nat (Yoneda a) 〚 a 〛.
Proof.
  induction a; split; simpl; unfold Nat; unfold Yoneda.
  - intros b f; exact f.
  - intros b f; exact f.
  - intros.
    apply final.
  - intros; exact tt.
  - intros a [f g]; apply pair.
    + apply IHa1; auto.
    + apply IHa2; auto.
  - intros.
    split.
    + apply IHa1.
      eapply pi_1; eauto.
    + apply IHa2; eapply pi_2; eauto.
  - intros; apply lam.
    apply IHa2.
    apply X.
    split.
    + eapply pi_1; exact ident.
    + apply IHa1.
      eapply pi_2; exact ident.
  - intros.
    unfold Exp.
    intros b [f m]; apply IHa2.
    eapply app.
    + eapply transport_y.
      -- exact X.
      -- exact f.
    + apply IHa1.
      exact m.
Defined.

Notation "'q'" := (fst q_q_inv).

Notation "'q⁻'" := (snd q_q_inv).

Check q⁻.
Check q.

Check comp_Nat.

Check reify_y.

Print reify_y.

Check comp_Nat.

Notation "m ∘ n" := (comp_Nat n m)(at level 50).

Check q⁻.

Definition nf {a b : Obj} (f : Mor a b) :=
  let up_down := q ∘ (| f |) ∘ q⁻
  in
  reify_y up_down
.

  (* q _ ( (| f |) _ (q⁻ _ ident)). *)

Check nf.

Variable a b : A.

Definition test : Mor 1 (a ==> a).
Proof.
  apply lam.
  eapply comp.
  eapply pi_2.
  exact ident.
  apply ident.
Defined.

Definition test' : Mor 1 (a ==> a).
Proof.
  apply lam.
  eapply pi_2; apply ident.
Defined.

Goal (nf test = nf test').
Proof.
  vm_compute.
  reflexivity.
Qed.

Definition test'' : Mor 1 (a ==> b ==> b x a).
Proof.
  apply lam.
  apply lam.
  eapply pair.
  - eapply pi_2.
    exact ident.
  - eapply pi_2.
    eapply pi_1.
    exact ident.
Defined.

Definition test''' : Mor (a ==> b ==> b x a) (a ==> b ==> a).
Proof.
  apply lam.
  apply lam.
  eapply pi_2.
  eapply app.
  eapply app.
  eapply pi_1.
  eapply pi_1.
  exact ident.
  eapply pi_2.
  eapply pi_1.
  exact ident.

  eapply pi_2.
  exact ident.
Defined.

Print test'.

Definition test'''' : Mor 1 (a ==> b ==> a).
Proof.
  apply lam.
  apply lam.
  eapply pi_2.
  eapply pi_1.
  exact ident.
Defined.

Check test''.

Definition foo := comp test'' test'''.

Check (q⁻ _ ident).

Check ((| foo |) _ (q⁻ _ ident)).

Eval compute in ( q _ ((| foo |) _ (q⁻ _ ident))).

Eval compute in nf (nf foo).

Eval vm_compute in comp test'' test'''.
(* Set Printing Implicit. *)
Eval vm_compute in (nf (comp test'' test''')).
Eval vm_compute in (nf (nf (comp test'' test'''))).
Eval vm_compute in (nf test'''').

Goal (nf (comp test'' test''') = nf test'''').
  vm_compute.
  (* Uh oh *)
  Fail reflexivity.
Abort.

Definition blah : Mor a a.
  eapply pi_1.
  eapply pi_1.
  eapply comp.
  eapply pair.
  eapply pair.
  exact ident.
  exact ident.
  exact ident.
  exact ident.
Defined.

Print blah.

Eval compute in (nf blah).


Require Import Setoid.
Require Import Morphisms.

Require Import Tactical.Propositional.
Require Import Tactical.Misc.
From Classes Require Import Classes.

Set Implicit Arguments.
Generalizable All Variables.
(* for compatibility with coq master *)
Set Warnings "-undeclared-scope".

Section OutputRelations.

  (* an output relation: a heterogeneous relation from [A] to [B] that also
  emits some value of type [T] *)
  Definition relation A B T := A -> B -> T -> Prop.

  (** Several operations on relations *)
  Definition and_then {A B C} {T1 T2}
             (r1: relation A B T1)
             (r2: T1 -> relation B C T2) :
    relation A C T2 :=
    fun x z o2 => exists o1 y, r1 x y o1 /\ (r2 o1) y z o2.

  Notation "p1 ;; p2" := (and_then p1 (fun _ => p2))
                           (at level 55, p2 at next level, right associativity).
  Notation "x <- p1 ; p2" := (and_then p1 (fun x => p2))
                               (at level 54, right associativity).

  Definition pure A T (o0:T) : relation A A T :=
    fun x y o => x = y /\ o = o0.

  Definition identity {A} {T} : relation A A T :=
    fun x y o => x = y.

  Definition any {A B} {T} : relation A B T :=
    fun x y o => True.

  Definition reads {A} {T} (f: A -> T) : relation A A T :=
    fun x y o => o = f x /\ x = y.

  Definition puts {A} (f: A -> A) : relation A A unit :=
    fun x y o => y = f x.

  Definition predicate A := A -> Prop.
  Definition test {A} (P: predicate A) : relation A A unit :=
    fun x y _ => P x /\ x = y.

  Definition rel_or A B T (r1 r2: relation A B T) : relation A B T :=
    fun x y o => r1 x y o \/ r2 x y o.

  Infix "+" := rel_or.

  Inductive seq_star A `(r: relation A A T) : relation A A T :=
  | seq_star_refl : forall x o,
      seq_star r x x o
  | seq_star_one_more : forall x y z o1 o2,
      r x y o1 ->
      seq_star r y z o2 ->
      (* TODO: rewrite to return the value from the last iteration *)
      seq_star r x z o2
  .

  (* at-least-once iteration *)
  Inductive seq_plus A `(r: relation A A T) : relation A A T :=
  | seq_plus_once : forall x y o,
      r x y o ->
      seq_plus r x y o
  | seq_plus_one_more : forall x y z o1 o2,
      r x y o1 ->
      seq_plus r y z o2 ->
      seq_plus r x z o2.

  Inductive bind_star A `(r: T -> relation A A T) : T -> relation A A T :=
  | bind_star_pure : forall (o:T) x,
      bind_star r o x x o
  | bind_star_one_more : forall (o1:T) x y z o2 o3,
      r o1 x y o2 ->
      bind_star r o2 y z o3 ->
      bind_star r o1 x z o3
  .

  Inductive bind_star_r A `(r: T -> relation A A T) : T -> relation A A T :=
  | bind_star_r_pure : forall (o:T) x,
      bind_star_r r o x x o
  | bind_star_r_one_more : forall (o1:T) x y z o2 o3,
      bind_star_r r o1 x y o2 ->
      r o2 y z o3 ->
      bind_star_r r o1 x z o3
  .

  (** Notions of equivalence and implication *)

  Definition rimpl {A B} {T} (r1 r2: relation A B T) :=
    forall x y o, r1 x y o -> r2 x y o.

  Global Instance rimpl_preorder {A B} T : PreOrder (rimpl (A:=A) (B:=B) (T:=T)) :=
    ltac:(firstorder).

  Definition requiv {A B} {T} (r1 r2: relation A B T) :=
    forall x y o, r1 x y o <-> r2 x y o.

  Global Instance requiv_equivalence {A B T} : Equivalence (requiv (A:=A) (B:=B) (T:=T)) :=
    RelInstance.

  Infix "--->" := rimpl (at level 60, no associativity).
  Infix "<--->" := requiv (at level 60, no associativity).

  Global Instance rimpl_requiv_sub {A B T} : subrelation (requiv (A:=A) (B:=B) (T:=T)) rimpl :=
    ltac:(firstorder).

  Global Instance rimpl_proper_basics_flip A B T (r: relation A B T) :
    Proper
      (Basics.flip rimpl ==> Basics.flip Basics.impl) (rimpl r) :=
    ltac:(firstorder).

  Theorem rimpl_to_requiv A B T (r1 r2: relation A B T) :
    r1 ---> r2 ->
    r2 ---> r1 ->
    r1 <---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpl1 A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r1 ---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpl2 A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r2 ---> r1.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpls A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r1 ---> r2 /\ r2 ---> r1.
  Proof.
    firstorder.
  Qed.

  Hint Immediate rimpl_to_requiv requiv_to_rimpl1 requiv_to_rimpl2 : core.

  (* we define an ordering over relations ---> in a natural way for relations,
  but the definition is equivalent to starting with equivalence [<--->] and
  defining [r1 <= r2 := r1 + r2 <---> r2] *)
  Theorem rimpl_or A B T (r1 r2: relation A B T) :
    r1 ---> r2 ->
    r1 + r2 <---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem rel_or_to_rimpl A B T (r1 r2: relation A B T) :
    r1 + r2 <---> r2 ->
    r1 ---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem rel_forall_intro A B T X (r : relation A B T) (rpred: X -> relation A B T) :
    (forall x, r ---> (rpred x)) ->
    r ---> (fun a b t => forall x, rpred x a b t).
  Proof.
    firstorder.
  Qed.

  (** Various equivalence and implication proofs *)
  Hint Unfold Proper respectful pointwise_relation : t.
  Hint Unfold Basics.flip Basics.impl : t.
  Hint Unfold and_then rel_or pure any identity reads : t.

  Ltac t :=
    autounfold with t;
    repeat match goal with
           | |- _ <---> _ => split
           | |- _ ---> _ => unfold "--->"
           | [ H: ?r <---> _,
                  H': ?r ?x ?y ?o |- _ ] =>
             add_hypothesis (proj1 (H x y o) H')
           | [ H: _ <---> ?r,
                  H': ?r ?x ?y ?o |- _ ] =>
             add_hypothesis (proj2 (H x y o) H')
           | [ H: ?r ---> _,
                  H': ?r ?x ?y ?o |- _ ] =>
             add_hypothesis (H x y o H')
           | [ u: unit |- _ ] => destruct u
           | [ |- exists (_:unit), _ ] => exists tt
           | _ => progress propositional
           | _ => solve [ eauto 10 ]
           | [ H: _ \/ _  |- _ ] => destruct H
        end.

  (* first some respectful/congruence rules *)
  Global Instance or_respects_equiv {A B T} :
    Proper (requiv ==> requiv ==> requiv) (rel_or (A:=A) (B:=B) (T:=T)).
  Proof.
    t.
  Qed.

  Global Instance or_respects_impl {A B T} :
    Proper (rimpl ==> rimpl ==> rimpl) (rel_or (A:=A) (B:=B) (T:=T)).
  Proof.
    t.
  Qed.

  Theorem and_then_monotonic A B C T1 T2
          (r1 r1': relation A B T1) (r2 r2': T1 -> relation B C T2) :
    r1 ---> r1' ->
    (forall x, r2 x ---> r2' x) ->
    and_then r1 r2 ---> and_then r1' r2'.
  Proof.
    t.
    specialize (H0 o1); t.
  Qed.

  Theorem and_then_monotonic_wit A B C T1 T2
          (r1 r1': relation A B T1) (r2 r2': T1 -> relation B C T2) :
    r1 ---> r1' ->
    (forall a b x, r1 a b x -> (r2 x ---> r2' x)) ->
    and_then r1 r2 ---> and_then r1' r2'.
  Proof.
    t.
    specialize (H0 x y0 o1) as H0.
    t.
  Qed.

  Global Instance and_then_respectful {A B C T1 T2} :
    Proper (rimpl ==> pointwise_relation _ rimpl ==> rimpl) (and_then (A:=A) (B:=B) (C:=C) (T1:=T1) (T2:=T2)).
  Proof.
    unfold Proper, "==>"; intros.
    apply and_then_monotonic; auto.
  Qed.

  Theorem and_then_equiv_cong A B C T1 T2
          (r1 r1': relation A B T1)
          (r2 r2': T1 -> relation B C T2) :
    r1 <---> r1' ->
    (forall x, r2 x <---> r2' x) ->
    and_then r1 r2 <---> and_then r1' r2'.
  Proof.
    t.
    specialize (H0 o1); t.
    specialize (H0 o1); t.
  Qed.

  Theorem and_then_cong_l A B C T1 T2
          (r1 r1': relation A B T1)
          (r2: T1 -> relation B C T2) :
    r1 <---> r1' ->
    and_then r1 r2 <---> and_then r1' r2.
  Proof.
    t.
  Qed.

  Theorem and_then_cong_r A B C T1 T2
          (r1: relation A B T1)
          (r2 r2': T1 -> relation B C T2) :
    (forall x, r2 x <---> r2' x) ->
    and_then r1 r2 <---> and_then r1 r2'.
  Proof.
    intros.
    apply and_then_equiv_cong; try reflexivity; eauto.
  Qed.

  Theorem bind_identity1 A B T1 T2 (r: relation A B T2) :
    (_ <- identity (T:=T1); r) ---> r.
  Proof.
    t.
  Qed.

  Theorem bind_identity A B T1 T2 (r: relation A B T2) (_:Default T1) :
    (_ <- identity (T:=T1); r) <---> r.
  Proof.
    t.
  Qed.

  Theorem reads_identity A T (f: A -> T) :
    reads f ---> identity.
  Proof.
    t.
  Qed.

  Global Instance and_then_respectful_equiv {A B C T1 T2} :
    Proper (requiv ==> pointwise_relation _ requiv ==> requiv) (and_then (A:=A) (B:=B) (C:=C) (T1:=T1) (T2:=T2)).
  Proof.
    unfold Proper, "==>"; intros.
    apply and_then_equiv_cong; auto.
  Qed.

  Hint Constructors seq_star : core.

  Global Instance seq_star_respectful {A T} :
    Proper (rimpl ==> rimpl) (seq_star (A:=A) (T:=T)).
  Proof.
    t.
    induction H0; eauto.
  Qed.

  Global Instance seq_star_equiv_respectful {A T} :
    Proper (requiv ==> requiv) (seq_star (A:=A) (T:=T)).
  Proof.
    t.
    eapply seq_star_respectful; eauto.
    eapply seq_star_respectful; eauto.
  Qed.

  Hint Constructors bind_star : core.

  Global Instance bind_star_respectful {A T} :
    Proper (pointwise_relation _ rimpl ==> eq ==> rimpl) (bind_star (A:=A) (T:=T)).
  Proof.
    t.
    induction H0; eauto.
    specialize (H o1); eauto.
  Qed.

  Global Instance bind_star_equiv_respectful {A T} :
    Proper (pointwise_relation _ requiv ==> eq ==> requiv) (bind_star (A:=A) (T:=T)).
  Proof.
    t.
    - induction H0; eauto.
      specialize (H o1).
      apply requiv_to_rimpls in H; propositional; eauto.
    - induction H0; eauto.
      specialize (H o1).
      apply requiv_to_rimpls in H; propositional; eauto.
  Qed.

  Theorem and_then_monotonic_r A B C T1 T2
          (r1 r2: relation A B T1) (rx: T1 -> relation B C T2) :
    r1 ---> r2 ->
    and_then r1 rx ---> and_then r2 rx.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Theorem rel_or_symmetric A B T (r1 r2: relation A B T) :
    r1 + r2 <---> r2 + r1.
  Proof.
    t.
  Qed.

  Theorem rel_or_assoc A B T (r1 r2 r3: relation A B T) :
    r1 + (r2 + r3) <---> r1 + r2 + r3.
  Proof.
    t.
  Qed.

  Theorem rel_or_idem A B T (r: relation A B T) :
    r + r <---> r.
  Proof.
    t.
  Qed.

  Theorem rel_or_monotonic A B T (r1 r2: relation A B T) r :
    r1 ---> r2 ->
    r1 + r ---> r2 + r.
  Proof.
    t.
  Qed.

  Theorem rel_or_introl A B T (r1 r2: relation A B T) :
    r1 ---> r1 + r2.
  Proof.
    t.
  Qed.

  Theorem rel_or_intror A B T (r1 r2: relation A B T) :
    r2 ---> r1 + r2.
  Proof.
    t.
  Qed.

  Theorem rel_or_elim A B T (r1 r2: relation A B T) r :
    r1 ---> r ->
    r2 ---> r ->
    r1 + r2 ---> r.
  Proof.
    t.
  Qed.

  Theorem rel_or_elim_rx A B T (r1 r2: relation A B T)
          C T' (rx: T -> relation B C T') r :
    and_then r1 rx ---> r ->
    and_then r2 rx ---> r ->
    and_then (r1 + r2) rx ---> r.
  Proof.
    t.
  Qed.

  Theorem bind_left_id A B T1 T2 (v:T1) (r: T1 -> relation A B T2) :
    and_then (pure v) r <---> r v.
  Proof.
    t.
  Qed.

  Theorem bind_right_id A T (r: relation A A T) :
    and_then r (@pure A T) <---> r.
  Proof.
    t.
  Qed.

  (* pure tt is also the right identity for relations at output type T *)
  Theorem bind_right_id_unit A (r: relation A A unit) :
    and_then r (fun _ => pure tt) <---> r.
  Proof.
    t.
  Qed.

  Theorem bind_assoc
          A B C D
          T1 T2 T3
          (r1: relation A B T1)
          (r2: T1 -> relation B C T2)
          (r3: T2 -> relation C D T3) :
    and_then (and_then r1 r2) r3 <--->
             and_then r1 (fun v => and_then (r2 v) r3).
  Proof.
    t.
  Qed.

  Theorem to_any A B T (r: relation A B T) :
    r ---> any.
  Proof.
    t.
  Qed.

  Theorem identity_to_any A :
    pure tt ---> any (A:=A).
  Proof.
    t.
  Qed.

  Theorem any_idem A B C T1 T2 :
    any (B:=B) (T:=T1);; any --->
        any (A:=A) (B:=C) (T:=T2).
  Proof.
    t.
  Qed.

  Theorem seq_star_to_bind_star : forall A (r: relation A A unit),
      seq_star r <---> bind_star (fun _ => r) tt.
  Proof.
    t.
    - induction H; t.
    - induction H; t.
  Qed.

  Lemma bind_star_fun_ext A T (r r': T -> relation A A T) (init: T) :
    (forall x, r x <---> r' x) ->
    bind_star r init <---> bind_star r' init.
  Proof.
    t.
    - induction H0; eauto.
      specialize (H o1); t.
    - induction H0; eauto.
      specialize (H o1); t.
  Qed.

  Theorem bind_star_unit A (r: unit -> relation A A unit) u :
      bind_star r u <---> seq_star (r tt).
  Proof.
    intros.
    destruct u.
    rewrite seq_star_to_bind_star.
    apply bind_star_fun_ext; intros.
    destruct x; reflexivity.
  Qed.

  Theorem bind_star_expand A T (r: T -> relation A A T) (v:T) :
    pure v + and_then (r v) (bind_star r) <---> bind_star r v.
  Proof.
    t.
    induction H; eauto.
  Qed.

  Global Instance rimpl_equiv_proper A B T (r: relation A B T) :
    Proper (requiv ==> Basics.flip Basics.impl) (rimpl r).
  Proof.
    t.
  Qed.

  Global Instance rimpl_equiv_applied_proper A B T :
    Proper (requiv ==> requiv ==> iff) (rimpl (A:=A) (B:=B) (T:=T)).
  Proof.
    t.
    split; t.
  Qed.

  Definition rimpl_refl A B T (r: relation A B T) : r ---> r := ltac:(reflexivity).
  Definition requiv_refl A B T (r: relation A B T) : r <---> r := ltac:(reflexivity).

  Hint Resolve rimpl_refl requiv_refl : core.

  Theorem bind_dist_r A B C T1 T2 (r1 r2: relation A B T1) (r3: T1 -> relation B C T2) :
    and_then (r1 + r2) r3 <---> (and_then r1 r3) + (and_then r2 r3).
  Proof.
    t.
  Qed.

  Theorem bind_dist_l A B C T1 T2 (r1: relation A B T1) (r2 r3: T1 -> relation B C T2) :
    and_then r1 (fun v => r2 v + r3 v) <---> and_then r1 r2 + and_then r1 r3.
  Proof.
    t.
  Qed.

  Theorem star_ind A T (r x: relation A A T) :
    identity ---> x ->
    r;; x ---> x ->
    seq_star r ---> x.
  Proof.
    t.
    induction H1; eauto.
  Qed.

  Theorem star_expand A T (r: relation A A T) :
    seq_star r <---> identity + (r;; seq_star r).
  Proof.
    apply rimpl_to_requiv.
    - apply star_ind; t.
    - t.
  Qed.

  Theorem seq_star1 A T (r: relation A A T) :
    r;; seq_star r ---> seq_star r.
  Proof.
    t.
  Qed.

  Theorem seq_star_fold A T (r r': relation A A T) :
    r' ---> r ->
    r';; seq_star r ---> seq_star r.
  Proof.
    t.
  Qed.

  Theorem seq_star_none A T (r: relation A A T) :
    identity ---> seq_star r.
  Proof.
    t.
  Qed.

  Theorem seq_star_one A T (r: relation A A T) :
    r ---> seq_star r.
  Proof.
    t.
  Qed.

  Hint Constructors seq_plus : core.

  Theorem plus_one `(r: relation A A T) :
    r ---> seq_plus r.
  Proof.
    t.
  Qed.

  Theorem plus_expand A T (r: relation A A T) :
    seq_plus r <---> r + (r;; seq_plus r).
  Proof.
    t.
    induction H; eauto.
  Qed.

  Inductive seq_plus_r `(r: relation A A T) : relation A A T :=
  | seq_plus_r_once : forall x y o,
      r x y o ->
      seq_plus_r r x y o
  | seq_plus_r_one_more : forall x y z o1 o2,
      seq_plus_r r x y o1 ->
      r y z o2 ->
      seq_plus_r r x z o2.

  Hint Constructors seq_plus_r : core.

  Theorem seq_plus_lr `(r: relation A A T) :
    seq_plus r <---> seq_plus_r r.
  Proof.
    t.
    - induction H; eauto.
      clear H0.
      induction IHseq_plus; eauto.
    - induction H; eauto.
      clear H.
      induction IHseq_plus_r; eauto.
  Qed.

  Theorem plus_expand_r A T (r: relation A A T) :
    seq_plus r <---> r + (seq_plus r;; r).
  Proof.
    rewrite seq_plus_lr.
    t.
    induction H; eauto.
  Qed.

  Global Instance and_then_pointwise A B C T1 T2 (r: relation A B T1) :
    Proper (pointwise_relation _ (Basics.flip rimpl) ==> Basics.flip (rimpl (B:=C) (T:=T2)))
           (and_then r).
  Proof.
    t.
    specialize (H o1); t.
  Qed.

  Theorem star_duplicate A T (r: relation A A T) :
    seq_star r <---> seq_star r;; seq_star r.
  Proof.
    t.
    induction H; t.
  Qed.

  Theorem star_one A T (r: relation A A T) :
    r ---> seq_star r.
  Proof.
    t.
  Qed.

  Lemma star_monotonic A T (r1 r2: relation A A T) :
    r1 ---> r2 ->
    seq_star r1 ---> seq_star r2.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Lemma star_congruent A T (r1 r2: relation A A T) :
    r1 <---> r2 ->
    seq_star r1 <---> seq_star r2.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Lemma bind_star_congruent A T (r1 r2: T -> relation A A T) (v:T) :
    (forall v, r1 v <---> r2 v) ->
    bind_star r1 v <---> bind_star r2 v.
  Proof.
    intros.
    apply bind_star_equiv_respectful; auto.
  Qed.

  Ltac cong :=
    let solver := try reflexivity; try solve [ t ] in
    match goal with
    | |- and_then _ _ ---> and_then _ _ =>
      apply and_then_monotonic; intros;
      solver
    | |- seq_star _ ---> seq_star _ =>
      apply star_monotonic;
      solver
    end.

  Theorem denesting A T (r1 r2: relation A A T) :
    seq_star (r1 + r2) <--->
             seq_star r1;; (seq_star (r2;; seq_star r1)).
  Proof.
    apply rimpl_to_requiv.
    - apply star_ind; t.
    - setoid_rewrite star_duplicate at 4; cong.
      cong.

      apply star_ind; try solve [ t ].
      setoid_rewrite star_duplicate at 3; cong.

      setoid_rewrite star_duplicate at 2; cong.
      cong.

      Unshelve.
      all: trivial.
  Qed.

  Theorem bind_sliding A T1 (p: relation A A T1) (q: T1 -> relation A A unit) :
    seq_star (and_then p q);; p <--->
             v <- p; bind_star (fun v0 => q v0;; p) v.
  Proof.
    apply rimpl_to_requiv.
    - t.
      gen y.
      induction H; t.
      specialize (IHseq_star _ ltac:(eauto)); t.
    - t.
      gen x.
      induction H0; t.
      specialize (IHbind_star _ ltac:(eauto)); t.
  Qed.

  Theorem seq_sliding A T1 (p: relation A A T1) (q: relation A A unit) :
    seq_star (p;; q);; p --->
             p;; seq_star (q;; p).
  Proof.
    t.
    gen y.
    induction H; t.
    specialize (IHseq_star _ ltac:(eauto)); t.
  Qed.

  Theorem seq_unit_sliding A (p: relation A A unit) (q: relation A A unit) :
    p;; seq_star (q;; p) --->
     seq_star (p;; q);; p.
  Proof.
    t.
    gen x.
    induction H0; t.
    specialize (IHseq_star _ ltac:(eauto)); t.
  Qed.

  Theorem seq_plus_precise A T1 (p: relation A A T1) (q: relation A A unit) :
    seq_plus (p;; q);; p <---> p ;; seq_plus (q;; p).
  Proof.
    t.
    - gen y o.
      induction H; t.
      specialize (IHseq_plus _ _ ltac:(eauto)); t.
    - gen x o1.
      induction H0; t.
      specialize (IHseq_plus _ _ ltac:(eauto)); t.
  Qed.

  Theorem seq_plus_to_seq_star A B T (p: relation A A unit) (r: relation A B T) :
    seq_plus p;; r <---> p;; seq_star p;; r.
  Proof.
    t.
    - induction H; t.
    - gen x y o.
      induction H1; t.
      specialize (IHseq_star _ ltac:(eauto)).
      specialize (IHseq_star _ _ ltac:(eauto)); t.
  Qed.

  Theorem seq_sliding_precise A T1 (p: relation A A T1) (q: relation A A unit) :
    seq_star (p;; q);; p <---> p + (p ;; seq_plus (q;; p)).
  Proof.
    t.
    - gen y o.
      induction H; t.
      specialize (IHseq_star _ _ ltac:(eauto)); t.
    - gen x o1.
      induction H0; t.
      specialize (IHseq_plus _ _ ltac:(eauto)); t.
  Qed.

  Theorem bind_unit A B C T (p: relation A B unit) (q: unit -> relation B C T) :
    and_then p q <---> p;; q tt.
  Proof.
    t.
  Qed.

  Inductive seq_star_r A `(r: relation A A T) : relation A A T :=
  | seq_star_r_refl : forall x o,
      seq_star_r r x x o
  | seq_star_r_one_more : forall x y z o1 o2,
      seq_star_r r x y o1 ->
      r y z o2 ->
      seq_star_r r x z o1.

  Hint Constructors seq_star_r : core.

  Theorem seq_star_lr A `(r: relation A A T) :
    seq_star r <---> seq_star_r r;; identity.
  Proof.
    t.
    - induction H; propositional; eauto.
      clear H0.
      induction H1; propositional; eauto.
    - induction H; propositional; eauto.
      clear H.
      induction IHseq_star_r; propositional; eauto.
      Unshelve.
      all: auto.
  Qed.

  Hint Constructors bind_star_r : core.

  Theorem bind_star_lr A `(r: T -> relation A A T) (v:T) :
    bind_star r v <---> bind_star_r r v.
  Proof.
    t.
    - induction H; eauto.
      clear H0.
      induction IHbind_star; eauto.
    - induction H; eauto.
      clear H.
      induction IHbind_star_r; eauto.
  Qed.

  Theorem bind_star_expand_r `(r: T -> relation A A T) (v:T) :
    pure v + and_then (bind_star r v) r <---> bind_star r v.
  Proof.
    rewrite bind_star_lr.
    t.
    induction H; eauto.
  Qed.

  Theorem seq_star_ind_l A B T1 (q x: relation A B T1) T2 (p: relation A A T2) :
    q + and_then p (fun _ => x) ---> x ->
    and_then (seq_star p) (fun _ => q) ---> x.
  Proof.
    t.
    induction H0; intros; eauto 10.
  Qed.

  Theorem bind_star_ind_r A B T1 (q x: relation A B T1) (p: T1 -> relation B B T1) :
    q + and_then x p ---> x ->
    and_then q (bind_star p) ---> x.
  Proof.
    t.
    apply bind_star_lr in H1.
    induction H1; intros; eauto 10.
  Qed.

  Theorem simulation_seq A B
          (p: relation A B unit)
          (q: relation B B unit)
          (r: relation A A unit) :
    p;; q ---> r;; p ->
    p;; seq_star q ---> seq_star r;; p.
  Proof.
    setoid_rewrite seq_star_lr.
    t.
    induction H1; propositional.
    - eauto 10.
    - repeat match goal with
             | [ u: unit |- _ ] => destruct u
             end.
      unfold rimpl in H; simpl in *.
      specialize (H y0 z tt).
      match type of H with
      | ?P -> ?Q =>
        let HP := fresh in
        assert P as HP;
          [ | specialize (H HP) ]
      end; eauto; propositional.
      eauto 10.

      Unshelve.
      all: auto.
  Qed.

  Theorem simulation_seq_value A B T
          (p: relation A B unit)
          (q: relation B B T)
          (r: relation A A T) :
    p;; q ---> v <- r; (p;; pure v) ->
    p;; seq_star q ---> v <- seq_star r; (p;; pure v).
  Proof.
    setoid_rewrite seq_star_lr.
    t.
    induction H1; propositional.
    - eauto 15.
    - repeat match goal with
             | [ u: unit |- _ ] => destruct u
             end.
      unfold rimpl in H; simpl in *.
      specialize (H y0 z o2).
      match type of H with
      | ?P -> ?Q =>
        let HP := fresh in
        assert P as HP;
          [ | specialize (H HP) ]
      end; eauto; propositional.
      eauto 15.

      Unshelve.
      all: auto.
  Qed.

  (* some basic properties of tests *)
  Hint Unfold test : t.

  Theorem test_to_id A (P: predicate A) :
    test P ---> identity.
  Proof.
    t.
  Qed.

  Definition pred_and A (P1 P2: predicate A) : predicate A :=
    fun x => P1 x /\ P2 x.

  Hint Unfold pred_and : t.

  Theorem test_and A (P1 P2: predicate A) :
    test P1;; test P2 <---> test (pred_and P1 P2).
  Proof.
    t.
  Qed.

  Theorem test_idem A (P: predicate A) :
    test P;; test P <---> test P.
  Proof.
    t.
  Qed.

  Theorem test_identity A :
    identity (A:=A) <---> test (fun _ => True).
  Proof.
    t.
  Qed.

  Lemma unit_identity A :
    identity (A:=A) <---> pure tt.
  Proof.
    t.
  Qed.

End OutputRelations.

Module RelationNotations.
  (* Declare Scope relation_scope. *)
  Delimit Scope relation_scope with rel.
  Open Scope relation_scope.
  Notation "r1 ---> r2" := (rimpl r1 r2)
                             (at level 60, no associativity,
                              format "'[hv' r1  '/' ---> '/'  r2 ']'")
                           : relation_scope.
  Notation "r1 <---> r2" := (requiv r1 r2)
                              (at level 60, no associativity,
                               format "'[hv' r1  '/' <---> '/'  r2 ']'")
                            : relation_scope.
  Infix "+" := rel_or : relation_scope.

  Notation "p1 ;; p2" := (and_then p1 (fun _ => p2))
                           (at level 54, right associativity)
  : relation_scope.
  (* TODO: experiment more with printing boxes *)
  Notation "x <- p1 ; p2" := (and_then p1 (fun x => p2))
                              (at level 54, right associativity,
                               format "'[' x  <-  '[v    ' p1 ']' ; ']'  '/' p2")
                             : relation_scope.
End RelationNotations.


Require Export GeoCoq.Tarski_dev.Ch12_parallel.

Section Circle.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma inc112 : forall A B,
 InCircle A A B.
Proof.
  unfold InCircle.
  Le.
Qed.

Lemma onc212 : forall A B,
 OnCircle B A B.
Proof.
  unfold OnCircle.
  Cong.
Qed.

Lemma onc_sym : forall A B P, OnCircle P A B -> OnCircle B A P.
Proof.
  unfold OnCircle.
  Cong.
Qed.

Lemma ninc__outcs : forall X O P, ~ InCircle X O P -> OutCircleS X O P.
Proof.
intros.
unfold OutCircleS.
unfold InCircle in *.
apply nle__lt in H; auto.
Qed.

Lemma inc__outc : forall A B P, InCircle P A B <-> OutCircle B A P.
Proof.
  split; trivial.
Qed.

Lemma incs__outcs : forall A B P, InCircleS P A B <-> OutCircleS B A P.
Proof.
  split; trivial.
Qed.

Lemma onc__inc : forall A B P, OnCircle P A B -> InCircle P A B.
Proof.
unfold OnCircle, InCircle.
Le.
Qed.

Lemma onc__outc : forall A B P, OnCircle P A B -> OutCircle P A B.
Proof.
unfold OnCircle, OutCircle.
Le.
Qed.

Lemma inc_outc__onc : forall A B P, InCircle P A B -> OutCircle P A B -> OnCircle P A B.
Proof.
  intros A B P HIn HOut.
  apply le_anti_symmetry; trivial.
Qed.

Lemma incs__inc : forall A B P, InCircleS P A B -> InCircle P A B.
Proof.
unfold InCircleS, InCircle.
Le.
Qed.

Lemma outcs__outc : forall A B P, OutCircleS P A B -> OutCircle P A B.
Proof.
unfold OutCircleS, OutCircle.
Le.
Qed.

Lemma incs__noutc : forall A B P, InCircleS P A B <-> ~ OutCircle P A B.
Proof.
intros.
split; intro; [apply lt__nle|apply nle__lt]; assumption.
Qed.

Lemma outcs__ninc : forall A B P, OutCircleS P A B <-> ~ InCircle P A B.
Proof.
intros.
split; intro; [apply lt__nle|apply nle__lt]; assumption.
Qed.

Lemma inc__noutcs : forall A B P, InCircle P A B <-> ~ OutCircleS P A B.
Proof.
intros.
split; intro; [apply le__nlt|apply nlt__le]; assumption.
Qed.

Lemma outc__nincs : forall A B P, OutCircle P A B <-> ~ InCircleS P A B.
Proof.
intros.
split; intro; [apply le__nlt|apply nlt__le]; assumption.
Qed.

Lemma inc_eq : forall A P, InCircle P A A -> A = P.
Proof.
intros A B HIn.
apply le_zero with A; assumption.
Qed.

Lemma outc_eq : forall A B, OutCircle A A B -> A = B.
Proof.
intros A B HOut.
apply le_zero with A; assumption.
Qed.

Lemma onc2__cong : forall O P A B, OnCircle A O P -> OnCircle B O P -> Cong O A O B.
Proof.
unfold OnCircle.
intros O P A B H1 H2.
apply cong_transitivity with O P; Cong.
Qed.

End Circle.

#[global]
Hint Resolve inc112 onc212 onc_sym inc__outc onc__inc onc__outc
             inc_outc__onc incs__inc outcs__outc : circle.

Ltac Circle := auto with circle.

Ltac treat_equalities :=
treat_equalities_aux;
repeat
  match goal with
   | H : Cong ?X3 ?X3 ?X1 ?X2 |- _ =>
      apply cong_symmetry in H; apply cong_identity in H; smart_subst X2
   | H : Cong ?X1 ?X2 ?X3 ?X3 |- _ =>
      apply cong_identity in H;smart_subst X2
   | H : Bet ?X1 ?X2 ?X1 |- _ =>
      apply between_identity in H;smart_subst X2
   | H : Le ?X1 ?X2 ?X3 ?X3 |- _ =>
      apply le_zero in H;smart_subst X2
   | H : Midpoint ?X ?Y ?Y |- _ => apply l7_3 in H; smart_subst Y
   | H : Midpoint ?A ?B ?A |- _ => apply is_midpoint_id_2 in H; smart_subst A
   | H : Midpoint ?A ?A ?B |- _ => apply is_midpoint_id in H; smart_subst A
   | H : OnCircle ?A ?A ?B |- _ =>
      apply cong_reverse_identity in H;smart_subst B
   | H : OnCircle ?B ?A ?A |- _ =>
      apply cong_identity in H;smart_subst B
   | H : InCircle ?B ?A ?A |- _ =>
      apply le_zero in H;smart_subst B
   | H : OutCircle ?A ?A ?B |- _ =>
      apply le_zero in H;smart_subst B
   | H : Bet ?A ?B ?C, H2 : Bet ?B ?A ?C |- _ =>
     let T := fresh in assert (T : A=B) by (apply (between_equality A B C); Between);
                       smart_subst A
   | H : Bet ?A ?B ?C, H2 : Bet ?A ?C ?B |- _ =>
     let T := fresh in assert (T : B=C) by (apply (between_equality_2 A B C); Between);
                       smart_subst B
   | H : Bet ?A ?B ?C, H2 : Bet ?C ?A ?B |- _ =>
     let T := fresh in assert (T : A=B) by (apply (between_equality A B C); Between);
                       smart_subst A
   | H : Bet ?A ?B ?C, H2 : Bet ?B ?C ?A |- _ =>
     let T := fresh in assert (T : B=C) by (apply (between_equality_2 A B C); Between);
                       smart_subst A
   | H : Midpoint ?P ?A ?P1, H2 : Midpoint ?P ?A ?P2 |- _ =>
     let T := fresh in assert (T := symmetric_point_uniqueness A P P1 P2 H H2); smart_subst P1
   | H : Midpoint ?A ?P ?X, H2 : Midpoint ?A ?Q ?X |- _ =>
     let T := fresh in assert (T := l7_9 P Q A X H H2); smart_subst P
   | H : Midpoint ?A ?P ?X, H2 : Midpoint ?A ?X ?Q |- _ =>
     let T := fresh in assert (T := l7_9_bis P Q A X H H2); smart_subst P
   | H : Midpoint ?A ?P ?P', H2 : Midpoint ?B ?P ?P' |- _ =>
     let T := fresh in assert (T := l7_17 P P' A B H H2); smart_subst A
   | H : Midpoint ?A ?P ?P', H2 : Midpoint ?B ?P' ?P |- _ =>
     let T := fresh in assert (T := l7_17_bis P P' A B H H2); smart_subst A
end.

Ltac CongR :=
 let tpoint := constr:(Tpoint) in
 let cong := constr:(Cong) in
   treat_equalities; unfold OnCircle, Midpoint in *; spliter; Cong; Cong_refl tpoint cong.

Section Circle_2.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** If a point is strictly inside a segment of a disk, it is strictly inside the circle. *)

Lemma bet_inc2__incs : forall O P U V X,
 X <> U -> X <> V -> Bet U X V ->
 InCircle U O P -> InCircle V O P ->
 InCircleS X O P.
Proof.
intros O P U V X HUX HVX HBet HUIn HVIn.
destruct (le_cases O U O V).
- apply le3456_lt__lt with O V; trivial.
  apply lt_comm, (bet_le__lt U); Le.
- apply le3456_lt__lt with O U; trivial.
  apply lt_comm, (bet_le__lt V); Between; Le.
Qed.

Lemma bet_incs2__incs : forall O P U V X,
 Bet U X V -> InCircleS U O P -> InCircleS V O P ->
 InCircleS X O P.
Proof.
intros O P U V X HBet HUIn HVIn.
destruct (eq_dec_points X U).
  subst; assumption.
destruct (eq_dec_points X V).
  subst; assumption.
apply bet_inc2__incs with U V; Circle.
Qed.

(** If A and B are two points inside the circle, then all points on the segment AB are also
    in the circle, i.e. a circle is a convex figure.
*)

Lemma bet_inc2__inc : forall A B U V P, InCircle U A B -> InCircle V A B -> Bet U P V ->
  InCircle P A B.
Proof.
  intros A B U V P HU HV HBet.
  destruct (eq_dec_points P U).
    subst P; assumption.
  destruct (eq_dec_points P V).
    subst P; assumption.
  apply incs__inc, bet_inc2__incs with U V; assumption.
Qed.

(** Given two points U and V on a circle, the points of the line UV which are inside the circle are
    between U and V. *)

Lemma col_inc_onc2__bet : forall A B U V P, U <> V -> OnCircle U A B -> OnCircle V A B ->
  Col U V P -> InCircle P A B -> Bet U P V.
Proof.
  intros A B U V P HUV HU HV HCol HIn.
  destruct (eq_dec_points P U); [subst; Between|].
  destruct (eq_dec_points P V); [subst; Between|].
  assert (Cong A U A V) by (apply (onc2__cong A B); assumption).
  apply out2__bet; apply not_bet_out; Col; intro.
  - apply (bet_le__lt P V A U); Cong.
    apply (l5_6 A P A B); Cong.
  - apply (bet_le__lt P U A V); Between; Cong.
    apply (l5_6 A P A B); Cong.
Qed.

(** Given two points U and V on a circle, all points of line UV which are outside the segment UV are
    outside the circle. *)

Lemma onc2_out__outcs : forall A B U V P, U <> V -> OnCircle U A B -> OnCircle V A B -> Out P U V ->
  OutCircleS P A B.
Proof.
  intros A B U V P HUV HUOn HVOn HOut.
  apply outcs__ninc.
  intro HIn.
  apply (not_bet_and_out U P V).
  split; trivial.
  apply (col_inc_onc2__bet A B); Col.
Qed.

(** Given two points U and V inside a circle, all points of line UV which are outside the circle are
    outside the segment UV. *)

Lemma col_inc2_outcs__out : forall A B U V P, InCircle U A B -> InCircle V A B ->
  Col U V P -> OutCircleS P A B -> Out P U V.
Proof.
  intros A B U V P HUIn HVIn HCol HOut.
  apply not_bet_out; Col.
  intro HBet.
  apply outcs__ninc in HOut.
  apply HOut, bet_inc2__inc with U V; trivial.
Qed.

(** If the center of a circle belongs to a chord, then it is the midpoint of the chord. *)

Lemma col_onc2__mid : forall A B U V, U <> V -> OnCircle U A B -> OnCircle V A B ->
  Col U V A -> Midpoint A U V.
Proof.
  intros A B U V HUV HU HV HCol.
  split.
    apply (col_inc_onc2__bet A B); Circle.
    apply cong_transitivity with A B; Cong.
Qed.

(** Given a point U on a circle and a point P inside the circle, there is a point V such as
    UV is a chord of the circle going through P. *)

Lemma chord_completion : forall A B U P, OnCircle U A B -> InCircle P A B ->
  exists V, OnCircle V A B /\ Bet U P V.
Proof.
  intros A B U P HOn HIn.
  destruct (eq_dec_points U A).
    unfold OnCircle, InCircle in *|-.
    treat_equalities; exists U; split; Circle; Between.
  assert (HA' : exists A', U <> A' /\ Col U P A' /\ Per A A' U).
  { destruct (col_dec U P A) as [HCol|HNCol].
      exists A; split; Col; Perp.
    destruct (l8_18_existence U P A) as [A' [HCol HPerp]]; trivial.
    assert (U <> A').
    { intro; treat_equalities.
      assert_diffs.
      destruct (l11_46 P U A) as [_ HLt]; auto.
        left; Perp.
      apply lt__nle in HLt.
      apply HLt.
      apply (l5_6 A P A B); Cong.
    }
    exists A'; repeat split; trivial.
    apply l8_2, perp_per_1.
    apply perp_left_comm, perp_col with P; trivial.
  }
  destruct HA' as [A' [HUA' [HCol HPer]]].
  destruct (symmetric_point_construction U A') as [V HV].
  assert_diffs.
  assert (HCong := per_double_cong A A' U V HPer HV).
  assert (HVOn : OnCircle V A B).
    unfold OnCircle in *.
    apply cong_transitivity with A U; Cong.
  exists V; split; trivial.
  apply (col_inc_onc2__bet A B); trivial.
  ColR.
Qed.

(** Given a circle, there is a point strictly outside the circle. *)

Lemma outcs_exists : forall O P, exists Q, OutCircleS Q O P.
Proof.
intros.
induction(eq_dec_points O P).
subst P.
assert(HH:=another_point O).
ex_and HH Q.
exists Q.
unfold OutCircleS.
apply lt1123;auto.

assert(HH:=segment_construction O P O P).
ex_and HH Q.
exists Q.
split.
exists P.
split; Cong.
intro.
assert (P=Q) by eauto using between_cong.
treat_equalities;intuition.
Qed.

(** Given a circle of center O and a ray OX, there is a point on the ray
    which is also strictly outside the circle. *)

Lemma outcs_exists1 : forall O P X, X <> O -> exists Q, Out O X Q /\ OutCircleS Q O P.
Proof.
intros O P X HOX.
destruct (segment_construction O X O P) as [Q [HQ1 HQ2]].
exists Q; split.
  apply bet_out; auto.
split.
- apply le_comm.
  exists X.
  split; Between; Cong.
- intro.
  apply HOX.
  apply between_cong with Q; Between.
  apply cong_transitivity with O P; Cong.
Qed.

(** Given a circle there is a point which is strictly inside. *)

Lemma incs_exists : forall O P, O <> P -> exists Q, InCircleS Q O P.
Proof.
intros.
exists O.
apply lt1123;auto.
Qed.

(** Given a circle of center O and a ray OX, there is a point on the ray
    which is also strictly inside the circle. *)

Lemma incs_exists1 : forall O P X, X <> O -> P <> O -> exists Q, Out O X Q /\ InCircleS Q O P.
Proof.
intros O P X HOX HOP.
destruct (midpoint_existence O P) as [M HM].
destruct (segment_construction_3 O X O M) as [Q [HQ1 HQ2]]; auto.
  intro; treat_equalities; auto.
exists Q; split; auto.
apply (cong2_lt__lt O M O P); Cong.
apply mid__lt; auto.
Qed.

(** Given a circle of center O and a ray OX, there is a point on the ray which is also on the circle. *)

Lemma onc_exists : forall O P X,  X <> O -> O <> P -> exists Q, OnCircle Q O P /\ Out O X Q.
Proof.
intros.
assert(HH:=segment_construction_2 X O O P H).
ex_and HH Q.
exists Q.
split.
unfold OnCircle.
Cong.
unfold Out.
repeat split; auto.
intro.
subst Q.
treat_equalities; tauto.
Qed.

(** Given a circle of center O and a line OX, O is between two points of the line
    which are also on the circle. *)

Lemma diam_points : forall O P X, exists Q1 Q2,
  Bet Q1 O Q2 /\ Col Q1 Q2 X /\ OnCircle Q1 O P /\ OnCircle Q2 O P.
Proof.
intros O P X.
destruct (eq_dec_points X O).
  subst X.
  destruct (segment_construction P O O P) as [P' [HP'1 HP'2]].
  exists P, P'; repeat split; Col; Circle.
destruct (eq_dec_points O P).
  subst P.
  exists O, O; repeat split; finish.
assert(HH:= onc_exists O P X H H0).
ex_and HH Q1.
assert(HH:= segment_construction Q1 O O Q1).
ex_and HH Q2.
exists Q1, Q2.
repeat split; Col.
ColR.
apply cong_transitivity with O Q1; Cong.
Qed.

(** The symmetric of a point on a circle relative to the center is also on the circle. *)

Lemma symmetric_oncircle : forall X Y O P,
 Midpoint O X Y -> OnCircle X O P -> OnCircle Y O P.
Proof.
intros.
apply cong_transitivity with O X; Cong.
Qed.

(** The middle of a chord together with the center of the circle and one end of the chord
    form a right angle *)

Lemma mid_onc2__per : forall O P U V X,
 OnCircle U O P -> OnCircle V O P -> Midpoint X U V -> Per O X U.
Proof.
intros.
unfold Per.
exists V.
unfold OnCircle in *.
split; trivial.
apply cong_transitivity with O P; Cong.
Qed.

(** Euclid Book III Prop 3 (two lemmas).
 If a straight line passing through the center of a circle
 bisects a straight line not passing through the center,
 then it also cuts it at right angles; and if it cuts it at right angles, then it also bisects it.
*)

(** The line from the center of a circle to the midpoint of a chord is perpendicular to the chord. *)

Lemma mid_onc2__perp : forall O P A B X,
 O <> X -> A <> B -> OnCircle A O P -> OnCircle B O P -> Midpoint X A B -> Perp O X A B.
Proof.
intros.
assert(Per O X A).
apply (mid_onc2__per O P A B X); auto.
unfold Midpoint in *.
spliter.

apply per_perp_in in H4; auto.
apply perp_in_perp in H4.
apply perp_sym.

apply (perp_col _ X); Perp.
Col.
intro.
subst X.
treat_equalities; tauto.
Qed.

(** If a line passing through the center of a circle is perpendicular to a chord,
    then they intersect at the middle of the chord *)

Lemma col_onc2_perp__mid : forall O P A B X,
 O<>X -> A<>B -> Col A B X -> OnCircle A O P -> OnCircle B O P -> Perp O X A B -> Midpoint X A B.
Proof.
  intros O P A B X HOX HAB HCol HAOn HBOn HPerp.
  destruct (midpoint_existence A B) as [M HM].
  cut (X = M).
    intro; subst; trivial.
  assert (HNCol : ~ Col A B O) by (destruct (perp_not_col2 A B O X); Perp; Col).
  apply (l8_18_uniqueness A B O); Col; Perp.
  apply perp_sym, mid_onc2__perp with P; auto.
  intro; subst; apply HNCol; Col.
Qed.

(** If two circles intersect at a point which is not on the line joining the center,
    then they intersect on any half-plane delimited by that line. *)

Lemma circle_circle_os : forall A B C D I P,
  OnCircle I A B -> OnCircle I C D -> ~ Col A C I -> ~ Col A C P ->
  exists Z, OnCircle Z A B /\ OnCircle Z C D /\ OS A C P Z.
Proof.
  intros A B C D I P HI1 HI2 HNCol1 HNCol2.
  destruct (l8_18_existence A C I) as [X []]; trivial.
  destruct (l10_15 A C X P) as [Z0 []]; trivial.
  assert_diffs.
  destruct (l6_11_existence X X I Z0) as [Z []]; auto.
  exists Z.
  assert (Perp A C X Z).
    assert_diffs; apply perp_sym, perp_col with Z0; Perp; Col.
  assert (OS A C P Z).
    apply one_side_transitivity with Z0; trivial.
    apply out_one_side_1 with X; [apply one_side_not_col124 with P| |apply l6_6]; trivial.
  clear dependent Z0.
  repeat split; auto.
  - apply cong_transitivity with A I; trivial.
    destruct (eq_dec_points A X).
      subst; assumption.
    apply l10_12 with X X; Cong; [apply perp_per_2|apply perp_per_1];
      apply perp_left_comm, perp_col with C; auto.
  - apply cong_transitivity with C I; trivial.
    destruct (eq_dec_points C X).
      subst; assumption.
    apply l10_12 with X X; Cong; [apply perp_per_2|apply perp_per_1];
      apply perp_left_comm, perp_col with A; Perp; Col.
Qed.

(** If two circles intersect, then they intersect on any plane containing the centers *)

Lemma circle_circle_cop : forall A B C D I P, OnCircle I A B -> OnCircle I C D ->
  exists Z, OnCircle Z A B /\ OnCircle Z C D /\ Coplanar A C P Z.
Proof.
  intros A B C D I P HI1 HI2.
  destruct (col_dec A C P).
    exists I; repeat split; trivial.
    exists P; left; split; Col.
  destruct (col_dec A C I).
    exists I; repeat split; trivial.
    exists I; left; split; Col.
  destruct (circle_circle_os A B C D I P) as [Z [HZ1 [HZ2 HOS]]]; trivial.
  exists Z; repeat split; Cop.
Qed.

(** A circle does not cut a line at more than two points. *)

Lemma line_circle_two_points : forall O P U V W,
 U <> V -> Col U V W -> OnCircle U O P -> OnCircle V O P -> OnCircle W O P ->
 W = U \/ W = V.
Proof.
intros O P U V W HUV HCol HUOn HVOn HWOn.
destruct (eq_dec_points W U); auto.
right.
apply between_equality with U; apply col_inc_onc2__bet with O P; Col; Circle.
Qed.

(** The midpoint of a chord is strictly inside the circle. *)

Lemma onc2_mid__incs : forall O P U V M,
 U <> V -> OnCircle U O P -> OnCircle V O P -> Midpoint M U V ->
 InCircleS M O P.
Proof.
intros O P U V M HUV HUOn HVOn HM.
assert_diffs.
apply bet_inc2__incs with U V; Between; Circle.
Qed.

(** A point is either strictly inside, on or strictly outside a circle. *)

Lemma circle_cases : forall O P X,
  OnCircle X O P \/ InCircleS X O P \/ OutCircleS X O P.
Proof.
intros O P X.
destruct (cong_dec O X O P); auto.
right.
destruct (le_cases O P O X); [right|left]; split; Cong.
Qed.

(** If a point is inside a circle, then it lies on a radius. *)

Lemma inc__radius : forall O P X, InCircle X O P ->
  exists Y, OnCircle Y O P /\ Bet O X Y.
Proof.
  intros O P X HIn.
  destruct (eq_dec_points O P).
    unfold InCircle in HIn; treat_equalities.
    exists O; split; Circle; Between.
  destruct (eq_dec_points O X).
    subst; exists P; split; Circle; Between.
  destruct (segment_construction_3 O X O P) as [Y [HY1 HY2]]; auto.
  exists Y; split; auto.
  apply l6_13_1; trivial.
  apply (l5_6 O X O P); Cong.
Qed.

Lemma inc_onc2_out__eq : forall O P A B C,
  InCircle A O P -> OnCircle B O P -> OnCircle C O P -> Out A B C -> B = C.
Proof.
  intros O P A B C HA HB HC HOut.
  destruct (chord_completion O P B A) as [B' [HB' HBet]]; trivial.
  assert_diffs.
  destruct (line_circle_two_points O P B B' C); auto.
    ColR.
  subst C.
  exfalso.
  apply (not_bet_and_out B A B'); split; assumption.
Qed.

Lemma onc_not_center : forall O P A, O <> P -> OnCircle A O P -> A <> O.
Proof.
intros.
intro.
unfold OnCircle in *.
treat_equalities; tauto.
Qed.

Lemma onc2_per__mid : forall O P U V M, U <> V -> M <> U ->
 OnCircle U O P -> OnCircle V O P -> Col M U V -> Per O M U -> Midpoint M U V .
Proof.
intros.
assert(HH:=midpoint_existence U V).
ex_and HH M'.
assert(HH:=(mid_onc2__per O P U V M' H1 H2 H5)).
assert(M = M' \/ ~ Col M' U V).
apply(col_per2_cases O M U V M'); Col.
assert_diffs;auto.
induction H6.
subst M'.
assumption.
apply False_ind.
apply H6.
ColR.
Qed.

(** Euclid Book III Prop 14
Equal straight lines in a circle are equally distant from the center,
and those which are equally distant from the center equal one another.
*)

Lemma cong_chord_cong_center : forall O P A B C D M N,
 OnCircle A O P ->
 OnCircle B O P ->
 OnCircle C O P ->
 OnCircle D O P ->
 Midpoint M A B ->
 Midpoint N C D ->
 Cong A B C D ->
 Cong O N O M.
Proof.
intros.
assert(Cong M B N D).
apply cong_commutativity.
eapply (cong_cong_half_1 _ _ A _ _ C); Midpoint.
Cong.
unfold Midpoint in *.
unfold OnCircle in *.
spliter.
apply cong_commutativity.
apply cong_symmetry.
apply(l4_2 A M B O C N D O).
unfold IFSC.
repeat split; Cong.
apply (cong_transitivity _ _ O P); Cong.
apply (cong_transitivity _ _ O P); Cong.
Qed.

(** variant *)
Lemma cong_chord_cong_center1 : forall O P A B C D M N,
 A <> B -> C <> D -> M <> A -> N <> C ->
 OnCircle A O P ->
 OnCircle B O P ->
 OnCircle C O P ->
 OnCircle D O P ->
 Col M A B ->
 Col N C D ->
 Per O M A ->
 Per O N C ->
 Cong A B C D ->
 Cong O N O M.
Proof.
intros.
assert(Midpoint M A B).
apply(onc2_per__mid O P A B M H H1 H3 H4 H7 H9).
assert(Midpoint N C D).
apply(onc2_per__mid O P C D N H0 H2 H5 H6 H8 H10).
apply (cong_chord_cong_center O P A B C D M N); auto.
Qed.

(** Prop 7   **)

Lemma onc_sym__onc : forall O P A B X Y,
Bet O A B -> OnCircle A O P -> OnCircle B O P -> OnCircle X O P -> ReflectL X Y A B -> OnCircle Y O P.
Proof.
intros.
unfold OnCircle in *.
assert(Cong X O Y O).
  {
    apply(is_image_spec_col_cong A B X Y O H3);Col.
  }
apply cong_transitivity with O X; Cong.
Qed.

Lemma mid_onc__diam : forall O P A B, OnCircle A O P -> Midpoint O A B -> Diam A B O P.
Proof.
  intros O P A B HA HB.
  repeat split; Between.
  apply (symmetric_oncircle A); trivial.
Qed.

Lemma chord_le_diam : forall O P A B U V,
 Diam A B O P -> OnCircle U O P -> OnCircle V O P -> Le U V A B.
Proof.
intros.
unfold OnCircle in *.
unfold Diam in *.
spliter.
apply(triangle_inequality_2 U O V A O B); trivial;
apply cong_transitivity with O P; Cong.
Qed.

Lemma chord_lt_diam : forall O P A B U V,
 ~ Col O U V -> Diam A B O P -> OnCircle U O P -> OnCircle V O P ->
 Lt U V A B.
Proof.
intros.
assert(HH:= chord_le_diam O P A B U V H0 H1 H2).
unfold Lt.
split; auto.
intro.
apply H.
unfold Diam in *.
assert(HP:=midpoint_existence U V).
ex_and HP O'.
unfold Midpoint in *.
spliter.
unfold OnCircle in *.
assert(Cong O A O B) by (apply cong_transitivity with O P; Cong).
assert(Cong A O U O').
apply(cong_cong_half_1 A O B U O' V); unfold Midpoint; try split; Cong.
assert(Cong B O V O').
apply(cong_cong_half_2 A O B U O' V); unfold Midpoint; try split; Cong.
apply(l4_13 O A B).
Col.
unfold Cong_3.
repeat split; Cong; apply cong_transitivity with O P; Cong.
Qed.

Lemma inc2_le_diam: forall O P A B U V, Diam A B O P -> InCircle U O P -> InCircle V O P -> Le U V A B.
Proof.
intros.
unfold InCircle in *.
unfold Diam in *.
spliter.
unfold OnCircle in *.
assert(HH:= segment_construction U O O V).
ex_and HH W.
assert(Le U V U W).
{
  apply (triangle_inequality U O); Between; Cong.
}

assert(Le U W A B).
{
  apply(bet2_le2__le O O A B U W); Between.

  apply (l5_6 O U O P O U O A);Cong.
  apply (l5_6 O V O P O W O B);Cong.
}
apply(le_transitivity U V U W A B); auto.
Qed.

Lemma onc_col_diam__eq : forall O P A B X, Diam A B O P -> OnCircle X O P -> Col A B X -> X = A \/ X = B.
Proof.
intros.
unfold Diam in *.
spliter.
unfold OnCircle in *.
induction(eq_dec_points O P).
treat_equalities.
left; auto.

induction(eq_dec_points X B).
right; auto.
left.
assert_diffs.
assert(Cong O A O X) by (apply cong_transitivity with O P; Cong).
assert(Col A O X) by ColR.
assert(HH:= l7_20 O A X H11 H10).
induction HH.
auto.
assert(Midpoint O A B).
unfold Midpoint; split; trivial.
apply cong_transitivity with O P; Cong.
apply False_ind.
apply H5.
apply (symmetric_point_uniqueness A O ); auto.
Qed.

Lemma bet_onc_le_a : forall O P A B T X, Diam A B O P -> Bet B O T -> OnCircle X O P -> Le T A T X.
Proof.
intros.
unfold Diam in*.
spliter.
unfold OnCircle in *.
assert(Cong O X O A) by (apply cong_transitivity with O P; Cong).
induction(eq_dec_points P O).
treat_equalities.
apply le_reflexivity.
induction(eq_dec_points T O).
subst T.
apply cong__le;Cong.
assert_diffs.
apply(triangle_reverse_inequality O T X A); Cong.
assert_diffs.
repeat split; auto.
apply (l5_2 B); Between.
Qed.

Lemma bet_onc_lt_a : forall O P A B T X,
 Diam A B O P -> O <> P -> O <> T -> X <> A -> Bet B O T  -> OnCircle X O P ->
 Lt T A T X.
Proof.
intros.
assert(HH:= bet_onc_le_a O P A B T X H H3 H4).
assert(Lt T A T X \/ Cong T A T X).
{
  induction(cong_dec T A T X).
  right; auto.
  left.
  unfold Lt.
  split; auto.
}
induction H5; auto.
unfold Diam in*.
spliter.
unfold OnCircle in *.
assert_diffs.
assert(Bet O A T \/ Bet O T A).
apply(l5_2 B O A T); Between.
assert (Cong O A O X) by (apply cong_transitivity with O P; Cong).
induction H13.
assert(Bet O X T).
{
  apply(l4_6 O A T O X T); auto.
  unfold Cong_3.
  repeat split; Cong.
}
apply False_ind.
apply H2.
apply(between_cong_2 O T); Cong.
assert(Bet O T X).
{
  apply(l4_6 O T A O T X); auto.
  unfold Cong_3.
  repeat split; Cong.
}
apply False_ind.
apply H2.
apply(between_cong_3 O T); Cong.
Qed.

Lemma bet_onc_le_b : forall O P A B T X,
 Diam A B O P -> Bet A O T -> OnCircle X O P ->
 Le T X T A.
Proof.
intros.
unfold Diam in *.
spliter.
unfold OnCircle in *.
apply(triangle_inequality T O X A).
Between.
apply cong_transitivity with O P; Cong.
Qed.

Lemma bet_onc_lt_b : forall O P A B T X,
 Diam A B O P -> T <> O -> X <> A -> Bet A O T -> OnCircle X O P ->
 Lt T X T A.
Proof.
intros.
assert(HH:= bet_onc_le_b O P A B T X H H2 H3 ).
assert(Lt T X  T A \/ Cong T A T X).
{
  induction(cong_dec T A T X).
  right; auto.
  left.
  unfold Lt.
  split; Cong.
}
unfold Diam in *.
spliter.
unfold OnCircle in *.
induction H4; auto.
apply False_ind.
assert(Bet T O A) by eBetween.
assert(Bet T O X).
{
  apply(l4_6 T O A T O X); auto.
  repeat split.
    apply cong_reflexivity.
    assumption.
    apply cong_transitivity with O P; Cong.
}
apply H1.
apply(between_cong_3 T O); trivial.
apply cong_transitivity with O P; Cong.
Qed.

Lemma incs2_lt_diam : forall O P A B U V, Diam A B O P -> InCircleS U O P -> InCircleS V O P -> Lt U V A B.
Proof.
intros.
unfold Diam in H.
spliter.
unfold OnCircle in *.
unfold InCircleS in *.

induction(eq_dec_points O P).
treat_equalities.
unfold Lt in H0.
spliter.
apply le_zero in H.
treat_equalities.
apply False_ind.
apply H0; Cong.

assert(Lt A O A B /\ Lt B O A B).
{
  assert (Midpoint O A B).
    split; [assumption|apply cong_transitivity with O P; Cong].
  split.
  apply(mid__lt ); assert_diffs;auto.
  assert (Lt B O B A) by (assert_diffs; apply mid__lt; Midpoint).
  auto using lt_right_comm.
}
spliter.

induction(eq_dec_points O U).
treat_equalities.
spliter.
assert(Lt O V O A).
{
  apply(cong2_lt__lt O V O P); Cong.
}
apply (lt_transitivity O V O A A B); auto.
apply lt_left_comm; auto.

assert(HH:=segment_construction U O O V).
ex_and HH V'.

assert(Le U V U V').
{
  apply(triangle_inequality U O V V' H8); Cong.
}
assert(Lt U V' A B).
{
  apply(bet2_lt2__lt O O A B U V' H8 H).
  apply(cong2_lt__lt O U O P O U O A); Cong.
  apply(cong2_lt__lt O V O P O V' O B); Cong.
}

apply(le1234_lt__lt U V U V' A B); auto.
Qed.

Lemma incs_onc_diam__lt : forall O P A B U V, Diam A B O P -> InCircleS U O P -> OnCircle V O P -> Lt U V A B.
Proof.
intros.
unfold Diam in *.
spliter.
unfold OnCircle in *.
unfold InCircleS in *.

assert(HH:=segment_construction V O O U).
ex_and HH U'.
assert(Lt V U' A B).
{
  apply(bet2_lt_le__lt O O A B V U' H4 H).
  apply cong_transitivity with O P; Cong.
  apply(cong2_lt__lt O U O P); Cong.
}
assert(Le V U V U').
{
  apply(triangle_inequality V O U U' H4); Cong.
}
apply lt_left_comm.
apply(le1234_lt__lt V U V U'); auto.
Qed.

Lemma diam_cong_incs__outcs : forall O P A B U V, Diam A B O P -> Cong A B U V -> InCircleS U O P -> OutCircleS V O P.
Proof.
intros.
induction(eq_dec_points O P).
treat_equalities.
unfold InCircleS in H1.

unfold Lt in H1.
spliter.
apply le_zero in H1.
treat_equalities.
apply False_ind.
apply H2; Cong.

assert(HH:= circle_cases O P V).
induction HH.
assert(Lt U V A B) by  apply(incs_onc_diam__lt O P A B U V H H1 H3).
unfold Lt in H4.
spliter.
apply False_ind.
apply H5; Cong.

induction H3.
assert(HH:=incs2_lt_diam O P A B U V H H1 H3).
unfold Lt in HH.
spliter.
apply False_ind.
apply H5; Cong.
assumption.
Qed.

Lemma diam_uniqueness : forall O P A B X, Diam A B O P -> Cong A X A B -> OnCircle X O P -> X = B.
Proof.
intros.
unfold Diam in *.
spliter.
unfold OnCircle in *.
induction(eq_dec_points O P).
treat_equalities; auto.
assert(Bet A O X).
{
  apply(l4_6 A O B A O X); auto.
  repeat split; Cong.
  apply cong_transitivity with O P; Cong.
}
assert_diffs.
apply(between_cong_3 A O); auto.
apply cong_transitivity with O P; Cong.
Qed.

Lemma onc3__ncol : forall O P A B C,
 A <> B -> A <> C -> B <> C ->
 OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
 ~ Col A B C.
Proof.
intros.
assert (Hcong := onc2__cong O P).
apply (cong2__ncol O); Cong.
Qed.

Lemma diam_exists : forall O P T, exists A, exists B, Diam A B O P /\ Col A B T.
Proof.
intros.
destruct (diam_points O P T) as [A [B [HBet [HCol [HA HB]]]]].
exists A, B.
repeat split; auto.
Qed.

Lemma chord_intersection : forall O P A B X Y,
  OnCircle A O P -> OnCircle B O P -> OnCircle X O P -> OnCircle Y O P -> TS A B X Y ->
  TS X Y A B.
Proof.
intros.
unfold TS in H3.
spliter.
ex_and H5 T.
repeat split.
apply (onc3__ncol O P); Circle; try(intro; treat_equalities; Col).
apply (onc3__ncol O P); Circle; try(intro; treat_equalities; Col).
exists T.
split.
Col.
assert_diffs.
apply (col_inc_onc2__bet O P); Col.
apply(bet_inc2__incs O P X Y T); Circle; intro; treat_equalities; Col.
Qed.

Lemma ray_cut_chord : forall O P A B X Y,
  Diam A B O P -> OnCircle X O P -> OnCircle Y O P -> TS A B X Y -> OS X Y O A ->
  TS X Y O B.
Proof.
intros.
unfold Diam in *.
spliter.
apply(l9_8_2 X Y A O B); [|Side].
apply (chord_intersection O P); assumption.
Qed.

Lemma center_col__diam : forall O P A B,
 A <> B -> Col O A B -> OnCircle A O P -> OnCircle B O P ->
 Diam A B O P.
Proof.
Proof.
intros.
unfold Diam.
split; Circle.
assert(Cong O A O B) by (apply cong_transitivity with O P; Cong).
assert(A = B \/ Midpoint O A B) by (apply(l7_20 O A B); Col).
induction H4.
contradiction.
Between.
Qed.

Lemma diam__midpoint: forall O P A B, Diam A B O P -> Midpoint O A B.
Proof.
intros.
unfold Diam in *.
spliter.
unfold Midpoint.
unfold OnCircle in *.
split.
  assumption.
apply cong_transitivity with O P; Cong.
Qed.

Lemma diam_sym : forall O P A B, Diam A B O P -> Diam B A O P.
Proof.
intros.
unfold Diam in *.
spliter.
repeat split; Between.
Qed.

Lemma diam_end_uniqueness : forall O P A B C, Diam A B O P -> Diam A C O P -> B = C.
Proof.
intros.
apply diam__midpoint in H.
apply diam__midpoint in H0.
apply (symmetric_point_uniqueness A O); Midpoint.
Qed.

Lemma center_onc2_mid__ncol : forall O P A B M ,
 O <> P -> ~ Col O A B ->
 OnCircle A O P -> OnCircle B O P ->
 Midpoint M A B  -> ~ Col A O M.
Proof.
intros.
intro.
assert_diffs.
unfold Midpoint in H3.
spliter.
apply H0.
ColR.
Qed.

Lemma bet_chord__diam_or_ncol : forall O P A B T,
  A <> B -> T <> A -> T <> B -> OnCircle A O P -> OnCircle B O P -> Bet A T B ->
  Diam A B O P \/ ~Col O A T /\ ~Col O B T.
Proof.
intros.
induction(col_dec O A B).
left.
apply(center_col__diam); Col.
right.
split.
intro.
apply H5; ColR.
intro.
apply H5; ColR.
Qed.

Lemma mid_chord__diam_or_ncol : forall O P A B T,
 A <> B -> OnCircle A O P -> OnCircle B O P ->
 Midpoint T A B ->
 Diam A B O P \/ ~Col O A T /\ ~Col O B T.
Proof.
intros.
unfold Midpoint in H2.
spliter.
apply(bet_chord__diam_or_ncol);auto.
intro.
treat_equalities; tauto.
intro.
treat_equalities; tauto.
Qed.

Lemma cop_mid_onc2_perp__col : forall O P A B X Y, A <> B -> OnCircle A O P -> OnCircle B O P ->
  Midpoint X A B -> Perp X Y A B -> Coplanar O A B Y -> Col X Y O.
Proof.
  intros O P A B X Y HAB HAOn HBOn HX HPerp HCop.
  destruct (eq_dec_points O X).
    subst; Col.
  apply cop_perp2__col with A B; Cop.
  apply perp_left_comm, mid_onc2__perp with P; auto.
Qed.

Lemma cong2_cop2_onc3__eq : forall O P X A B C, A <> B -> A <> C -> B <> C ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  Cong X A X B -> Cong X A X C -> Coplanar A B C X ->
  X = O.
Proof.
  intros O P X A B C HAB HAC HBC HAOn HBOn HCOn HCop HCong1 HCong2 HCop1.
  destruct (midpoint_existence A B) as [M1 HM1].
  destruct (midpoint_existence A C) as [M2 HM2].
  assert (HNCol : ~ Col C A B) by (apply (onc3__ncol O P); auto).
  destruct (l10_15 A B M1 C) as [P1 [HPerp1 HOS1]]; Col.
  destruct (l10_15 A C M2 B) as [P2 [HPerp2 HOS2]]; Col.
  assert (HColX1 : Col M1 P1 X).
    apply (cop_mid_onc2_perp__col X A A B); Circle; Perp.
    apply coplanar_perm_12, coplanar_trans_1 with C; Cop.
  assert (HColO1 : Col M1 P1 O).
    apply (cop_mid_onc2_perp__col O P A B); Perp.
    apply coplanar_perm_12, coplanar_trans_1 with C; Cop.
  apply not_col_permutation_3 in HNCol.
  assert (HColX2 : Col M2 P2 X).
    apply (cop_mid_onc2_perp__col X A A C); Circle; Perp.
    apply coplanar_perm_12, coplanar_trans_1 with B; Cop.
  assert (HColO2 : Col M2 P2 O).
    apply (cop_mid_onc2_perp__col O P A C); Perp.
    apply coplanar_perm_12, coplanar_trans_1 with B; Cop.
  assert_diffs.
  destruct (col_dec M1 P1 M2); [apply (l6_21 M2 P2 M1 P1)|apply (l6_21 M1 P1 M2 P2)]; Col.
  intro.
  apply HBC.
  destruct (eq_dec_points M1 M2).
    apply (symmetric_point_uniqueness A M1); subst; trivial.
  apply l10_2_uniqueness_spec with M1 P1 A.
    split; Perp; exists M1; Col.
  split.
    exists M2; auto.
  left.
  apply perp_col2 with P2 M2; Perp; ColR.
Qed.

Lemma tree_points_onc_cop : forall O P, O <> P -> exists A B C,
  A <> B /\ A <> C /\ B <> C /\ OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ Coplanar A B C O.
Proof.
  intros O P HOP.
  destruct (not_col_exists O P) as [X HNCol]; auto.
  destruct (diam_points O P X) as [B [C [HBet [HCol []]]]].
  exists P, B, C.
  repeat split; Circle.
    intro; subst; apply HNCol; ColR.
    intro; subst; apply HNCol; ColR.
    intro; treat_equalities; auto.
    exists B; left; split; Col.
Qed.

Lemma tree_points_onc_cop2 : forall O P Q, O <> P -> exists A B C,
  A <> B /\ A <> C /\ B <> C /\ OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\
  Coplanar A B C O /\ Coplanar A B C Q.
Proof.
  intros O P Q HOP.
  destruct (eq_dec_points O Q).
    subst Q.
    destruct (tree_points_onc_cop O P HOP) as [A [B [C]]]; spliter.
    exists A, B, C; repeat split; auto.
  destruct (not_col_exists O Q) as [X HNCol]; auto.
  destruct (diam_points O P X) as [B [C [HBet [HCol []]]]].
  destruct (l6_11_existence O O P Q) as [A []]; auto.
  exists A, B, C.
  assert (~ Col O A B) by (intro; unfold OnCircle in *; assert_diffs; apply HNCol; ColR).
  assert_diffs.
  repeat split; Circle.
    intro; subst; apply HNCol; ColR.
    exists B; left; split; Col.
    exists O; right; right; split; Col.
Qed.

Lemma tree_points_onc : forall O P, O <> P -> exists A B C,
  A <> B /\ A <> C /\ B <> C /\ OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P.
Proof.
  intros O P HOP.
  destruct (tree_points_onc_cop O P HOP) as [A [B [C]]]; spliter.
  exists A, B, C; repeat split; assumption.
Qed.

Lemma bet_cop_onc2__ex_onc_os_out : forall O P A B C I,
  A <> I -> B <> I -> ~ Col A B C -> ~ Col A B O ->
  OnCircle A O P -> OnCircle B O P -> Bet A I B -> Coplanar A B C O ->
  exists C1, Out C1 O I /\ OnCircle C1 O P /\ OS A B C C1.
Proof.
  intros O P A B C I HAI HBI HNCol HNCol1 HA HB HBet HCop.
  destruct (diam_points O P I) as [C1 [C2 [HBet1 [HCol [HC1 HC2]]]]].
  assert (HTS : TS A B C1 C2).
  { apply (chord_intersection O P); trivial.
    unfold OnCircle in *; assert_diffs.
    repeat split; [intro; apply HNCol1; ColR..|exists I; split; Col].
  }
  assert (HBet2 : Bet C1 I C2).
  { assert_diffs; apply (col_inc_onc2__bet O P); auto.
    apply bet_inc2__inc with A B; Circle.
  }
  assert (HNCol2 : ~ Col C1 A B) by (destruct HTS; assumption).
  destruct (cop__one_or_two_sides A B C C1); Col.
    apply coplanar_trans_1 with O; Col; [Cop|exists I; right; right; assert_diffs; split; ColR].
  - exists C2.
    split; [|split; trivial; exists C1; Side].
    apply bet2__out with C1; Between.
      intro; treat_equalities; auto.
      destruct HTS as [_ [HNCol3 _]]; spliter; intro; subst; apply HNCol3; Col.
  - exists C1.
    split; [|split; trivial].
    apply bet2__out with C2; trivial.
      intro; treat_equalities; auto.
      intro; subst; apply HNCol2; Col.
Qed.

(** Two circles are equal if and only if they have the same center and the same radius *)

Lemma eqc_chara: forall A B C D, EqC A B C D <-> A = C /\ Cong A B C D.
Proof.
  intros A B C D.
  split.
  - intro Heq.
    unfold EqC in Heq.
    assert (C = A).
    { destruct (eq_dec_points A B) as [|Hd].
      - subst B.
        unfold OnCircle in Heq.
        assert (Cong A D A A) by (rewrite Heq; Cong).
        treat_equalities.
        destruct (segment_construction A C A C) as [A' []].
        assert (Cong A A' A A) by (rewrite Heq; Cong).
        treat_equalities; auto.
      - destruct (tree_points_onc_cop2 A B C Hd) as [B0 [B1 [B2]]].
        spliter.
        assert (HCong := onc2__cong C D).
        apply cong2_cop2_onc3__eq with B B0 B1 B2; try (apply HCong; apply Heq); auto.
    }
    subst C.
    split; trivial.
    unfold OnCircle in Heq.
    rewrite <- (Heq B); Cong.
  - intros [].
    subst C.
    intro X.
    split; intro; [apply cong_transitivity with A B|apply cong_transitivity with A D]; Cong.
Qed.

(** Two circles are distinct if and only if there is a point
    belonging to the first and not to the second *)

Lemma neqc_chara : forall A B C D, A <> B ->
  ~ EqC A B C D <->
  (exists X, OnCircle X A B /\ ~ OnCircle X C D).
Proof.
  intros A B C D HAB.
  split.
  { intro Hneq.
    destruct (eq_dec_points C A) as [|HCA].
    { destruct (cong_dec A B C D) as [|HNCong].
        exfalso; apply Hneq, eqc_chara; split; auto.
        subst C; exists B; split; Circle.
    }
    destruct (tree_points_onc_cop2 A B C HAB) as [B0 [B1 [B2]]]; spliter.
    destruct (cong_dec C B0 C D); [destruct (cong_dec C B1 C D);[destruct (cong_dec C B2 C D)|]|].
    - exfalso.
      apply HCA.
      apply cong2_cop2_onc3__eq with B B0 B1 B2; auto; apply cong_transitivity with C D; Cong.
    - exists B2; auto.
    - exists B1; auto.
    - exists B0; auto.
  }
  intros [X [HX Habs]] Heq.
  apply Habs, Heq, HX.
Qed.

(** The EqC predicate is an equivalence relation on ordered pairs of points *)

Lemma eqc_refl : forall A B, EqC A B A B.
Proof.
  unfold EqC; tauto.
Qed.

Lemma eqc_sym : forall A B C D, EqC A B C D -> EqC C D A B.
Proof.
  unfold EqC.
  intros A B C D Heq X.
  rewrite Heq.
  apply eqc_refl.
Qed.

Lemma eqc_trans : forall A B C D E F, EqC A B C D -> EqC C D E F -> EqC A B E F.
Proof.
  unfold EqC.
  intros A B C D E F Heq Heq' X.
  rewrite Heq.
  apply Heq'.
Qed.

(** If two circles have three common points, then they are equal *)

Lemma cop2_onc6__eqc : forall A B C O P O' P', A <> B -> B <> C -> A <> C ->
  OnCircle A O P ->  OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  OnCircle A O' P' ->  OnCircle B O' P' -> OnCircle C O' P' -> Coplanar A B C O' ->
  EqC O P O' P'.
Proof.
  intros A B C O P O' P'; intros.
  assert (HCong := onc2__cong O P).
  assert (HCong' := onc2__cong O' P').
  assert (O = O') by (apply (cong4_cop2__eq A B C); Cong).
  apply eqc_chara.
  split.
    assumption.
  subst O'.
  apply cong_transitivity with O A; Cong.
Qed.

(** If four coplanar points belong to a same sphere, then they belong to a same circle.
    This lemma justifies our definition of Concyclic. *)

Lemma concyclic_aux : forall A B C D, Concyclic A B C D -> exists O P,
  OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ OnCircle D O P /\ Coplanar A B C O.
Proof.
  intros A B C D [HCop [O1 [P1]]]; spliter.
  destruct (col_dec A B C).
    exists O1, P1; repeat split; Cop.
  destruct (l11_62_existence A B C O1) as [O []].
  exists O, A.
  assert (HCong := onc2__cong O1 P1).
  repeat split; [Circle|apply cong2_per2__cong with O1 O1; finish..|assumption].
Qed.

Lemma concyclic_perm_1 : forall A B C D, Concyclic A B C D -> Concyclic B C D A.
Proof.
  unfold Concyclic.
  intros A B C D [HCop [O [P]]].
  split.
    Cop.
  exists O, P.
  spliter; repeat split; assumption.
Qed.

Lemma concyclic_gen_perm_1 : forall A B C D,
  Concyclic_gen A B C D -> Concyclic_gen B C D A.
Proof.
  intros A B C D [H|].
    left; apply concyclic_perm_1, H.
    right; spliter; repeat split; Col.
Qed.

Lemma concyclic_perm_2 : forall A B C D, Concyclic A B C D -> Concyclic B A C D.
Proof.
  unfold Concyclic.
  intros A B C D [HCop [O [P]]].
  split.
    Cop.
  exists O, P.
  spliter; repeat split; assumption.
Qed.

Lemma concyclic_gen_perm_2 : forall A B C D,
  Concyclic_gen A B C D -> Concyclic_gen B A C D.
Proof.
  intros A B C D [H|].
    left; apply concyclic_perm_2, H.
    right; spliter; repeat split; Col.
Qed.

Lemma concyclic_trans_1 : forall P Q R A B, ~ Col P Q R ->
  Concyclic P Q R A -> Concyclic P Q R B -> Concyclic Q R A B.
Proof.
  intros P Q R A B HNC H1 H2.
  split.
    unfold Concyclic in *; spliter; apply coplanar_trans_1 with P; assumption.
  destruct (concyclic_aux P Q R A H1) as [O [M]].
  destruct (concyclic_aux P Q R B H2) as [O' [M']].
  spliter.
  exists O, M; repeat split; trivial.
  assert_diffs.
  apply (cop2_onc6__eqc P Q R O' M'); auto.
Qed.

Lemma concyclic_gen_trans_1 : forall P Q R A B,
  ~ Col P Q R ->
  Concyclic_gen P Q R A -> Concyclic_gen P Q R B ->
  Concyclic_gen Q R A B.
Proof.
  intros P Q R A B HNC [|] [|]; [|spliter; exfalso; apply HNC; Col..].
  left.
  apply (concyclic_trans_1 P); assumption.
Qed.

Lemma concyclic_pseudo_trans : forall A B C D P Q R, ~ Col P Q R ->
  Concyclic P Q R A -> Concyclic P Q R B -> Concyclic P Q R C -> Concyclic P Q R D ->
  Concyclic A B C D.
Proof.
  intros A B C D P Q R HNCol HA HB HC HD.
  spliter.
  split.
    unfold Concyclic in *; spliter; apply coplanar_pseudo_trans with P Q R; assumption.
  destruct (concyclic_aux P Q R A HA) as [OA [MA]].
  destruct (concyclic_aux P Q R B HB) as [OB [MB]].
  destruct (concyclic_aux P Q R C HC) as [OC [MC]].
  destruct (concyclic_aux P Q R D HD) as [OD [MD]].
  spliter.
  assert_diffs.
  exists OA, MA; repeat split; [|apply (cop2_onc6__eqc P Q R OB MB)|
    apply (cop2_onc6__eqc P Q R OC MC)|apply (cop2_onc6__eqc P Q R OD MD)]; auto.
Qed.

Lemma concyclic_gen_pseudo_trans : forall A B C D P Q R,
  ~ Col P Q R ->
  Concyclic_gen P Q R A ->
  Concyclic_gen P Q R B ->
  Concyclic_gen P Q R C ->
  Concyclic_gen P Q R D ->
  Concyclic_gen A B C D.
Proof.
  intros A B C D P Q R HNC [|] [|] [|] [|]; [|spliter; exfalso; apply HNC; Col..].
  left.
  apply concyclic_pseudo_trans with P Q R; assumption.
Qed.

End Circle_2.

Section Circle_2D.

Context `{T2D:Tarski_2D}.

(** The center of a circle belongs to the perpendicular bisector of each chord *)

Lemma mid_onc2_perp__col : forall O P A B X Y,
 A <> B -> OnCircle A O P -> OnCircle B O P -> Midpoint X A B -> Perp X Y A B -> Col X Y O.
Proof.
  intros O P A B X Y HAB HAOn HBOn HX HPerp.
  assert (HCop := all_coplanar O A B Y).
  apply cop_mid_onc2_perp__col with P A B; assumption.
Qed.

(** Euclid Book III Prop 4.
 If in a circle two straight lines which do not pass through the center cut one another,
 then they do not bisect one another.
 *)

Lemma mid2_onc4__eq : forall O P A B C D X, B <> C-> A <> B ->
 OnCircle A O P ->
 OnCircle B O P ->
 OnCircle C O P ->
 OnCircle D O P ->
 Midpoint X A C ->
 Midpoint X B D ->
 X=O.
Proof.
intros O P A B C D X Hbc.
intros.
assert(HH:=mid_onc2__per O P A C X H0 H2 H4).
assert(HP:=mid_onc2__per O P B D X H1 H3 H5).

induction(eq_dec_points X O).
auto.
assert(Col A B X).
apply(per2__col A B O X); Perp.
unfold Midpoint in *.
spliter.
assert(Col B X D).
apply bet_col; auto.
assert(Col A X C).
ColR.

induction(eq_dec_points A X).
subst X.
treat_equalities.
assert(OutCircleS D O P).
apply(onc2_out__outcs O P A B D); auto.
assert_diffs.
unfold Out.
split.
auto.
split.
auto.
left; Between.

unfold OutCircleS in *.
unfold Lt in *.
spliter.
unfold OnCircle in H3.
apply False_ind.
absurd (Cong O P O D);Cong.

assert(Col A B C).
ColR.

assert(C = A \/ C = B).
apply(line_circle_two_points O P A B C); Col.
destruct H14.
treat_equalities.
intuition.
treat_equalities.
assert(A = D) by
(apply (symmetric_point_uniqueness C X); split; Between; Cong).
treat_equalities.
tauto.
Qed.

(** Euclid Book III Prop 9.
 If a point is taken within a circle,
 and more than two equal straight lines fall from the point on the circle,
 then the point taken is the center of the circle.
*)

Lemma cong2_onc3__eq : forall O P X A B C, A <> B -> A <> C -> B <> C ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  Cong X A X B -> Cong X A X C ->
  X = O.
Proof.
  intros O P X A B C HAB HAC HBC HAOn HBOn HCOn HCong1 HCong2.
  assert (HCop := all_coplanar A B C O).
  assert (HCop1 := all_coplanar A B C X).
  apply cong2_cop2_onc3__eq with P A B C; assumption.
Qed.

Lemma onc2_mid_cong_col : forall O P U V M X,
 U <> V ->OnCircle U O P -> OnCircle V O P -> Midpoint M U V -> Cong U X V X -> Col O X M.
Proof.
intros.
assert(HH:=mid_onc2__per O P U V M H0 H1 H2).
assert(Per X M U).
unfold Per.
exists V.
unfold OnCircle in *.
split; Cong.
apply(per2__col _ _ U); auto.
assert_diffs.
auto.
Qed.

Lemma cong_onc3_cases : forall O P A X Y,
 Cong A X A Y ->
 OnCircle A O P -> OnCircle X O P -> OnCircle Y O P ->
 X = Y \/ ReflectL X Y O A.
Proof.
intros.
unfold OnCircle in *.
induction(eq_dec_points X Y).
left; auto.
right.
assert(HH:= midpoint_existence X Y).
ex_and HH M.
assert(Per O M X).
{
  apply(mid_onc2__per O P X Y M); Circle.
}
assert(Per A M X).
{
  unfold Per.
  exists Y.
  split; auto.
}
assert(Col A O M).
{
  apply (per2__col _ _ X); auto.
  intro.
  treat_equalities; tauto.
}

unfold ReflectL.
split.
exists M.
split; Midpoint.
Col.
left.

unfold Midpoint in *.
spliter.

induction(eq_dec_points M O).
subst M.
apply per_perp_in in H6.
apply perp_in_comm in H6.
apply perp_in_perp in H6.
apply perp_sym in H6.
apply (perp_col X O O A Y) in H6; Col.
Perp.
intro.
treat_equalities; tauto.
intro.
treat_equalities; tauto.

apply(perp_col O M Y X A);Col.
intro.
treat_equalities; tauto.
apply per_perp_in in H5.
apply perp_in_comm in H5.
apply perp_in_perp in H5.
apply perp_sym in H5.
apply(perp_col X M M O Y) in H5; auto.
Perp.
Col.
auto.
intro.
treat_equalities; tauto.
Qed.

Lemma bet_cong_onc3_cases : forall O P A X Y T,
 T <> O -> Bet A O T -> Cong T X T Y ->
 OnCircle A O P  -> OnCircle X O P  -> OnCircle Y O P ->
 X = Y \/ ReflectL X Y O A.
Proof.
intros.
unfold OnCircle in *.
induction(eq_dec_points O P).
treat_equalities.
left; auto.

induction(eq_dec_points T X).
treat_equalities.
left; auto.

assert(CongA T O X T O Y /\ CongA O T X O T Y /\ CongA T X O T Y O).
{
  apply(l11_51 O T X O T Y); Cong.
    intro.
    treat_equalities; tauto.
  apply cong_transitivity with O P; Cong.
}
spliter.
assert(Out T A O).
{
  repeat split; auto.
  intro.
  treat_equalities; tauto.
  Between.
}
assert(Cong A X A Y).
{ apply(cong2_conga_cong A T X A T Y); Cong.
  apply (l11_10 O T X O T Y); auto.
  apply out_trivial; auto.
  apply out_trivial.
  intro.
  treat_equalities; tauto.
}
apply (cong_onc3_cases O P); auto.
Qed.

Lemma prop_7_8 : forall O P A B T X Y , Diam A B O P -> Bet A O T
                               -> OnCircle X O P -> OnCircle Y O P
                               -> LeA A O X A O Y -> Le T Y T X.
Proof.
intros.
assert(HD:=H).
unfold Diam in H.
spliter.
unfold OnCircle in *.
induction(eq_dec_points O P).
subst P.
treat_equalities; auto.
apply le_reflexivity.

induction(eq_dec_points O T).
treat_equalities.
apply cong__le, cong_transitivity with O P; Cong.

induction(cong_dec A X A Y).
assert(X = Y \/ ReflectL X Y O A).
{
  apply(cong_onc3_cases O P A X Y); Circle.
}
induction H9.
treat_equalities.
apply le_reflexivity.
apply cong__le.
apply cong_symmetry.
apply cong_commutativity.
apply(is_image_spec_col_cong O A X Y T); auto.
unfold Diam in *.
spliter.
ColR.

assert(Le T X T A).
{
  apply(bet_onc_le_b O P A B T X HD H0).
  Circle.
}
assert_diffs.

assert(LeA Y O T X O T).
{
  apply lea_comm.
  apply(l11_36 A O X A O Y T T); auto.
}

assert(Lt T Y T X).
{
  assert(Cong O X O Y) by (apply cong_transitivity with O P; Cong).
  apply(t18_18 O T X O T Y); Cong.
  unfold LtA.
  split; auto.
  intro.
  assert(Cong Y T X T).
  {
    apply(cong2_conga_cong Y O T X O T); Cong.
  }
  assert(CongA A O X A O Y).
  apply(l11_13 T O X T O Y A A); Between.
  CongA.
  apply H8.
  apply(cong2_conga_cong A O X A O Y); Cong.
}
apply lt__le.
assumption.
Qed.

Lemma Prop_7_8_uniqueness : forall O P A X Y Z T, T <> O -> X <> Y ->
  Bet A O T -> Cong T X T Y -> Cong T X T Z ->
  OnCircle A O P -> OnCircle X O P -> OnCircle Y O P -> OnCircle Z O P ->
  Z = X \/ Z = Y.
Proof.
intros.
induction(eq_dec_points O P).
unfold OnCircle in *.
treat_equalities.
auto.
assert(X = Y \/ ReflectL X Y O A).
{
  apply(bet_cong_onc3_cases O P A X Y T); auto.
}
assert(X = Z \/ ReflectL X Z O A).
{
  apply(bet_cong_onc3_cases O P A X Z T); auto.
}
assert(Y = Z \/ ReflectL Y Z O A).
{
  apply(bet_cong_onc3_cases O P A Y Z T); auto.
  apply cong_transitivity with T X; Cong.
}
induction H9.
contradiction.
induction H10.
auto.
induction H11.
auto.
assert(HH:=l10_2_uniqueness_spec O A Z X Y H10 H11).
contradiction.
Qed.

Lemma chords_midpoints_col_par : forall O P A M B C N D,
 O <> P ->
 OnCircle A O P -> OnCircle B O P ->
 OnCircle C O P -> OnCircle D O P ->
 Midpoint M A B -> Midpoint N C D ->
 Col O M N -> ~ Col O A B -> ~ Col O C D -> Par A B C D.
Proof.
intros.
assert(Perp O M A B).
{
  apply(mid_onc2__perp O  P A B M); Circle.
  intro.
  treat_equalities.
  apply H7.
  Col.
  intro.
  treat_equalities.
  apply H7; Col.
}
assert(Perp O N C D).
{
  apply(mid_onc2__perp O  P C D N); Circle.
  intro.
  treat_equalities.
  apply H8.
  Col.
  intro.
  treat_equalities.
  apply H8; Col.
}
assert(Perp O M C D).
{
  apply (perp_col O N C D M); Col.
  intro.
  treat_equalities.
  apply H7; Col.
}
apply (l12_9_2D A B C D O M); Perp.
Qed.

Lemma onc3_mid2__ncol : forall O P A B C A' B',
 O <> P ->
 OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
 Midpoint A' A C -> Midpoint B' B C -> ~ Col A B C ->
 ~ Col O A' B' \/ A' = O \/ B' = O.
Proof.
intros.
induction(col_dec O A C).
assert(A = C \/ Midpoint O A C) by (apply l7_20; [Col|CongR]).
induction H7.
treat_equalities.
apply False_ind.
apply H5; Col.
right; left.
apply (l7_17 A C); auto.

induction(col_dec O B C).
assert(B = C \/ Midpoint O B C) by (apply l7_20; [Col|CongR]).
induction H8.
treat_equalities.
apply False_ind.
apply H5; Col.
right; right.
apply (l7_17 B C); auto.
left.
intro.
assert(HH:=chords_midpoints_col_par O P A A' C B B' C H H0 H2 H1 H2 H3 H4 H8 H6 H7).
induction HH.
apply H9.
exists C.
split; Col.
spliter; contradiction.
Qed.

(** Euclid Book III Prop 9.
 If a point is taken within a circle,
 and more than two equal straight lines fall from the point on the circle,
 then the point taken is the center of the circle.*)

Lemma onc4_cong2__eq:
 forall A B C D O P X,
 A<>B -> C<>D ->
 ~ Par A B C D ->
 OnCircle A O P ->
 OnCircle B O P ->
 OnCircle C O P ->
 OnCircle D O P ->
 Cong A X B X ->
 Cong C X D X ->
 O=X.
Proof.
intros.

assert(HP:O <> P).
{
intro.
unfold OnCircle in *.
treat_equalities. intuition.
}

assert(HH:= midpoint_existence A B).
ex_and HH M.
assert(HH:= midpoint_existence C D).
ex_and HH N.

assert(Col O X M)
 by (apply(onc2_mid_cong_col O P A B M X); auto).
assert(Col O X N)
 by (apply(onc2_mid_cong_col O P C D N X); auto).

induction(eq_dec_points O X).
- auto.
- assert(Col O M N) by eCol.

assert(HH1:=cong_perp_or_mid A B M X H H8 H6).
assert(HH2:=cong_perp_or_mid C D N X H0 H9 H7).

induction HH1.
subst X.
induction HH2.
subst N.

induction(col_dec O A B).
assert(A = B \/ Midpoint O A B).
unfold OnCircle in *.
apply l7_20; Col.
apply cong_transitivity with O P; Cong.
induction H15.
contradiction.
assert(M = O).
apply (l7_17 A B); auto.
subst M; tauto.

induction(col_dec O C D).
assert(C = D \/ Midpoint O C D).
unfold OnCircle in *.
apply l7_20; Col.
apply cong_transitivity with O P; Cong.
induction H16.
contradiction.
apply (l7_17 C D); auto.
assert(HM1:=mid_onc2__perp O P A B M H12 H H2 H3 H8).
assert(HM2:=mid_onc2__perp O P C D M H12 H0 H4 H5 H9).
apply False_ind.
apply H1.
apply (l12_9_2D _ _ _ _ O M); Perp.

spliter.
apply perp_in_perp in H15.
induction(col_dec O A B).
assert(A = B \/ Midpoint O A B).
unfold OnCircle in *.
apply l7_20; Col.
apply cong_transitivity with O P; Cong.
induction H17.
contradiction.
assert(M = O).
apply (l7_17 A B); auto.
subst M; tauto.
assert(HM1:=mid_onc2__perp O P A B M H12 H H2 H3 H8).
apply(perp_col M N C D O ) in H15; Col.
apply False_ind.
apply H1.
apply (l12_9_2D _ _ _ _ O M); Perp.
induction HH2.
subst X.
spliter.

induction(col_dec O C D).
assert(C = D \/ Midpoint O C D).
unfold OnCircle in *.
apply l7_20; Col.
apply cong_transitivity with O P; Cong.
induction H17.
contradiction.
apply (l7_17 C D); auto.

assert(HM1:=mid_onc2__perp O P C D N H12 H0 H4 H5 H9).
apply perp_in_perp in H15.
apply False_ind.
apply H1.
apply(perp_col N M A B O) in H15; Col.

apply (l12_9_2D _ _ _ _ O N); Perp.
spliter.
apply perp_in_perp in H17.
apply perp_in_perp in H16.

apply(perp_col X M A B O) in H17; Col.
apply(perp_col X N C D O) in H16; Col.
apply False_ind.
apply H1.
apply (l12_9_2D _ _ _ _ O X); Perp.
Qed.

End Circle_2D.