(**
BinProducts of  arities using LModulesBinProducts
(inspired by SignatureCoproduct
pullback binproducts
 *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.BinProductComplements.
Require Import Modules.Prelims.LModulesBinProducts.
Require Import Modules.Signatures.Signature.

Section Binprod.
  Context {C : category} .

  Context {cpC : BinProducts  C}.

  Local Notation hsC := (homset_property C).

  Local Notation Signature := (signature C).
  Local Notation MOD R := (category_LModule R C).

  Let cpLM (X : Monad C) := LModule_BinProducts   X cpC .
  Let cpFunc := BinProducts_functor_precat  C _ cpC  .

  (* Local Notation SIGNATURE := (signature C). *)

  Context (a b : Signature).
  Local Notation BPO := (BinProductObject _ ).

  Definition signature_BinProduct_on_objects (R : Monad C) : LModule R C :=
    BPO (cpLM R (a R) (b R)).

  Let ab := signature_BinProduct_on_objects.

  Definition signature_BinProduct_on_morphisms (R S : Monad C)
             (f : Monad_Mor R S) : LModule_Mor _ (ab R)
                                               (pb_LModule f (ab S)).
    eapply (compose (C := (MOD _))); revgoals.
    - cbn.
      apply binprod_pbm_to_pbm_binprod.
    - apply  (BinProductOfArrows _  (cpLM R _ _) (cpLM R _ _)).
      exact ((# a f)%ar).
      exact ((# b f)%ar).
  Defined.

  Definition signature_binProd_data : @signature_data C
    := signature_BinProduct_on_objects ,, signature_BinProduct_on_morphisms.

  Lemma signature_binProd_is_signature : is_signature signature_binProd_data.
  Proof.
    split.
    - intros R c.
      cbn  -[BinProductOfArrows].
      rewrite id_right.
      apply pathsinv0.
      apply BinProductArrowUnique.
      + etrans;[apply id_left|].
        apply pathsinv0.
        etrans;[|apply id_right].
        apply cancel_precomposition.
        apply signature_id.
      + etrans;[apply id_left|].
        apply pathsinv0.
        etrans;[|apply id_right].
        apply cancel_precomposition.
        apply signature_id.
    - intros R S T f g.
      apply LModule_Mor_equiv.
      { apply homset_property. }
      apply nat_trans_eq.
      apply homset_property.
      intro x.
      cbn  -[BinProductOfArrows ].
      repeat  rewrite id_right.
      apply pathsinv0.
      etrans; [apply BinProductOfArrows_comp|].
      apply BinProductOfArrows_eq.
      + assert (h := signature_comp a f g).
        apply LModule_Mor_equiv in h;[|apply homset_property].
        eapply nat_trans_eq_pointwise in h.
        apply pathsinv0.
        etrans;[eapply h|].
        cbn.
        rewrite id_right.
        apply idpath.
      + assert (h := signature_comp b f g).
        apply LModule_Mor_equiv in h;[|apply homset_property].
        eapply nat_trans_eq_pointwise in h.
        apply pathsinv0.
        etrans;[eapply h|].
        cbn.
        rewrite id_right.
        apply idpath.
  Qed.

  Definition signature_binProd : Signature := _ ,, signature_binProd_is_signature.

  Lemma signature_binProductPr1_laws :
    is_signature_Mor signature_binProd a
                 (fun R => BinProductPr1  _  (cpLM R (a R) (b R)   )).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn -[BinProductPr1 BinProductOfArrows].
    rewrite id_right.
    cbn.
    unfold binproduct_nat_trans_pr1_data.
    set (CC := cpC _ _).
    use (BinProductOfArrowsPr1 _  CC).
  Qed.

  Lemma signature_binProductPr2_laws :
    is_signature_Mor signature_binProd b
                 (fun R => BinProductPr2  _  (cpLM R (a R) (b R)   )).
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn -[BinProductPr2 BinProductOfArrows].
    rewrite id_right.
    cbn.
    unfold binproduct_nat_trans_pr2_data.
    set (CC := cpC _ _).
    use (BinProductOfArrowsPr2 _  CC).
  Qed.

  Definition signature_binProductPr1 :
    signature_Mor  signature_binProd a := _ ,, signature_binProductPr1_laws .

  Definition signature_binProductPr2 :
    signature_Mor  signature_binProd b := _ ,, signature_binProductPr2_laws .

  (* TODO : move to Signature *)
  Definition signature_binProductArrow_laws {c : Signature} (ca :  signature_Mor c a )
             (cb : signature_Mor c b)
    :
    is_signature_Mor
      c signature_binProd
      (fun R => BinProductArrow  _  (cpLM R (a R) (b R)) (ca R) (cb R))  .
  Proof.
    intros R S f.
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn -[BinProductPr1 BinProductPr2 BinProductOfArrows].
    rewrite id_right.
    unfold binproduct_nat_trans_data.
    apply pathsinv0.
    etrans;[apply postcompWithBinProductArrow|].
    apply pathsinv0.
    apply BinProductArrowUnique.
    - cbn.
      etrans.
      {
        rewrite <- assoc.
        apply cancel_precomposition.
        set (CC := cpC _ _).
        apply (BinProductPr1Commutes _ _ _ CC).
      }
      apply signature_Mor_ax_pw.
    - cbn.
      etrans.
      {
        rewrite <- assoc.
        apply cancel_precomposition.
        set (CC := cpC _ _).
        apply (BinProductPr2Commutes _ _ _ CC).
      }
      apply signature_Mor_ax_pw.
  Qed.

  Definition signature_binProductArrow {c : Signature} (ca :  signature_Mor c a )
             (cb : signature_Mor c b) :
    signature_Mor c signature_binProd  := _ ,, signature_binProductArrow_laws ca cb.

  Lemma signature_isBinProduct : isBinProduct signature_category   _ _ _
                                           signature_binProductPr1 signature_binProductPr2.
  Proof.
    intros c ca cb.
    use unique_exists.
    - exact (signature_binProductArrow ca cb).
    - split.
      + apply signature_Mor_eq.
        intro R.
        apply (BinProductPr1Commutes  (MOD R) _ _ (cpLM R (a R) (b R))).
      + apply signature_Mor_eq.
        intro R.
        apply (BinProductPr2Commutes  (MOD R) _ _ (cpLM R (a R) (b R))).
    - intro y.
      cbn -[isaprop].
      apply isapropdirprod; apply signature_category_has_homsets.
    - intros y [h1 h2].
      apply signature_Mor_eq.
      intro R.
      apply (BinProductArrowUnique   (MOD R) _ _ (cpLM R (a R) (b R))).
      + rewrite <- h1. apply idpath.
      + rewrite <- h2. apply idpath.
  Defined.

  Definition signature_BinProduct : BinProduct signature_category a b :=
    make_BinProduct  _ _ _ _ _ _ signature_isBinProduct.

End Binprod.

Definition signature_BinProducts {C : category}
           (cpC : BinProducts C)
            : BinProducts (signature_category (C := C)) :=
   signature_BinProduct (cpC := cpC).


From Hammer Require Import Hammer.

Require Export Coq.Classes.SetoidTactics.

Export Morphisms.ProperNotations.

Definition Setoid_Theory := @Equivalence.
Definition Build_Setoid_Theory := @Build_Equivalence.

Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x.
Proof. hammer_hook "Setoid" "Setoid.Seq_refl".
unfold Setoid_Theory in s. intros ; reflexivity.
Defined.

Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x.
Proof. hammer_hook "Setoid" "Setoid.Seq_sym".
unfold Setoid_Theory in s. intros ; symmetry ; assumption.
Defined.

Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z.
Proof. hammer_hook "Setoid" "Setoid.Seq_trans".
unfold Setoid_Theory in s. intros ; transitivity y ; assumption.
Defined.

Ltac trans_st x :=
idtac "trans_st on Setoid_Theory is OBSOLETE";
idtac "use transitivity on Equivalence instead";
match goal with
| H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
apply (Seq_trans _ _ H) with x; auto
end.

Ltac sym_st :=
idtac "sym_st on Setoid_Theory is OBSOLETE";
idtac "use symmetry on Equivalence instead";
match goal with
| H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
apply (Seq_sym _ _ H); auto
end.

Ltac refl_st :=
idtac "refl_st on Setoid_Theory is OBSOLETE";
idtac "use reflexivity on Equivalence instead";
match goal with
| H : Setoid_Theory _ ?eqA |- ?eqA _ _ =>
apply (Seq_refl _ _ H); auto
end.

Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
Proof. hammer_hook "Setoid" "Setoid.gen_st".
constructor; congruence.
Qed.


(** ** Constructions related to ltowers over an object

by Vladimir Voevodsky, started on Feb. 3, 2015.

*)

Require Import UniMath.Foundations.All.
Require Export TypeTheory.Csystems.lTowers.

(** ltowers of objects over an object *)

Definition ltower_over_carrier { T : ltower } ( A : T ) := ∑ X : T, isover X A.

Definition obj_over_constr { T : ltower } { A : T } { X : T } ( isov : isover X A ):
  ltower_over_carrier A := tpair ( fun X : T => isover X A ) _ isov.

Definition isov_isov { T : ltower } { A : T } ( X : ltower_over_carrier A ):
  isover ( pr1 X ) A := pr2 X.

(** ltower operations on this carrier *)
Definition ltower_over_ll { T : ltower } { A : T } ( X : ltower_over_carrier A ): nat :=
  ll ( pr1 X ) - ll A.

Definition ltower_over_ft { T : ltower } { A : T } ( X : ltower_over_carrier A ):
  ltower_over_carrier A.
Proof.
  destruct ( isover_choice ( isov_isov X ) ) as [ isov | eq ].
  - exact ( ( ft ( pr1 X ) ) ,, isov ).
  - exact ( tpair ( fun X : T => isover X A ) A ( isover_XX A ) ).
Defined.

(** ltower laws for these operations *)
Lemma ltower_over_ll_ft_eq { T : ltower } { A : T } ( X : ltower_over_carrier A ):
  ltower_over_ll ( ltower_over_ft X ) = ltower_over_ll X - 1.
Proof.
  unfold ltower_over_ft.
  destruct ( isover_choice ( isov_isov X ) ) as [ isov | eq ]; unfold ltower_over_ll; simpl.
  - rewrite ll_ft.
    rewrite natminusassoc.
    rewrite natpluscomm.
    rewrite <- natminusassoc.
    apply idpath.
  - rewrite natminusnn.
    rewrite <- eq.
    rewrite natminusnn.
    apply idpath.
Defined.

Lemma ispointed_ltower_over_int { T : ltower } ( A : T ):
  iscontr ( ∑ X : ltower_over_carrier A , ltower_over_ll X = 0 ).
Proof.
  assert ( weq1 : ( ∑ X : ltower_over_carrier A, ltower_over_ll X = 0 ) ≃
                  ( ∑ X : T, ( isover X A ) × ( ll X - ll A = 0 ) ) )
  by apply weqtotal2asstor.
  assert ( weq2 : ( ∑ X : T, ( isover X A ) × ( ll X - ll A = 0 ) ) ≃
                  ( ∑ X : T, A = X ) ).
  { use weqfibtototal.
    intro X.
    assert ( weq3 : ( (isover X A) × (ll X - ll A = 0) ) ≃
                    ( (ll X - ll A = 0) × (isover X A) ) )
    by apply weqdirprodcomm.
    assert ( weq4 :  ( (ll X - ll A = 0) × (isover X A) ) ≃
                     ( (ll X - ll A = 0) × ( A = X ) ) ).
    { use weqfibtototal.
      intro eq .
      unfold isover.
      rewrite eq.
      apply idweq.
    }
    assert ( weq5 : ( (ll X - ll A = 0) × (A = X) ) ≃
                    ( (A = X) × (ll X - ll A = 0) ) )
    by apply weqdirprodcomm.
    assert ( weq6 : ( (A = X) × (ll X - ll A = 0) ) ≃
                    ( A = X ) ).
    { apply weqpr1.
      intro eq .
      rewrite eq.
      rewrite natminusnn.
      apply iscontraprop1.
      - apply isasetnat.
      - apply idpath.
    }
    apply ( weqcomp weq3 ( weqcomp weq4 ( weqcomp weq5 weq6 ) ) ).
  }
  set ( weq := weqcomp weq1 weq2 ).
  apply ( iscontrweqb weq ).
  apply iscontrpathsfrom.
Defined.

Lemma ltower_over_ll0_eq { T : ltower } { A : T }
      ( X : ltower_over_carrier A ) ( eq0 : ltower_over_ll X = 0 ):
  ltower_over_ft X = X.
Proof.
  assert ( eq0' : ltower_over_ll ( ltower_over_ft X ) = 0 ).
  { rewrite ltower_over_ll_ft_eq.
    rewrite eq0.
    apply idpath.
  }
  assert ( int : tpair ( fun X' => ltower_over_ll X' = 0 ) _ eq0' =
                 tpair ( fun X' => ltower_over_ll X' = 0 ) X eq0 )
  by use ( proofirrelevancecontr ( ispointed_ltower_over_int _ ) ).
  apply ( maponpaths ( @pr1 _ ( fun X' => ltower_over_ll X' = 0 ) ) int ).
Defined.

(** put these findings together *)
Definition ltower_over { T : ltower } ( A : T ): ltower :=
  ltower_constr ( @ltower_over_ll _ A ) ( @ltower_over_ft _ A )
                ( @ltower_over_ll_ft_eq _ A ) ( @ltower_over_ll0_eq _ A ).

(** The name of the following function comes from the word octothrope that is the official name for the
"pound sign". This symbol, as a subscript, is used sometimes to denote the left adjoint to the pull-back
functor that takes a presheaf represented by p : X -> B over B to the presheaf represented by X. *)

Definition pocto { T : ltower } { A : T } ( X : ltower_over A ): T := pr1 X.

Lemma ll_pocto { T : ltower } { A : T } ( X : ltower_over A ):
  ll ( pocto X ) = ll X + ll A.
Proof.
  change ( ll X ) with ( ltower_over_ll X ).
  unfold ltower_over_ll.
  rewrite minusplusnmm.
  - apply idpath.
  - apply ( isover_geh ( pr2 X ) ).
Defined.

(* just to check/assert that [isov_isov] has the stated type: *)
Local Definition check_isov_isov (T: ltower) (A:T)
  := isov_isov
: forall ( X : ltower_over_carrier A ), isover ( pocto X ) A.

Definition ispointed_ltower_over { T : ltower } ( A : T ): ispointed_type ( ltower_over A ) :=
  ispointed_ltower_over_int A.

Definition pltower_over { T : ltower } ( A : T ): pltower := pltower_constr ( ispointed_ltower_over A ).

Definition ltower_over_to_pltower_over { T : ltower } ( A : T ) ( X : ltower_over A ):
  pltower_over A := X.

Lemma ltower_over_ftn { T : ltower } { A : T } ( n : nat )
      ( X : ltower_over A ) ( ge : ll X >= n ): pocto ( ftn n X ) = ftn n ( pocto X ).
Proof.
  revert X ge.
  induction n.
  + intros.
    apply idpath.
  + intros.
    do 2 rewrite <- ftn_ft.
    assert ( int : ft ( pocto X ) = pocto ( ft X ) ).
    { change ( ft X ) with ( ltower_over_ft X ).
      unfold ltower_over_ft.
      destruct ( isover_choice (isov_isov X) ) as [ isov | eq ].
      *  simpl.
         apply idpath.
      *  change ( ll X ) with ( ll ( pocto X ) - ll A ) in ge.
         change (A = pocto X) in eq.
         rewrite <- eq in ge.
         rewrite natminusnn in ge.
         destruct (nopathsfalsetotrue ge).
    }
    rewrite int.
    use ( IHn ( ft X ) ).
    apply ( ll_ft_gtn ge ).
Defined.

(** **** Standard constructions of over-objects *)

Definition X_over_X { T : ltower } ( X : T ): ltower_over X :=
  obj_over_constr ( isover_XX X ).

Lemma ll_X_over_X { T : ltower } ( X : T ): ll ( X_over_X X ) = 0.
Proof.
  change ( ll X - ll X = 0 ).
  apply natminusnn.
Defined.

Definition X_over_ftX { T : ltower } ( X : T ): ltower_over ( ft X ) :=
  obj_over_constr ( isover_X_ftX X ).

Lemma ll_X_over_ftX { T : ltower } { X : T } ( gt0 : ll X > 0 ):
  ll ( X_over_ftX X ) = 1.
Proof.
  change ( ltower_over_ll (X_over_ftX X) = 1 ).
  unfold ltower_over_ll.
  rewrite ll_ft.
  change ( ll X - ( ll X - 1 ) = 1 ).
  apply natminusmmk.
  apply ( @natgthminus1togeh 1 _ gt0 ).
Defined.

(** The projection pocto from the over-tower to the tower is over-monotone *)

Lemma isllmonot_pocto { T : ltower } { A : T }: isllmonot (pocto(A:=A)).
(* Lemma ll_over_minus_ll_over { T : ltower } { A : T } ( X1 X2 : ltower_over A ):
  ll X1 - ll X2 = ll ( pocto X1 ) - ll ( pocto X2 ). *)
Proof.
  red.
  intros X1 X2.
  apply pathsinv0. (* in order to stay close to Vladimir's proof *)
  destruct X1 as [ X1 isov1 ].
  destruct X2 as [ X2 isov2 ].
  unfold ll.
  simpl.
  unfold ltower_over_ll.
  simpl.
  change ( ( ll X1 - ll A ) - ( ll X2 - ll A ) = ( ll X1 - ll X2 ) ).
  rewrite natminusassoc.
  rewrite natpluscomm.
  rewrite ( minusplusnmm _ _ ( isover_geh isov2 ) ).
  apply idpath.
Defined.

Definition isovmonot_pocto { T : ltower } ( A : T ): isovmonot (pocto(A:=A)).
(* Definition isovmonot_pocto { T : ltower } ( A : T ) { X Y : ltower_over A } ( isov : isover X Y ):
isover ( pocto X ) ( pocto Y ). *)
Proof.
  red.
  intros X Y isov.
  destruct X as [ X isovX ].
  destruct Y as [ Y isovY ].
  simpl.
  set ( int := maponpaths pocto isov ).
  simpl in int.
  rewrite ltower_over_ftn in int.
  - simpl in int.
    rewrite <-isllmonot_pocto in int.
    simpl in int.
    exact int.
  - use natminuslehn.
Defined.

(*
Lemma isllmonot_pocto { T : ltower } { A : T }: isllmonot ( @pocto T A ).
Proof.
  unfold isllmonot.
  intros X Y.
  apply ( ! ( ll_over_minus_ll_over X Y ) ).
Defined.
*)

(** **** The projection pocto and ft *)

Lemma ft_pocto { T : ltower } { A : T } { X : ltower_over A } ( gt0 : ll X > 0 ):
  ft ( pocto X ) = pocto ( ft X ).
Proof.
  change ( ft X ) with ( ltower_over_ft X ).
  unfold ltower_over_ft.
  destruct (isover_choice (isov_isov X)) as [ isov | eq ].
  - simpl.
    apply idpath.
  - apply fromempty.
    assert ( eq0 : ll X = 0 ).
    { change ( ll ( pr1 X ) - ll A = 0 ).
      rewrite <- eq.
      apply natminusnn.
    }
    rewrite eq0 in gt0.
    apply ( negnatgthnn _ gt0 ).
Defined.

(** **** Some functions between over-towers *)

Definition to_ltower_over { T : pltower } ( X : T ): ltower_over ( cntr T ).
Proof.
  exact ( obj_over_constr ( isoverll0 ( ll_cntr T ) X ) ).
Defined.

Lemma ll_to_ltower_over { T : pltower } ( X : T ):
  ll ( to_ltower_over X ) = ll X.
Proof.
  unfold ll.
  simpl.
  unfold ltower_over_ll.
  rewrite ll_cntr.
  rewrite natminuseqn.
  apply idpath.
Defined.

Corollary isllmonot_to_ltower_over ( T : pltower ):
  isllmonot ( @to_ltower_over T ).
Proof.
  unfold isllmonot.
  intros.
  do 2 rewrite ll_to_ltower_over.
  apply idpath.
Defined.

Corollary isbased_to_ltower_over ( T : pltower ):
  isbased ( @to_ltower_over T ).
Proof.
  unfold isbased.
  intros X eq0.
  rewrite ll_to_ltower_over.
  exact eq0.
Defined.

(** The following constructions probably work for all ltowers
but we only give a proof for ltowers of sets in the file hSet_ltowers.v .

Definition ovmonot_to_over_pocto  { T : ltower } { X : T } { X' : ltower_over X } :
  ovmonot_fun ( ltower_over X' ) ( ltower_over ( pocto X' ) ) .

Definition ovmonot_over { T1 T2 : ltower } ( f : ovmonot_fun T1 T2 )
           ( X : T1 ) : ovmonot_fun ( ltower_over X ) ( ltower_over ( f X ) ) .

Definition lft { T : hSet_ltower }
           { X : T } { X' : ltower_over X } ( X'' : ltower_over ( pocto X' ) ) : ltower_over X' .

Definition ovmonot_second { T : ltower }
           { X Y : T } ( f : ovmonot_fun ( ltower_over X ) ( ltower_over Y ) )
           ( X' : ltower_over X ) :
  ovmonot_fun ( ltower_over ( pocto X' ) ) ( ltower_over ( pocto ( f X' ) ) ) .

Lemma isovmonot_to_ltower_over { T : ltower } ( is : ispointed T ) : isovmonot ( to_ltower_over is ) .

*)

(* End of the file ltowers_over.v *)


Require Export GeoCoq.Elements.OriginalProofs.proposition_42B.
Require Export GeoCoq.Elements.OriginalProofs.proposition_44A.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_44 :
   forall A B D J N R a b c,
   Triangle a b c -> nCol J D N -> nCol A B R ->
   exists X Y Z, PG A B X Y /\ CongA A B X J D N /\ EF a b Z c A B X Y /\ Midpoint b Z c /\ TS X A B R.
Proof.
intros.
assert (neq A B) by (forward_using lemma_NCdistinct).
assert (nCol a b c) by (conclude_def Triangle ).
assert (neq b c) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists m, (BetS b m c /\ Cong m b m c)) by (conclude proposition_10);destruct Tf as [m];spliter.
assert (Cong b m m c) by (forward_using lemma_congruenceflip).
assert (Midpoint b m c) by (conclude_def Midpoint ).
assert (neq m c) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists E, (BetS A B E /\ Cong B E m c)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (Col A B E) by (conclude_def Col ).
assert (Col B A E) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col B A B) by (conclude_def Col ).
assert (nCol B A R) by (forward_using lemma_NCorder).
assert (nCol B E R) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists g e, (Out B E e /\ CongA g B e J D N /\ OS g R B E)) by (conclude proposition_23C);destruct Tf as [g[e]];spliter.
assert (neq B A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists P, (BetS B A P /\ Cong A P B A)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (neq E B) by (conclude lemma_inequalitysymmetric).
assert (neq b m) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists Q, (BetS E B Q /\ Cong B Q b m)) by (conclude lemma_extension);destruct Tf as [Q];spliter.
assert (Cong b m m c) by (forward_using lemma_congruenceflip).
assert (Cong B Q m c) by (conclude lemma_congruencetransitive).
assert (Cong m c B E) by (conclude lemma_congruencesymmetric).
assert (Cong B Q B E) by (conclude lemma_congruencetransitive).
assert (BetS Q B E) by (conclude axiom_betweennesssymmetry).
assert (Cong Q B B E) by (forward_using lemma_congruenceflip).
assert (Midpoint Q B E) by (conclude_def Midpoint ).
assert (nCol B A R) by (forward_using lemma_NCorder).
assert (Col A B E) by (conclude_def Col ).
assert (Col B A E) by (forward_using lemma_collinearorder).
assert (neq B E) by (forward_using lemma_betweennotequal).
assert (nCol B E R) by (conclude lemma_NChelper).
assert (nCol R B E) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists G F, (PG G B E F /\ EF a b m c G B E F /\ CongA E B G J D N /\ OS R G B E)) by (conclude proposition_42B);destruct Tf as [G[F]];spliter.
assert (PG B E F G) by (conclude lemma_PGrotate).
let Tf:=fresh in
assert (Tf:exists M L, (PG A B M L /\ CongA A B M J D N /\ EF B E F G L M B A /\ BetS G B M)) by (conclude proposition_44A);destruct Tf as [M[L]];spliter.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (Par G B E F) by (conclude_def PG ).
assert (nCol G B E) by (forward_using lemma_parallelNC).
assert (nCol E B G) by (forward_using lemma_NCorder).
assert (Col E B A) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col E B B) by (conclude_def Col ).
assert (nCol A B G) by (conclude lemma_NChelper).
assert (TS G A B M) by (conclude_def TS ).
assert (EF a b m c B E F G) by (forward_using axiom_EFpermutation).
assert (EF a b m c L M B A) by (conclude axiom_EFtransitive).
assert (EF a b m c A B M L) by (forward_using axiom_EFpermutation).
assert (Col B E A) by (forward_using lemma_collinearorder).
assert (OS R G B A) by (conclude lemma_samesidecollinear).
assert (OS R G A B) by (conclude lemma_samesideflip).
assert (TS R A B M) by (conclude lemma_planeseparation).
assert (TS M A B R) by (conclude lemma_oppositesidesymmetric).
close.
Qed.

End Euclid.