Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__equalanglesNC.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglessymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__interior5.
Require Export lemma__layoff.
Require Export lemma__paralleldef2B.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export lemma__ray5.
Require Export lemma__sameside2.
Require Export lemma__samesidecollinear.
Require Export lemma__samesideflip.
Require Export lemma__samesidesymmetric.
Require Export lemma__samesidetransitive.
Require Export logic.
Require Export proposition__04.
Require Export proposition__23C.
Require Export proposition__42.
Definition proposition__42B : forall B C D E J K R a b c e, (euclidean__axioms.Triangle a b c) -> ((euclidean__defs.Midpoint b e c) -> ((euclidean__axioms.nCol J D K) -> ((euclidean__defs.Midpoint B E C) -> ((euclidean__axioms.Cong E C e c) -> ((euclidean__axioms.nCol R E C) -> (exists X Z, (euclidean__defs.PG X E C Z) /\ ((euclidean__axioms.EF a b e c X E C Z) /\ ((euclidean__defs.CongA C E X J D K) /\ (euclidean__defs.OS R X E C))))))))).
Proof.
intro B.
intro C.
intro D.
intro E.
intro J.
intro K.
intro R.
intro a.
intro b.
intro c.
intro e.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
intro H4.
assert (* Cut *) ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as H5.
- assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as H5 by exact H2.
assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as __TmpHyp by exact H5.
destruct __TmpHyp as [H6 H7].
assert ((euclidean__axioms.BetS b e c) /\ (euclidean__axioms.Cong b e e c)) as H8 by exact H0.
assert ((euclidean__axioms.BetS b e c) /\ (euclidean__axioms.Cong b e e c)) as __TmpHyp0 by exact H8.
destruct __TmpHyp0 as [H9 H10].
split.
-- exact H6.
-- exact H7.
- assert (* Cut *) ((euclidean__axioms.BetS b e c) /\ (euclidean__axioms.Cong b e e c)) as H6.
-- assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as H6 by exact H5.
assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as __TmpHyp by exact H6.
destruct __TmpHyp as [H7 H8].
assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as H9 by exact H2.
assert ((euclidean__axioms.BetS B E C) /\ (euclidean__axioms.Cong B E E C)) as __TmpHyp0 by exact H9.
destruct __TmpHyp0 as [H10 H11].
assert ((euclidean__axioms.BetS b e c) /\ (euclidean__axioms.Cong b e e c)) as H12 by exact H0.
assert ((euclidean__axioms.BetS b e c) /\ (euclidean__axioms.Cong b e e c)) as __TmpHyp1 by exact H12.
destruct __TmpHyp1 as [H13 H14].
split.
--- exact H13.
--- exact H14.
-- assert (* Cut *) (euclidean__axioms.neq B C) as H7.
--- destruct H6 as [H7 H8].
destruct H5 as [H9 H10].
assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq B E) /\ (euclidean__axioms.neq B C))) as H11.
---- apply (@lemma__betweennotequal.lemma__betweennotequal B E C H9).
---- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H15.
--- assert (* Cut *) (euclidean__axioms.nCol a b c) as H8.
---- destruct H6 as [H8 H9].
destruct H5 as [H10 H11].
exact H.
---- assert (* Cut *) (euclidean__axioms.nCol E C R) as H9.
----- destruct H6 as [H9 H10].
destruct H5 as [H11 H12].
assert (* Cut *) ((euclidean__axioms.nCol E R C) /\ ((euclidean__axioms.nCol E C R) /\ ((euclidean__axioms.nCol C R E) /\ ((euclidean__axioms.nCol R C E) /\ (euclidean__axioms.nCol C E R))))) as H13.
------ apply (@lemma__NCorder.lemma__NCorder R E C H4).
------ destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H16.
----- assert (* Cut *) (euclidean__axioms.Col B E C) as H10.
------ destruct H5 as [H10 H11].
destruct H6 as [H12 H13].
right.
right.
right.
right.
left.
exact H10.
------ assert (* Cut *) (euclidean__axioms.Col E C B) as H11.
------- destruct H6 as [H11 H12].
destruct H5 as [H13 H14].
assert (* Cut *) ((euclidean__axioms.Col E B C) /\ ((euclidean__axioms.Col E C B) /\ ((euclidean__axioms.Col C B E) /\ ((euclidean__axioms.Col B C E) /\ (euclidean__axioms.Col C E B))))) as H15.
-------- apply (@lemma__collinearorder.lemma__collinearorder B E C H10).
-------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H18.
------- assert (* Cut *) (C = C) as H12.
-------- destruct H6 as [H12 H13].
destruct H5 as [H14 H15].
apply (@logic.eq__refl Point C).
-------- assert (* Cut *) (euclidean__axioms.Col E C C) as H13.
--------- right.
right.
left.
exact H12.
--------- assert (* Cut *) (euclidean__axioms.nCol B C R) as H14.
---------- destruct H6 as [H14 H15].
destruct H5 as [H16 H17].
apply (@euclidean__tactics.nCol__notCol B C R).
-----------apply (@euclidean__tactics.nCol__not__Col B C R).
------------apply (@lemma__NChelper.lemma__NChelper E C R B C H9 H11 H13 H7).

---------- assert (* Cut *) (exists P H15, (euclidean__defs.Out B C H15) /\ ((euclidean__defs.CongA P B H15 a b c) /\ (euclidean__defs.OS P R B C))) as H15.
----------- destruct H6 as [H15 H16].
destruct H5 as [H17 H18].
apply (@proposition__23C.proposition__23C B C b a c R H7 H8 H14).
----------- destruct H15 as [P H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H6 as [H23 H24].
destruct H5 as [H25 H26].
assert (* Cut *) (euclidean__axioms.Cong B E e c) as H27.
------------ apply (@lemma__congruencetransitive.lemma__congruencetransitive B E E C e c H26 H3).
------------ assert (* Cut *) (euclidean__axioms.Cong E C B E) as H28.
------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric E B E C H26).
------------- assert (euclidean__axioms.Cong E C e c) as H29 by exact H3.
assert (euclidean__axioms.Cong B E e c) as H30 by exact H27.
assert (* Cut *) (euclidean__axioms.Cong e c b e) as H31.
-------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric e b e c H24).
-------------- assert (* Cut *) (euclidean__axioms.Cong B E b e) as H32.
--------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B E e c b e H30 H31).
--------------- assert (* Cut *) (euclidean__axioms.Cong B C b c) as H33.
---------------- apply (@euclidean__axioms.cn__sumofparts B E C b e c H32 H29 H25 H23).
---------------- assert (* Cut *) (euclidean__defs.CongA a b c P B H17) as H34.
----------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric P B H17 a b c H21).
----------------- assert (* Cut *) (euclidean__defs.Out B H17 C) as H35.
------------------ apply (@lemma__ray5.lemma__ray5 B C H17 H19).
------------------ assert (* Cut *) (euclidean__axioms.nCol B C P) as H36.
------------------- assert (exists X U V, (euclidean__axioms.Col B C U) /\ ((euclidean__axioms.Col B C V) /\ ((euclidean__axioms.BetS P U X) /\ ((euclidean__axioms.BetS R V X) /\ ((euclidean__axioms.nCol B C P) /\ (euclidean__axioms.nCol B C R)))))) as H36 by exact H22.
assert (exists X U V, (euclidean__axioms.Col B C U) /\ ((euclidean__axioms.Col B C V) /\ ((euclidean__axioms.BetS P U X) /\ ((euclidean__axioms.BetS R V X) /\ ((euclidean__axioms.nCol B C P) /\ (euclidean__axioms.nCol B C R)))))) as __TmpHyp by exact H36.
destruct __TmpHyp as [x H37].
destruct H37 as [x0 H38].
destruct H38 as [x1 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H48.
------------------- assert (* Cut *) (euclidean__axioms.neq B P) as H37.
-------------------- assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq C P) /\ ((euclidean__axioms.neq B P) /\ ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq P C) /\ (euclidean__axioms.neq P B)))))) as H37.
--------------------- apply (@lemma__NCdistinct.lemma__NCdistinct B C P H36).
--------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H42.
-------------------- assert (euclidean__axioms.nCol a b c) as H38 by exact H8.
assert (* Cut *) (euclidean__axioms.neq b a) as H39.
--------------------- assert (* Cut *) ((euclidean__axioms.neq a b) /\ ((euclidean__axioms.neq b c) /\ ((euclidean__axioms.neq a c) /\ ((euclidean__axioms.neq b a) /\ ((euclidean__axioms.neq c b) /\ (euclidean__axioms.neq c a)))))) as H39.
---------------------- apply (@lemma__NCdistinct.lemma__NCdistinct a b c H38).
---------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
--------------------- assert (* Cut *) (exists A, (euclidean__defs.Out B P A) /\ (euclidean__axioms.Cong B A b a)) as H40.
---------------------- apply (@lemma__layoff.lemma__layoff B P b a H37 H39).
---------------------- destruct H40 as [A H41].
destruct H41 as [H42 H43].
assert (* Cut *) (euclidean__defs.CongA a b c A B C) as H44.
----------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper a b c P B H17 A C H34 H42 H35).
----------------------- assert (* Cut *) (euclidean__defs.CongA A B C a b c) as H45.
------------------------ apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric a b c A B C H44).
------------------------ assert (* Cut *) (euclidean__axioms.nCol A B C) as H46.
------------------------- apply (@euclidean__tactics.nCol__notCol A B C).
--------------------------apply (@euclidean__tactics.nCol__not__Col A B C).
---------------------------apply (@lemma__equalanglesNC.lemma__equalanglesNC a b c A B C H44).

------------------------- assert (euclidean__axioms.Triangle A B C) as H47 by exact H46.
assert (* Cut *) (euclidean__axioms.Cong A C a c) as H48.
-------------------------- assert (* Cut *) (forall A0 B0 C0 a0 b0 c0, (euclidean__axioms.Cong A0 B0 a0 b0) -> ((euclidean__axioms.Cong A0 C0 a0 c0) -> ((euclidean__defs.CongA B0 A0 C0 b0 a0 c0) -> (euclidean__axioms.Cong B0 C0 b0 c0)))) as H48.
--------------------------- intro A0.
intro B0.
intro C0.
intro a0.
intro b0.
intro c0.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__axioms.Cong B0 C0 b0 c0) /\ ((euclidean__defs.CongA A0 B0 C0 a0 b0 c0) /\ (euclidean__defs.CongA A0 C0 B0 a0 c0 b0))) as __2.
---------------------------- apply (@proposition__04.proposition__04 A0 B0 C0 a0 b0 c0 __ __0 __1).
---------------------------- destruct __2 as [__2 __3].
exact __2.
--------------------------- apply (@H48 B A C b a c H43 H33 H45).
-------------------------- assert (* Cut *) (euclidean__axioms.Cong A B a b) as H49.
--------------------------- assert (* Cut *) ((euclidean__axioms.Cong A B a b) /\ ((euclidean__axioms.Cong A B b a) /\ (euclidean__axioms.Cong B A a b))) as H49.
---------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip B A b a H43).
---------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H50.
--------------------------- assert (* Cut *) (euclidean__axioms.Cong C A c a) as H50.
---------------------------- assert (* Cut *) ((euclidean__axioms.Cong C A c a) /\ ((euclidean__axioms.Cong C A a c) /\ (euclidean__axioms.Cong A C c a))) as H50.
----------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A C a c H48).
----------------------------- destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H51.
---------------------------- assert (* Cut *) (euclidean__axioms.Cong E A e a) as H51.
----------------------------- apply (@lemma__interior5.lemma__interior5 B E C A b e c a H25 H23 H32 H29 H43 H50).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong A E a e) as H52.
------------------------------ assert (* Cut *) ((euclidean__axioms.Cong A E a e) /\ ((euclidean__axioms.Cong A E e a) /\ (euclidean__axioms.Cong E A a e))) as H52.
------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip E A e a H51).
------------------------------- destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H53.
------------------------------ assert (* Cut *) (euclidean__axioms.Cong E B e b) as H53.
------------------------------- assert (* Cut *) ((euclidean__axioms.Cong E B e b) /\ ((euclidean__axioms.Cong E B b e) /\ (euclidean__axioms.Cong B E e b))) as H53.
-------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip B E b e H32).
-------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H54.
------------------------------- assert (euclidean__axioms.Col B E C) as H54 by exact H10.
assert (* Cut *) (euclidean__axioms.Col B C E) as H55.
-------------------------------- assert (* Cut *) ((euclidean__axioms.Col E B C) /\ ((euclidean__axioms.Col E C B) /\ ((euclidean__axioms.Col C B E) /\ ((euclidean__axioms.Col B C E) /\ (euclidean__axioms.Col C E B))))) as H55.
--------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B E C H54).
--------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H62.
-------------------------------- assert (* Cut *) (euclidean__axioms.nCol B C A) as H56.
--------------------------------- assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H56.
---------------------------------- apply (@lemma__NCorder.lemma__NCorder A B C H47).
---------------------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H59.
--------------------------------- assert (* Cut *) (B = B) as H57.
---------------------------------- apply (@logic.eq__refl Point B).
---------------------------------- assert (* Cut *) (euclidean__axioms.Col B C B) as H58.
----------------------------------- right.
left.
exact H57.
----------------------------------- assert (* Cut *) (euclidean__axioms.neq B E) as H59.
------------------------------------ assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq B E) /\ (euclidean__axioms.neq B C))) as H59.
------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B E C H25).
------------------------------------- destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H62.
------------------------------------ assert (* Cut *) (euclidean__axioms.nCol B E A) as H60.
------------------------------------- apply (@euclidean__tactics.nCol__notCol B E A).
--------------------------------------apply (@euclidean__tactics.nCol__not__Col B E A).
---------------------------------------apply (@lemma__NChelper.lemma__NChelper B C A B E H56 H58 H55 H59).

------------------------------------- assert (* Cut *) (euclidean__axioms.nCol A E B) as H61.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol E B A) /\ ((euclidean__axioms.nCol E A B) /\ ((euclidean__axioms.nCol A B E) /\ ((euclidean__axioms.nCol B A E) /\ (euclidean__axioms.nCol A E B))))) as H61.
--------------------------------------- apply (@lemma__NCorder.lemma__NCorder B E A H60).
--------------------------------------- destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
exact H69.
-------------------------------------- assert (* Cut *) (euclidean__axioms.Col b e c) as H62.
--------------------------------------- right.
right.
right.
right.
left.
exact H23.
--------------------------------------- assert (* Cut *) (euclidean__axioms.Col b c e) as H63.
---------------------------------------- assert (* Cut *) ((euclidean__axioms.Col e b c) /\ ((euclidean__axioms.Col e c b) /\ ((euclidean__axioms.Col c b e) /\ ((euclidean__axioms.Col b c e) /\ (euclidean__axioms.Col c e b))))) as H63.
----------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder b e c H62).
----------------------------------------- destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
exact H70.
---------------------------------------- assert (* Cut *) (euclidean__axioms.nCol b c a) as H64.
----------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol b a c) /\ ((euclidean__axioms.nCol b c a) /\ ((euclidean__axioms.nCol c a b) /\ ((euclidean__axioms.nCol a c b) /\ (euclidean__axioms.nCol c b a))))) as H64.
------------------------------------------ apply (@lemma__NCorder.lemma__NCorder a b c H38).
------------------------------------------ destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H67.
----------------------------------------- assert (* Cut *) (b = b) as H65.
------------------------------------------ apply (@logic.eq__refl Point b).
------------------------------------------ assert (* Cut *) (euclidean__axioms.Col b c b) as H66.
------------------------------------------- right.
left.
exact H65.
------------------------------------------- assert (* Cut *) (euclidean__axioms.neq b e) as H67.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq e c) /\ ((euclidean__axioms.neq b e) /\ (euclidean__axioms.neq b c))) as H67.
--------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal b e c H23).
--------------------------------------------- destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
exact H70.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol b e a) as H68.
--------------------------------------------- apply (@euclidean__tactics.nCol__notCol b e a).
----------------------------------------------apply (@euclidean__tactics.nCol__not__Col b e a).
-----------------------------------------------apply (@lemma__NChelper.lemma__NChelper b c a b e H64 H66 H63 H67).

--------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol a e b) as H69.
---------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol e b a) /\ ((euclidean__axioms.nCol e a b) /\ ((euclidean__axioms.nCol a b e) /\ ((euclidean__axioms.nCol b a e) /\ (euclidean__axioms.nCol a e b))))) as H69.
----------------------------------------------- apply (@lemma__NCorder.lemma__NCorder b e a H68).
----------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H77.
---------------------------------------------- assert (euclidean__axioms.Triangle A E B) as H70 by exact H61.
assert (* Cut *) (euclidean__axioms.Cong__3 A E B a e b) as H71.
----------------------------------------------- split.
------------------------------------------------ exact H52.
------------------------------------------------ split.
------------------------------------------------- exact H53.
------------------------------------------------- exact H49.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.ET A E B a e b) as H72.
------------------------------------------------ apply (@euclidean__axioms.axiom__congruentequal A E B a e b H71).
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col C B E) as H73.
------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B E) /\ ((euclidean__axioms.Col C E B) /\ ((euclidean__axioms.Col E B C) /\ ((euclidean__axioms.Col B E C) /\ (euclidean__axioms.Col E C B))))) as H73.
-------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C E H55).
-------------------------------------------------- destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
exact H74.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq E C) as H74.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq E C) /\ ((euclidean__axioms.neq B E) /\ (euclidean__axioms.neq B C))) as H74.
--------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B E C H25).
--------------------------------------------------- destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
exact H75.
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C E) as H75.
--------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric E C H74).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C B A) as H76.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol B A C) /\ (euclidean__axioms.nCol A C B))))) as H76.
----------------------------------------------------- apply (@lemma__NCorder.lemma__NCorder B C A H56).
----------------------------------------------------- destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
exact H77.
---------------------------------------------------- assert (C = C) as H77 by exact H12.
assert (* Cut *) (euclidean__axioms.Col C B C) as H78.
----------------------------------------------------- right.
left.
exact H77.
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C E A) as H79.
------------------------------------------------------ apply (@euclidean__tactics.nCol__notCol C E A).
-------------------------------------------------------apply (@euclidean__tactics.nCol__not__Col C E A).
--------------------------------------------------------apply (@lemma__NChelper.lemma__NChelper C B A C E H76 H78 H73 H75).

------------------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol A E C) as H80.
------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol E C A) /\ ((euclidean__axioms.nCol E A C) /\ ((euclidean__axioms.nCol A C E) /\ ((euclidean__axioms.nCol C A E) /\ (euclidean__axioms.nCol A E C))))) as H80.
-------------------------------------------------------- apply (@lemma__NCorder.lemma__NCorder C E A H79).
-------------------------------------------------------- destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
exact H88.
------------------------------------------------------- assert (euclidean__axioms.Triangle A E C) as H81 by exact H80.
assert (* Cut *) (euclidean__axioms.Cong__3 A E C a e c) as H82.
-------------------------------------------------------- split.
--------------------------------------------------------- exact H52.
--------------------------------------------------------- split.
---------------------------------------------------------- exact H29.
---------------------------------------------------------- exact H48.
-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.ET A E C a e c) as H83.
--------------------------------------------------------- apply (@euclidean__axioms.axiom__congruentequal A E C a e c H82).
--------------------------------------------------------- assert (* Cut *) (E = E) as H84.
---------------------------------------------------------- apply (@logic.eq__refl Point E).
---------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E E) as H85.
----------------------------------------------------------- right.
right.
left.
exact H84.
----------------------------------------------------------- assert (* Cut *) (euclidean__axioms.TS B A E C) as H86.
------------------------------------------------------------ exists E.
split.
------------------------------------------------------------- exact H25.
------------------------------------------------------------- split.
-------------------------------------------------------------- exact H85.
-------------------------------------------------------------- exact H70.
------------------------------------------------------------ assert (* Cut *) (e = e) as H87.
------------------------------------------------------------- apply (@logic.eq__refl Point e).
------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col a e e) as H88.
-------------------------------------------------------------- right.
right.
left.
exact H87.
-------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.TS b a e c) as H89.
--------------------------------------------------------------- exists e.
split.
---------------------------------------------------------------- exact H23.
---------------------------------------------------------------- split.
----------------------------------------------------------------- exact H88.
----------------------------------------------------------------- exact H69.
--------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.EF A B E C a b e c) as H90.
---------------------------------------------------------------- apply (@euclidean__axioms.axiom__paste3 A E B C E a e b c e H72 H83 H25).
-----------------------------------------------------------------right.
right.
exact H84.

----------------------------------------------------------------- exact H23.
-----------------------------------------------------------------right.
right.
exact H87.

---------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.EF a b e c A B E C) as H91.
----------------------------------------------------------------- apply (@euclidean__axioms.axiom__EFsymmetric A B E C a b e c H90).
----------------------------------------------------------------- assert (* Cut *) (exists F G, (euclidean__defs.PG F E C G) /\ ((euclidean__axioms.EF A B E C F E C G) /\ ((euclidean__defs.CongA C E F J D K) /\ (euclidean__axioms.Col F G A)))) as H92.
------------------------------------------------------------------ apply (@proposition__42.proposition__42 A B C D E J K H47 H1 H2).
------------------------------------------------------------------ destruct H92 as [F H93].
destruct H93 as [G H94].
destruct H94 as [H95 H96].
destruct H96 as [H97 H98].
destruct H98 as [H99 H100].
assert (* Cut *) (euclidean__axioms.EF a b e c F E C G) as H101.
------------------------------------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive a b e c F E C G A B E C H91 H97).
------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R P B C) as H102.
-------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS R P B C) /\ ((euclidean__defs.OS P R C B) /\ (euclidean__defs.OS R P C B))) as H102.
--------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B C P R H22).
--------------------------------------------------------------------- destruct H102 as [H103 H104].
destruct H104 as [H105 H106].
exact H103.
-------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B B C) as H103.
--------------------------------------------------------------------- left.
exact H57.
--------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R A B C) as H104.
---------------------------------------------------------------------- apply (@lemma__sameside2.lemma__sameside2 B B C R P A H102 H103 H42).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R A C B) as H105.
----------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip B C R A H104).
----------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R A C E) as H106.
------------------------------------------------------------------------ apply (@lemma__samesidecollinear.lemma__samesidecollinear C B E R A H105 H73 H75).
------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS A R C E) as H107.
------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS A R C E) /\ ((euclidean__defs.OS R A E C) /\ (euclidean__defs.OS A R E C))) as H107.
-------------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric C E R A H106).
-------------------------------------------------------------------------- destruct H107 as [H108 H109].
destruct H109 as [H110 H111].
exact H108.
------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS A R E C) as H108.
-------------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip C E A R H107).
-------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col G F A) as H109.
--------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col G F A) /\ ((euclidean__axioms.Col G A F) /\ ((euclidean__axioms.Col A F G) /\ ((euclidean__axioms.Col F A G) /\ (euclidean__axioms.Col A G F))))) as H109.
---------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder F G A H100).
---------------------------------------------------------------------------- destruct H109 as [H110 H111].
destruct H111 as [H112 H113].
destruct H113 as [H114 H115].
destruct H115 as [H116 H117].
exact H110.
--------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par F G E C) as H110.
---------------------------------------------------------------------------- destruct H95 as [H110 H111].
exact H111.
---------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E C F G) as H111.
----------------------------------------------------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric F G E C H110).
----------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E C G F) as H112.
------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__defs.Par C E F G) /\ ((euclidean__defs.Par E C G F) /\ (euclidean__defs.Par C E G F))) as H112.
------------------------------------------------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip E C F G H111).
------------------------------------------------------------------------------- destruct H112 as [H113 H114].
destruct H114 as [H115 H116].
exact H115.
------------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS R F E C) as H113.
------------------------------------------------------------------------------- assert (* Cut *) ((A = F) \/ (euclidean__axioms.neq A F)) as H113.
-------------------------------------------------------------------------------- apply (@euclidean__tactics.eq__or__neq A F).
-------------------------------------------------------------------------------- assert ((A = F) \/ (euclidean__axioms.neq A F)) as H114 by exact H113.
assert ((A = F) \/ (euclidean__axioms.neq A F)) as __TmpHyp by exact H114.
destruct __TmpHyp as [H115|H115].
--------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R A E C) as H116.
---------------------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip C E R A H106).
---------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R F E C) as H117.
----------------------------------------------------------------------------------- apply (@eq__ind__r euclidean__axioms.Point F (fun A0 => (euclidean__defs.Out B P A0) -> ((euclidean__axioms.Cong B A0 b a) -> ((euclidean__defs.CongA a b c A0 B C) -> ((euclidean__defs.CongA A0 B C a b c) -> ((euclidean__axioms.nCol A0 B C) -> ((euclidean__axioms.Triangle A0 B C) -> ((euclidean__axioms.Cong A0 C a c) -> ((euclidean__axioms.Cong A0 B a b) -> ((euclidean__axioms.Cong C A0 c a) -> ((euclidean__axioms.Cong E A0 e a) -> ((euclidean__axioms.Cong A0 E a e) -> ((euclidean__axioms.nCol B C A0) -> ((euclidean__axioms.nCol B E A0) -> ((euclidean__axioms.nCol A0 E B) -> ((euclidean__axioms.Triangle A0 E B) -> ((euclidean__axioms.Cong__3 A0 E B a e b) -> ((euclidean__axioms.ET A0 E B a e b) -> ((euclidean__axioms.nCol C B A0) -> ((euclidean__axioms.nCol C E A0) -> ((euclidean__axioms.nCol A0 E C) -> ((euclidean__axioms.Triangle A0 E C) -> ((euclidean__axioms.Cong__3 A0 E C a e c) -> ((euclidean__axioms.ET A0 E C a e c) -> ((euclidean__axioms.Col A0 E E) -> ((euclidean__axioms.TS B A0 E C) -> ((euclidean__axioms.EF A0 B E C a b e c) -> ((euclidean__axioms.EF a b e c A0 B E C) -> ((euclidean__axioms.EF A0 B E C F E C G) -> ((euclidean__axioms.Col F G A0) -> ((euclidean__defs.OS R A0 B C) -> ((euclidean__defs.OS R A0 C B) -> ((euclidean__defs.OS R A0 C E) -> ((euclidean__defs.OS A0 R C E) -> ((euclidean__defs.OS A0 R E C) -> ((euclidean__axioms.Col G F A0) -> ((euclidean__defs.OS R A0 E C) -> (euclidean__defs.OS R F E C)))))))))))))))))))))))))))))))))))))) with (x := A).
------------------------------------------------------------------------------------intro H117.
intro H118.
intro H119.
intro H120.
intro H121.
intro H122.
intro H123.
intro H124.
intro H125.
intro H126.
intro H127.
intro H128.
intro H129.
intro H130.
intro H131.
intro H132.
intro H133.
intro H134.
intro H135.
intro H136.
intro H137.
intro H138.
intro H139.
intro H140.
intro H141.
intro H142.
intro H143.
intro H144.
intro H145.
intro H146.
intro H147.
intro H148.
intro H149.
intro H150.
intro H151.
intro H152.
exact H152.

------------------------------------------------------------------------------------ exact H115.
------------------------------------------------------------------------------------ exact H42.
------------------------------------------------------------------------------------ exact H43.
------------------------------------------------------------------------------------ exact H44.
------------------------------------------------------------------------------------ exact H45.
------------------------------------------------------------------------------------ exact H46.
------------------------------------------------------------------------------------ exact H47.
------------------------------------------------------------------------------------ exact H48.
------------------------------------------------------------------------------------ exact H49.
------------------------------------------------------------------------------------ exact H50.
------------------------------------------------------------------------------------ exact H51.
------------------------------------------------------------------------------------ exact H52.
------------------------------------------------------------------------------------ exact H56.
------------------------------------------------------------------------------------ exact H60.
------------------------------------------------------------------------------------ exact H61.
------------------------------------------------------------------------------------ exact H70.
------------------------------------------------------------------------------------ exact H71.
------------------------------------------------------------------------------------ exact H72.
------------------------------------------------------------------------------------ exact H76.
------------------------------------------------------------------------------------ exact H79.
------------------------------------------------------------------------------------ exact H80.
------------------------------------------------------------------------------------ exact H81.
------------------------------------------------------------------------------------ exact H82.
------------------------------------------------------------------------------------ exact H83.
------------------------------------------------------------------------------------ exact H85.
------------------------------------------------------------------------------------ exact H86.
------------------------------------------------------------------------------------ exact H90.
------------------------------------------------------------------------------------ exact H91.
------------------------------------------------------------------------------------ exact H97.
------------------------------------------------------------------------------------ exact H100.
------------------------------------------------------------------------------------ exact H104.
------------------------------------------------------------------------------------ exact H105.
------------------------------------------------------------------------------------ exact H106.
------------------------------------------------------------------------------------ exact H107.
------------------------------------------------------------------------------------ exact H108.
------------------------------------------------------------------------------------ exact H109.
------------------------------------------------------------------------------------ exact H116.
----------------------------------------------------------------------------------- exact H117.
--------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E C A F) as H116.
---------------------------------------------------------------------------------- apply (@lemma__collinearparallel.lemma__collinearparallel E C A G F H112 H109 H115).
---------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E C F A) as H117.
----------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par C E A F) /\ ((euclidean__defs.Par E C F A) /\ (euclidean__defs.Par C E F A))) as H117.
------------------------------------------------------------------------------------ apply (@lemma__parallelflip.lemma__parallelflip E C A F H116).
------------------------------------------------------------------------------------ destruct H117 as [H118 H119].
destruct H119 as [H120 H121].
exact H120.
----------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.TP E C F A) as H118.
------------------------------------------------------------------------------------ apply (@lemma__paralleldef2B.lemma__paralleldef2B E C F A H117).
------------------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS F A E C) as H119.
------------------------------------------------------------------------------------- destruct H118 as [H119 H120].
destruct H120 as [H121 H122].
destruct H122 as [H123 H124].
exact H124.
------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS F R E C) as H120.
-------------------------------------------------------------------------------------- apply (@lemma__samesidetransitive.lemma__samesidetransitive E C F A R H119 H108).
-------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS R F E C) as H121.
--------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS R F E C) /\ ((euclidean__defs.OS F R C E) /\ (euclidean__defs.OS R F C E))) as H121.
---------------------------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric E C F R H120).
---------------------------------------------------------------------------------------- destruct H121 as [H122 H123].
destruct H123 as [H124 H125].
exact H122.
--------------------------------------------------------------------------------------- exact H121.
------------------------------------------------------------------------------- exists F.
exists G.
split.
-------------------------------------------------------------------------------- exact H95.
-------------------------------------------------------------------------------- split.
--------------------------------------------------------------------------------- exact H101.
--------------------------------------------------------------------------------- split.
---------------------------------------------------------------------------------- exact H99.
---------------------------------------------------------------------------------- exact H113.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*********************************************************)
(**          Definitions for the axiomatization          *)
(*********************************************************)

Declare ML Module "r_syntax_plugin".
Require Export ZArith_base.

Parameter R : Set.

(* Declare Scope positive_scope with Key R *)
Delimit Scope R_scope with R.

(* Automatically open scope R_scope for arguments of type R *)
Bind Scope R_scope with R.

Open Local Scope R_scope.

Parameter R0 : R.
Parameter R1 : R.
Parameter Rplus : R -> R -> R.
Parameter Rmult : R -> R -> R.
Parameter Ropp : R -> R.
Parameter Rinv : R -> R.
Parameter Rlt : R -> R -> Prop.
Parameter up : R -> Z.

Infix "+" := Rplus : R_scope.
Infix "*" := Rmult : R_scope.
Notation "- x" := (Ropp x) : R_scope.
Notation "/ x" := (Rinv x) : R_scope.

Infix "<" := Rlt : R_scope.

(***********************************************************)

(**********)
Definition Rgt (r1 r2:R) : Prop := r2 < r1.

(**********)
Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.

(**********)
Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2.

(**********)
Definition Rminus (r1 r2:R) : R := r1 + - r2.

(**********)
Definition Rdiv (r1 r2:R) : R := r1 * / r2.

(**********)

Infix "-" := Rminus : R_scope.
Infix "/" := Rdiv   : R_scope.

Infix "<=" := Rle : R_scope.
Infix ">=" := Rge : R_scope.
Infix ">"  := Rgt : R_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope.
Notation "x <= y < z"  := (x <= y /\ y <  z) : R_scope.
Notation "x < y < z"   := (x <  y /\ y <  z) : R_scope.
Notation "x < y <= z"  := (x <  y /\ y <= z) : R_scope.


Require Import Real.
Require Import RealSubsets.
(* computing a multivalued function using limit; e.g., complex sqrt *)

Require Import Psatz.

(* for a classical description of real numbers [P : Real -> Prop],
   [x : Real] approximates it by [prec n] *)
(* Definition w_approx (P : Real -> Prop) (n : nat) (x : Real) : Prop *)
(*   := exists y, P y /\ dist x y <= prec n. *)

(* (* a predicate [P : Real -> Prop] is complete if for any converging seqeunce *)
(*    [f : nat -> Real] such that [w_approx P n (f n)] holds for all [n : nat], *)
(*    the limit point satisfies [P x]. For example, [Real \ {0}] is not complete. *) *)
(* Definition closed_predicate (P : Real -> Prop) := *)
(*   forall f : nat -> Real, *)
(*     is_fast_cauchy f -> (forall n, w_approx P n (f n)) -> (forall x, is_fast_limit x f -> P x). *)

Section MultiLimit.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  (* from a multivalued procedure apporximating, we get approximating sequences *)
  Lemma consecutive_converging_fast_cauchy : forall f : nat -> Real,
      (forall n, dist (f n) (f (S n)) <= prec (S n)) -> is_fast_cauchy f.
  Proof.
    intros f H.
    apply (proj2 (is_fast_cauchy_iff_p  _)).
    intros n1 m1.

    assert (forall n m k,  (n <= m)%nat -> (k = m - n)%nat ->  - prec n - prec m <= f n - f m <= prec n + prec m).
    intros n m k H0 e.
    assert (m  = k + n)%nat by (rewrite e; lia).
    induction (eq_sym H1).
    assert (- prec n + prec (n + k) <=  f n - f (k + n)%nat <= prec n - prec (n + k)).
    induction k.
    replace (n + 0)%nat with n by lia; replace (0 + n)%nat with n by lia; split; simpl.
    replace (-prec n + prec n) with real_0 by ring.
    replace (f n - f n) with real_0 by ring.
    right; auto.
    replace (prec n - prec n) with real_0 by ring.
    replace (f n - f n) with real_0 by ring.
    right; auto.
    assert ( k = (k + n - n)%nat) by lia.
    assert ((k + n)%nat = (k + n)%nat) by apply eq_refl.
    assert (n <= k + n)%nat by lia.
    pose proof (IHk H4 H2 H3).
    clear e H1 H0 IHk H2 H3 H4.
    split.
    destruct H5.
    pose proof (H (k + n)%nat).

    pose proof ( proj1 (dist_le_prop _ _ _) H2).
    clear H2.
    destruct H3.
    pose proof (real_le_le_plus_le _ _ _ _ H0 H2).
    ring_simplify in H4.
    assert (
        - prec n + prec (n + S k)
        <=  - prec n + prec (n + k) - prec (S (k + n))).
    right.
    rewrite<- (prec_twice (n + k)).
    replace (n + S k )%nat with (n + k + 1)%nat by lia.
    replace (S (k + n ))%nat with (n + k + 1)%nat by lia.
    ring.
    exact (real_le_le_le _ _ _ H5 H4).
    destruct H5.
    pose proof (H (k + n)%nat).
    pose proof (proj1 (dist_le_prop _ _ _) H2).
    clear H2.
    destruct H3.
    pose proof (real_le_le_plus_le _ _ _ _ H1 H3).
    ring_simplify in H4.
    assert (
        prec n - prec (n + k) + prec (S (k + n)) <=
        prec n - prec (n + S k)).
    right.
    rewrite<- (prec_twice (n + k)).
    replace (n + S k )%nat with (n + k + 1)%nat by lia.
    replace (S (k + n ))%nat with (n + k + 1)%nat by lia.
    ring.
    exact (real_le_le_le _ _ _ H4 H5).
    destruct H2.
    split.
    apply (fun a => real_le_le_le _ _ _ a H2).
    pose proof (real_lt_lt_plus_lt _ _ _ _ (prec_pos (k + n)) (prec_pos (k + n))).
    apply (real_lt_plus_lt (-prec n - prec (k + n))) in H4.
    ring_simplify in H4.
    replace (n + k)%nat with (k + n)%nat by lia.
    left; auto.
    apply (fun a => real_le_le_le _ _ _ H3 a).
    pose proof (real_lt_lt_plus_lt  _ _ _ _ (prec_pos (k + n)) (prec_pos (k + n))).
    apply (real_lt_plus_lt (prec n - prec (k + n))) in H4.
    ring_simplify in H4.
    replace (n + k)%nat with (k + n)%nat by lia.
    left; auto.
    assert (J : (n1 <= m1 \/ m1 <= n1)%nat) by lia; destruct J.

    apply (H0 _ _ (m1 - n1)%nat H1  eq_refl).
    pose proof (H0 _ _  (n1 - m1)%nat H1 eq_refl).
    destruct H2 as [H2 H3].
    apply (real_le_plus_le (prec m1 + prec n1 - (f m1) + (f n1))) in H2.
    ring_simplify in H2.
    apply (real_le_plus_le (- prec m1 - prec n1 + (f n1) - (f m1))) in H3.
    ring_simplify in H3.
    replace (prec n1 + prec m1) with (prec m1 + prec n1) by ring;
      replace (- prec n1 - prec m1) with (- prec m1 - prec n1) by ring.
    replace (- f m1 + f n1) with (f n1 - f m1) in H2 by ring.
    split; auto.
  Defined.

    (* for a complete predicate [P : real_ -> Prop], when we give an initial searching point
   [ M {x : real_ | w_approx P O x}] and a procedure that refines it,
   [f : forall n x, w_approx P n x -> M {y : real_ | w_approx P (S n) y /\ dist_ x y <= prec n}],
   (see that f is a function that [ (f n) x p] is roughly a multivalued real number [y]
   such that (1) [y] approximates [P] by [prec (n + 1)] and (2) [|x-y| <= prec n] when
   [x] is [prec n] approximation of [P]) it gives us a multivalued real numbers
   that are in [P] *)
  Definition real_mlimit_P : forall P : Real -> Prop,
      is_seq_closed P ->
      M {x : Real | w_approx P O x} ->
      (forall n x, w_approx P n x ->
                   M {y : Real | w_approx P (S n) y /\ dist x y <= prec (S n)}) ->
      M {x : Real | P x}.
  Proof.
    intros P c X f.
    assert ((forall n (x : {x : Real | w_approx P n x}),
                M {y : { y : Real | w_approx P (S n) y} | dist (projP1 _ _ x) (projP1 _ _ y) <= prec  (S n)})).
    intros.
    destruct x.
    pose proof (f n x w).
    apply (M_lift {y : Real | w_approx P (S n) y /\ dist x y <= prec (S n)}).
    intro.
    rename X1 into H.
    destruct H.
    destruct a.
    exists (exist _ x0 H).
    simpl.
    exact H0.
    exact X0.
    pose proof (M_paths _ _ X X0).
    simpl in X1.
    apply (M_lift_dom {x | w_approx P 0 x}).
    intro.
    apply (M_lift {f : forall n : nat, {x : Real | w_approx P n x}
                 | forall m : nat,
                     dist (projP1 Real (fun x : Real => w_approx P m x) (f m))
                           (projP1 Real (fun y : Real => w_approx P (S m) y) (f (S m))) <= prec (S m)}).
    intro.
    rename X2 into H.
    rename X3 into H0.
    destruct H.
    destruct H0.
    simpl in r.
    assert (is_fast_cauchy (fun n => projP1 _ _ (x0 n))).
    apply consecutive_converging_fast_cauchy.
    exact r.
    pose proof (real_limit _ H).
    rename X2 into H0.
    destruct H0.
    exists x1.
    pose proof (c (fun n => projP1 _ _ (x0 n)) H ).
    assert (forall n : nat, w_approx P n ((fun n0 : nat => projP1 Real (w_approx P n0) (x0 n0)) n)).
    intro.
    destruct (x0 n).
    simpl.
    exact w0.
    apply (H0 H1).
    exact i.
    exact X1.
    exact X.
  Defined.

  Definition real_mlimit_PQ :
    forall P : Real -> Prop,
      forall Q : nat -> Real -> Prop,
        is_seq_closed P ->
        M {x : Real | w_approx P O x /\ Q O x} ->
        (forall n x, w_approx P n x -> Q n x ->
                     M {y : Real | w_approx P (S n) y /\ Q (S n) y /\ dist x y <= prec (S n)}) ->
        M {x : Real | P x}.
  Proof.
    intros P Q c X f.
    assert ((forall n (x : {x : Real | w_approx P n x /\ Q n x}),
                M {y : { y : Real | w_approx P (S n) y /\ Q (S n) y} | dist (projP1 _ _ x) (projP1 _ _ y) <= prec  (S n)})).
    intros.
    destruct x as [x [w w0]].
    pose proof (f n x w).
    apply (M_lift {y : Real | w_approx P (S n) y /\ Q (S n) y /\ dist x y <= prec (S n)}).
    intro.
    rename X1 into H.
    destruct H.
    assert ( w_approx P (S n) x0 /\ Q (S n) x0).
    destruct a.
    destruct H0.
    auto.
    exists (exist _ x0 H).
    simpl.
    destruct a.
    destruct H1.
    exact H2.
    exact (X0 w0).
    pose proof (M_paths _ _ X X0).
    simpl in X1.
    apply (M_lift_dom {x | w_approx P 0 x /\ Q O x}).
    intro.
    apply (M_lift {f : forall n : nat, {x : Real | w_approx P n x /\ Q n x}
                 | forall m : nat,
                     dist (projP1 Real (fun x : Real => w_approx P m x /\ Q m x) (f m))
                           (projP1 Real (fun y : Real => w_approx P (S m) y /\ Q (S m) y) (f (S m))) <= prec (S m)}).
    intro.
    rename X2 into H.
    rename X3 into H0.
    destruct H.
    destruct H0.
    simpl in r.
    assert (is_fast_cauchy (fun n => projP1 _ _ (x0 n))).
    apply consecutive_converging_fast_cauchy.
    exact r.
    pose proof (real_limit _ H).
    rename X2 into H0.
    destruct H0.
    exists x1.
    pose proof (c (fun n => projP1 _ _ (x0 n)) H ).
    assert (forall n : nat, w_approx P n ((fun n0 : nat => projP1 _ _ (x0 n0)) n)).

    intro.
    destruct (x0 n).
    simpl.
    destruct a0.
    exact H1.
    apply (H0 H1).
    exact i.
    exact X1.
    exact X.
  Defined.

End MultiLimit.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Import ZArith.
Require Export Znumtheory.
Require Import Tactic.
Require Import ZAux.
Require Import Zp.
Require Import FGroup.
Require Import EGroup.
Require Import Euler.

Open Scope Z_scope.

Theorem Pocklington:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
  forall n, prime n -> (n | N) -> n mod F1 = 1.
intros N F1 R1 HF1 HR1 Neq Rec n Hn H.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite Neq; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
assert (Hn1: 1 < n); auto with zarith.
apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith.
assert (H1: (F1 | n - 1)).
2: rewrite <- (Zmod_def_small 1 F1); auto with zarith.
2: case H1; intros k H1'.
2: replace n with (1 + (n - 1)); auto with zarith.
2: rewrite H1'; apply Z_mod_plus; auto with zarith.
apply Zdivide_Zpower; auto with zarith.
intros p i Hp Hi HiF1.
case (Rec p); auto.
apply Zdivide_trans with (2 := HiF1).
apply Zpower_divide; auto with zarith.
intros a (Ha1, (Ha2, Ha3)).
assert (HNn: a ^ (N - 1) mod n = 1).
apply Zdivide_mod_minus; auto with zarith.
apply Zdivide_trans with (1 := H).
apply Zmod_divide_minus; auto with zarith.
assert (~(n | a)).
intros H1; absurd (0 = 1); auto with zarith.
rewrite <- HNn; auto.
apply sym_equal; apply Zdivide_mod; auto with zarith.
apply Zdivide_trans with (1 := H1); apply Zpower_divide; auto with zarith.
assert (Hr: rel_prime a n).
apply rel_prime_sym; apply prime_rel_prime; auto.
assert (Hz: 0 < Zorder a n).
apply Zorder_power_pos; auto.
apply Zdivide_trans with (Zorder a n).
apply prime_divide_Zpower_Zdiv with (N - 1); auto with zarith.
apply Zorder_div_power; auto with zarith.
intros H1; absurd (1 < n); auto; apply Zle_not_lt; apply Zdivide_le; auto with zarith.
rewrite <- Ha3; apply Zdivide_Zgcd; auto with zarith.
apply Zmod_divide_minus; auto with zarith.
case H1; intros t Ht; rewrite Ht.
assert (Ht1: 0 <= t).
apply Zmult_le_reg_r with (Zorder a n); auto with zarith.
rewrite Zmult_0_l; rewrite <- Ht.
apply Zge_le; apply Z_div_ge0; auto with zarith.
apply Zlt_gt; apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith.
rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith.
rewrite Zmod_Zpower; auto with zarith.
rewrite Zorder_power_is_1; auto with zarith.
rewrite Zpower_1; auto with zarith.
apply Zmod_def_small; auto with zarith.
apply Zdivide_trans with (1:= HiF1); rewrite Neq; apply Zdivide_factor_r.
apply Zorder_div; auto.
Qed.

Theorem PocklingtonCorollary1:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> N < F1 * F1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
   prime N.
intros N F1 R1 H H1 H2 H3 H4; case (prime_dec N); intros H5; auto.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H2; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
case Zdivide_div_prime_le_square with (2:= H5); auto with zarith.
intros n (Hn, (Hn1, Hn2)).
assert (Hn3: 0 <= n).
apply Zle_trans with 2; try apply prime_le_2; auto with zarith.
absurd (n = 1).
intros H6; contradict Hn; subst; apply not_prime_1.
rewrite <- (Zmod_def_small n F1); try split; auto.
apply Pocklington with (R1 := R1) (4 := H4); auto.
apply Zlt_square_mult_inv; auto with zarith.
Qed.

Theorem PocklingtonCorollary2:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 ->
   (forall p,  prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
  forall n, 0 <= n -> (n | N) -> n mod F1 = 1.
intros N F1 R1 H1 H2 H3 H4 n H5; pattern n; apply prime_induction; auto.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H3; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
intros (u, Hu); contradict HN; subst; rewrite Zmult_0_r; auto with zarith.
intro H6; rewrite Zmod_def_small; auto with zarith.
intros p q Hp Hp1 Hp2; rewrite Zmod_mult; auto with zarith.
rewrite Pocklington with (n := p) (R1 := R1) (4 := H4); auto.
rewrite Hp1.
rewrite Zmult_1_r; rewrite Zmod_def_small; auto with zarith.
apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_l.
apply Zdivide_trans with (2 := Hp2); apply Zdivide_factor_r; auto.
Qed.

Definition isSquare x := exists y, x = y * y.

Theorem PocklingtonExtra:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
   forall m, 1 <= m ->  (forall l, 1 <= l < m -> ~((l * F1 + 1) | N)) ->
    let s := (R1 / (2 * F1)) in
    let r := (R1 mod (2 * F1)) in
      N < (m * F1 + 1) * (2 * F1 * F1 + (r - m) * F1 + 1) ->
      (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N.
intros N F1 R1 H1 H2 H3 OF1 ER1 H4 m H5 H6 s r H7 H8.
case (prime_dec N); auto; intros H9.
assert (HN: 1 < N).
assert (0 < N - 1); auto with zarith.
rewrite H3; auto with zarith.
apply Zlt_le_trans with (1* R1); auto with zarith.
case  Zdivide_div_prime_le_square with N; auto.
intros X (Hx1, (Hx2, Hx3)).
assert (Hx0: 1 < X).
apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith.
pose (c := (X /  F1)).
assert(Hc1: 0 <= c); auto with zarith.
apply Zge_le; unfold c; apply Z_div_ge0; auto with zarith.
assert (Hc2: X = c * F1 + 1).
rewrite (Z_div_mod_eq X F1); auto with zarith.
eq_tac; auto.
rewrite (Zmult_comm F1); auto.
apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith.
case Zle_lt_or_eq with (1 := Hc1); clear Hc1; intros Hc1.
2: contradict Hx0; rewrite Hc2; try rewrite <- Hc1; auto with zarith.
case (Zle_or_lt m c); intros Hc3.
2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith.
2: case (H6 c); auto with zarith; rewrite <- Hc2; auto.
2: contradict Hc3; rewrite <- H5; auto with zarith.
pose (d := ((N / X) /  F1)).
assert(Hd0: 0 <= N / X); auto with zarith.
apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith.
assert(Hd1: 0 <= d); auto with zarith.
apply Zge_le; unfold d; repeat apply Z_div_ge0; auto with zarith.
assert (Hd2: N / X =  d * F1 + 1).
rewrite (Z_div_mod_eq (N / X) F1); auto with zarith.
eq_tac; auto.
rewrite (Zmult_comm F1); auto.
apply PocklingtonCorollary2 with (R1 := R1) (4 := H4); auto with zarith.
exists X; auto with zarith.
apply Zdivide_Zdiv_eq; auto with zarith.
case Zle_lt_or_eq with (1  := Hd0); clear Hd0; intros Hd0.
2: contradict HN; rewrite (Zdivide_Zdiv_eq X N); auto with zarith.
2: rewrite <- Hd0; auto with zarith.
case (Zle_lt_or_eq 1 (N / X)); auto with zarith; clear Hd0; intros Hd0.
2: contradict H9; rewrite (Zdivide_Zdiv_eq X N); auto with zarith.
2: rewrite <- Hd0; rewrite Zmult_1_r; auto with zarith.
case Zle_lt_or_eq with (1 := Hd1); clear Hd1; intros Hd1.
2: contradict Hd0; rewrite Hd2; try rewrite <- Hd1; auto with zarith.
case (Zle_or_lt m d); intros Hd3.
2: case Zle_lt_or_eq with (1 := H5); clear H5; intros H5; auto with zarith.
2: case (H6 d); auto with zarith; rewrite <- Hd2; auto.
2: exists X; auto with zarith.
2: apply Zdivide_Zdiv_eq; auto with zarith.
2: contradict Hd3; rewrite <- H5; auto with zarith.
assert (L5: N = (c * F1 + 1) * (d * F1 + 1)).
rewrite <- Hc2; rewrite <- Hd2; apply Zdivide_Zdiv_eq; auto with zarith.
assert (L6: R1 = c * d * F1 + c + d).
apply trans_equal with ((N - 1) / F1).
rewrite H3; rewrite Zmult_comm; apply sym_equal; apply Z_div_mult; auto with zarith.
rewrite L5.
match goal with |- (?X / ?Y = ?Z) => replace X with (Z * Y) end; try ring; apply Z_div_mult; auto with zarith.
assert (L6_1: Zodd (c + d)).
case (Zeven_odd_dec (c + d)); auto; intros O1.
contradict ER1; apply Zeven_not_Zodd; rewrite L6; rewrite <- Zplus_assoc; apply Zeven_plus_Zeven_Zeven; auto.
apply Zeven_mult_Zeven_r; auto.
assert (L6_2: Zeven (c * d)).
case (Zeven_odd_dec c); intros HH1.
apply Zeven_mult_Zeven_l; auto.
case (Zeven_odd_dec d); intros HH2.
apply Zeven_mult_Zeven_r; auto.
contradict L6_1; apply Zeven_not_Zodd; apply Zodd_plus_Zodd_Zeven; auto.
assert ((c + d) mod (2 * F1) = r).
rewrite <- Z_mod_plus with (b := Zdiv2 (c * d)); auto with zarith.
match goal with |- ?X mod _ = _ => replace X with R1 end; auto.
rewrite L6; pattern (c * d) at 1.
rewrite Zeven_div2 with (1 := L6_2); ring.
assert (L9: c + d - r < 2 * F1).
apply Zplus_lt_reg_r with (r - m).
apply Zmult_lt_reg_r with (F1); auto with zarith.
apply Zplus_lt_reg_r with 1.
match goal with |-  ?X < ?Y =>
  replace Y with (2 * F1 * F1 + (r - m) * F1 + 1); try ring;
  replace X with ((((c + d) - m) * F1) + 1); try ring
end.
apply Zmult_lt_reg_r with (m * F1 + 1); auto with zarith.
apply Zlt_trans with (m * F1 + 0); auto with zarith.
rewrite Zplus_0_r; apply Zmult_lt_O_compat; auto with zarith.
repeat rewrite (fun x => Zmult_comm x (m * F1 + 1)).
apply Zle_lt_trans with (2 := H7).
rewrite L5.
match goal with |-  ?X <= ?Y =>
  replace X with ((m * (c + d) - m * m ) * F1 * F1 + (c + d) * F1 + 1); try ring;
  replace Y with ((c * d) * F1 * F1 + (c + d) * F1 + 1); try ring
end.
repeat apply Zplus_le_compat_r.
repeat apply Zmult_le_compat_r; auto with zarith.
assert (tmp: forall p q, 0 <= p - q  -> q <= p); auto with zarith; try apply tmp.
match goal with |-  _ <= ?X =>
  replace X with ((c - m) * (d - m)); try ring; auto with zarith
end.
assert (L10: c + d = r).
apply Zmod_closeby_eq with (2 * F1); auto with zarith.
unfold r; apply Z_mod_lt; auto with zarith.
assert (L11: 2 * s  = c * d).
apply Zmult_reg_r with F1; auto with zarith.
apply trans_equal with (R1 - (c + d)).
rewrite L10; rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith.
unfold s, r; ring.
rewrite L6; ring.
case H8; intro H10.
absurd (0 < c * d); auto with zarith.
apply Zmult_lt_O_compat; auto with zarith.
case H10; exists (c - d); auto with zarith.
rewrite <- L10.
replace (8 * s) with (4 * (2 * s)); auto with zarith; try rewrite L11; ring.
Qed.

Theorem PocklingtonExtraCorollary:
forall N F1 R1, 1 < F1 -> 0 < R1 -> N - 1 = F1 * R1 -> Zeven F1 -> Zodd R1 ->
   (forall p, prime p -> (p | F1) -> exists a,  1 < a /\ a^(N - 1) mod N = 1 /\ Zgcd (a ^ ((N - 1)/ p) - 1) N = 1) ->
    let s := (R1 / (2 * F1)) in
    let r := (R1 mod (2 * F1)) in
      N < 2 * F1 * F1 * F1 ->  (s = 0 \/ ~ isSquare (r * r - 8 * s)) -> prime N.
intros N F1 R1 H1 H2 H3 OF1 ER1 H4 s r H5 H6.
apply PocklingtonExtra with (6 := H4) (R1 := R1) (m := 1); auto with zarith.
apply Zlt_le_trans with (1 := H5).
match goal with |-  ?X <= ?K * ((?Y + ?Z) + ?T) =>
    rewrite <- (Zplus_0_l X);
   replace (K * ((Y + Z) + T)) with ((F1 * (Z + T) +  Y + Z + T) + X);[idtac | ring]
end.
apply Zplus_le_compat_r.
case (Zle_lt_or_eq 0 r); unfold r; auto with zarith.
case (Z_mod_lt R1 (2 * F1)); auto with zarith.
intros HH; repeat ((rewrite <- (Zplus_0_r 0); apply Zplus_le_compat)); auto with zarith.
intros HH; contradict ER1; apply Zeven_not_Zodd.
rewrite (Z_div_mod_eq R1 (2 * F1)); auto with zarith.
rewrite <- HH; rewrite Zplus_0_r.
rewrite <- Zmult_assoc; apply Zeven_2p.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e150m3_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e150m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e206m5_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e130m5_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e213m3_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(* Abelian groups and Homomorphisms *)

Require Import Utf8.
Require Import Setoid Morphisms.

Reserved Notation "x '∈' S" (at level 60).
Reserved Notation "x '≡' y" (at level 70).

(* Abelian Groups.

   Notes:

   -sets in groups are predicates (naive theory of sets); a value of type
    gr_set is not necessarily in the group set. To be in the group set, it
    must satisfy the predicate gr_mem, which is later syntaxified by the
    usual symbol ∈. This allows to create subgroups by changing gr_mem.

   -group sets are setoids: there is a specific equality (gr_eq) which is
    compatible with membership (gr_mem_compat), addition (gr_add_compat),
    and opposite (gr_opp_compat). This allows to define quotient groups,
    for example in cokernets, by changing this equality.
*)

Record AbGroup :=
  { (* data *)
    gr_set : Type;
    gr_mem : gr_set → Prop where "x ∈ G" := (gr_mem x);
    gr_eq : gr_set → gr_set → Prop where "x ≡ y" := (gr_eq x y);
    gr_zero : gr_set where "0" := (gr_zero);
    gr_add : gr_set → gr_set → gr_set where "x + y" := (gr_add x y);
    gr_opp : gr_set → gr_set where "- x" := (gr_opp x);
    (* properties *)
    gr_zero_mem : 0 ∈ G;
    gr_add_mem : ∀ x y, x ∈ G → y ∈ G → x + y ∈ G;
    gr_add_0_l : ∀ x, 0 + x ≡ x;
    gr_add_assoc : ∀ x y z, (x + y) + z ≡ x + (y + z);
    gr_opp_mem : ∀ x, x ∈ G → - x ∈ G;
    gr_add_opp_r : ∀ x, x + (- x) ≡ 0;
    gr_add_comm : ∀ x y, x + y ≡ y + x;
    gr_equiv : Equivalence gr_eq;
    gr_mem_compat : ∀ x y, x ≡ y → x ∈ G → y ∈ G;
    gr_add_compat : ∀ x y x' y', x ≡ y → x' ≡ y' → x + x' ≡ y + y';
    gr_opp_compat : ∀ x y, x ≡ y → - x ≡ - y }.

(* coq stuff: implicit and renamed arguments *)

Arguments gr_eq [_].
Arguments gr_zero [_].
Arguments gr_add [_].
Arguments gr_opp [_].
Arguments gr_zero_mem G : rename.
Arguments gr_add_mem G : rename.
Arguments gr_add_0_l G : rename.
Arguments gr_add_assoc G : rename.
Arguments gr_opp_mem G : rename.
Arguments gr_add_opp_r G : rename.
Arguments gr_add_comm G : rename.
Arguments gr_equiv G : rename.
Arguments gr_mem_compat G : rename.
Arguments gr_add_compat G : rename.
Arguments gr_opp_compat G : rename.

(* syntaxes for expressions for groups elements and sets *)

Delimit Scope group_scope with G.

Notation "0" := (gr_zero) : group_scope.
Notation "a = b" := (gr_eq a b) : group_scope.
Notation "a ≠ b" := (¬ gr_eq a b) : group_scope.
Notation "a + b" := (gr_add a b) : group_scope.
Notation "a - b" := (gr_add a (gr_opp b)) : group_scope.
Notation "- a" := (gr_opp a) : group_scope.

Notation "x '∈' S" := (gr_mem S x) (at level 60).
Notation "x '∉' S" := (¬ gr_mem S x) (at level 60).

Open Scope group_scope.

(* Homomorphism between groups *)

Record HomGr (A B : AbGroup) :=
  { Happ : gr_set A → gr_set B;
    Hmem_compat : ∀ x, x ∈ A → Happ x ∈ B;
    Happ_compat : ∀ x y, x ∈ A → (x = y)%G → (Happ x = Happ y)%G;
    Hadditive : ∀ x y,
      x ∈ A → y ∈ A → (Happ (x + y) = Happ x + Happ y)%G }.

(* coq stuff: implicit and renamed arguments *)

Arguments Happ [A] [B].
Arguments Hmem_compat _ _ f : rename.
Arguments Happ_compat _ _ f : rename.
Arguments Hadditive _ _ f : rename.

(* Equality (gr_eq) of groups elements is an equivalence relation *)

Instance gr_eq_rel {G} : Equivalence (@gr_eq G).
Proof. apply gr_equiv. Qed.

(* Coq "Morphisms": they allow to use "rewrite" in expressions containing
   opposites (-), additions (+) and memberships (∈) *)

Instance gr_opp_morph {G} : Proper (@gr_eq G ==> @gr_eq G) (@gr_opp G).
Proof.
intros x y Hxy.
now apply gr_opp_compat.
Qed.

Instance gr_add_morph {G} :
  Proper (@gr_eq G ==> @gr_eq G ==> @gr_eq G) (@gr_add G).
Proof.
intros x y Hxy x' y' Hxy'.
now apply gr_add_compat.
Qed.

Instance gr_mem_morph {G} : Proper (@gr_eq G ==> iff) (@gr_mem G).
Proof.
intros x y Hxy.
split; intros H.
-eapply gr_mem_compat; [ apply Hxy | easy ].
-eapply gr_mem_compat; [ symmetry; apply Hxy | easy ].
Qed.

(*
Instance gr_app_morph {G H f} : Proper (@gr_eq G ==> @gr_eq H) (Happ f).
Proof.
intros x y Hxy.
apply Happ_compat; [ | easy ].
...
blocked: we have to prove x ∈ G but it is not possible to
have this hypothesis in Proper
*)

(* Miscellaneous theorems in groups *)

Theorem gr_add_0_r : ∀ G (x : gr_set G), (x + 0 = x)%G.
Proof.
intros.
rewrite gr_add_comm.
apply gr_add_0_l.
Qed.

Theorem gr_add_opp_l : ∀ G (x : gr_set G), (- x + x = 0)%G.
Proof.
intros.
rewrite gr_add_comm.
apply gr_add_opp_r.
Qed.

Theorem gr_opp_zero : ∀ G, (- 0 = @gr_zero G)%G.
Proof.
intros.
rewrite <- gr_add_0_l.
apply gr_add_opp_r.
Qed.

Theorem gr_sub_0_r : ∀ G (x : gr_set G), (x - 0 = x)%G.
Proof.
intros.
symmetry; rewrite <- gr_add_0_r at 1.
apply gr_add_compat; [ easy | now rewrite gr_opp_zero ].
Qed.

Theorem gr_sub_move_r : ∀ G (x y z : gr_set G),
  (x - y = z)%G ↔ (x = z + y)%G.
Proof.
intros.
split; intros Hxyz.
-now rewrite <- Hxyz, gr_add_assoc, gr_add_opp_l, gr_add_0_r.
-now rewrite Hxyz, gr_add_assoc, gr_add_opp_r, gr_add_0_r.
Qed.

Theorem gr_sub_move_l : ∀ G (x y z : gr_set G),
  (x - y = z)%G ↔ (x = y + z)%G.
Proof.
intros.
split; intros Hxyz.
-now rewrite <- Hxyz, gr_add_comm, gr_add_assoc, gr_add_opp_l, gr_add_0_r.
-now rewrite Hxyz, gr_add_comm, <- gr_add_assoc, gr_add_opp_l, gr_add_0_l.
Qed.

Theorem gr_opp_add_distr : ∀ G (x y : gr_set G), (- (x + y) = - x - y)%G.
Proof.
intros *.
symmetry.
apply gr_sub_move_r.
rewrite <- gr_add_0_l.
apply gr_sub_move_r.
symmetry; rewrite gr_add_assoc.
symmetry.
apply gr_sub_move_r.
rewrite gr_add_0_l.
apply gr_opp_compat, gr_add_comm.
Qed.

Theorem gr_opp_involutive : ∀ G (x : gr_set G), (- - x = x)%G.
Proof.
intros.
transitivity (- - x + (- x + x))%G.
-rewrite <- gr_add_0_r at 1.
 apply gr_add_compat; [ easy | ].
 now rewrite gr_add_opp_l.
-now rewrite <- gr_add_assoc, gr_add_opp_l, gr_add_0_l.
Qed.

Theorem gr_eq_opp_l : ∀ G (x y : gr_set G), (- x = y)%G ↔ (x = - y)%G.
Proof.
intros.
split; intros Hxy.
-rewrite <- Hxy; symmetry; apply gr_opp_involutive.
-rewrite Hxy; apply gr_opp_involutive.
Qed.

(* Theorems on homomorphisms *)

Theorem Hzero : ∀ A B (f : HomGr A B), (Happ f 0 = 0)%G.
Proof.
intros.
assert (H1 : (@gr_zero A + 0 = 0)%G) by apply A.
assert (H2 : (Happ f 0 + Happ f 0 = Happ f 0)%G). {
  rewrite <- Hadditive; [ | apply A | apply A ].
  apply f; [ apply A; apply A | apply A ].
}
assert (H3 : (Happ f 0 + Happ f 0 - Happ f 0 = Happ f 0 - Happ f 0)%G). {
  apply gr_add_compat; [ apply H2 | easy ].
}
assert (H4 : (Happ f 0 + Happ f 0 - Happ f 0 = 0)%G). {
  rewrite H3; apply gr_add_opp_r.
}
rewrite <- H4.
now rewrite gr_add_assoc, gr_add_opp_r, gr_add_0_r.
Qed.

Theorem Hopp : ∀ A B (f : HomGr A B) x,
  x ∈ A → (Happ f (- x) = - Happ f x)%G.
Proof.
intros * Hx.
assert (H2 : (Happ f (x - x) = Happ f 0)%G). {
  apply Happ_compat; [ now apply A, A | apply A ].
}
assert (H3 : (Happ f x + Happ f (- x) = Happ f 0)%G). {
  rewrite <- H2.
  symmetry; apply Hadditive; [ easy | now apply A ].
}
assert (H4 : (Happ f x + Happ f (- x) = 0)%G). {
  rewrite H3; apply Hzero.
}
symmetry; rewrite <- gr_add_0_l.
apply gr_sub_move_l.
now symmetry.
Qed.

(* Images *)

Theorem Im_zero_mem {G H} : ∀ (f : HomGr G H),
  ∃ a : gr_set G, a ∈ G ∧ (Happ f a = 0)%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | apply Hzero ].
Qed.

Theorem Im_add_mem {G H} : ∀ f (x y : gr_set H),
  (∃ a : gr_set G, a ∈ G ∧ (Happ f a = x)%G)
  → (∃ a : gr_set G, a ∈ G ∧ (Happ f a = y)%G)
  → ∃ a : gr_set G, a ∈ G ∧ (Happ f a = x + y)%G.
Proof.
intros f y y' (x & Hxg & Hx) (x' & Hx'g & Hx').
exists (gr_add x x').
split; [ now apply G | ].
rewrite Hadditive; [ | easy | easy ].
now apply gr_add_compat.
Qed.

Theorem Im_opp_mem {G H} : ∀ (f : HomGr G H) (x : gr_set H),
  (∃ a : gr_set G, a ∈ G ∧ (Happ f a = x)%G)
  → ∃ a : gr_set G, a ∈ G ∧ (Happ f a = - x)%G.
Proof.
intros f x (y & Hy & Hyx).
exists (gr_opp y).
split; [ now apply gr_opp_mem | ].
rewrite <- Hyx.
now apply Hopp.
Qed.

Theorem Im_mem_compat {G H} : ∀ f (x y : gr_set H),
  (x = y)%G
  → (∃ a, a ∈ G ∧ (Happ f a = x)%G)
  → ∃ a, a ∈ G ∧ (Happ f a = y)%G.
intros * Hxy (z & Hz & Hfz).
exists z.
split; [ easy | now rewrite Hfz ].
Qed.

Definition Im {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set H;
     gr_zero := gr_zero;
     gr_eq := @gr_eq H;
     gr_mem := λ b, ∃ a, a ∈ G ∧ (Happ f a = b)%G;
     gr_add := @gr_add H;
     gr_opp := @gr_opp H;
     gr_zero_mem := Im_zero_mem f;
     gr_add_mem := Im_add_mem f;
     gr_add_0_l := gr_add_0_l H;
     gr_add_assoc := gr_add_assoc H;
     gr_opp_mem := Im_opp_mem f;
     gr_add_opp_r := gr_add_opp_r H;
     gr_add_comm := gr_add_comm H;
     gr_equiv := gr_equiv H;
     gr_mem_compat := Im_mem_compat f;
     gr_add_compat := gr_add_compat H;
     gr_opp_compat := gr_opp_compat H |}.

(* Kernels *)

Theorem Ker_zero_mem {G H} : ∀ (f : HomGr G H), 0%G ∈ G ∧ (Happ f 0 = 0)%G.
Proof.
intros f.
split; [ apply gr_zero_mem | apply Hzero ].
Qed.

Theorem Ker_add_mem {G H} : ∀ (f : HomGr G H) (x y : gr_set G),
  x ∈ G ∧ (Happ f x = 0)%G
  → y ∈ G ∧ (Happ f y = 0)%G → (x + y)%G ∈ G ∧ (Happ f (x + y) = 0)%G.
Proof.
intros f x x' (Hx, Hfx) (Hx', Hfx').
split; [ now apply gr_add_mem | ].
rewrite Hadditive; [ | easy | easy ].
rewrite Hfx, Hfx'.
apply gr_add_0_r.
Qed.

Theorem Ker_opp_mem {G H} : ∀ (f : HomGr G H) (x : gr_set G),
  x ∈ G ∧ (Happ f x = 0)%G → (- x)%G ∈ G ∧ (Happ f (- x) = 0)%G.
Proof.
intros f x (Hx & Hfx).
split; [ now apply gr_opp_mem | ].
rewrite Hopp; [ | easy ].
rewrite Hfx.
apply gr_opp_zero.
Qed.

Theorem Ker_mem_compat {G H} : ∀ (f : HomGr G H) x y,
  (x = y)%G → x ∈ G ∧ (Happ f x = 0)%G → y ∈ G ∧ (Happ f y = 0)%G.
Proof.
intros * Hxy (ax, Hx).
split.
-eapply gr_mem_compat; [ apply Hxy | easy ].
-rewrite <- Hx.
 apply f; [ | easy ].
 now rewrite <- Hxy.
Qed.

Definition Ker {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set G;
     gr_zero := gr_zero;
     gr_eq := @gr_eq G;
     gr_mem := λ a, a ∈ G ∧ (Happ f a = gr_zero)%G;
     gr_add := @gr_add G;
     gr_opp := @gr_opp G;
     gr_zero_mem := Ker_zero_mem f;
     gr_add_mem := Ker_add_mem f;
     gr_add_0_l := gr_add_0_l G;
     gr_add_assoc := gr_add_assoc G;
     gr_opp_mem := Ker_opp_mem f;
     gr_add_opp_r := gr_add_opp_r G;
     gr_add_comm := gr_add_comm G;
     gr_equiv := gr_equiv G;
     gr_mem_compat := Ker_mem_compat f;
     gr_add_compat := gr_add_compat G;
     gr_opp_compat := gr_opp_compat G |}.

(* Cokernels

   x ∈ Coker f ↔ x ∈ H/Im f
   quotient group is H with setoid, i.e. set with its own equality *)

Definition Coker_eq {G H} (f : HomGr G H) x y := (x - y)%G ∈ Im f.

Theorem Coker_add_0_l {G H} : ∀ (f : HomGr G H) x, Coker_eq f (0 + x)%G x.
Proof.
intros.
unfold Coker_eq.
exists 0%G.
split; [ apply gr_zero_mem | ].
rewrite gr_add_0_l, gr_add_opp_r.
simpl; apply Hzero.
Qed.

Theorem Coker_add_assoc {G H} : ∀ (f : HomGr G H) x y z,
  Coker_eq f (x + y + z)%G (x + (y + z))%G.
Proof.
intros.
unfold Coker_eq.
exists 0%G.
split; [ apply gr_zero_mem | ].
rewrite Hzero.
symmetry; simpl.
apply gr_sub_move_r.
rewrite gr_add_0_l.
apply gr_add_assoc.
Qed.

Theorem Coker_add_opp_r {G H} : ∀ (f : HomGr G H) x, Coker_eq f (x - x)%G 0%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | ].
now rewrite Hzero, gr_add_opp_r, gr_sub_0_r.
Qed.

Theorem Coker_add_comm {G H} : ∀ (f : HomGr G H) x y,
  Coker_eq f (x + y)%G (y + x)%G.
Proof.
intros.
exists 0%G.
split; [ apply gr_zero_mem | ].
rewrite Hzero.
symmetry.
simpl; apply gr_sub_move_l.
now rewrite gr_add_0_r, gr_add_comm.
Qed.

Theorem Coker_eq_refl {G H} (f : HomGr G H) : Reflexive (Coker_eq f).
Proof.
intros x.
exists 0%G.
split; [ apply gr_zero_mem | ].
rewrite gr_add_opp_r.
simpl; apply Hzero.
Qed.

Theorem Coker_eq_symm {G H} (f : HomGr G H) : Symmetric (Coker_eq f).
Proof.
intros x y Hxy.
destruct Hxy as (z & Hz & Hfz).
exists (- z)%G.
split; [ now apply gr_opp_mem | ].
rewrite Hopp; [ | easy ].
rewrite Hfz.
simpl; rewrite gr_opp_add_distr, gr_add_comm.
apply gr_add_compat; [ | easy ].
apply gr_opp_involutive.
Qed.

Theorem Coker_eq_trans {G H} (f : HomGr G H) : Transitive (Coker_eq f).
Proof.
intros x y z Hxy Hyz.
simpl in Hxy, Hyz.
destruct Hxy as (t & Ht & Hft).
destruct Hyz as (u & Hu & Hfu).
exists (t + u)%G.
split; [ now apply gr_add_mem | ].
rewrite Hadditive; [ | easy | easy ].
rewrite Hft, Hfu.
simpl; rewrite gr_add_assoc.
apply gr_add_compat; [ easy | ].
now rewrite <- gr_add_assoc, gr_add_opp_l, gr_add_0_l.
Qed.

Theorem Coker_equiv {G H} : ∀ (f : HomGr G H), Equivalence (Coker_eq f).
Proof.
intros.
unfold Coker_eq; split.
-apply Coker_eq_refl.
-apply Coker_eq_symm.
-apply Coker_eq_trans.
Qed.

Add Parametric Relation {G H} {f : HomGr G H} : (gr_set (Im f)) (Coker_eq f)
 reflexivity proved by (Coker_eq_refl f)
 symmetry proved by (Coker_eq_symm f)
 transitivity proved by (Coker_eq_trans f)
 as gr_cokereq_rel.

Theorem Coker_mem_compat {G H} : ∀ (f : HomGr G H) x y,
  Coker_eq f x y → x ∈ H → y ∈ H.
Proof.
intros * Heq Hx.
destruct Heq as (z & Hz & Hfz).
apply gr_mem_compat with (x := (x - Happ f z)%G).
-rewrite Hfz.
 simpl; apply gr_sub_move_r.
 now rewrite gr_add_comm, gr_add_assoc, gr_add_opp_l, gr_add_0_r.
-simpl; apply gr_add_mem; [ easy | ].
 apply gr_opp_mem.
 now apply f.
Qed.

Theorem Coker_add_compat {G H} : ∀ (f : HomGr G H) x y x' y',
  Coker_eq f x y → Coker_eq f x' y' → Coker_eq f (x + x')%G (y + y')%G.
Proof.
intros f x y x' y' (z & Hz & Hfz) (z' & Hz' & Hfz').
exists (z + z')%G.
split.
-now apply gr_add_mem.
-rewrite Hadditive; [ | easy | easy ].
 rewrite Hfz, Hfz'; simpl.
 rewrite gr_add_assoc; symmetry.
 rewrite gr_add_assoc; symmetry.
 apply gr_add_compat; [ easy | ].
 rewrite gr_add_comm, gr_add_assoc.
 apply gr_add_compat; [ easy | ].
 rewrite gr_add_comm; symmetry.
 apply gr_opp_add_distr.
Qed.

Theorem Coker_opp_compat {G H} :∀ (f : HomGr G H) x y,
  Coker_eq f x y → Coker_eq f (- x)%G (- y)%G.
Proof.
intros * (z & Hz & Hfz).
unfold Coker_eq; simpl.
exists (- z)%G.
split; [ now apply gr_opp_mem | ].
rewrite Hopp; [ | easy ].
rewrite Hfz.
simpl; apply gr_opp_add_distr.
Qed.

Definition Coker {G H : AbGroup} (f : HomGr G H) :=
  {| gr_set := gr_set H;
     gr_zero := gr_zero;
     gr_eq := Coker_eq f;
     gr_mem := gr_mem H;
     gr_add := @gr_add H;
     gr_opp := @gr_opp H;
     gr_zero_mem := @gr_zero_mem H;
     gr_add_mem := @gr_add_mem H;
     gr_add_0_l := Coker_add_0_l f;
     gr_add_assoc := Coker_add_assoc f;
     gr_opp_mem := gr_opp_mem H;
     gr_add_opp_r := Coker_add_opp_r f;
     gr_add_comm := Coker_add_comm f;
     gr_equiv := Coker_equiv f;
     gr_mem_compat := Coker_mem_compat f;
     gr_add_compat := Coker_add_compat f;
     gr_opp_compat := Coker_opp_compat f |}.

(* Exact sequences *)

Inductive sequence {A : AbGroup} :=
  | SeqEnd : sequence
  | Seq : ∀ {B} (f : HomGr A B), @sequence B → sequence.

Notation "A ⊂ B" := (∀ a, a ∈ A → a ∈ B) (at level 60).
Notation "A == B" := (A ⊂ B ∧ B ⊂ A) (at level 60).

Fixpoint exact_sequence {A : AbGroup} (S : sequence) :=
  match S with
  | SeqEnd => True
  | Seq f S' =>
      match S' with
      | SeqEnd => True
      | Seq g S'' => Im f == Ker g ∧ exact_sequence S'
      end
  end.

Delimit Scope seq_scope with S.

Notation "[ ]" := SeqEnd (format "[ ]") : seq_scope.
Notation "[ x ]" := (Seq x SeqEnd) : seq_scope.
Notation "[ x ; y ; .. ; z ]" := (Seq x (Seq y .. (Seq z SeqEnd) ..)) : seq_scope.

Arguments exact_sequence _ S%S.

(* Commuting diagram
        f
    A------>B
    |       |
   g|       |h
    |       |
    v       v
    C------>D
        k
*)

Definition diagram_commutes {A B C D}
     (f : HomGr A B) (g : HomGr A C) (h : HomGr B D) (k : HomGr C D) :=
  ∀ x, (Happ h (Happ f x) = Happ k (Happ g x))%G.

(* The trivial group *)

Theorem Gr1_add_0_l : ∀ x : True, I = x.
Proof. now destruct x. Qed.

Definition Gr1 :=
   {| gr_set := True;
      gr_mem _ := True;
      gr_eq := eq;
      gr_zero := I;
      gr_add _ _ := I;
      gr_opp x := x;
      gr_zero_mem := I;
      gr_add_mem _ _ _ _ := I;
      gr_add_0_l := Gr1_add_0_l;
      gr_add_assoc _ _ _ := eq_refl;
      gr_opp_mem _ H := H;
      gr_add_opp_r _ := eq_refl;
      gr_add_comm _ _ := eq_refl;
      gr_equiv := eq_equivalence;
      gr_mem_compat _ _ _ _ := I;
      gr_add_compat _ _ _ _ _ _ := eq_refl;
      gr_opp_compat _ _ H := H |}.

(* *)

Definition is_mono {A B} (f : HomGr A B) :=
  ∀ C (g₁ g₂ : HomGr C A),
  (∀ z, z ∈ C → (Happ f (Happ g₁ z) = Happ f (Happ g₂ z))%G)
  → (∀ z, z ∈ C → (Happ g₁ z = Happ g₂ z)%G).

Definition is_epi {A B} (f : HomGr A B) :=
  ∀ C (g₁ g₂ : HomGr B C),
  (∀ x, x ∈ A → (Happ g₁ (Happ f x) = Happ g₂ (Happ f x))%G)
  → (∀ y, y ∈ B → (Happ g₁ y = Happ g₂ y)%G).

Definition is_iso {A B} (f : HomGr A B) :=
  ∃ g : HomGr B A,
  (∀ x, x ∈ A → (Happ g (Happ f x) = x)%G) ∧
  (∀ y, y ∈ B → (Happ f (Happ g y) = y)%G).

(* Proofs that epimorphism is surjective and monomorphism is injective *)

Theorem epi_is_surj : ∀ {A B} {f : HomGr A B},
  is_epi f
  → ∀ y, y ∈ B → ∃ t, t ∈ A ∧ (Happ f t = y)%G.
Proof.
intros * Hed y Hy.
(* trick to make identity of type gr_set B → gr_set (Coker f) *)
set (v y1 := let _ : gr_set B := y1 in y1 : gr_set (Coker f)).
assert (Hmc : ∀ y1, y1 ∈ B → v y1 ∈ B) by easy.
assert (Hac : ∀ y1 y2, y1 ∈ B → (y1 = y2)%G → (v y1 = v y2)%G). {
  intros * Hy1 Hyy.
  exists 0; split; [ apply A | ].
  now unfold v; simpl; rewrite Hzero, Hyy, gr_add_opp_r.
}
assert (Had : ∀ y1 y2, y1 ∈ B → y2 ∈ B → (v (y1 + y2) = v y1 + v y2)%G). {
  intros * Hy1 Hy2.
  exists 0; split; [ apply A | now unfold v; rewrite Hzero, gr_add_opp_r ].
}
set (hv :=
  {| Happ := v;
     Hmem_compat := Hmc;
     Happ_compat := Hac;
     Hadditive := Had |}).
assert (Hmc₀ : ∀ y1, y1 ∈ B → 0 ∈ Coker f) by (intros; apply B).
assert (Hac₀ : ∀ y1 y2, y1 ∈ B → (y1 = y2)%G → (@gr_zero (Coker f) = 0)%G). {
  intros * Hy1 Hyy.
  simpl; unfold Coker_eq; simpl.
  exists 0; split; [ apply A | now rewrite Hzero, gr_add_opp_r ].
}
assert (Had₀ : ∀ y1 y2, y1 ∈ B → y2 ∈ B → (@gr_zero (Coker f) = 0 + 0)%G). {
  intros * Hy1 Hy2.
  simpl; unfold Coker_eq; simpl.
  exists 0; split; [ apply A | now rewrite Hzero, gr_add_0_r, gr_sub_0_r ].
}
set (hw :=
  {| Happ _ := 0;
     Hmem_compat := Hmc₀;
     Happ_compat := Hac₀;
     Hadditive := Had₀ |}).
specialize (Hed (Coker f) hv hw) as H1.
assert (H : ∀ x, x ∈ A → (Happ hv (Happ f x) = Happ hw (Happ f x))%G). {
  intros x Hx.
  simpl; unfold v; unfold Coker_eq; simpl.
  exists x; split; [ easy | now rewrite gr_sub_0_r ].
}
specialize (H1 H y Hy); clear H.
simpl in H1; unfold Coker_eq in H1; simpl in H1.
destruct H1 as (x & Hx).
rewrite gr_sub_0_r in Hx.
now exists x.
Qed.

Theorem mono_is_inj : ∀ {A B} {f : HomGr A B},
  is_mono f
  → ∀ x1 x2, x1 ∈ A → x2 ∈ A → (Happ f x1 = Happ f x2)%G → (x1 = x2)%G.
Proof.
intros * Hf * Hx1 Hx2 Hxx.
(* morphism identity from Ker f to A *)
set (v x := let _ : gr_set (Ker f) := x in x : gr_set A).
assert (Hmc : ∀ x, x ∈ Ker f → v x ∈ A) by (intros x Hx; apply Hx).
set (hv :=
  {| Happ := v;
     Hmem_compat := Hmc;
     Happ_compat _ _ _ H := H;
     Hadditive _ _ _ _ := reflexivity _ |}).
(* morphism null from Ker f to A *)
set (hw :=
  {| Happ x := let _ : gr_set (Ker f) := x in 0 : gr_set A;
     Hmem_compat _ _ := gr_zero_mem A;
     Happ_compat _ _ _ _ := reflexivity _;
     Hadditive _ _ _ _ := symmetry (gr_add_0_r _ _) |}).
specialize (Hf (Ker f) hv hw) as H1.
assert (H : ∀ z, z ∈ Ker f → (Happ f (Happ hv z) = Happ f (Happ hw z))%G). {
  intros z (Hz, Hfz).
  unfold hv, hw, v; simpl.
  now rewrite Hfz, Hzero.
}
specialize (H1 H (x1 - x2)); clear H.
assert (H : x1 - x2 ∈ Ker f). {
  split.
  -apply A; [ easy | now apply A ].
  -rewrite Hadditive; [ | easy | now apply A ].
   rewrite Hopp; [ | easy ].
   now rewrite Hxx, gr_add_opp_r.
}
specialize (H1 H); clear H.
unfold hv, hw, v in H1; simpl in H1.
apply gr_sub_move_r in H1.
now rewrite gr_add_0_l in H1.
Qed.

(* We sometimes need these axioms *)

Definition Choice := ∀ {A B} {R : A → B → Prop},
   (∀ x : A, ∃ y : B, R x y) → ∃ f : A → B, ∀ x : A, R x (f x).
Definition Decidable_Membership := ∀ G x, {x ∈ G} + {x ∉ G}.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(* Make [omega] work for [N] *)

Require Import Coq.Arith.Arith Coq.ZArith.ZArith Coq.NArith.NArith.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition;
  apply nat_of_N_eq in H0; tauto.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).