Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__crossimpliesopposite.
Require Export lemma__diagonalsmeet.
Require Export lemma__equalanglesflip.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglesreflexive.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelNC.
Require Export lemma__parallelflip.
Require Export lemma__ray4.
Require Export logic.
Require Export proposition__26A.
Require Export proposition__29B.
Require Export proposition__34.
Definition lemma__diagonalsbisect : forall A B C D, (euclidean__defs.PG A B C D) -> (exists X, (euclidean__defs.Midpoint A X C) /\ (euclidean__defs.Midpoint B X D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) (exists M, (euclidean__axioms.BetS A M C) /\ (euclidean__axioms.BetS B M D)) as H0.
- apply (@lemma__diagonalsmeet.lemma__diagonalsmeet A B C D H).
- destruct H0 as [M H1].
destruct H1 as [H2 H3].
assert (* Cut *) ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H4.
-- assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H4 by exact H.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp by exact H4.
destruct __TmpHyp as [H5 H6].
split.
--- exact H5.
--- exact H6.
-- assert (* Cut *) (euclidean__axioms.neq A C) as H5.
--- destruct H4 as [H5 H6].
assert (* Cut *) ((euclidean__axioms.neq M C) /\ ((euclidean__axioms.neq A M) /\ (euclidean__axioms.neq A C))) as H7.
---- apply (@lemma__betweennotequal.lemma__betweennotequal A M C H2).
---- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H11.
--- assert (* Cut *) (euclidean__axioms.neq B D) as H6.
---- destruct H4 as [H6 H7].
assert (* Cut *) ((euclidean__axioms.neq M D) /\ ((euclidean__axioms.neq B M) /\ (euclidean__axioms.neq B D))) as H8.
----- apply (@lemma__betweennotequal.lemma__betweennotequal B M D H3).
----- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H12.
---- assert (* Cut *) (euclidean__defs.CR A C B D) as H7.
----- exists M.
split.
------ exact H2.
------ exact H3.
----- assert (* Cut *) (euclidean__defs.Par A B C D) as H8.
------ destruct H4 as [H8 H9].
destruct H as [H10 H11].
exact H8.
------ assert (* Cut *) (euclidean__defs.Par A B D C) as H9.
------- destruct H4 as [H9 H10].
assert (* Cut *) ((euclidean__defs.Par B A C D) /\ ((euclidean__defs.Par A B D C) /\ (euclidean__defs.Par B A D C))) as H11.
-------- apply (@lemma__parallelflip.lemma__parallelflip A B C D H8).
-------- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H14.
------- assert (* Cut *) (euclidean__axioms.nCol A B D) as H10.
-------- destruct H4 as [H10 H11].
assert (* Cut *) ((euclidean__axioms.nCol A B D) /\ ((euclidean__axioms.nCol A D C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol A B C)))) as H12.
--------- apply (@lemma__parallelNC.lemma__parallelNC A B D C H9).
--------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H13.
-------- assert (* Cut *) (euclidean__axioms.TS A B D C) as H11.
--------- destruct H4 as [H11 H12].
assert (* Cut *) ((euclidean__axioms.TS A B D C) /\ ((euclidean__axioms.TS A D B C) /\ ((euclidean__axioms.TS C B D A) /\ (euclidean__axioms.TS C D B A)))) as H13.
---------- apply (@lemma__crossimpliesopposite.lemma__crossimpliesopposite A C B D H7 H10).
---------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H14.
--------- assert (* Cut *) (euclidean__defs.Par B A D C) as H12.
---------- destruct H4 as [H12 H13].
assert (* Cut *) ((euclidean__defs.Par B A D C) /\ ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par B A C D))) as H14.
----------- apply (@lemma__parallelflip.lemma__parallelflip A B D C H9).
----------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H15.
---------- assert (* Cut *) (euclidean__axioms.BetS C M A) as H13.
----------- destruct H4 as [H13 H14].
apply (@euclidean__axioms.axiom__betweennesssymmetry A M C H2).
----------- assert (* Cut *) (euclidean__axioms.BetS D M B) as H14.
------------ destruct H4 as [H14 H15].
apply (@euclidean__axioms.axiom__betweennesssymmetry B M D H3).
------------ assert (* Cut *) (euclidean__defs.CR B D A C) as H15.
------------- exists M.
split.
-------------- exact H3.
-------------- exact H2.
------------- assert (* Cut *) (euclidean__axioms.nCol A B C) as H16.
-------------- destruct H4 as [H16 H17].
assert (* Cut *) ((euclidean__axioms.nCol A B D) /\ ((euclidean__axioms.nCol A D C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol A B C)))) as H18.
--------------- apply (@lemma__parallelNC.lemma__parallelNC A B D C H9).
--------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H24.
-------------- assert (* Cut *) (euclidean__axioms.nCol B A C) as H17.
--------------- destruct H4 as [H17 H18].
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 H19.
---------------- apply (@lemma__NCorder.lemma__NCorder A B C H16).
---------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H20.
--------------- assert (* Cut *) (euclidean__axioms.TS B A C D) as H18.
---------------- destruct H4 as [H18 H19].
assert (* Cut *) ((euclidean__axioms.TS B A C D) /\ ((euclidean__axioms.TS B C A D) /\ ((euclidean__axioms.TS D A C B) /\ (euclidean__axioms.TS D C A B)))) as H20.
----------------- apply (@lemma__crossimpliesopposite.lemma__crossimpliesopposite B D A C H15 H17).
----------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H21.
---------------- assert (* Cut *) (euclidean__axioms.Cong A B D C) as H19.
----------------- destruct H4 as [H19 H20].
assert (* Cut *) ((euclidean__axioms.Cong A D B C) /\ ((euclidean__axioms.Cong A B D C) /\ ((euclidean__defs.CongA B A D D C B) /\ ((euclidean__defs.CongA A D C C B A) /\ (euclidean__axioms.Cong__3 B A D D C B))))) as H21.
------------------ apply (@proposition__34.proposition__34 A D B C H).
------------------ destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H24.
----------------- assert (* Cut *) (euclidean__axioms.Cong A B C D) as H20.
------------------ destruct H4 as [H20 H21].
assert (* Cut *) ((euclidean__axioms.Cong B A C D) /\ ((euclidean__axioms.Cong B A D C) /\ (euclidean__axioms.Cong A B C D))) as H22.
------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A B D C H19).
------------------- destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H26.
------------------ assert (* Cut *) (~(euclidean__axioms.Col M A B)) as H21.
------------------- intro H21.
assert (* Cut *) (euclidean__axioms.Col A M C) as H22.
-------------------- right.
right.
right.
right.
left.
exact H2.
-------------------- assert (* Cut *) (euclidean__axioms.Col M A C) as H23.
--------------------- destruct H4 as [H23 H24].
assert (* Cut *) ((euclidean__axioms.Col M A C) /\ ((euclidean__axioms.Col M C A) /\ ((euclidean__axioms.Col C A M) /\ ((euclidean__axioms.Col A C M) /\ (euclidean__axioms.Col C M A))))) as H25.
---------------------- apply (@lemma__collinearorder.lemma__collinearorder A M C H22).
---------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H26.
--------------------- assert (* Cut *) (euclidean__axioms.neq A M) as H24.
---------------------- destruct H4 as [H24 H25].
assert (* Cut *) ((euclidean__axioms.neq M C) /\ ((euclidean__axioms.neq A M) /\ (euclidean__axioms.neq A C))) as H26.
----------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A M C H2).
----------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H29.
---------------------- assert (* Cut *) (euclidean__axioms.neq M A) as H25.
----------------------- destruct H4 as [H25 H26].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A M H24).
----------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H26.
------------------------ destruct H4 as [H26 H27].
apply (@euclidean__tactics.not__nCol__Col A B C).
-------------------------intro H28.
apply (@euclidean__tactics.Col__nCol__False A B C H28).
--------------------------apply (@lemma__collinear4.lemma__collinear4 M A B C H21 H23 H25).

------------------------ assert (* Cut *) (euclidean__axioms.nCol A B C) as H27.
------------------------- destruct H4 as [H27 H28].
assert (* Cut *) ((euclidean__axioms.nCol B A D) /\ ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol A D C) /\ (euclidean__axioms.nCol B A C)))) as H29.
-------------------------- apply (@lemma__parallelNC.lemma__parallelNC B A D C H12).
-------------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H16.
------------------------- apply (@euclidean__tactics.Col__nCol__False A B C H27 H26).
------------------- assert (* Cut *) (euclidean__axioms.Triangle M A B) as H22.
-------------------- apply (@euclidean__tactics.nCol__notCol M A B H21).
-------------------- assert (* Cut *) (~(euclidean__axioms.Col M C D)) as H23.
--------------------- intro H23.
assert (* Cut *) (euclidean__axioms.Col A M C) as H24.
---------------------- right.
right.
right.
right.
left.
exact H2.
---------------------- assert (* Cut *) (euclidean__axioms.Col M C A) as H25.
----------------------- destruct H4 as [H25 H26].
assert (* Cut *) ((euclidean__axioms.Col M A C) /\ ((euclidean__axioms.Col M C A) /\ ((euclidean__axioms.Col C A M) /\ ((euclidean__axioms.Col A C M) /\ (euclidean__axioms.Col C M A))))) as H27.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder A M C H24).
------------------------ destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H30.
----------------------- assert (* Cut *) (euclidean__axioms.neq M C) as H26.
------------------------ destruct H4 as [H26 H27].
assert (* Cut *) ((euclidean__axioms.neq M C) /\ ((euclidean__axioms.neq A M) /\ (euclidean__axioms.neq A C))) as H28.
------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A M C H2).
------------------------- destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H29.
------------------------ assert (* Cut *) (euclidean__axioms.Col C D A) as H27.
------------------------- destruct H4 as [H27 H28].
apply (@euclidean__tactics.not__nCol__Col C D A).
--------------------------intro H29.
apply (@euclidean__tactics.Col__nCol__False C D A H29).
---------------------------apply (@lemma__collinear4.lemma__collinear4 M C D A H23 H25 H26).

------------------------- assert (* Cut *) (euclidean__axioms.Col A C D) as H28.
-------------------------- destruct H4 as [H28 H29].
assert (* Cut *) ((euclidean__axioms.Col D C A) /\ ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col A C D) /\ ((euclidean__axioms.Col C A D) /\ (euclidean__axioms.Col A D C))))) as H30.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder C D A H27).
--------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H35.
-------------------------- assert (* Cut *) (euclidean__axioms.nCol A C D) as H29.
--------------------------- destruct H4 as [H29 H30].
assert (* Cut *) ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol A C D) /\ ((euclidean__axioms.nCol B C D) /\ (euclidean__axioms.nCol A B D)))) as H31.
---------------------------- apply (@lemma__parallelNC.lemma__parallelNC A B C D H8).
---------------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H34.
--------------------------- apply (@H21).
----------------------------apply (@euclidean__tactics.not__nCol__Col M A B).
-----------------------------intro H30.
apply (@euclidean__tactics.Col__nCol__False A C D H29 H28).

--------------------- assert (* Cut *) (euclidean__axioms.Triangle M C D) as H24.
---------------------- apply (@euclidean__tactics.nCol__notCol M C D H23).
---------------------- assert (* Cut *) (euclidean__defs.Par B A C D) as H25.
----------------------- destruct H4 as [H25 H26].
assert (* Cut *) ((euclidean__defs.Par A B D C) /\ ((euclidean__defs.Par B A C D) /\ (euclidean__defs.Par A B C D))) as H27.
------------------------ apply (@lemma__parallelflip.lemma__parallelflip B A D C H12).
------------------------ destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
exact H30.
----------------------- assert (* Cut *) (euclidean__defs.CongA B A C A C D) as H26.
------------------------ destruct H4 as [H26 H27].
apply (@proposition__29B.proposition__29B B D A C H25 H18).
------------------------ assert (* Cut *) (euclidean__defs.CongA B A C B A C) as H27.
------------------------- destruct H4 as [H27 H28].
apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive B A C H17).
------------------------- assert (* Cut *) (euclidean__defs.Out A C M) as H28.
-------------------------- destruct H4 as [H28 H29].
apply (@lemma__ray4.lemma__ray4 A C M).
---------------------------left.
exact H2.

--------------------------- exact H5.
-------------------------- assert (* Cut *) (B = B) as H29.
--------------------------- destruct H4 as [H29 H30].
apply (@logic.eq__refl Point B).
--------------------------- assert (* Cut *) (euclidean__axioms.nCol A B C) as H30.
---------------------------- destruct H4 as [H30 H31].
assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol A C D) /\ (euclidean__axioms.nCol B A D)))) as H32.
----------------------------- apply (@lemma__parallelNC.lemma__parallelNC B A C D H25).
----------------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H16.
---------------------------- assert (* Cut *) (euclidean__axioms.neq A B) as H31.
----------------------------- destruct H4 as [H31 H32].
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 H33.
------------------------------ apply (@lemma__NCdistinct.lemma__NCdistinct A B C H30).
------------------------------ destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H34.
----------------------------- assert (* Cut *) (euclidean__defs.Out A B B) as H32.
------------------------------ destruct H4 as [H32 H33].
apply (@lemma__ray4.lemma__ray4 A B B).
-------------------------------right.
left.
exact H29.

------------------------------- exact H31.
------------------------------ assert (* Cut *) (euclidean__defs.CongA B A C B A M) as H33.
------------------------------- destruct H4 as [H33 H34].
apply (@lemma__equalangleshelper.lemma__equalangleshelper B A C B A C B M H27 H32 H28).
------------------------------- assert (* Cut *) (euclidean__defs.CongA B A M B A C) as H34.
-------------------------------- destruct H4 as [H34 H35].
apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric B A C B A M H33).
-------------------------------- assert (* Cut *) (euclidean__defs.CongA B A M A C D) as H35.
--------------------------------- destruct H4 as [H35 H36].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B A M B A C A C D H34 H26).
--------------------------------- assert (* Cut *) (D = D) as H36.
---------------------------------- destruct H4 as [H36 H37].
apply (@logic.eq__refl Point D).
---------------------------------- assert (* Cut *) (euclidean__axioms.nCol A C D) as H37.
----------------------------------- destruct H4 as [H37 H38].
assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol A C D) /\ (euclidean__axioms.nCol B A D)))) as H39.
------------------------------------ apply (@lemma__parallelNC.lemma__parallelNC B A C D H25).
------------------------------------ destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H44.
----------------------------------- assert (* Cut *) (euclidean__axioms.neq C D) as H38.
------------------------------------ destruct H4 as [H38 H39].
assert (* Cut *) ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ (euclidean__axioms.neq D A)))))) as H40.
------------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct A C D H37).
------------------------------------- destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H43.
------------------------------------ assert (* Cut *) (euclidean__axioms.neq C A) as H39.
------------------------------------- destruct H4 as [H39 H40].
assert (* Cut *) ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ (euclidean__axioms.neq D A)))))) as H41.
-------------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct A C D H37).
-------------------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H48.
------------------------------------- assert (* Cut *) (euclidean__defs.Out C D D) as H40.
-------------------------------------- destruct H4 as [H40 H41].
apply (@lemma__ray4.lemma__ray4 C D D).
---------------------------------------right.
left.
exact H36.

--------------------------------------- exact H38.
-------------------------------------- assert (* Cut *) (euclidean__defs.Out C A M) as H41.
--------------------------------------- destruct H4 as [H41 H42].
apply (@lemma__ray4.lemma__ray4 C A M).
----------------------------------------left.
exact H13.

---------------------------------------- exact H39.
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA A C D A C D) as H42.
---------------------------------------- destruct H4 as [H42 H43].
apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A C D H37).
---------------------------------------- assert (* Cut *) (euclidean__defs.CongA A C D M C D) as H43.
----------------------------------------- destruct H4 as [H43 H44].
apply (@lemma__equalangleshelper.lemma__equalangleshelper A C D A C D M D H42 H41 H40).
----------------------------------------- assert (* Cut *) (euclidean__defs.CongA B A M M C D) as H44.
------------------------------------------ destruct H4 as [H44 H45].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B A M A C D M C D H35 H43).
------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol A C D) as H45.
------------------------------------------- destruct H4 as [H45 H46].
assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol A C D) /\ (euclidean__axioms.nCol B A D)))) as H47.
-------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC B A C D H25).
-------------------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H37.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A M C) as H46.
-------------------------------------------- right.
right.
right.
right.
left.
exact H2.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A C M) as H47.
--------------------------------------------- destruct H4 as [H47 H48].
assert (* Cut *) ((euclidean__axioms.Col M A C) /\ ((euclidean__axioms.Col M C A) /\ ((euclidean__axioms.Col C A M) /\ ((euclidean__axioms.Col A C M) /\ (euclidean__axioms.Col C M A))))) as H49.
---------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A M C H46).
---------------------------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H56.
--------------------------------------------- assert (* Cut *) (C = C) as H48.
---------------------------------------------- destruct H4 as [H48 H49].
apply (@logic.eq__refl Point C).
---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A C C) as H49.
----------------------------------------------- right.
right.
left.
exact H48.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.neq M C) as H50.
------------------------------------------------ destruct H4 as [H50 H51].
assert (* Cut *) ((euclidean__axioms.neq M C) /\ ((euclidean__axioms.neq A M) /\ (euclidean__axioms.neq A C))) as H52.
------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A M C H2).
------------------------------------------------- destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H53.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol M C D) as H51.
------------------------------------------------- destruct H4 as [H51 H52].
exact H24.
------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA M C D D C M) as H52.
-------------------------------------------------- destruct H4 as [H52 H53].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA M C D H51).
-------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA B A M D C M) as H53.
--------------------------------------------------- destruct H4 as [H53 H54].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B A M M C D D C M H44 H52).
--------------------------------------------------- assert (* Cut *) (euclidean__defs.Par A B D C) as H54.
---------------------------------------------------- destruct H4 as [H54 H55].
assert (* Cut *) ((euclidean__defs.Par A B C D) /\ ((euclidean__defs.Par B A D C) /\ (euclidean__defs.Par A B D C))) as H56.
----------------------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip B A C D H25).
----------------------------------------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
exact H60.
---------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B D B D C) as H55.
----------------------------------------------------- destruct H4 as [H55 H56].
apply (@proposition__29B.proposition__29B A C B D H54 H11).
----------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B D A B D) as H56.
------------------------------------------------------ destruct H4 as [H56 H57].
apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A B D H10).
------------------------------------------------------ assert (* Cut *) (euclidean__defs.Out B D M) as H57.
------------------------------------------------------- destruct H4 as [H57 H58].
apply (@lemma__ray4.lemma__ray4 B D M).
--------------------------------------------------------left.
exact H3.

-------------------------------------------------------- exact H6.
------------------------------------------------------- assert (* Cut *) (A = A) as H58.
-------------------------------------------------------- destruct H4 as [H58 H59].
apply (@logic.eq__refl Point A).
-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol B A D) as H59.
--------------------------------------------------------- destruct H4 as [H59 H60].
assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol A C D) /\ (euclidean__axioms.nCol B A D)))) as H61.
---------------------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC B A C D H25).
---------------------------------------------------------- destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
exact H67.
--------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B A) as H60.
---------------------------------------------------------- destruct H4 as [H60 H61].
assert (* Cut *) ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq D A) /\ (euclidean__axioms.neq D B)))))) as H62.
----------------------------------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct B A D H59).
----------------------------------------------------------- destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H63.
---------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B A A) as H61.
----------------------------------------------------------- destruct H4 as [H61 H62].
apply (@lemma__ray4.lemma__ray4 B A A).
------------------------------------------------------------right.
left.
exact H58.

------------------------------------------------------------ exact H60.
----------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B D A B M) as H62.
------------------------------------------------------------ destruct H4 as [H62 H63].
apply (@lemma__equalangleshelper.lemma__equalangleshelper A B D A B D A M H56 H61 H57).
------------------------------------------------------------ assert (* Cut *) (euclidean__defs.CongA A B M A B D) as H63.
------------------------------------------------------------- destruct H4 as [H63 H64].
apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B D A B M H62).
------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B M B D C) as H64.
-------------------------------------------------------------- destruct H4 as [H64 H65].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B M A B D B D C H63 H55).
-------------------------------------------------------------- assert (* Cut *) (C = C) as H65.
--------------------------------------------------------------- destruct H4 as [H65 H66].
exact H48.
--------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol B D C) as H66.
---------------------------------------------------------------- destruct H4 as [H66 H67].
assert (* Cut *) ((euclidean__axioms.nCol A B D) /\ ((euclidean__axioms.nCol A D C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol A B C)))) as H68.
----------------------------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC A B D C H54).
----------------------------------------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H73.
---------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq D C) as H67.
----------------------------------------------------------------- destruct H4 as [H67 H68].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq C D) /\ (euclidean__axioms.neq C B)))))) as H69.
------------------------------------------------------------------ apply (@lemma__NCdistinct.lemma__NCdistinct B D C H66).
------------------------------------------------------------------ destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
exact H72.
----------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H68.
------------------------------------------------------------------ destruct H4 as [H68 H69].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq C D) /\ (euclidean__axioms.neq C B)))))) as H70.
------------------------------------------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct B D C H66).
------------------------------------------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
exact H77.
------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.Out D C C) as H69.
------------------------------------------------------------------- destruct H4 as [H69 H70].
apply (@lemma__ray4.lemma__ray4 D C C).
--------------------------------------------------------------------right.
left.
exact H65.

-------------------------------------------------------------------- exact H67.
------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out D B M) as H70.
-------------------------------------------------------------------- destruct H4 as [H70 H71].
apply (@lemma__ray4.lemma__ray4 D B M).
---------------------------------------------------------------------left.
exact H14.

--------------------------------------------------------------------- exact H68.
-------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA B D C B D C) as H71.
--------------------------------------------------------------------- destruct H4 as [H71 H72].
apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive B D C H66).
--------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA B D C M D C) as H72.
---------------------------------------------------------------------- destruct H4 as [H72 H73].
apply (@lemma__equalangleshelper.lemma__equalangleshelper B D C B D C M C H71 H70 H69).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B M M D C) as H73.
----------------------------------------------------------------------- destruct H4 as [H73 H74].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B M B D C M D C H64 H72).
----------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol B D C) as H74.
------------------------------------------------------------------------ destruct H4 as [H74 H75].
assert (* Cut *) ((euclidean__axioms.nCol A B D) /\ ((euclidean__axioms.nCol A D C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol A B C)))) as H76.
------------------------------------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC A B D C H54).
------------------------------------------------------------------------- destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H66.
------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col B M D) as H75.
------------------------------------------------------------------------- right.
right.
right.
right.
left.
exact H3.
------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B D M) as H76.
-------------------------------------------------------------------------- destruct H4 as [H76 H77].
assert (* Cut *) ((euclidean__axioms.Col M B D) /\ ((euclidean__axioms.Col M D B) /\ ((euclidean__axioms.Col D B M) /\ ((euclidean__axioms.Col B D M) /\ (euclidean__axioms.Col D M B))))) as H78.
--------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B M D H75).
--------------------------------------------------------------------------- destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
exact H85.
-------------------------------------------------------------------------- assert (* Cut *) (D = D) as H77.
--------------------------------------------------------------------------- destruct H4 as [H77 H78].
exact H36.
--------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B D D) as H78.
---------------------------------------------------------------------------- right.
right.
left.
exact H77.
---------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq M D) as H79.
----------------------------------------------------------------------------- destruct H4 as [H79 H80].
assert (* Cut *) ((euclidean__axioms.neq M D) /\ ((euclidean__axioms.neq B M) /\ (euclidean__axioms.neq B D))) as H81.
------------------------------------------------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal B M D H3).
------------------------------------------------------------------------------ destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
exact H82.
----------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol M D C) as H80.
------------------------------------------------------------------------------ destruct H4 as [H80 H81].
apply (@euclidean__tactics.nCol__notCol M D C).
-------------------------------------------------------------------------------apply (@euclidean__tactics.nCol__not__Col M D C).
--------------------------------------------------------------------------------apply (@lemma__NChelper.lemma__NChelper B D C M D H74 H76 H78 H79).

------------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.CongA M D C C D M) as H81.
------------------------------------------------------------------------------- destruct H4 as [H81 H82].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA M D C H80).
------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B M C D M) as H82.
-------------------------------------------------------------------------------- destruct H4 as [H82 H83].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B M M D C C D M H73 H81).
-------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA M A B M C D) as H83.
--------------------------------------------------------------------------------- destruct H4 as [H83 H84].
apply (@lemma__equalanglesflip.lemma__equalanglesflip B A M D C M H53).
--------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong M A M C) /\ ((euclidean__axioms.Cong M B M D) /\ (euclidean__defs.CongA A M B C M D))) as H84.
---------------------------------------------------------------------------------- destruct H4 as [H84 H85].
apply (@proposition__26A.proposition__26A M A B M C D H22 H51 H83 H82 H20).
---------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A M M C) as H85.
----------------------------------------------------------------------------------- destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
destruct H4 as [H89 H90].
assert (* Cut *) ((euclidean__axioms.Cong A M C M) /\ ((euclidean__axioms.Cong A M M C) /\ (euclidean__axioms.Cong M A C M))) as H91.
------------------------------------------------------------------------------------ apply (@lemma__congruenceflip.lemma__congruenceflip M A M C H85).
------------------------------------------------------------------------------------ destruct H91 as [H92 H93].
destruct H93 as [H94 H95].
exact H94.
----------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B M M D) as H86.
------------------------------------------------------------------------------------ destruct H84 as [H86 H87].
destruct H87 as [H88 H89].
destruct H4 as [H90 H91].
assert (* Cut *) ((euclidean__axioms.Cong B M D M) /\ ((euclidean__axioms.Cong B M M D) /\ (euclidean__axioms.Cong M B D M))) as H92.
------------------------------------------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip M B M D H88).
------------------------------------------------------------------------------------- destruct H92 as [H93 H94].
destruct H94 as [H95 H96].
exact H95.
------------------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.Midpoint A M C) as H87.
------------------------------------------------------------------------------------- split.
-------------------------------------------------------------------------------------- exact H2.
-------------------------------------------------------------------------------------- exact H85.
------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Midpoint B M D) as H88.
-------------------------------------------------------------------------------------- split.
--------------------------------------------------------------------------------------- exact H3.
--------------------------------------------------------------------------------------- exact H86.
-------------------------------------------------------------------------------------- exists M.
split.
--------------------------------------------------------------------------------------- exact H87.
--------------------------------------------------------------------------------------- exact H88.
Qed.


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

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

Print Assumptions mul.


(*************************************************************************

 Every adjunction gives rise to a monad

 In arbitrary bicategories, every adjunction gives rise to a monad

 *************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.

Local Open Scope cat.

Section MonadFromAdjunction.
  Context {B : bicat}
          {x y : B}
          (l : adjunction x y).

  Let r : y --> x := left_adjoint_right_adjoint l.
  Let η : id₁ _ ==> l · r := left_adjoint_unit l.
  Let ε : r · l ==> id₁ _ := left_adjoint_counit l.

  Let f : x --> x := l · r.
  Let monad_η : id₁ _ ==> f := η.
  Let monad_μ : f · f ==> f
    := rassociator _ _ _
       • (_ ◃ lassociator _ _ _)
       • (_ ◃ (ε ▹ _))
       • (_ ◃ lunitor _).

  Local Lemma mnd_from_adjunction_η_left
    : (linvunitor f • (monad_η ▹ f)) • monad_μ = id₂ _.
  Proof.
    pose (p₁ := internal_triangle1 l).
    unfold monad_η, monad_μ, f.
    cbn -[η ε] ; cbn -[η ε] in p₁.
    rewrite !vassocl.
    rewrite !vassocl in p₁.
    refine (_ @ id2_rwhisker _ _).
    rewrite <- p₁.
    rewrite <- !rwhisker_vcomp.
    rewrite linvunitor_assoc.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite <- rwhisker_rwhisker_alt.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite <- rassociator_rassociator.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
    rewrite lwhisker_vcomp.
    rewrite rassociator_lassociator.
    rewrite lwhisker_id2.
    rewrite id2_left.
    rewrite !vassocr.
    rewrite rwhisker_lwhisker_rassociator.
    rewrite !vassocl.
    apply maponpaths.
    rewrite lunitor_lwhisker.
    apply idpath.
  Qed.

  Local Lemma mnd_from_adjunction_η_right
    : (rinvunitor f • (f ◃ monad_η)) • monad_μ = id₂ _.
  Proof.
    pose (p₁ := internal_triangle1 l).
    pose (p₂ := internal_triangle2 l).
    unfold monad_η, monad_μ, f.
    cbn -[η ε] ; cbn -[η ε] in p₁, p₂.
    rewrite !vassocl.
    rewrite !vassocl in p₂.
    refine (_ @ lwhisker_id2 _ _).
    refine (!_).
    etrans.
    {
      apply maponpaths.
      exact (!p₂).
    }
    rewrite <- !lwhisker_vcomp.
    rewrite <- rinvunitor_triangle.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite <- lwhisker_lwhisker.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite lassociator_rassociator.
    rewrite id2_left.
    apply idpath.
  Qed.

  Local Lemma mnd_from_adjunction_assoc
    : (rassociator f f f • (f ◃ monad_μ)) • monad_μ
      =
      (monad_μ ▹ f) • monad_μ.
  Proof.
    unfold monad_μ.
    rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
    rewrite !vassocr.
    rewrite !vassocl.
    etrans.
    {
      do 5 apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        do 2 apply maponpaths_2.
        rewrite lwhisker_hcomp.
        etrans.
        {
          apply inverse_pentagon_4.
        }
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker_rassociator.
      apply idpath.
    }
    etrans.
    {
      do 3 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        do 4 apply maponpaths_2.
        apply lwhisker_lwhisker.
      }
      rewrite !vassocr.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      do 4 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocl.
    etrans.
    {
      do 5 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      apply idpath.
    }
    rewrite !vassocl.
    etrans.
    {
      do 5 apply maponpaths.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite <- lwhisker_lwhisker_rassociator.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      apply idpath.
    }
    etrans.
    {
      do 5 apply maponpaths.
      rewrite !vassocl.
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply lwhisker_vcomp.
      }
      rewrite vcomp_lunitor.
      refine (lwhisker_vcomp _ _ _ @ _).
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      apply idpath.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    do 2 apply maponpaths_2.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        refine (!_).
        apply rwhisker_lwhisker_rassociator.
      }
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      refine (!_).
      apply rwhisker_lwhisker_rassociator.
    }
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      apply idpath.
    }
    rewrite !lunitor_assoc.
    rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp, <- !lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    refine (!_).
    rewrite !vassocl.
    etrans.
    {
      do 6 apply maponpaths.
      rewrite !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      rewrite <- rwhisker_rwhisker.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite lwhisker_vcomp.
    rewrite pentagon_6.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      etrans.
      {
        do 3 apply maponpaths_2.
        apply inverse_pentagon_7.
      }
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    rewrite <- rwhisker_lwhisker_rassociator.
    etrans.
    {
      do 4 apply maponpaths.
      rewrite !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      rewrite <- lassociator_lassociator.
      rewrite <- !lwhisker_vcomp.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
    refine (_ @ !(rassociator_rassociator _ _ _ _)).
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      etrans.
      {
        apply maponpaths_2.
        apply lwhisker_lwhisker_rassociator.
      }
      rewrite !vassocl.
      apply maponpaths.
      apply lwhisker_lwhisker_rassociator.
    }
    rewrite !vassocr.
    refine (_ @ id2_left _).
    apply maponpaths_2.
    rewrite !lwhisker_vcomp.
    rewrite <- lwhisker_id2.
    apply maponpaths.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite lwhisker_id2.
      apply id2_left.
    }
    apply rassociator_lassociator.
  Qed.

  Definition mnd_from_adjunction
    : mnd B.
  Proof.
    use make_mnd.
    - use make_mnd_data.
      + exact x.
      + exact f.
      + exact monad_η.
      + exact monad_μ.
    - refine (_ ,, _ ,, _).
      + exact mnd_from_adjunction_η_left.
      + exact mnd_from_adjunction_η_right.
      + exact mnd_from_adjunction_assoc.
  Defined.
End MonadFromAdjunction.


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

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

Print Assumptions mul.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.

Section PairParam.
  Variable T : Type.
  Variable eqT : T -> T -> Prop.
  Variable U : Type.
  Variable eqU : U -> U -> Prop.

  Inductive sum_eq : T + U -> T + U -> Prop :=
  | Inl_eq : forall a b, eqT a b -> sum_eq (inl a) (inl b)
  | Inr_eq : forall a b, eqU a b -> sum_eq (inr a) (inr b).

  Variable EDT : RelDec eqT.
  Variable EDU : RelDec eqU.

  Global Instance RelDec_equ_sum
  : RelDec (sum_eq) :=
  { rel_dec := fun x y =>
                 match x , y with
                   | inl x , inl y => rel_dec x y
                   | inr x , inr y => rel_dec x y
                   | inl _ , inr _ => false
                   | inr _ , inl _ => false
                 end }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_equ_sum : RelDec_Correct RelDec_equ_sum.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; intuition; try solve [ constructor; auto | congruence ].
    + inversion H. intuition.
    + inversion H.
    + inversion H.
    + inversion H; intuition.
  Qed.
End PairParam.

Section SumEq.
  Variable T : Type.
  Variable U : Type.

  Variable EDT : RelDec (@eq T).
  Variable EDU : RelDec (@eq U).

  (** Specialization for equality **)
  Global Instance RelDec_eq_pair : RelDec (@eq (T + U)) :=
  { rel_dec := fun x y =>
                 match x , y with
                   | inl x , inl y => rel_dec x y
                   | inr x , inr y => rel_dec x y
                   | inl _ , inr _ => false
                   | inr _ , inl _ => false
                 end }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_eq_pair : RelDec_Correct RelDec_eq_pair.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros;
      repeat match goal with
               | [ H : context [ rel_dec ?X ?Y ] |- _ ] =>
                 consider (rel_dec X Y); intros; subst
               | [ |- context [ rel_dec ?X ?Y ] ] =>
                 consider (rel_dec X Y); intros; subst
             end; congruence.
  Qed.
End SumEq.

Global Instance Injective_inl T U a c : Injective (@inl T U a = inl c).
refine {| result := a = c |}.
Proof. abstract (inversion 1; intuition). Defined.

Global Instance Injective_inr T U a c : Injective (@inr T U a = inr c).
refine {| result := a = c |}.
Proof. abstract (inversion 1; intuition). Defined.

Global Instance Injective_inl_False T U a c : Injective (@inl T U a = inr c).
refine {| result := False |}.
Proof. abstract (inversion 1; intuition). Defined.

Global Instance Injective_inr_False T U a c : Injective (@inr T U a = inl c).
refine {| result := False |}.
Proof. abstract (inversion 1; intuition). Defined.


(** * A long hydra battle

  Pierre Castéran, LaBRI, Univ Bordeaux

 *)

From Coq Require Import Arith Relations Lia.
From hydras Require Import Hydra_Definitions Hydra_Lemmas Iterates Exp2.

(** Let us consider a small hydra [hinit] *)

(* begin snippet hinitDef *)
#[local] Notation  h3 := (hyd_mult head 3).
Definition hinit := hyd3 h3  head head.
(* end snippet hinitDef *)

(**
the first steps of a standard battle (Hercules chops off the rightmost head)
*)

(* begin snippet L02 *)
(*| .. coq:: no-out |*)
Lemma L_0_2 : rounds standard 0 hinit 2 (hyd1 h3).
Proof.
  eapply rounds_trans with (h := hyd2 h3 head) (i:=1).
  (* ... *) (*| .. coq:: none |*)
  - left; trivial.
    red. cbn. chop_off 1.
  - left; trivial.
    red; left;  trivial.
    split; repeat constructor.
(*||*)
Qed.
(* end snippet L02 *)

(** In the next round, there is a replication of h3 into 3 copies of h2

More generally,  all the future hydras will be composed of several copies
of h2, then several copies of h1, then several heads *)

(* begin snippet Notations *)

Notation h2 := (hyd_mult head 2).
Notation h1 := (hyd1 head).

Notation hyd a b c :=
  (node (hcons_mult h2  a
             (hcons_mult h1  b
                         (hcons_mult head c hnil)))).

(* end snippet Notations *)

(* begin snippet L23L03 *)
(*| .. coq:: no-out |*)
Lemma L_2_3 : rounds standard 2 (hyd1 h3)  3 (hyd 3 0 0).
Proof.
  left; trivial; right ;  simpl;  left; left.
  split; right; right; left.
Qed.

Lemma L_0_3 : rounds standard 0 hinit 3 (hyd 3 0 0).
Proof.
  apply rounds_trans with (1:= L_2_3) (2:= L_0_2).
Qed.
(*||*)
(* end snippet L23L03 *)

(** From now on, we abstract the configurations of the battle
  as tuples (round number, n2, n1, nh) where n2 (resp. n1, nh) is the number of
  sub-hydras h2 [resp. h1, heads] *)

(* begin snippet stateDef *)

Record state : Type :=
  mks {round : nat ; n2 : nat ; n1 : nat ; nh : nat}.

(* end snippet stateDef *)

(* begin snippet nextDef *)

Definition next (s : state) :=
  match s with
  | mks round a b (S c) => mks (S round) a b c
  | mks round a (S b) 0 => mks (S round) a b (S round)
  | mks round (S a) 0 0 => mks (S round) a (S round) 0
  | _ => s
  end.

(* end snippet nextDef *)

(** returns the state at the n-th round *)

(* begin snippet testDefTests *)

Definition test n := iterate next (n-3)  (mks 3 3 0 0).

Compute test 3.

Compute test 4.

Compute test 5.

Compute test 2000.

(* end snippet testDefTests *)

(* begin snippet smartTest *)

Compute test 10.

(* end snippet smartTest *)

(* begin snippet smartTestb *)

Compute test 22.

Compute test 46.

Compute test 94.

(* end snippet smartTestb *)

(* begin snippet smartTestc *)

Compute test 95.

(* end snippet smartTestc *)

(* begin snippet doubleS *)

Definition doubleS (n : nat) := 2 * (S n).

Compute test (doubleS 95).

Compute test (iterate doubleS 2 95).

(* end snippet doubleS *)

(** OK, instead of tests based on the function next, we consider now
    relations (which allow us to consider accessibility predicates)  *)

(** steps  i a b c j a' b' c' has  almost the same meaning as
    iterate test (j - i) (mks t a b c) = (mks t' a' b' c')

 *)

(* begin snippet oneStep *)

Inductive one_step (i: nat) :
  nat -> nat -> nat -> nat -> nat -> nat -> Prop :=
| step1: forall a b c,  one_step i a b (S c) a b c
| step2: forall a b ,  one_step i a (S b) 0 a b (S i)
| step3: forall a, one_step i (S a) 0 0 a (S i) 0.

(* end snippet oneStep *)

(* begin snippet stepBattle *)

Lemma step_rounds : forall i a b c a' b' c',
    one_step i a b c a' b' c' ->
    rounds standard i (hyd  a b c) (S i) (hyd a' b' c'). (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  destruct 1.
  - left; trivial;  left;  split.
    do 2 apply hcons_mult_S0; now left.
  - left; trivial; right; left.
    apply hcons_mult_S1; simpl.
    rewrite <- hcons_mult_comm.
    apply hcons_mult_S1.
    unfold hyd_mult; cbn.
    left;  split; constructor.

  - left; trivial;  right; left.
    simpl; rewrite  <- hcons_mult_comm;  apply hcons_mult_S1.
    left; split;  simpl;  right; constructor.
Qed.
(*||*)

(* end snippet stepBattle *)

(* begin snippet steps *)

Inductive steps : nat -> nat -> nat -> nat ->
                  nat -> nat -> nat -> nat -> Prop :=
| steps1 : forall i a b c a' b' c',
    one_step i a b c a' b' c' -> steps i a b c (S i) a' b' c'
| steps_S : forall i a b c j a' b' c' k a'' b'' c'',
    steps i a b c j a' b' c' ->
    steps j a' b' c' k a'' b'' c'' ->
    steps i a b c k  a'' b'' c''.

(**  reachability (for i > 0) *)

Definition reachable (i a b c : nat) : Prop :=
  steps 3 3 0 0 i a b c.

(* end snippet steps *)

(* begin snippet stepsBattle *)

Lemma steps_rounds : forall i a b c j  a' b' c',
    steps i a b c j a' b' c' ->
    rounds standard i (hyd  a b c) j (hyd a' b' c'). (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  induction 1.
  - now apply step_rounds.
  - eapply rounds_trans.
   +   apply IHsteps2.
   +  assumption.
Qed.
(*||*)

(* end snippet stepsBattle *)

(**  From now on, we play again the same tests as above, but instead of plain uses of Compute, we prove and register lemmas that we will be used later *)

(* begin snippet L4 *)

(*|
.. coq:: no-out
|*)
Lemma L4 : reachable 4 2 4 0.
Proof. left; constructor. Qed.
(*||*)
(* end snippet L4 *)

(** Now we prove some laws we observed in our test phase *)

(* begin snippet LS *)

(*|
.. coq:: no-out
|*)
Lemma LS : forall c a b i,  steps i a b (S c) (i + S c) a b 0.
Proof.
  induction c.
 -  intros;  replace (i + 1) with (S i) by ring.
    repeat constructor.
 -  intros; eapply  steps_S.
    + eleft; apply step1.
    + replace (i + S (S c)) with (S i + S c) by ring;  apply IHc.
Qed.

(**   The law that relates two consecutive events with  (nh = 0)  *)

Lemma doubleS_law : forall  a b i, steps i a (S b) 0 (doubleS i) a b 0.
Proof.
  intros;  eapply steps_S.
  + eleft;   apply step2.
  + unfold doubleS; replace (2 * S i) with (S i + S i) by ring;
      apply LS.
Qed.

Lemma reachable_S  : forall i a b, reachable i a (S b) 0 ->
                                   reachable (doubleS i) a b 0.
Proof. intros; right with  (1 := H); apply doubleS_law. Qed.

(* end snippet LS *)

(* begin snippet L10To95 *)

(*|
.. coq:: no-out
|*)

Lemma L10 : reachable 10 2 3 0.
Proof.   change 10 with (doubleS 4); apply reachable_S, L4. Qed.

Lemma L22 : reachable 22 2 2 0.
Proof. change 22 with (doubleS 10); apply reachable_S, L10. Qed.

Lemma L46 : reachable 46 2 1 0.
Proof. change 46 with (doubleS 22); apply  reachable_S, L22. Qed.

Lemma L94 : reachable 94 2 0 0.
Proof. change 94 with (doubleS 46); apply reachable_S, L46. Qed.

Lemma L95 : reachable 95 1 95 0.
Proof. eapply steps_S; [eapply L94|]; repeat constructor. Qed.

(*||*)

(* end snippet L10To95 *)

Lemma L0_95 : rounds standard 3 (hyd 3 0 0) 95 (hyd 1 95 0).
Proof. apply steps_rounds, L95. Qed.

(** No more tests ! we are going to build bigger transitions *)

(* begin snippet Bigstep *)

(*|
.. coq:: no-out
|*)

Lemma Bigstep : forall b i a , reachable i a b 0 ->
                               reachable (iterate doubleS b i) a 0 0.
 Proof.
  induction b.
  -  trivial.
  -  intros;  simpl;   apply reachable_S in H.
     rewrite <- iterate_comm; now apply IHb.
 Qed.

 (*||*)

(* end snippet Bigstep *)

 (** From all the lemmas above, we now get a pretty big step *)

 (* begin snippet MDef *)

Definition M := iterate doubleS 95 95.

Lemma L2_95 : reachable M 1 0 0. (* .no-out *)
Proof. (* .no-out *) apply Bigstep,  L95. Qed.
(* end snippet MDef *)

(** the next step creates (M+1) copies of h1 *)

(* begin snippet L295S  *)

(*|
.. coq:: no-out
|*)

Lemma L2_95_S : reachable (S M) 0 (S M) 0.
Proof. eright; [ apply L2_95 | left; constructor ]. Qed.
(*||*)

(* end snippet L295S  *)

(* begin snippet NDef *)

Definition N :=   iterate doubleS (S M) (S M).

Theorem   SuperbigStep : reachable N  0 0 0. (* .no-out *)
Proof. (* .no-out *) apply Bigstep, L2_95_S. Qed.

(* end snippet NDef *)

(** We can  ow apply our study based on abstract states to "real" hydras *)

(** transforming our relation one_step into standard battles *)

(** We get now statements about hydras and battles *)

(* begin snippet Done *)

(*|
.. coq:: no-out
|*)

Lemma Almost_done :
  rounds standard 3 (hyd 3 0 0) N (hyd 0 0 0).
Proof.  apply steps_rounds, SuperbigStep. Qed.

Theorem Done :
  rounds standard 0 hinit N head.
Proof. eapply rounds_trans with (1:= Almost_done) (2:= L_0_3). Qed.

(*||*)

(* end snippet Done *)

(** The natural number N is expressed in terms of the (iterate doubleS)
   function.  The rest of this file is dedicated to get an intuition of how it is huge .
     Our idea is to get a minoration by exponentials of base 2

 *)

(* begin snippet minorationLemmas *)
Lemma minoration_0 : forall n,  2 * n <= doubleS n. (* .no-out *)
(*| .. coq:: none |*)
Proof. unfold doubleS;intros; abstract lia. Qed.
(*||*)

Lemma minoration_1 : forall n x, exp2 n * x <= iterate doubleS n x. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  induction n; simpl.
  -  intro;  abstract lia.
  -  intros; unfold doubleS.
     transitivity (2 * iterate doubleS n x).
    +  specialize (IHn x). ring_simplify. lia.
    +  unfold doubleS; abstract lia.
Qed.
(*||*)

Lemma minoration_2 : exp2 95 * 95 <= M. (* .no-out *)
(*| .. coq:: none |*)
Proof. apply minoration_1. Qed.
(*||*)

Lemma minoration_3 : exp2 (S M) * S M <= N. (* .no-out *)
(*| .. coq:: none |*)
Proof. apply minoration_1.  Qed.
(*||*)

(*| .. coq:: none |*)
Lemma exp2_mono1 : forall n p,  n <= p ->  exp2 n  <= exp2 p .
Proof.
  induction 1; [reflexivity | rewrite exp2S;  abstract lia].
Qed.
(*||*)

Lemma minoration : exp2 (exp2 95 * 95) <= N. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  transitivity (exp2 (S M) * S M).
  -   replace (exp2 (exp2 95 * 95)) with ((exp2 (exp2 95 * 95) * 1)).
      apply Nat.mul_le_mono.
      +   apply exp2_mono1.
          transitivity M.
          * apply minoration_2.
          * right; left.
      + auto with arith.
      + apply Nat.mul_1_r.
  -  apply minoration_3.
Qed.
(*||*)
(* end snippet minorationLemmas *)

(** Hence, the length of the battle is greater or equal than
  exp2 (exp2 95 * 95), a number whose representation in base 10 has
  at least 10 ^ 30 digits ! *)

(** from OCAML

let exp2 x = 2.0 ** x;;

let _ = exp2 95.0 *. 95.0;;

float = 3.76333771942755604e+30

N >= 2 ** 3.7e+30

log10 N >= 3.7e+30 * log10 2 >= 1.0e+30

N >= 10 ** (10 ** 30)

 *)


(** * Real number facts and definitions. *)

From Coq Require Import
  RelationClasses
  Lra
  Basics
  Lia
  Reals
  ClassicalChoice
.

Local Open Scope program_scope.
Local Open Scope R_scope.

From algco Require Import
  misc
  order
  tactics
.

Local Open Scope order_scope.

(* Sequence g converges to limit point lim. *)
Definition converges_R (g : nat -> R) (lim : R) :=
  forall eps, 0 < eps -> exists n0, forall n, (n0 <= n)%nat -> Rabs (lim - g n) < eps.

#[global]
  Program Instance OType_R : OType R :=
  { leq := Rle }.
Next Obligation.
  constructor; unfold Reflexive, Transitive; intros; lra.
Qed.

Lemma R_bounded_complete {A} `{Inhabited A} (f : A -> R) :
  bounded_above f ->
  exists s : R, supremum s f.
Proof.
  intros H0.
  generalize (completeness_weak (fun r => exists n, f n = r)).
  destruct H0 as [ub H0]; intro Hcomplete.
  assert (H2: bound (fun r => exists n, f n = r)).
  { exists ub; intros x [n H2]; subst; apply H0. }
  apply Hcomplete in H2.
  { destruct H2 as [m H2]; exists m.
    destruct H2 as [H2 H3]; split.
    - intro i; apply H2; exists i; reflexivity.
    - intros x Hub; simpl; apply H3; intros i [n H4]; subst; apply Hub. }
  destruct H; exists (f el), el; reflexivity.
Qed.

Lemma dec_chain_opp_chain (f : nat -> R) :
  dec_chain f ->
  chain (Ropp ∘ f).
Proof.
  unfold compose, dec_chain, chain.
  intros H0 i.
  unfold leq in *; simpl in *.
  specialize (H0 i); lra.
Qed.

Lemma supremum_opp_infimum {A} (s : R) (f : A -> R) :
  supremum s (Ropp ∘ f) ->
  infimum (- s) f.
Proof.
  unfold supremum, infimum, upper_bound, lower_bound, compose, leq; simpl.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); lra.
  - intros x Hlb.
    specialize (Hlub (- x)).
    cut (s <= - x); try lra.
    apply Hlub; intro i; specialize (Hlb i); lra.
Qed.

Lemma infimum_opp_supremum {A} (s : R) (f : A -> R) :
  infimum s (Ropp ∘ f) ->
  supremum (- s) f.
Proof.
  unfold supremum, infimum, upper_bound, lower_bound, compose, leq; simpl.
  intros [Hlb Hglb]; split.
  - intro i; specialize (Hlb i); lra.
  - intros x Hub.
    specialize (Hglb (- x)).
    cut (- x <= s); try lra.
    apply Hglb; intro i; specialize (Hub i); lra.
Qed.

Lemma R_eq_dec (a b : R) :
  {a = b} + {a <> b}.
Proof.
  destruct (Rlt_le_dec a b).
  - right; lra.
  - destruct (Rlt_le_dec b a).
    + right; lra.
    + left; lra.
Qed.

Lemma Rle_leq (a b : R) :
  a ⊑ b ->
  a <= b.
Proof. auto. Qed.

Definition Req_bool (r1 r2 : R) : bool :=
  if R_eq_dec r1 r2 then true else false.

Lemma Req_bool_spec (r1 r2 : R) : Bool.reflect (r1 = r2) (Req_bool r1 r2).
Proof.
  unfold Req_bool; destruct (R_eq_dec r1 r2); constructor; auto.
Qed.

Lemma Rle_Rdiv a b c:
  0 < a ->
  a * b <= c ->
  b <= c / a.
Proof.
  intros Ha H; apply Rmult_le_reg_r with a; auto.
  unfold Rdiv; rewrite Rmult_assoc, Rinv_l; lra.
Qed.

Lemma supremum_sum_R (f g : nat -> R) (a b : R) :
  chain f ->
  chain g ->
  supremum a f ->
  supremum b g ->
  supremum (a + b) (fun i => f i + g i).
Proof.
  intros Hf Hg [Ha Ha'] [Hb Hb']; split.
  - intro i; simpl in *.
    apply Rplus_le_compat.
    + apply Ha.
    + apply Hb.
  - intros x Hx; simpl in *.
    unfold upper_bound in Hx; simpl in *.
    destruct (Rle_dec (a + b) x); auto.
    assert (x < a + b) by lra; clear n.
    exfalso.
    assert (x - b < a) by lra.
    assert (upper_bound (x - b) f).
    { intro i; simpl.
      cut (b <= x - f i); try lra.
      apply Hb'.
      intro j; simpl.
      cut (f i + g j <= x); try lra.
      destruct (dec_le i j).
      - apply Rle_trans with (f j + g j).
        { apply Rplus_le_compat_r.
          apply Rle_leq, chain_leq; auto. }
        apply Hx.
      - apply Rle_trans with (f i + g i).
        { apply Rplus_le_compat_l.
          apply Rle_leq, chain_leq; auto; lia. }
        apply Hx. }
    apply Ha' in H1; lra.
Qed.

Lemma converges_opp (f : nat -> R) (a : R) :
  converges_R (Ropp ∘ f) (- a) <-> converges_R f a.
Proof.
  unfold converges_R.
  split; intros H eps Heps; specialize (H eps Heps);
    destruct H as [n0 H]; exists n0; intros n Hle; specialize (H n Hle); unfold compose in H.
  - replace (- a - - f n) with (- (a - f n)) in H by lra.
    rewrite Rabs_Ropp in H; auto.
  - unfold compose.
    replace (-a - - f n) with (f n - a) by lra.
    rewrite Rabs_minus_sym; auto.
Qed.

Lemma supremum_converges_R (f : nat -> R) (a : R) :
  chain f ->
  supremum a f ->
  converges_R f a.
Proof.
  intros Hf Ha eps Heps.
  assert (H: exists n, Rabs (a - f n) < eps).
  { destruct (classic (exists n, Rabs (a - f n) < eps)); auto.
    assert (forall n, eps <= Rabs (a - f n)).
    { intro n; apply not_ex_all_not with (n:=n) in H; try lra. }
    clear H.
    exfalso.
    assert (forall n, eps <= a - f n).
    { intro n; specialize (H0 n).
      rewrite Rabs_right in H0; auto.
      cut (f n <= a); try lra; apply Ha. }
    clear H0.
    assert (upper_bound (a - eps) f).
    { intro i; simpl; specialize (H i); lra. }
    apply Ha in H0; simpl in H0; lra. }
  destruct H as [n0 H].
  exists n0; intros n Hle.
  assert (forall n', a - f n' >= 0).
  { intro n'; cut (f n' <= a); try lra; apply Ha. }
  rewrite Rabs_right in H; auto.
  rewrite Rabs_right; auto.
  cut (a < eps + f n); try lra.
  apply Rlt_le_trans with (eps + f n0); try lra.
  apply Rplus_le_compat_l.
  apply Rle_leq.
  apply chain_leq; auto.
Qed.

Lemma infimum_converges_R (f : nat -> R) (a : R) :
  dec_chain f ->
  infimum a f ->
  converges_R f a.
Proof.
  intros Hf Ha eps Heps.
  replace f with (Ropp ∘ (Ropp ∘ f)) in Ha.
  2: { unfold compose; ext s; lra. }
  apply dec_chain_opp_chain in Hf.
  apply infimum_opp_supremum in Ha.
  apply converges_opp; auto.
  apply supremum_converges_R; auto.
Qed.

Lemma converges_const_sum (f g : nat -> R) (a b c : R) :
  (forall i, f i + g i = c) ->
  converges_R f a ->
  converges_R g b ->
  a + b = c.
Proof.
  intros Hc Ha Hb.
  apply cond_eq; intros eps Heps.
  assert (H: 0 < eps / 2) by lra.
  specialize (Ha _ H).
  specialize (Hb _ H).
  destruct Ha as [n Ha].
  destruct Hb as [m Hb].
  destruct (Nat.leb_spec0 n m).
  - specialize (Ha m l).
    specialize (Hb m (le_n m)).
    specialize (Hc m).
    rewrite <- Hc.
    replace (a + b - (f m + g m)) with ((a - f m) + (b - g m)).
    2: { lra. }
    eapply Rle_lt_trans.
    apply Rabs_triang.
    lra.
  - assert (Hle: (m <= n)%nat) by lia.
    specialize (Ha n (le_n n)).
    specialize (Hb n Hle).
    specialize (Hc n).
    rewrite <- Hc.
    replace (a + b - (f n + g n)) with ((a - f n) + (b - g n)).
    2: { lra. }
    eapply Rle_lt_trans.
    apply Rabs_triang.
    lra.
Qed.

Lemma supremum_infimum_sum_R (f g : nat -> R) (a b c : R) :
  chain f ->
  dec_chain g ->
  (forall i, f i + g i = c) ->
  supremum a f ->
  infimum b g ->
  a + b = c.
Proof.
  intros Hf Hg Heq Ha Hb.
  eapply converges_const_sum; eauto.
  - apply supremum_converges_R; auto.
  - apply infimum_converges_R; auto.
Qed.

Lemma upper_bound_Ropp_lower_bound {A} (a : R) (f : A -> R) :
  upper_bound (-a) (Ropp ∘ f) <->
    lower_bound a f.
Proof.
  unfold upper_bound, lower_bound, compose; simpl.
  split; intros Hub y; specialize (Hub y); lra.
Qed.

Lemma converges_increasing_ub (g : nat -> R) (lim : R) :
  (forall i, g i <= g (S i)) ->
  converges_R g lim ->
  upper_bound lim g.
Proof.
  unfold converges_R.
  intros Hle Hc n; simpl.
  destruct (Rlt_le_dec lim (g n)); auto.
  set (eps := g n - lim).
  assert (0 < eps).
  { unfold eps; lra. }
  specialize (Hc eps H); destruct Hc as [n0 Hc].
  specialize (Hc (max n n0) (Nat.le_max_r _ _)).
  rewrite Rabs_minus_sym in Hc.
  assert (H0: forall m, (n <= m)%nat -> g n <= g m).
  { intros m Hle'; induction m.
    - inversion Hle'; lra.
    - destruct (Nat.eqb_spec n (S m)); subst.
      + lra.
      + assert (n <= m)%nat. lia.
        apply IHm in H0; eapply Rle_trans; eauto. }
  assert (H1: g n <= g (max n n0)).
  { apply H0. apply Nat.le_max_l. }
  rewrite Rabs_pos_eq in Hc.
  - unfold eps in Hc; lra.
  - lra.
Qed.

Lemma converges_decreasing_lb (g : nat -> R) (lim : R) :
  (forall i, g i >= g (S i)) ->
  converges_R g lim ->
  lower_bound lim g.
Proof.
  intros H0 H1.
  apply converges_opp in H1.
  apply upper_bound_Ropp_lower_bound.
  apply converges_increasing_ub; auto.
  intro i; unfold compose; specialize (H0 i); lra.
Qed.

Lemma converges_increasing_le_ub (g : nat -> R) (lim : R) :
  converges_R g lim ->
  forall ub, upper_bound ub g -> lim <= ub.
Proof.
  unfold upper_bound; simpl; unfold converges_R.
  intros Hc ub Hub; destruct (Rlt_le_dec ub lim); auto.
  set (eps := lim - ub).
  assert (Heps: 0 < eps).
  { unfold eps; lra. }
  specialize (Hc eps Heps); destruct Hc as [n0 Hc].
  specialize (Hc n0 (Nat.le_refl _)); specialize (Hub n0).
  unfold eps in Hc; rewrite Rabs_pos_eq in Hc; lra.
Qed.

Lemma converges_decreasing_ge_lb (g : nat -> R) (lim : R) :
  converges_R g lim ->
  forall lb, lower_bound lb g -> lb <= lim.
Proof.
  intros Hlim lb Hlb.
  apply upper_bound_Ropp_lower_bound in Hlb.
  apply converges_opp in Hlim.
  eapply converges_increasing_le_ub in Hlb; eauto.
  lra.
Qed.

(* If g is monotonically increasing and converges to lim, then lim is
   the supremum of g. *)
Lemma converges_infimum_R (g : nat -> R) (lim : R) :
  (forall i, g i >= g (S i)) ->
  converges_R g lim ->
  infimum lim g.
Proof.
  unfold converges_R.
  intros Hc. split.
  - apply converges_decreasing_lb; auto.
  - apply converges_decreasing_ge_lb; auto.
Qed.

Lemma supremum_scalar_R {A} `{Inhabited A} (f : A -> R) (a c : R) :
  0 <= c ->
  supremum a f ->
  supremum (c * a) (fun i => c * f i).
Proof.
  destruct (Req_dec c 0); subst.
  { intros _ _.
    replace (fun i => 0 * f i) with (fun _ : A => 0).
    { rewrite Rmult_0_l; apply supremum_const. }
    ext i; lra. }
  intros Hle [Hub Hlub]; split.
  - intro i; simpl.
    cut (f i <= a); try nra.
    apply Hub.
  - intros x Hx; simpl.
    unfold upper_bound in *; simpl in *.
    cut (c * / c * a <= x * /c).
    { intro H1; eapply Rmult_le_reg_r.
      2: { rewrite Rmult_assoc, (@Rmult_comm a _), <- Rmult_assoc; apply H1. }
      apply Rinv_0_lt_compat; lra. }
    rewrite Rinv_r; auto.
    rewrite Rmult_1_l; apply Hlub.
    intro i; specialize (Hx i).
    eapply Rmult_le_reg_l with (r:=c); try lra.
    rewrite <- Rmult_assoc, (@Rmult_comm c x), Rmult_assoc, Rinv_r; lra.
Qed.

Definition pow_sequence (a : R) (n : nat) : R := pow a n.

Lemma archimedean (r : R) :
  exists n, (r < INR n)%R.
Proof.
  destruct (Rlt_le_dec 0 r).
  - assert (Hlt: (0 < / r)%R).
    { apply Rinv_0_lt_compat; auto. }
    generalize (archimed_cor1 (/ r) Hlt).
    intros [n [H Hnz]]; exists n.
    rewrite <- Rinv_inv, <- (Rinv_inv r); try lra.
    apply Rinv_lt_contravar; auto.
    apply Rmult_lt_0_compat; auto.
    apply Rinv_0_lt_compat.
    replace 0%R with (INR 0) by reflexivity.
    apply lt_INR; auto.
  - exists (S O); eapply Rle_lt_trans; eauto.
    replace 0%R with (INR 0) by reflexivity.
    apply lt_INR; lia.
Qed.

Lemma ln_neg (a : R) :
  (0 < a)%R ->
  (a < 1)%R ->
  (ln a < 0)%R.
Proof.
  intro Hlt.
  replace 0%R with (ln 1).
  2: apply ln_1.
  apply ln_increasing; auto.
Qed.

Lemma pow_sequence_converges :
  forall a : R,
    (0 < a)%R -> (a < 1)%R ->
    forall eps : R, (0 < eps)%R -> exists n0, forall n, (n0 <= n)%nat -> (pow a n < eps)%R.
Proof.
  intros a H0 H1 eps Heps.
  generalize (archimedean (/ ln a * ln eps)); intros [n0 H2].
  exists n0; intros n Hle.
  apply ln_lt_inv; auto.
  { apply pow_lt; auto. }
  rewrite ln_pow; auto.
  apply Rmult_lt_reg_l with (r := Ropp (Rinv (ln a))%R).
  { rewrite <- Rinv_opp.
    apply Rinv_0_lt_compat, Ropp_0_gt_lt_contravar, Rlt_gt, ln_neg; auto. }
  rewrite 2!Ropp_mult_distr_l_reverse.
  apply Ropp_lt_contravar.
  replace (INR n * ln a)%R with (ln a * INR n)%R.
  2: { apply Rmult_comm. }
  rewrite <- Rmult_assoc.
  replace (/ ln a * ln a)%R with 1%R.
  2: { field; apply ln_neq_0; lra. }
  rewrite Rmult_1_l.
  apply Rlt_le_trans with (INR n0); auto.
  apply le_INR; auto.
Qed.

Lemma pow_sequence_converges' :
  forall a : R,
    (0 < a)%R -> (a < 1)%R ->
    converges_R (pow_sequence a) 0.
Proof.
  intros a H0 H1 eps Heps.
  generalize (pow_sequence_converges a H0 H1 eps Heps); intros [n0 Hn].
  exists n0; intros n Hle.
  apply Hn in Hle.
  rewrite Rabs_minus_sym.
  rewrite Rminus_0_r.
  unfold pow_sequence.
  rewrite Rabs_pos_eq; auto.
  apply pow_le; lra.
Qed.

Lemma Rmult_le_1_le a b :
  a <= 1 ->
  0 <= b ->
  a * b <= b.
Proof. nra. Qed.

Lemma Rminus_0_le a b :
  b <= a ->
  0 <= a - b.
Proof. lra. Qed.

Lemma Rle_not_eq_Rlt a b :
  a <= b ->
  b <> a ->
  a < b.
Proof. lra. Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.

Require Import ExtLib.Data.ListNth.

Require Import Helix.Util.OptionSetoid.
Require Import Helix.Tactics.HelixTactics.

Import ListNotations.

Fixpoint fold_left_rev
         {A B : Type}
         (f : A -> B -> A) (a : A) (l : list B)
  : A
  := match l with
     | List.nil => a
     | List.cons b l => f (fold_left_rev f a l) b
     end.

Program Fixpoint Lbuild {A: Type}
        (n : nat)
        (gen : forall i, i < n -> A) {struct n}: list A :=
  match n with
  | O => List.nil
  | S p =>
    let gen' := fun i ip => gen (S i) _ in
    List.cons (gen 0 _) (@Lbuild A p gen')
  end.
Next Obligation. apply lt_n_S, ip. Qed.
Next Obligation. apply Nat.lt_0_succ. Qed.

Lemma nth_error_Sn {A:Type} (x:A) (xs:list A) (n:nat):
  nth_error (x::xs) (S n) = nth_error xs n.
Proof.
  reflexivity.
Qed.

Lemma rev_nil (A:Type) (x:list A):
  rev x = nil -> x = nil.
Proof.
  intros H.
  destruct x.
  -
    reflexivity.
  -
    simpl in H.
    symmetry in H.
    contradict H.
    apply app_cons_not_nil.
Qed.

(* List elements unique wrt projection [p] using [eq] *)
Definition list_uniq {A B:Type} (p: A -> B) (l:list A): Prop
  := forall x y a b,
    List.nth_error l x = Some a ->
    List.nth_error l y = Some b ->
    (p a) = (p b) -> x=y.

Lemma list_uniq_nil {A B:Type} (p: A -> B):
  list_uniq p (@nil A).
Proof.
  unfold list_uniq.
  intros x y a b H H0 H1.
  rewrite nth_error_nil in H.
  inversion H.
Qed.

Lemma list_uniq_de_cons {A B:Type} (p: A -> B) (a:A) (l:list A):
  list_uniq p (a :: l) ->
  list_uniq p l.
Proof.
  intros H.
  unfold list_uniq in *.
  intros x y a0 b H0 H1 H2.
  cut (S x = S y). auto.
  eapply H; eauto.
Qed.

Lemma list_uniq_cons {A B:Type} (p: A -> B) (a:A) (l:list A):
  list_uniq p l /\
  not (exists j x, nth_error l j = Some x /\ p x = p a) <->
  list_uniq p (a :: l).
Proof.
  split.
  -
    intros [U E].
    unfold list_uniq in *.
    intros x y a0 b H H0 H1.
    destruct x,y; cbn in *.
    +
      reflexivity.
    +
      inversion H; subst.
      contradict E.
      exists y, b.
      auto.
    +
      inversion H0; subst.
      contradict E.
      exists x, a0.
      auto.
    +
      apply eq_S.
      eapply U; eauto.
  -
    intros H.
    split ; [eapply list_uniq_de_cons; eauto|].

    intros C.
    destruct C as (j & x & C0 & C1).
    unfold list_uniq in H.
    specialize (H 0 (S j)).
    cbn in H.
    specialize (H a x).
    cut(0 = S j). intros. inv H0.
    apply H; auto.
Qed.

Lemma app_nth_error2 :
  forall {A: Type} (l:list A) l' n, n >= List.length l -> nth_error (l++l') n = nth_error l' (n-length l).
Proof.
  induction l; intros l' d [|n]; auto;
    cbn; rewrite IHl; auto with arith.
Qed.

Lemma app_nth_error1 :
  forall {A:Type} (l:list A) l' n, n < length l -> nth_error (l++l') n = nth_error l n.
Proof.
  induction l.
  - inversion 1.
  - intros l' n H.
    cbn.
    destruct n; [reflexivity|].
    rewrite 2!nth_error_Sn.
    apply IHl.
    cbn in H.
    auto with arith.
Qed.

Lemma rev_nth_error : forall {A:Type} (l:list A) n,
    (n < List.length l)%nat ->
    nth_error (rev l) n = nth_error l (List.length l - S n) .
Proof.
  induction l.
  intros; inversion H.
  intros.
  simpl in H.
  simpl (rev (a :: l)).
  simpl (List.length (a :: l) - S n).
  inversion H.
  rewrite <- minus_n_n; simpl.
  rewrite <- rev_length.
  rewrite app_nth_error2; auto.
  rewrite <- minus_n_n; auto.
  rewrite app_nth_error1; auto.
  rewrite (minus_plus_simpl_l_reverse (length l) n 1).
  replace (1 + length l) with (S (length l)); auto with arith.
  rewrite <- minus_Sn_m; auto with arith.
  apply IHl ; auto with arith.
  rewrite rev_length; auto.
Qed.

Lemma fold_left_rev_def {A B : Type} (l : list B) (e : A) (f : A -> B -> A) :
  fold_left_rev f e l = fold_left f (rev l) e.
Proof.
  induction l.
  -
    reflexivity.
  -
    cbn.
    rewrite fold_left_app, IHl.
    reflexivity.
Qed.

Lemma fold_left_fold_left_rev
      {A : Type}
      (l : list A)
      (e : A)
      (f : A -> A -> A)
      (f_commut : forall x y, f x y = f y x)
      (f_assoc : forall x y z, f x (f y z) = f (f x y) z)
  :
    fold_left_rev f e l = fold_left f l e.
Proof.
  rewrite fold_left_rev_def.
  rewrite <-fold_left_rev_right.
  rewrite rev_involutive.
  induction l; [reflexivity |].
  cbn.
  rewrite_clear IHl.
  generalize dependent a.
  induction l; [reflexivity |].
  cbn.
  congruence.
Qed.

Lemma fold_left_preservation
      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PP : forall a b, P a \/ P b -> P (f a b))
  :
    (P init \/ exists a, P a /\ In a l) ->
    P (fold_left f l init).
Proof.
  intros.
  generalize dependent init.
  induction l.
  -
    intros.
    intuition.
    destruct H0.
    intuition.
  -
    intros.
    cbn.
    apply IHl.
    destruct H as [I | [a' [Pa' La']]]; auto.
    inversion La'.
    subst; auto.
    right.
    exists a'.
    auto.
Qed.

Lemma fold_left_emergence2
      {A B : Type}
      (f : A -> B -> A)
      (init : A)
      (l : list B)
      (P : A -> Prop)
      (Q : B -> Prop)
      (PE : forall a b, P (f a b) -> P a \/ Q b)
  :
    P (fold_left f l init) ->
    (P init \/ exists a, Q a /\ In a l).
Proof.
  intros.
  generalize dependent init.
  induction l.
  -
    intros.
    tauto.
  -
    intros.
    cbn in H.
    apply IHl in H.
    destruct H as [I | [a' [Pa' La']]].
    +
      apply PE in I.
      destruct I; auto.
      right.
      exists a.
      cbn.
      auto.
    +
      right.
      exists a'.
      cbn.
      auto.
Qed.

Lemma fold_left_emergence
      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PE : forall a b, P (f a b) -> P a \/ P b)
  :
    P (fold_left f l init) ->
    (P init \/ exists a, P a /\ In a l).
Proof.
  now apply fold_left_emergence2.
Qed.

Lemma fold_left_invariant
      {A : Type}
      (f : A -> A -> A)
      (init : A)
      (l : list A)
      (P : A -> Prop)
      (PI : forall a b, P (f a b) <-> P a \/ P b)
  :
    P (fold_left f l init) <-> (P init \/ exists a, P a /\ In a l).
Proof.
  split; intros.
  -
    apply fold_left_emergence with (f0:=f).
    apply PI.
    assumption.
  -
    apply fold_left_preservation with (f0:=f).
    apply PI.
    assumption.
Qed.

Lemma Forall2_firstn
      {A B : Type}
      (R : A -> B -> Prop)
      (l1 : list A)
      (l2 : list B)
      (n : nat)
  :
    Forall2 R l1 l2 ->
    Forall2 R (firstn n l1) (firstn n l2).
Proof.
  intros I.
  generalize dependent n.
  induction I;
    intro n.
  -
    now rewrite !firstn_nil.
  -
    destruct n.
    +
      constructor.
    +
      cbn; constructor.
      assumption.
      apply IHI.
Qed.

Lemma Forall2_skipn
      {A B : Type}
      (R : A -> B -> Prop)
      (l1 : list A)
      (l2 : list B)
      (n : nat)
  :
    Forall2 R l1 l2 ->
    Forall2 R (skipn n l1) (skipn n l2).
Proof.
  intros I.
  generalize dependent n.
  induction I;
    intro n.
  -
    now rewrite !skipn_nil.
  -
    destruct n.
    now constructor.
    apply IHI.
Qed.

Lemma Forall2_nth_error
      {A B : Type}
      (n : nat)
      (P : A -> B -> Prop)
      (l1 : list A)
      (l2 : list B)
  :
    Forall2 P l1 l2 ->
    hopt_r P (nth_error l1 n) (nth_error l2 n).
Proof.
  revert n l2.
  induction l1;
    intros * F.
  -
    inv F.
    rewrite !nth_error_nil.
    constructor.
  -
    inv F.
    rename a into e1', y into e2', l' into l2, H1 into E, H3 into L.
    destruct n.
    +
      now constructor.
    +
      cbn.
      now apply IHl1.
Qed.

Lemma firstn_app_exact {A : Type} (l1 l2 : list A) (n : nat) :
  n = length l1 ->
  firstn n (l1 ++ l2) = l1.
Proof.
  intros L.
  subst.
  rewrite <-PeanoNat.Nat.add_0_r with (n:=length l1).
  rewrite firstn_app_2, firstn_O, app_nil_r.
  reflexivity.
Qed.

Lemma skipn_app_exact {A : Type} (l1 l2 : list A) (n : nat) :
  n = length l1 ->
  skipn n (l1 ++ l2) = l2.
Proof.
  intros L.
  subst.
  rewrite skipn_app.
  rewrite PeanoNat.Nat.sub_diag.
  rewrite skipn_all, skipn_O, app_nil_l.
  reflexivity.
Qed.


Set Implicit Arguments.

Require Import Logic.FunctionalExtensionality.
Require Import Behavior.
Local Open Scope behavior.

Section Syntax.

  Variable A : Type.

  Definition Predicate := A -> Prop.
  Definition Action := A -> A -> Prop.

  Inductive Expr :=
  | E_Predicate : Predicate -> Expr
  | E_AlwaysAction : forall {B : Type}, (A -> B) -> Action -> Expr
  | E_EventuallyAction : forall {B : Type}, (A -> B) -> Action -> Expr
  | E_Neg : Expr -> Expr
  | E_Conj : Expr -> Expr -> Expr
  | E_Disj : Expr -> Expr -> Expr
  | E_Impl : Expr -> Expr -> Expr
  | E_Equiv : Expr -> Expr -> Expr
  | E_Always : Expr -> Expr
  | E_Eventually : Expr -> Expr
  | E_ForallRigid : forall {B : Type}, (B -> Expr) -> Expr
  | E_ExistsRigid : forall {B : Type}, (B -> Expr) -> Expr.

  Definition E_Enabled (r : Action) :=
    E_Predicate (fun st => exists st', r st st').
(*
  Definition E_Skip := E_Action eq.
  Definition E_Box e := E_Disj e E_Skip.
 *)

End Syntax.

(*Arguments E_Skip {A}.*)

(* Notations *)

Delimit Scope tla_scope with tla.

Notation "P `<=> Q" :=
  (E_Equiv P Q) (at level 95, no associativity) : tla_scope.

Notation "P `=> Q" :=
  (E_Impl P Q) (at level 90, right associativity) : tla_scope.

Notation "P `\/ Q" :=
  (E_Disj P Q) (at level 85, right associativity) : tla_scope.

Notation "P `/\ Q" :=
  (E_Conj P Q) (at level 80, right associativity): tla_scope.

Notation "`~ P" :=
  (E_Neg P) (at level 75, right associativity) : tla_scope.

Notation "[] P" :=
  (E_Always P) (at level 75, right associativity) : tla_scope.

Notation "<> P" :=
  (E_Eventually P) (at level 75, right associativity) : tla_scope.

Definition E_LeadsTo {T} (P Q : Expr T) := E_Always (E_Impl P (E_Eventually Q)).

Notation "P `~> Q" :=
  (E_LeadsTo P Q) (at level 90, right associativity) : tla_scope.

Notation "'ENABLED' r" :=
  (E_Enabled r) (at level 70, no associativity) : tla_scope.

Notation "[][ R ]" := (E_AlwaysAction (fun x => x)  R) : tla_scope.

Notation "<>< R >" := (E_EventuallyAction (fun x => x)  R) : tla_scope.

(* Notation "'SKIP'" := (E_Skip) : tla_scope. *)

Notation "` P" :=
  (E_Predicate P) (at level 0, right associativity) : tla_scope.

Notation "'FORALL' p" := (E_ForallRigid p) (at level 70, right associativity)
                         : tla_scope.

Notation "'EXISTS' p" := (E_ForallRigid p) (at level 70, right associativity)
                         : tla_scope.

(* Coercing predicates doesn't seem to work all the time, so use the
explicit notation above. *)
(* Coercion E_Predicate : Predicate >-> Expr. *)

Local Open Scope tla.

Definition WF {T} (A : Action T) : Expr T :=
  ([] (E_EventuallyAction (fun x => x) A)) `\/ ([]<>(`~ ENABLED A)).

Definition SF {T} (A : Action T) : Expr T :=
  ([] (E_EventuallyAction (fun x => x) A)) `\/ (<>[](`~ ENABLED A)).

Arguments WF _ A%tla.
Arguments SF _ A%tla.

Fixpoint eval (A : Type) (e : Expr A) : Behavior A -> Prop :=
  match e with
    | E_Predicate p => fun s => p (s 0)
    | E_AlwaysAction f r => fun s => forall n, (r (s@n 0) (s@n 1)) \/ f (s@n 0) = f (s@n 1)
    | E_EventuallyAction f r => fun s => exists n, (r (s@n 0) (s@ n 1)) /\ f (s@n 0) <> f (s@n 1)
    | `~ e => fun s => ~ eval e s
    | e1 `/\ e2 => fun s => eval e1 s /\ eval e2 s
    | e1 `\/ e2 => fun s => eval e1 s \/ eval e2 s
    | e1 `=> e2 => fun s => eval e1 s -> eval e2 s
    | e1 `<=> e2 => fun s => eval e1 s <-> eval e2 s
    | [] e => fun s => forall n, eval e (s@n)
    | <> e => fun s => exists n, eval e (s@n)
    | E_ForallRigid f => fun s => forall x, eval (f x) s
    | E_ExistsRigid f => fun s => exists x, eval (f x) s
  end.

Definition valid (A : Type) (e : Expr A) : Prop :=
  forall s, eval e s.

Arguments valid _ e%tla.
Arguments eval _ e%tla s%behavior.

Fixpoint map (C A : Type) (f : C -> A) (e : Expr A) : Expr C :=
  match e with
    | E_Predicate P => E_Predicate (fun st => P (f st))
    | E_AlwaysAction g R => E_AlwaysAction (fun st => g (f st)) (fun st st' => R (f st) (f st'))
    | E_EventuallyAction g R => E_EventuallyAction (fun st => g (f st)) (fun st st' => R (f st) (f st'))
    | `~ P => `~ (map f P)
    | P `/\ Q => (map f P) `/\ (map f Q)
    | P `\/ Q => (map f P) `\/ (map f Q)
    | P `=> Q => (map f P) `=> (map f Q)
    | P `<=> Q => (map f P) `<=> (map f Q)
    | [] P => [] (map f P)
    | <> P => <> (map f P)
    | E_ForallRigid g => E_ForallRigid (fun x => map f (g x))
    | E_ExistsRigid g => E_ExistsRigid (fun x => map f (g x))
  end.

Lemma same_args_same_res : forall A, forall B, forall (f : A -> B), forall x y, x = y -> f x = f y.
    intros A B f x y H; rewrite H; auto.
Qed.

Lemma map_id :
  forall (A : Type) (e : Expr A),
    map (fun x => x) e = e.
Proof.
  assert (arg : forall A, forall B, forall (f : A -> B), forall x y, x = y -> f x = f y). intros A B f x y H; rewrite H; auto.
  induction e; simpl;
  try (rewrite IHe1; rewrite IHe2; trivial);
  try (rewrite IHe; trivial);
  try trivial;
  try (apply same_args_same_res; extensionality x; auto).
Qed.

Lemma map_map :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (e : Expr C),
    map f (map g e) = map (fun x => g (f x)) e.
Proof.
  induction e; simpl;
  try (rewrite IHe1; rewrite IHe2; trivial);
  try (rewrite IHe; trivial);
  try trivial;
  try (apply same_args_same_res; extensionality x; auto).
Qed.

Lemma slide_shift : forall A B (f : A -> B) s n, (fun x => f (s x)) @ n = fun x => f ((s @ n) x).
Proof.
  intros A B f s n.
  extensionality x.
  induction n; auto.
Qed.

Lemma map_eval :
  forall (A B : Type) (f : A -> B) (e : Expr B) (s : Behavior A),
    eval (map f e) s <-> eval e (fun x => f (s x)).
Proof.
  intros A B f e s.  generalize dependent s.
  induction e; simpl; intros;
  try (rewrite IHe1; rewrite IHe2; solve [intuition]);
  try (rewrite IHe; solve [intuition]);
  try solve [intuition].
  split; intros H n;
  [ try (rewrite slide_shift; apply IHe; trivial) |
    specialize H with n; rewrite slide_shift in H; apply IHe in H; trivial].
  split; intros H; destruct H as (n,H); exists n;
  [ rewrite slide_shift; apply IHe; trivial |
    rewrite slide_shift in H; apply IHe in H; trivial].
  split; intros H0 x; apply H; trivial.
  split; intros H0; destruct H0 as (x,H0); exists x; apply H; trivial.
Qed.

Theorem stutter_equiv_eval : forall A (e : Expr A) (s s' : Behavior A), stutter_equiv s s' ->
                                                                        eval e s <->
                                                                        eval e s'.
Proof.
  intros A e.
  induction e; intros s s' H0; simpl.
  apply stutter_equiv_same_first in H0; rewrite H0; split; auto.
  split; intros H1 n; unfold shift in *; simpl in *;
  set (a' := fun x y => a x y \/ b x = b y).
  assert (H2 :  a' (s' n) (s' (S n)) \/ s' n = s' (S n)).
  apply stutter_equiv_induct_next with s; auto. intros n0.
  specialize H1 with n0. destruct H1 as [H1|H1]; left. left; auto. right; auto.
  destruct H2 as [[H2|H2]|H2]. left; auto. right; auto. rewrite H2; right; auto.
  assert (H2 :  a' (s n) (s (S n)) \/ s n = s (S n)).
  apply stutter_equiv_induct_next with s'; auto. symmetry; auto. intros n0.
  specialize H1 with n0. destruct H1 as [H1|H1]; left. left; auto. right; auto.
  destruct H2 as [[H2|H2]|H2]. left; auto. right; auto. rewrite H2; right; auto.
  split; intros H1.
  apply stutter_equiv_induct_next'' with s; auto.
  apply stutter_equiv_induct_next'' with s'; auto.
  assert (H : s = fun n => s @ n 0). extensionality n; auto.
  rewrite <- H. symmetry. auto.
  split; intros H1 H2; apply H1. apply IHe with s'; auto.  apply IHe with s; auto. symmetry; auto.
  assert (H3 : stutter_equiv s s'); auto.
  apply IHe1 in H0. apply IHe2 in H3.
  intuition.
  assert (H3 : stutter_equiv s s'); auto.
  apply IHe1 in H0. apply IHe2 in H3.
  split; intros H1; destruct H1; intuition.
  assert (H3 : stutter_equiv s s'); auto.
  apply IHe1 in H0. apply IHe2 in H3.
  intuition.
  assert (H3 : stutter_equiv s s'); auto.
  apply IHe1 in H0. apply IHe2 in H3.
  intuition.
  split; intros H1 n.
  assert (H2: exists m, stutter_equiv (s' @ n) (s @ m)). apply stutter_equiv_univ. symmetry; auto.
  destruct H2 as (m,H2). apply IHe in H2. intuition.
  assert (H2 : exists m, stutter_equiv (s @ n) (s' @ m)). apply stutter_equiv_univ; auto.
  destruct H2 as (m,H2). apply IHe in H2. intuition.
  split; intros H1; destruct H1 as (n,H1).
  assert (H2 : exists m, stutter_equiv (s @ n) (s' @ m)). apply stutter_equiv_univ; auto.
  destruct H2 as (m,H2). apply IHe in H2. exists m; intuition.
  assert (H2 : exists m, stutter_equiv (s' @ n) (s @ m)). apply stutter_equiv_univ. symmetry; auto.
  destruct H2 as (m,H2). apply IHe in H2. exists m; intuition.
  split; intros H1 x; specialize H with x s s'; intuition.
  split; intros H1; destruct H1 as (x,H1); specialize H with x s s'; exists x; intuition.
Qed.


From CoqMTL Require Import Control.All.
From CoqMTL Require Import Control.Monad.Class.All.

(** [State S A] models a computation which returns a result of type [A]
    and has read and write access to a single cell of state of type [S]. *)
Definition State (S A : Type) := S -> A * S.

(** We can map over such a computation by applying a function to its
    result without touching the state. *)
Definition fmap_State
  (S A B : Type) (f : A -> B) (st : State S A) : State S B :=
    fun s : S => let (a, s') := st s in (f a, s').

#[global] Hint Unfold fmap_State : CoqMTL.

#[refine]
#[export]
Instance Functor_State (S : Type) : Functor (State S) :=
{
  fmap := @fmap_State S;
}.
Proof. all: unfold compose; monad. Defined.

(** We can inject a value into the monad by returning it without changing
    the state. *)
Definition pure_State
  (S A : Type) : A -> State S A :=
    fun (a : A) (s : S) => (a, s).

(** We can apply a stateful function to a stateful argument by running
    the computations in this order and then applying the function to
    the argument. The resulting state is that obtained from computing
    the argument. *)
Definition ap_State
  (S A B : Type) (sf : State S (A -> B)) (sa : State S A) : State S B :=
    fun st : S =>
      let (f, stf) := sf st in
      let (a, sta) := sa stf in (f a, sta).

#[global] Hint Unfold pure_State ap_State : CoqMTL.

#[refine]
#[export]
Instance Applicative_State (S : Type) : Applicative (State S) :=
{
  is_functor := Functor_State S;
  pure := @pure_State S;
  ap := @ap_State S;
}.
Proof. all: unfold compose; monad. Defined.

(** [State S] is not a commutative applicative because the result of
    the computation depends on the state and changing the argument
    order changes the state in which things are evaluated. *)
Lemma State_not_CommutativeApplicative :
  ~ (forall S : Type, CommutativeApplicative _ (Applicative_State S)).
Proof.
  intro. destruct (H bool). compute in ap_comm.
  specialize (ap_comm nat nat nat (fun _ => id)
    (fun b => if b then (42, negb b) else (142, b))
    (fun b => if b then (143, b) else (43, negb b))).
  apply (@f_equal _ _ (fun f => f true)) in ap_comm.
  cbn in ap_comm. congruence.
Qed.

(** [State S] is also not [Alternative], because there are no computations
    returning values of the empty type if the state type is nonempty. *)
Lemma State_not_Alternative :
  (forall S : Type, Alternative (State S)) -> False.
Proof.
  unfold State. intro.
  destruct (X unit). destruct (aempty False tt).
  assumption.
Qed.

(** We can can sequence two stateful computation by running the first and
    feeding its result and state into the second. *)
Definition bind_State
  {S A B : Type} (sa : State S A) (f : A -> State S B)
    : State S B := fun s : S => let (a, s') := sa s in f a s'.

#[global] Hint Unfold bind_State : CoqMTL.

#[refine]
#[export]
Instance Monad_State (S : Type) : Monad (State S) :=
{
  is_applicative := Applicative_State S;
  bind := @bind_State S;
}.
Proof. all: monad. Defined.

(** [State S] is the primordial example of a state monad. *)
#[refine]
#[export]
Instance MonadState_State
  (S : Type) : MonadState S (State S) (Monad_State S) :=
{
  get := fun s : S => (s, s);
  put := fun s : S => fun _ => (tt, s);
}.
Proof. all: hs. Defined.