Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__betweennesspreserved.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__differenceofparts.
Require Export lemma__doublereverse.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__interior5.
Require Export lemma__twolines.
Require Export logic.
Require Export proposition__01.
Require Export proposition__03.
Definition proposition__10 : forall A B, (euclidean__axioms.neq A B) -> (exists X, (euclidean__axioms.BetS A X B) /\ (euclidean__axioms.Cong X A X B)).
Proof.
intro A.
intro B.
intro H.
assert (* Cut *) (exists C, (euclidean__defs.equilateral A B C) /\ (euclidean__axioms.Triangle A B C)) as H0.
- apply (@proposition__01.proposition__01 A B H).
- destruct H0 as [C H1].
destruct H1 as [H2 H3].
assert (euclidean__axioms.nCol A B C) as H4 by exact H3.
assert (* Cut *) ((euclidean__axioms.Cong A B B C) /\ (euclidean__axioms.Cong B C C A)) as H5.
-- assert ((euclidean__axioms.Cong A B B C) /\ (euclidean__axioms.Cong B C C A)) as H5 by exact H2.
assert ((euclidean__axioms.Cong A B B C) /\ (euclidean__axioms.Cong B C C A)) as __TmpHyp by exact H5.
destruct __TmpHyp as [H6 H7].
split.
--- exact H6.
--- exact H7.
-- assert (* Cut *) (euclidean__axioms.Cong A C C B) as H6.
--- destruct H5 as [H6 H7].
assert (* Cut *) ((euclidean__axioms.Cong A C C B) /\ (euclidean__axioms.Cong C B A C)) as H8.
---- apply (@lemma__doublereverse.lemma__doublereverse B C C A H7).
---- destruct H8 as [H9 H10].
exact H9.
--- assert (* Cut *) (euclidean__axioms.Cong A C B C) as H7.
---- destruct H5 as [H7 H8].
assert (* Cut *) ((euclidean__axioms.Cong C A B C) /\ ((euclidean__axioms.Cong C A C B) /\ (euclidean__axioms.Cong A C B C))) as H9.
----- apply (@lemma__congruenceflip.lemma__congruenceflip A C C B H6).
----- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exact H13.
---- assert (* Cut *) (~(C = B)) as H8.
----- intro H8.
assert (* Cut *) (euclidean__axioms.Col A C B) as H9.
------ right.
right.
left.
exact H8.
------ assert (* Cut *) (euclidean__axioms.Col A B C) as H10.
------- destruct H5 as [H10 H11].
assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H12.
-------- apply (@lemma__collinearorder.lemma__collinearorder A C B H9).
-------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
------- apply (@euclidean__tactics.Col__nCol__False A B C H4 H10).
----- assert (* Cut *) (exists D, (euclidean__axioms.BetS C B D) /\ (euclidean__axioms.Cong B D A B)) as H9.
------ destruct H5 as [H9 H10].
apply (@lemma__extension.lemma__extension C B A B H8 H).
------ destruct H9 as [D H10].
destruct H10 as [H11 H12].
destruct H5 as [H13 H14].
assert (* Cut *) (~(C = A)) as H15.
------- intro H15.
assert (* Cut *) (euclidean__axioms.Col B C A) as H16.
-------- right.
right.
left.
exact H15.
-------- assert (* Cut *) (euclidean__axioms.Col A B C) as H17.
--------- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H17.
---------- apply (@lemma__collinearorder.lemma__collinearorder B C A H16).
---------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H22.
--------- apply (@euclidean__tactics.Col__nCol__False A B C H4 H17).
------- assert (* Cut *) (exists E, (euclidean__axioms.BetS C A E) /\ (euclidean__axioms.Cong A E A B)) as H16.
-------- apply (@lemma__extension.lemma__extension C A A B H15 H).
-------- destruct H16 as [E H17].
destruct H17 as [H18 H19].
assert (* Cut *) (euclidean__axioms.BetS D B C) as H20.
--------- apply (@euclidean__axioms.axiom__betweennesssymmetry C B D H11).
--------- assert (* Cut *) (euclidean__axioms.BetS E A C) as H21.
---------- apply (@euclidean__axioms.axiom__betweennesssymmetry C A E H18).
---------- assert (* Cut *) (~(euclidean__axioms.Col D C E)) as H22.
----------- intro H22.
assert (* Cut *) (euclidean__axioms.Col C A E) as H23.
------------ right.
right.
right.
right.
left.
exact H18.
------------ assert (* Cut *) (euclidean__axioms.Col C B D) as H24.
------------- right.
right.
right.
right.
left.
exact H11.
------------- assert (* Cut *) (euclidean__axioms.Col E C D) as H25.
-------------- assert (* Cut *) ((euclidean__axioms.Col C D E) /\ ((euclidean__axioms.Col C E D) /\ ((euclidean__axioms.Col E D C) /\ ((euclidean__axioms.Col D E C) /\ (euclidean__axioms.Col E C D))))) as H25.
--------------- apply (@lemma__collinearorder.lemma__collinearorder D C E H22).
--------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H33.
-------------- assert (* Cut *) (euclidean__axioms.Col E C A) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Col A C E) /\ ((euclidean__axioms.Col A E C) /\ ((euclidean__axioms.Col E C A) /\ ((euclidean__axioms.Col C E A) /\ (euclidean__axioms.Col E A C))))) as H26.
---------------- apply (@lemma__collinearorder.lemma__collinearorder C A E H23).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H31.
--------------- assert (* Cut *) (euclidean__axioms.neq C E) as H27.
---------------- assert (* Cut *) ((euclidean__axioms.neq A E) /\ ((euclidean__axioms.neq C A) /\ (euclidean__axioms.neq C E))) as H27.
----------------- apply (@lemma__betweennotequal.lemma__betweennotequal C A E H18).
----------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
exact H31.
---------------- assert (* Cut *) (euclidean__axioms.neq E C) as H28.
----------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C E H27).
----------------- assert (* Cut *) (euclidean__axioms.Col C D A) as H29.
------------------ 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 E C D A H25 H26 H28).

------------------ assert (* Cut *) (euclidean__axioms.Col D C B) as H30.
------------------- assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H30.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H24).
-------------------- 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.Col D C A) as H31.
-------------------- 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 H31.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder C D A H29).
--------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H32.
-------------------- assert (* Cut *) (euclidean__axioms.neq C D) as H32.
--------------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H32.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H11).
---------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H36.
--------------------- assert (* Cut *) (euclidean__axioms.neq D C) as H33.
---------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C D H32).
---------------------- assert (* Cut *) (euclidean__axioms.Col C B A) as H34.
----------------------- apply (@euclidean__tactics.not__nCol__Col C B A).
------------------------intro H34.
apply (@euclidean__tactics.Col__nCol__False C B A H34).
-------------------------apply (@lemma__collinear4.lemma__collinear4 D C B A H30 H31 H33).

----------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H35.
------------------------ assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H35.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B A H34).
------------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H43.
------------------------ apply (@euclidean__tactics.Col__nCol__False A B C H4 H35).
----------- assert (* Cut *) (exists F, (euclidean__axioms.BetS D F A) /\ (euclidean__axioms.BetS E F B)) as H23.
------------ apply (@euclidean__axioms.postulate__Pasch__inner D E C B A H20 H21).
-------------apply (@euclidean__tactics.nCol__notCol D C E H22).

------------ destruct H23 as [F H24].
destruct H24 as [H25 H26].
assert (* Cut *) (euclidean__axioms.BetS B F E) as H27.
------------- apply (@euclidean__axioms.axiom__betweennesssymmetry E F B H26).
------------- assert (* Cut *) (euclidean__axioms.BetS A F D) as H28.
-------------- apply (@euclidean__axioms.axiom__betweennesssymmetry D F A H25).
-------------- assert (* Cut *) (euclidean__axioms.neq C D) as H29.
--------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H29.
---------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H11).
---------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H33.
--------------- assert (* Cut *) (euclidean__axioms.neq D C) as H30.
---------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C D H29).
---------------- assert (* Cut *) (~(euclidean__axioms.Col A D C)) as H31.
----------------- intro H31.
assert (* Cut *) (euclidean__axioms.Col C B D) as H32.
------------------ right.
right.
right.
right.
left.
exact H11.
------------------ assert (* Cut *) (euclidean__axioms.Col D C A) as H33.
------------------- assert (* Cut *) ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col D C A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A C D) /\ (euclidean__axioms.Col C D A))))) as H33.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder A D C H31).
-------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H36.
------------------- assert (* Cut *) (euclidean__axioms.Col D C B) as H34.
-------------------- assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H34.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H32).
--------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H39.
-------------------- assert (* Cut *) (euclidean__axioms.Col C A B) as H35.
--------------------- apply (@euclidean__tactics.not__nCol__Col C A B).
----------------------intro H35.
apply (@euclidean__tactics.Col__nCol__False C A B H35).
-----------------------apply (@lemma__collinear4.lemma__collinear4 D C A B H33 H34 H30).

--------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H36.
---------------------- assert (* Cut *) ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C B A) /\ (euclidean__axioms.Col B A C))))) as H36.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder C A B H35).
----------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H39.
---------------------- apply (@H22).
-----------------------apply (@euclidean__tactics.not__nCol__Col D C E).
------------------------intro H37.
apply (@euclidean__tactics.Col__nCol__False A B C H4 H36).

----------------- assert (* Cut *) (exists M, (euclidean__axioms.BetS A M B) /\ (euclidean__axioms.BetS C M F)) as H32.
------------------ apply (@euclidean__axioms.postulate__Pasch__inner A C D F B H28 H11).
-------------------apply (@euclidean__tactics.nCol__notCol A D C H31).

------------------ destruct H32 as [M H33].
destruct H33 as [H34 H35].
assert (* Cut *) (euclidean__axioms.Cong C A C B) as H36.
------------------- assert (* Cut *) ((euclidean__axioms.Cong C A C B) /\ ((euclidean__axioms.Cong C A B C) /\ (euclidean__axioms.Cong A C C B))) as H36.
-------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A C B C H7).
-------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H37.
------------------- assert (* Cut *) (euclidean__axioms.Cong A B A E) as H37.
-------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A E B H19).
-------------------- assert (* Cut *) (euclidean__axioms.Cong B D A E) as H38.
--------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B D A B A E H12 H37).
--------------------- assert (* Cut *) (euclidean__axioms.Cong A E B D) as H39.
---------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A B D E H38).
---------------------- assert (* Cut *) (euclidean__axioms.Cong A B B A) as H40.
----------------------- apply (@euclidean__axioms.cn__equalityreverse A B).
----------------------- assert (* Cut *) (euclidean__axioms.Cong C B C A) as H41.
------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C C A B H36).
------------------------ assert (* Cut *) (euclidean__axioms.Cong B E A D) as H42.
------------------------- apply (@euclidean__axioms.axiom__5__line C A E B C B D A H39 H41 H40 H18 H11 H36).
------------------------- assert (* Cut *) (euclidean__axioms.Cong B F B F) as H43.
-------------------------- apply (@euclidean__axioms.cn__congruencereflexive B F).
-------------------------- assert (* Cut *) (euclidean__defs.Lt B F B E) as H44.
--------------------------- exists F.
split.
---------------------------- exact H27.
---------------------------- exact H43.
--------------------------- assert (* Cut *) (euclidean__axioms.Cong A D B E) as H45.
---------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A B E D H42).
---------------------------- assert (* Cut *) (exists G, (euclidean__axioms.BetS A G D) /\ (euclidean__axioms.Cong A G B F)) as H46.
----------------------------- apply (@proposition__03.proposition__03 B E B F A D H44 H45).
----------------------------- destruct H46 as [G H47].
destruct H47 as [H48 H49].
assert (* Cut *) (euclidean__axioms.Cong G D F E) as H50.
------------------------------ apply (@lemma__differenceofparts.lemma__differenceofparts A G D B F E H49 H45 H48 H27).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong E F D G) as H51.
------------------------------- assert (* Cut *) ((euclidean__axioms.Cong E F D G) /\ (euclidean__axioms.Cong D G E F)) as H51.
-------------------------------- apply (@lemma__doublereverse.lemma__doublereverse G D F E H50).
-------------------------------- destruct H51 as [H52 H53].
exact H52.
------------------------------- assert (* Cut *) (euclidean__axioms.Cong F B G A) as H52.
-------------------------------- assert (* Cut *) ((euclidean__axioms.Cong F B G A) /\ (euclidean__axioms.Cong G A F B)) as H52.
--------------------------------- apply (@lemma__doublereverse.lemma__doublereverse A G B F H49).
--------------------------------- destruct H52 as [H53 H54].
exact H53.
-------------------------------- assert (* Cut *) (euclidean__axioms.Cong E A D B) as H53.
--------------------------------- assert (* Cut *) ((euclidean__axioms.Cong E A D B) /\ ((euclidean__axioms.Cong E A B D) /\ (euclidean__axioms.Cong A E D B))) as H53.
---------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A E B D H39).
---------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H54.
--------------------------------- assert (* Cut *) (euclidean__axioms.Cong B A A B) as H54.
---------------------------------- apply (@euclidean__axioms.cn__equalityreverse B A).
---------------------------------- assert (* Cut *) (euclidean__axioms.BetS D G A) as H55.
----------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A G D H48).
----------------------------------- assert (* Cut *) (euclidean__axioms.Cong F A G B) as H56.
------------------------------------ apply (@lemma__interior5.lemma__interior5 E F B A D G A B H26 H55 H51 H52 H53 H54).
------------------------------------ assert (* Cut *) (euclidean__axioms.Cong A F B G) as H57.
------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong A F B G) /\ ((euclidean__axioms.Cong A F G B) /\ (euclidean__axioms.Cong F A B G))) as H57.
-------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip F A G B H56).
-------------------------------------- destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
exact H58.
------------------------------------- assert (* Cut *) (euclidean__axioms.Cong E D D E) as H58.
-------------------------------------- apply (@euclidean__axioms.cn__equalityreverse E D).
-------------------------------------- assert (* Cut *) (euclidean__axioms.Cong F D G E) as H59.
--------------------------------------- apply (@lemma__interior5.lemma__interior5 E F B D D G A E H26 H55 H51 H52 H58 H38).
--------------------------------------- assert (* Cut *) (euclidean__axioms.BetS B G E) as H60.
---------------------------------------- apply (@lemma__betweennesspreserved.lemma__betweennesspreserved A F D B G E H57 H45 H59 H28).
---------------------------------------- assert (* Cut *) (euclidean__axioms.BetS E G B) as H61.
----------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B G E H60).
----------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col A D E)) as H62.
------------------------------------------ intro H62.
assert (* Cut *) (euclidean__axioms.Col C A E) as H63.
------------------------------------------- right.
right.
right.
right.
left.
exact H18.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E D) as H64.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A E) /\ ((euclidean__axioms.Col D E A) /\ ((euclidean__axioms.Col E A D) /\ ((euclidean__axioms.Col A E D) /\ (euclidean__axioms.Col E D A))))) as H64.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D E H62).
--------------------------------------------- destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H71.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E C) as H65.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A C E) /\ ((euclidean__axioms.Col A E C) /\ ((euclidean__axioms.Col E C A) /\ ((euclidean__axioms.Col C E A) /\ (euclidean__axioms.Col E A C))))) as H65.
---------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C A E H63).
---------------------------------------------- destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H68.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H66.
---------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq A E) /\ ((euclidean__axioms.neq C A) /\ (euclidean__axioms.neq C E))) as H66.
----------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C A E H18).
----------------------------------------------- destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
exact H67.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E D C) as H67.
----------------------------------------------- apply (@euclidean__tactics.not__nCol__Col E D C).
------------------------------------------------intro H67.
apply (@euclidean__tactics.Col__nCol__False E D C H67).
-------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 A E D C H64 H65 H66).

----------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E C D) as H68.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col D E C) /\ ((euclidean__axioms.Col D C E) /\ ((euclidean__axioms.Col C E D) /\ ((euclidean__axioms.Col E C D) /\ (euclidean__axioms.Col C D E))))) as H68.
------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder E D C H67).
------------------------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
exact H75.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col E C A) as H69.
------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E A C) /\ ((euclidean__axioms.Col E C A) /\ ((euclidean__axioms.Col C A E) /\ ((euclidean__axioms.Col A C E) /\ (euclidean__axioms.Col C E A))))) as H69.
-------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A E C H65).
-------------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H72.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C E) as H70.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq A E) /\ ((euclidean__axioms.neq C A) /\ (euclidean__axioms.neq C E))) as H70.
--------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C A E H18).
--------------------------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H74.
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq E C) as H71.
--------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C E H70).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C D A) as H72.
---------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col C D A).
-----------------------------------------------------intro H72.
apply (@euclidean__tactics.Col__nCol__False C D A H72).
------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 E C D A H68 H69 H71).

---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C B D) as H73.
----------------------------------------------------- right.
right.
right.
right.
left.
exact H11.
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col D C A) as H74.
------------------------------------------------------ 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 H74.
------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C D A H72).
------------------------------------------------------- destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H75.
------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col D C B) as H75.
------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H75.
-------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H73).
-------------------------------------------------------- destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
exact H80.
------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C D) as H76.
-------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq E G) /\ (euclidean__axioms.neq E B))) as H76.
--------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal E G B H61).
--------------------------------------------------------- destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
exact H29.
-------------------------------------------------------- assert (euclidean__axioms.neq D C) as H77 by exact H30.
assert (* Cut *) (euclidean__axioms.Col C A B) as H78.
--------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col C A B).
----------------------------------------------------------intro H78.
apply (@euclidean__tactics.Col__nCol__False C A B H78).
-----------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 D C A B H74 H75 H77).

--------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H79.
---------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C B A) /\ (euclidean__axioms.Col B A C))))) as H79.
----------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C A B H78).
----------------------------------------------------------- destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H82.
---------------------------------------------------------- apply (@H22).
-----------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col D C E).
------------------------------------------------------------intro H80.
apply (@euclidean__tactics.Col__nCol__False A B C H4 H79).

------------------------------------------ assert (* Cut *) (~(euclidean__axioms.Col A D B)) as H63.
------------------------------------------- intro H63.
assert (* Cut *) (euclidean__axioms.Col D B A) as H64.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col D B A) /\ ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col A B D) /\ (euclidean__axioms.Col B D A))))) as H64.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D B H63).
--------------------------------------------- destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H67.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C B D) as H65.
--------------------------------------------- right.
right.
right.
right.
left.
exact H11.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col D B C) as H66.
---------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H66.
----------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H65).
----------------------------------------------- destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H74.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H67.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H67.
------------------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal C B D H11).
------------------------------------------------ destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
exact H68.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H68.
------------------------------------------------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H67).
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col B A C) as H69.
------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col B A C).
--------------------------------------------------intro H69.
apply (@euclidean__tactics.Col__nCol__False B A C H69).
---------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 D B A C H64 H66 H68).

------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H70.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H70.
--------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A C H69).
--------------------------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
exact H71.
-------------------------------------------------- apply (@H22).
---------------------------------------------------apply (@euclidean__tactics.not__nCol__Col D C E).
----------------------------------------------------intro H71.
apply (@euclidean__tactics.Col__nCol__False A B C H4 H70).

------------------------------------------- assert (* Cut *) (euclidean__defs.Cut A D E B G) as H64.
-------------------------------------------- split.
--------------------------------------------- exact H48.
--------------------------------------------- split.
---------------------------------------------- exact H61.
---------------------------------------------- split.
----------------------------------------------- apply (@euclidean__tactics.nCol__notCol A D E H62).
----------------------------------------------- apply (@euclidean__tactics.nCol__notCol A D B H63).
-------------------------------------------- assert (* Cut *) (euclidean__defs.Cut A D E B F) as H65.
--------------------------------------------- split.
---------------------------------------------- exact H28.
---------------------------------------------- split.
----------------------------------------------- exact H26.
----------------------------------------------- split.
------------------------------------------------ apply (@euclidean__tactics.nCol__notCol A D E H62).
------------------------------------------------ apply (@euclidean__tactics.nCol__notCol A D B H63).
--------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col D E B)) as H66.
---------------------------------------------- intro H66.
assert (* Cut *) (euclidean__axioms.Col C B D) as H67.
----------------------------------------------- right.
right.
right.
right.
left.
exact H11.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.Col D B C) as H68.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H68.
------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H67).
------------------------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
exact H76.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col D B E) as H69.
------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E D B) /\ ((euclidean__axioms.Col E B D) /\ ((euclidean__axioms.Col B D E) /\ ((euclidean__axioms.Col D B E) /\ (euclidean__axioms.Col B E D))))) as H69.
-------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder D E B H66).
-------------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H76.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H70.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H70.
--------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H11).
--------------------------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H71.
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H71.
--------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H70).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B C E) as H72.
---------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col B C E).
-----------------------------------------------------intro H72.
apply (@euclidean__tactics.Col__nCol__False B C E H72).
------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 D B C E H68 H69 H71).

---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C A E) as H73.
----------------------------------------------------- right.
right.
right.
right.
left.
exact H18.
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E C A) as H74.
------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col A C E) /\ ((euclidean__axioms.Col A E C) /\ ((euclidean__axioms.Col E C A) /\ ((euclidean__axioms.Col C E A) /\ (euclidean__axioms.Col E A C))))) as H74.
------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C A E H73).
------------------------------------------------------- destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H79.
------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col E C B) as H75.
------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B E) /\ ((euclidean__axioms.Col C E B) /\ ((euclidean__axioms.Col E B C) /\ ((euclidean__axioms.Col B E C) /\ (euclidean__axioms.Col E C B))))) as H75.
-------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C E H72).
-------------------------------------------------------- destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
exact H83.
------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C E) as H76.
-------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq A E) /\ ((euclidean__axioms.neq C A) /\ (euclidean__axioms.neq C E))) as H76.
--------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C A E H18).
--------------------------------------------------------- destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
exact H80.
-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq E C) as H77.
--------------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C E H76).
--------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C A B) as H78.
---------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col C A B).
-----------------------------------------------------------intro H78.
apply (@euclidean__tactics.Col__nCol__False C A B H78).
------------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 E C A B H74 H75 H77).

---------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H79.
----------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C B A) /\ (euclidean__axioms.Col B A C))))) as H79.
------------------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder C A B H78).
------------------------------------------------------------ destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H82.
----------------------------------------------------------- apply (@H22).
------------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col D C E).
-------------------------------------------------------------intro H80.
apply (@euclidean__tactics.Col__nCol__False A B C H4 H79).

---------------------------------------------- assert (* Cut *) (G = F) as H67.
----------------------------------------------- apply (@lemma__twolines.lemma__twolines A D E B G F H64 H65).
------------------------------------------------apply (@euclidean__tactics.nCol__notCol D E B H66).

----------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong A F B F) as H68.
------------------------------------------------ apply (@eq__ind__r euclidean__axioms.Point F (fun G0 => (euclidean__axioms.BetS A G0 D) -> ((euclidean__axioms.Cong A G0 B F) -> ((euclidean__axioms.Cong G0 D F E) -> ((euclidean__axioms.Cong E F D G0) -> ((euclidean__axioms.Cong F B G0 A) -> ((euclidean__axioms.BetS D G0 A) -> ((euclidean__axioms.Cong F A G0 B) -> ((euclidean__axioms.Cong A F B G0) -> ((euclidean__axioms.Cong F D G0 E) -> ((euclidean__axioms.BetS B G0 E) -> ((euclidean__axioms.BetS E G0 B) -> ((euclidean__defs.Cut A D E B G0) -> (euclidean__axioms.Cong A F B F)))))))))))))) with (x := G).
-------------------------------------------------intro H68.
intro H69.
intro H70.
intro H71.
intro H72.
intro H73.
intro H74.
intro H75.
intro H76.
intro H77.
intro H78.
intro H79.
exact H75.

------------------------------------------------- exact H67.
------------------------------------------------- exact H48.
------------------------------------------------- exact H49.
------------------------------------------------- exact H50.
------------------------------------------------- exact H51.
------------------------------------------------- exact H52.
------------------------------------------------- exact H55.
------------------------------------------------- exact H56.
------------------------------------------------- exact H57.
------------------------------------------------- exact H59.
------------------------------------------------- exact H60.
------------------------------------------------- exact H61.
------------------------------------------------- exact H64.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Cong F A F B) as H69.
------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong F A F B) /\ ((euclidean__axioms.Cong F A B F) /\ (euclidean__axioms.Cong A F F B))) as H69.
-------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A F B F H68).
-------------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H70.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C M C M) as H70.
-------------------------------------------------- apply (@euclidean__axioms.cn__congruencereflexive C M).
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong M F M F) as H71.
--------------------------------------------------- apply (@euclidean__axioms.cn__congruencereflexive M F).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong M A M B) as H72.
---------------------------------------------------- apply (@lemma__interior5.lemma__interior5 C M F A C M F B H35 H35 H70 H71 H36 H69).
---------------------------------------------------- exists M.
split.
----------------------------------------------------- exact H34.
----------------------------------------------------- exact H72.
Qed.


(*|
####################################################
Using dependent types in Coq (safe ``nth`` function)
####################################################

:Link: https://stackoverflow.com/q/27637949
|*)

(*|
Question
********

I'm trying to learn Coq, but I find it hard to make the leap from what
I read in *Software Foundations and Certified Programming with
Dependent Types* to my own use cases.

In particular, I thought I'd try to make a verified version of the
``nth`` function on lists. I managed to write this:
|*)

Require Import Arith.
Require Import List.
Import ListNotations.

Lemma zltz : 0 < 0 -> False.
Proof.
  intros. contradict H. apply Lt.lt_irrefl.
Qed.

Lemma nltz : forall n : nat, n < 0 -> False.
Proof.
  intros. contradict H. apply Lt.lt_n_0.
Qed.

Lemma predecessor_proof : forall {X : Type} (n : nat) (x : X) (xs : list X),
    S n < length (x :: xs) -> n < length xs.
Proof.
  intros. simpl in H. apply Lt.lt_S_n. assumption.
Qed.

Fixpoint safe_nth {X : Type} (n : nat) (xs : list X) : n < length xs -> X :=
  match n, xs with
  | 0, [] => fun pf : 0 < length [] => match zltz pf with end
  | S n', [] => fun pf : S n' < length [] => match nltz (S n') pf with end
  | 0, x :: _ => fun _ => x
  | S n', x :: xs' => fun pf : S n' < length (x :: xs') =>
                        safe_nth n' xs' (predecessor_proof n' x xs' pf)
  end.

(*|
This works, but it raises two questions:

1. How would experienced Coq users write this? Are the three lemmas
   really necessary? Is this a use case for ``{ | }`` types?
2. How do I call this function from other code, i.e., how do I supply
   the required proofs?

I tried this:

.. code-block:: coq

    Require Import NPeano.
    Eval compute in
      if ltb 2 (length [1; 2; 3]) then safe_nth 2 [1; 2; 3] ??? else 0.

But of course this won't work until I figure out what to write for the
``???`` part. I tried putting ``2 < length [1; 2; 3]`` there but that
has type ``Prop`` rather than type ``2 < length [1; 2; 3]``. I could
write and prove a lemma of that specific type, and that works. But
what's the general solution?
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

I don't think there is a consensus on what the best way for doing this
sort of thing is.

I believe that usually Coq developments tend to favor indexed
inductive types for writing code like that. This is the solution
followed by the `vector library
<https://coq.inria.fr/distrib/current/stdlib/Coq.Vectors.Vector.html>`__
in the Coq distribution. There, you would define an indexed inductive
type for vectors and another one for bounded integers (called
``Vector.t`` and ``Fin.t`` in the standard library, respectively).
Some functions, such as ``nth``, are much simpler to write in this
style, since pattern matching on vectors and indices ends up doing a
little bit of reasoning for you when getting rid of contradictory
cases and doing recursive calls, for instance. The disadvantage is
that dependent pattern matching in Coq is not very intuitive, and
sometimes you have to write your functions in a weird way to get them
to work. Another problem with this approach is that one needs to
redefine many functions that work on lists to work on vectors.

Another solution is to define bounded integers as a dependent pair of
a ``nat`` and a proof that that index is bounded, which is essentially
what you going for when you mentioned ``{ | }`` types. This is the
approach followed by the `ssreflect
<http://ssr.msr-inria.inria.fr/~jenkins/current/Ssreflect.fintype.html>`__
library, for instance (look fot the ``ordinal`` type). To define a
safe ``nth`` function, what they do is to define a simple version that
takes a default element to return when the index is out of bounds, and
use the proof that ``n < length l`` to supply that default element
(have a look for instance at `tuple
<http://ssr.msr-inria.inria.fr/~jenkins/current/Ssreflect.tuple.html>`__
library of ssreflect, where they define length-indexed lists, and see
how they define ``tnth``). The advantage is that it is easier to
relate the more informative types and functions to the simpler
variants. The disadvantage is that some things become harder to
express directly: for instance, you can't do pattern-matching directly
on an ssreflect tuple.

Another point worth noting is that very often it is easier to work
with boolean properties instead of inductively defined ones, because
computation and simplification obviate the need for some lemmas. Thus,
when using a boolean version of ``<``, Coq doesn't make a difference
between a proof of ``0 < 0 = true`` and ``false = true``, or between a
proof of ``S n < length (x :: l) = true`` and a proof of ``n < length
l = true``, which means that you would be able to use those proofs
directly in your definition of ``nth`` without having to massage them
with auxiliary lemmas. The Coq standard library, unfortunately, tends
to favor inductively defined types over boolean computations in many
cases where they are not useful, such as for defining ``<``. The
`ssreflect <http://ssr.msr-inria.inria.fr/>`__ library, on the other
hand, makes much more use of boolean computations for defining
properties, making it more appropriate for this style of programming.
|*)

(*|
Answer (Perce Strop)
********************

``zltz`` has the same type as ``nltz 0``.
|*)

Check zltz.
Check nltz 0.

(*|
To use your function with ``2`` and ``[1; 2; 3]`` from within another
function, you can use ``lt_dec``.
|*)

Eval compute in match lt_dec 2 (length [1; 2; 3]) with
                | left pf => safe_nth 2 [1; 2; 3] pf
                | right _ => 0
                end.

(*|
If you extract ``lt_dec``, you'll find it's very similar to ``ltb``
after the proofs are erased. You don't need to use ``lt_dec`` if you
can build your proof from within the function where ``safe_nth`` is
called.

You can shorten your function a bit like this.
|*)

Fixpoint safe_nth' {X : Type} (xs : list X) (n : nat) : n < length xs -> X :=
  match xs, n with
  | [], _ => fun pf => match nltz n pf with end
  | x :: _, 0 => fun _ => x
  | x :: xs', S n' => fun pf => safe_nth' xs' n' (predecessor_proof n' x xs' pf)
  end.

(*|
I'm not sure what best practices are, but you get tidier extracted
code if you use ``sig``.

----

**Q:** Thanks for the explanation using ``lt_dec``, that was the piece
I was missing! And yes, I had seen the similarity between ``zltz`` and
``nltz`` but missed the equivalence...
|*)


Require Coq.Numbers.Cyclic.Int31.Int31.
Require Coq.Numbers.Natural.BigN.BigN.
Require Import ZArith.

Definition add31c' (n m: Int31.int31) : bool * Int31.int31 :=
 let npm := Int31.add31 n m in
   (negb (Z.eqb (Int31.phi npm) (Int31.phi n + Int31.phi m)), npm).

Definition sub31c' (n m: Int31.int31) : bool * Int31.int31 :=
 let npm := Int31.sub31 n m in
   (negb (Z.eqb (Int31.phi npm) (Int31.phi n - Int31.phi m)), npm).

(****
 In L1 or LambdaBoxMut, recognize the following functions and treat them
  opaquely (i.e., delete their function bodies, and let them be
 free variables with distinguished names):

  Int31.add31, Int31.add31c, Int31.add31carryc,
    Int31.iszero, and many others...

  and,    add31c', sub31c'  (* defined in this file *)

 Then, in translation to LambdaANF, replace these free variables as follows:
  where they occur in function-position,
    use  Eprim operators (primops);
  where they occur otherwise, use eta-expanded Eprim operators.

  We'll define the evaluation semantics of the Eprim operators
  w.r.t. the respective Coq functions.

****)

Module Bignum.
Import BigN.

SearchAbout (BigN.t -> Prop).

Definition maxint31 := sub31 0 1.
Definition maxint31b := BigN.N0 maxint31.

Inductive bignum :=
| BN_int: int31 -> bignum
| BN_big: forall i:BigN.t, BigN.lt maxint31b i -> bignum.

Definition t : Type := bignum.

Eval compute in BigN.of_pos (Pos.pow 2 32).

Fixpoint zn_last n (w: word BigN.w1 n) {struct n}: int31 :=
  match n  with
  | O =>
      fun w0 : word BigN.w1 O =>
      match w0 with
      | W0 => On
      | WW _ t1 => t1
      end
  | S n0 =>
      fun w0 : word BigN.w1 (S n0) =>
      match w0 with
      | W0 => On
      | WW _ w2 => zn_last n0 w2
      end
  end w.

Lemma w6_w1: forall n, word BigN.w6 (S n) = word BigN.w1 (6+n).
intros.
simpl.
rewrite !Nbasic.zn2z_word_comm.
reflexivity.
Qed.

Definition last_w6_plus (n : nat) (w : word BigN.w6 (S n)) : int31 :=
     zn_last (6 + n)
       (eq_rect (word BigN.w6 (S n)) (fun T : Type => T) w
          (word BigN.w1 (6 + n)) (w6_w1 n)).

Definition bign_to_int31 (a: BigN.t) : int31 :=
 match a with
 | BigN.N0 i => i
 | BigN.N1 w => zn_last O w
 | BigN.N2 w => zn_last 1 w
 | BigN.N3 w => zn_last 2 w
 | BigN.N4 w => zn_last 3 w
 | BigN.N5 w => zn_last 4 w
 | BigN.N6 w => zn_last 5 w
 | BigN.Nn n w => last_w6_plus n w
 end.

Lemma BigN_lt_dec: forall i j, {BigN.lt i j}+{~BigN.lt i j}.
Proof.
intros.
destruct (BigN.ltb i j) eqn:?; [left|right].
apply BigN.ltb_lt; auto.
apply BigN.ltb_nlt; auto.
Defined.

Definition normalize (a: BigN.t) :=
 match a with
 | BigN.N0 i => BN_int i
 | _ => match BigN_lt_dec maxint31b a with
            | left p => BN_big a p
            | right _ => BN_int (bign_to_int31 a)
            end
 end.

Definition add' (a b : bignum) : bignum :=
match a, b with
| BN_int i, BN_int j =>
     normalize (BigN.add (BigN.N0 i) (BigN.N0 j))
| BN_int i, BN_big j _ =>  normalize (BigN.add (BigN.N0 i) j)
| BN_big i _, BN_int j => normalize (BigN.add i (BigN.N0 j))
| BN_big i _, BN_big j _ => normalize (BigN.add i j)
end.

Definition add (a b : bignum) : bignum :=
match a, b with
| BN_int i, BN_int j =>
   match add31c' i j with
   | (false, k) => BN_int k
   | (true, _) => add' a b
   end
| _, _ => add' a b
end.

Definition sub' (a b : bignum) : bignum :=
match a, b with
| BN_int i, BN_int j =>
     normalize (BigN.sub (BigN.N0 i) (BigN.N0 j))
| BN_int i, BN_big j _ =>  normalize (BigN.sub (BigN.N0 i) j)
| BN_big i _, BN_int j => normalize (BigN.sub i (BigN.N0 j))
| BN_big i _, BN_big j _ => normalize (BigN.sub i j)
end.

Definition sub (a b : bignum) : bignum :=
match a, b with
| BN_int i, BN_int j =>
   match sub31c' i j with
   | (false, k) => BN_int k
   | (true, _) => sub' a b
   end
| _, _ => sub' a b
end.

Definition iszero (a: bignum) : bool :=
  match a with
  | BN_int i => iszero i
  | _ => false
  end.

Definition of_Z (n: Z) : bignum :=
 match n with
 | Zpos p => normalize (BigN.of_pos p)
 | Z0 => BN_int On
 | _ => BN_int On
 end.

Definition of_pos (n: positive) : bignum :=
  normalize (BigN.of_pos n).
Search (int31 -> nat).

Search (int31 -> nat).

Definition to_nat (a: bignum) : nat :=
 match a with
 | BN_int i => Z.to_nat (phi i)
 | BN_big i _ => Z.to_nat (BigN.to_Z i)
 end.

End Bignum.

(** Now, this is the code we'd like to optimize: *)

Definition add10 (x: Bignum.t) := Bignum.add x (Bignum.of_pos 10).

Eval compute in  add10 (Bignum.of_pos 5).
Eval compute in  add10 (Bignum.of_pos 2147483636).
Eval compute in  add10 (Bignum.of_pos 2147483646).

Require Import Recdef.

Lemma bignum_decr_less:
 forall n : Bignum.t,
 Bignum.iszero n = false ->
 Bignum.to_nat (Bignum.sub n (Bignum.of_Z 1)) < Bignum.to_nat n.
Admitted.

Function triang (n: Bignum.t) {measure Bignum.to_nat n}: Bignum.t :=
  if Bignum.iszero n
  then n
  else Bignum.add n (triang (Bignum.sub n (Bignum.of_Z 1))).
Proof.
exact bignum_decr_less.
Defined.

Eval compute in triang (Bignum.of_Z 3000).


(** * syntax: syntactic model for types structures (monoid operations) *)

Require Export positives comparisons.
Require Import Eqdep.
Require Import monoid.
Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Free syntactic model *)

Section s.

Notation I := positive.
Variable A : Set.
(* [A=positive] for normalisation tactics
   [A=positive+lsyntax.expr (ord n)] for KAT proofs
   [A=positive+lsyntax.expr positive] for KAT computations (not yet) *)
Variables s t: A -> I.

(** residuated Kleene allegory expressions over a set [A] of
   variables, the variables being typed according to the functions [s]
   (source) and [t] (target).

   The indexing types ([I]) are fixed to be [positive] numbers:
   - this is convenient and efficient in practice, for reification
   - we need a decidable type to get the untyping theorems without axioms

   Note that we include constructors for flat operations
   (cup,cap,bot,top,neg): it is not convenient to reuse [lsyntax.expr]
   here since we would need to restrict the alphabet under those nodes to
   something like [A_(n,m) = { a: A / s a = n /\ t a = m }].
*)

(* TOTHINK: add a phantom/strong dependency on [l] on the expr type ? *)
Inductive expr: I -> I -> Type :=
| e_zer: forall n m, expr n m
| e_top: forall n m, expr n m
| e_one: forall n, expr n n
| e_pls: forall n m, expr n m -> expr n m -> expr n m
| e_cap: forall n m, expr n m -> expr n m -> expr n m
| e_neg: forall n m, expr n m -> expr n m
(* | e_not: forall n, expr n n -> expr n n *)
| e_dot: forall n m p, expr n m -> expr m p -> expr n p
| e_itr: forall n, expr n n -> expr n n
| e_str: forall n, expr n n -> expr n n
| e_cnv: forall n m, expr n m -> expr m n
| e_ldv: forall n m p, expr n m -> expr n p -> expr m p
| e_rdv: forall n m p, expr m n -> expr p n -> expr p m
| e_var: forall a, expr (s a) (t a).

(** level of an expression: the set of operations that appear in that expression *)
Fixpoint e_level n m (x: expr n m): level :=
  match x with
    | e_zer _ _ => BOT
    | e_top _ _ => TOP
    | e_one _ => MIN
    | e_pls _ _ x y => CUP + e_level x + e_level y
    | e_cap _ _ x y => CAP + e_level x + e_level y
    | e_neg _ _ x => BL + e_level x
      (* negation is ill-defined without the other Boolean operations,
         whence the [BL] rather than [NEG] *)
    | e_dot _ _ _ x y => e_level x + e_level y
    | e_itr _ x => STR + e_level x
    | e_str _ x => STR + e_level x
    | e_cnv _ _ x => CNV + e_level x
    | e_ldv _ _ _ x y
    | e_rdv _ _ _ x y => DIV + e_level x + e_level y
    | e_var a => MIN
  end%level.

Section e.
Context {X: ops} {f': I -> ob X}.
Variable f: forall a, X (f' (s a)) (f' (t a)).

(** interpretation of an expression into an arbitray structure, given
   an assignation [f] of the variables (and a interpretation function
   [f'] for the types) *)

Fixpoint eval n m (x: expr n m): X (f' n) (f' m) :=
  match x with
    | e_zer _ _ => 0
    | e_top _ _ => top
    | e_one _ => 1
    | e_pls _ _ x y => eval x + eval y
    | e_cap _ _ x y => eval x ∩ eval y
    | e_neg _ _ x => ! eval x
    (* | e_not _ x => eval x ^~ *)
    | e_dot _ _ _ x y => eval x ⋅ eval y
    | e_itr _ x => (eval x)^+
    | e_str _ x => (eval x)^*
    | e_cnv _ _ x => (eval x)°
    | e_ldv _ _ _ x y => eval x -o eval y
    | e_rdv _ _ _ x y => eval y o- eval x
    | e_var a => f a
  end.
End e.

Section l.
Variable l: level.

(** * (In)equality of syntactic expressions.

   Like in [lsyntax], we use an impredicative encoding to define
   (in)equality in the free syntactic model, and we parametrise all
   definition with the level [l] at which we want to interpret the
   given expressions. *)

Definition e_leq n m (x y: expr n m) :=
  forall X (L:laws l X) f' (f: forall a, X (f' (s a)) (f' (t a))), eval f x ≦ eval f y.
Definition e_weq n m (x y: expr n m) :=
  forall X (L:laws l X) f' (f: forall a, X (f' (s a)) (f' (t a))), eval f x ≡ eval f y.

(** by packing syntactic expressions and the above predicates into a
   canonical structure for flat operations, and another one for the
   other operations, we get all notations for free *)

Canonical Structure expr_lattice_ops n m := {|
  car := expr n m;
  leq := @e_leq n m;
  weq := @e_weq n m;
  cup := @e_pls n m;
  cap := @e_cap n m;
  neg := @e_neg n m;
  bot := @e_zer n m;
  top := @e_top n m
|}.

Canonical Structure expr_ops := {|
  ob  := I;
  mor := expr_lattice_ops;
  dot := e_dot;
  one := e_one;
  itr := e_itr;
  str := e_str;
  cnv := e_cnv;
  ldv := e_ldv;
  rdv := e_rdv
|}.

(** we easily show that we get a model so that we immediately benefit
   from all lemmas about the various structures *)

Global Instance expr_lattice_laws n m: lattice.laws l (expr_lattice_ops n m).
Proof.
  constructor; try right. constructor.
   intros x X L u f. reflexivity.
   intros x y z H H' X L u f. transitivity (eval f y); auto.
   intros x y. split.
    intro H. split; intros X L u f. now apply weq_leq, H. now apply weq_geq, H.
    intros [H H'] X L u f. apply antisym; auto.
   intros Hl x y z. split.
    intro H. split; intros X L u f; specialize (H X L u f); simpl in H; hlattice.
    intros [H H'] X L u f. simpl. apply cup_spec; auto.
   intros Hl x y z. split.
    intro H. split; intros X L u f; specialize (H X L u f); simpl in H; hlattice.
    intros [H H'] X L u f. simpl. apply cap_spec; auto.
   intros x X L u f. apply leq_bx.
   intros x X L u f. apply leq_xt.
   intros Hl x y z X L u f. apply cupcap_.
   intros Hl x X L u f. apply capneg.
   intros Hl x X L u f. apply cupneg.
Qed.

Global Instance expr_laws: laws l expr_ops.
Proof.
  constructor; repeat right; repeat intro; simpl.
   apply expr_lattice_laws.
   apply dotA.
   apply dot1x.
   apply dotx1.
   apply dot_leq; auto.
   now rewrite dotplsx.
   now rewrite dotxpls.
   now rewrite dot0x.
   now rewrite dotx0.
   apply cnvdot_.
   apply cnv_invol.
   apply cnv_leq. now refine (H0 _ _ _ _).
   apply cnv_ext.
   apply str_refl.
   apply str_cons.
   apply str_ind_l. now refine (H0 _ _ _ _).
   apply str_ind_r. now refine (H0 _ _ _ _).
   apply itr_str_l.
   apply capdotx.
   split; intros E X L f' f; intros; simpl; apply ldv_spec, (E X L f' f).
   split; intros E X L f' f; intros; simpl; apply rdv_spec, (E X L f' f).
Qed.

End l.

(** * Testing for particular constants *)

Definition is_zer n m (x: expr n m) :=
  match x with e_zer _ _ => true | _ => false end.

Definition is_top n m (x: expr n m) :=
  match x with e_top _ _ => true | _ => false end.

Inductive is_case n m (k x: expr n m): expr n m -> bool -> Prop :=
| is_case_true: x=k -> is_case k x k true
| is_case_false: x<>k -> is_case k x x false.

Lemma is_zer_spec n m (x: expr n m): is_case (e_zer n m) x x (is_zer x).
Proof. destruct x; constructor; discriminate || reflexivity. Qed.

Lemma is_top_spec n m (x: expr n m): is_case (e_top n m) x x (is_top x).
Proof. destruct x; constructor; discriminate || reflexivity. Qed.

(** casting the type of an expression *)
Definition cast n m n' m' (Hn: n=n') (Hm: m=m') (x: expr n m): expr n' m' :=
  eq_rect n (fun n => expr n m') (eq_rect m (expr n) x _ Hm) _ Hn.

End s.
Arguments e_var [A s t] a.
Arguments e_one [A s t] n.
Arguments e_zer [A s t] n m.
Arguments e_top [A s t] n m.

Declare Scope ast_scope.
Bind Scope ast_scope with expr.
Delimit Scope ast_scope with ast.

(** additional notations, to specify explicitly at which level
   expressions are considered, or to work directly with the
   bare constructors (by opposition with the encapsulated ones,
   through monoid.ops) *)

Notation expr_ l s t n m := (expr_ops s t l n m).
Notation "x <==_[ l ] y" := (@leq (expr_ops _ _ l _ _) x y) (at level 79): ra_scope.
Notation "x ==_[ l ] y" := (@weq (expr_ops _ _ l _ _) x y) (at level 79): ra_scope.

Infix "+" := e_pls: ast_scope.
Infix "∩" := e_cap: ast_scope.
Infix "⋅" := e_dot: ast_scope.
Notation "1" := (e_one _): ast_scope.
Notation "0" := (e_zer _ _): ast_scope.
Notation top := (e_top _ _).
Notation "x ^+" := (e_itr x): ast_scope.
Notation "x °"  := (e_cnv x): ast_scope.
Notation "x ^*" := (e_str x): ast_scope.
Notation "! x"  := (e_neg x): ast_scope.
Notation "x -o y" := (e_ldv x y) (right associativity, at level 60): ast_scope.
Notation "y o- x" := (e_rdv x y) (left associativity, at level 61): ast_scope.

(** * weakening (in)equations *)
(** any equation holding at some level holds at all higher levels  *)

Lemma e_leq_weaken {h k} {Hl: h ≪ k} A s t n m (x y: @expr A s t n m):
  x <==_[h] y -> x <==_[k] y.
Proof. intros H X L f' f. eapply @H, lower_laws. Qed.

Lemma e_weq_weaken {h k} {Hl: h ≪ k} A s t n m (x y: @expr A s t n m):
  x ==_[h] y -> x ==_[k] y.
Proof. intros H X L f' f. eapply @H, lower_laws. Qed.

(** * comparing expressions syntactically  *)
Section expr_cmp.

Notation I := positive.
Context {A : cmpType}.
Variables s t: A -> I.
Notation expr := (expr s t).

(** we need to generalise the comparison function to expressions of
   distinct types because of Coq's dependent types *)
Fixpoint expr_compare n m (x: expr n m) p q (y: expr p q) :=
  match x,y with
    | e_zer _ _, e_zer _ _
    | e_top _ _, e_top _ _
    | e_one _, e_one _ => Eq
    | e_var a, e_var b => cmp a b
    | e_pls _ _ x x', e_pls _ _ y y'
    | e_cap _ _ x x', e_cap _ _ y y' =>
         lex (expr_compare x y) (expr_compare x' y')
    | e_dot _ u _ x x', e_dot _ v _ y y'
    | e_ldv u _ _ x x', e_ldv v _ _ y y'
    | e_rdv u _ _ x x', e_rdv v _ _ y y' =>
         lex (cmp u v) (lex (expr_compare x y) (expr_compare x' y'))
    | e_neg _ _ x, e_neg _ _ y
    | e_itr _ x, e_itr _ y
    | e_str _ x, e_str _ y
    | e_cnv _ _ x, e_cnv _ _ y => expr_compare x y
    | e_zer _ _, _       => Lt
    | _, e_zer _ _       => Gt
    | e_one _, _         => Lt
    | _, e_one _         => Gt
    | e_top _ _, _       => Lt
    | _, e_top _ _       => Gt
    | e_var _, _         => Lt
    | _, e_var _         => Gt
    | e_itr _ _, _       => Lt
    | _, e_itr _ _       => Gt
    | e_str _ _, _       => Lt
    | _, e_str _ _       => Gt
    | e_cnv _ _ _, _     => Lt
    | _, e_cnv _ _ _     => Gt
    | e_ldv _ _ _ _ _, _ => Lt
    | _, e_ldv _ _ _ _ _ => Gt
    | e_rdv _ _ _ _ _, _ => Lt
    | _, e_rdv _ _ _ _ _ => Gt
    | e_pls _ _ _ _, _   => Lt
    | _, e_pls _ _ _ _   => Gt
    | e_cap _ _ _ _, _   => Lt
    | _, e_cap _ _ _ _   => Gt
    | e_neg _ _ _, _     => Lt
    | _, e_neg _ _ _     => Gt
  end.

(** since [A] is decidable, [cast] provably acts as an identity  *)
Lemma cast_eq n m (x: expr n m) (H: n=n) (H': m=m): cast H H' x = x.
Proof. unfold cast. now rewrite 2 cmp_eq_rect_eq. Qed.

(** auxiliary lemma for [expr_compare_spec] below, using dependent equality *)
Lemma expr_compare_eq_dep n m (x: expr n m): forall p q (y: expr p q),
  expr_compare x y = Eq -> n=p -> m=q ->
  eq_dep (I*I) (fun x => expr (fst x) (snd x)) (n,m) x (p,q) y.
Proof.
  induction x; intros ? ? z C; destruct z; try discriminate C;
    try (intros <- <- || intros <- _); try reflexivity;
     simpl expr_compare in C.

   apply compare_lex_eq in C as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply compare_lex_eq in C as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply cmp_eq in C. subst. reflexivity.
Qed.

Lemma expr_compare_eq n m (x y: expr n m): x=y -> expr_compare x y = Eq.
Proof.
  intros <-. induction x; simpl expr_compare; trivial;
  rewrite ?compare_lex_eq, ?cmp_refl; tauto.
Qed.

(** final specification of the comparison function *)
Lemma expr_compare_spec n m (x y: expr n m): compare_spec (x=y) (expr_compare x y).
Proof.
  generalize (fun H => expr_compare_eq_dep x y H eq_refl eq_refl) as H.
  generalize (@expr_compare_eq _ _ x y) as H'.
  case (expr_compare x y); intros H' H; constructor.
   now apply cmp_eq_dep_eq in H.
   intro E. now discriminate H'.
   intro E. now discriminate H'.
Qed.

(** packaging as a [cmpType]  *)
Definition expr_compare_ n m (x y: expr n m) := expr_compare x y.
Canonical Structure cmp_expr n m := mk_simple_cmp (@expr_compare_ n m) (@expr_compare_spec n m).

End expr_cmp.

(** * Packages for typed reification *)

(** according to the interpretation function [eval], (typed)
   reification has to provide a set [A] for indexing variables, and four maps:
   - [f': I -> ob X], to interpret types as written in the expressions ([I=positive])
   - [s] and [t]: A -> I, to specify the source and target types of each variable
   - [f: forall a: A, expr s t (s a) (t a)], to interpret each variable

   [A] is also fixed to be [positive], so that we can use simple and
   efficient positive maps, but the fact that [f] has a dependent type
   is not convenient.

   This is why we introduce the additionnal layer, to ease the
   definition of such maps: thanks to the definitions below, it
   suffices to provide the map [f'], and a map [f: A -> Pack X f']. *)

Record Pack (X: ops) (f': positive -> ob X) := pack {
  src: positive;
  tgt: positive;
  val: X (f' src) (f' tgt)
}.

Definition packed_eval (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') :=
  eval (fun a => val (f a)) : forall n m, expr _ _ n m -> X (f' n) (f' m) .

(** these projections are used to build the reified expressions *)
Definition src_ (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') a := src (f a).
Definition tgt_ (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') a := tgt (f a).

(** loading ML reification module *)
Declare ML Module "coq-relation-algebra.reification".


Require Import HoTT.
Require Import polynomial.

Section Endpoints.
  (* The definition of a HIT signature and a HIT for the signature. *)

  (* An endpoint is also called a "constructor term". It is used in
the HIT signature to describe the endpoints of path constructors. *)

  (* Endpoints are parameterized by a family of polynomials which will
be specialized to the point constructors in the definition of HITS.
   *)
  Variable (I : Type)
           (C : I -> polynomial).

  Inductive endpoint : polynomial -> polynomial -> Type :=
  | endpoint_var :
      forall {P : polynomial},
        endpoint P P
  | endpoint_const :
      forall {P : polynomial} {T : Type},
        T -> endpoint P (poly_const T)
  | endpoint_constr :
      forall {P : polynomial} (i : I),
        endpoint P (C i) -> endpoint P poly_var
  | endpoint_fst :
      forall {P Q R : polynomial},
        endpoint P (poly_times Q R) -> endpoint P Q
  | endpoint_snd :
      forall {P Q R : polynomial},
        endpoint P (poly_times Q R) -> endpoint P R
  | endpoint_pair :
      forall {P Q R : polynomial},
        endpoint P Q -> endpoint P R -> endpoint P (poly_times Q R)
  | endpoint_inl :
      forall {P Q R : polynomial},
        endpoint P Q -> endpoint P (poly_plus Q R)
  | endpoint_inr :
      forall {P Q R : polynomial},
        endpoint P R -> endpoint P (poly_plus Q R).

  (* Endpoint acting on data for point constructors. *)
  Fixpoint endpoint_act
           {P Q : polynomial}
           {X : Type}
           (c : forall (i : I), poly_act (C i) X -> X)
           (e : endpoint P Q) (* the endpoint *)
    : poly_act P X -> poly_act Q X
    := match e with
       | endpoint_var _ => idmap
       | endpoint_const _ _ t => fun _ => t
       | endpoint_constr _ i e => fun u => c i (endpoint_act c e u)
       | endpoint_fst _ _ _ e => fun u => fst(endpoint_act c e u)
       | endpoint_snd _ _ _ e => fun u => snd(endpoint_act c e u)
       | endpoint_pair _ _ _ e1 e2 => fun u => (endpoint_act c e1 u, endpoint_act c e2 u)
       | endpoint_inl _ _ _ e => fun u => inl(endpoint_act c e u)
       | endpoint_inr _ _ _ e => fun u => inr(endpoint_act c e u)
       end.

  Fixpoint endpoint_act_compute
           {P Q : polynomial}
           {X Y : Type}
           (c : forall (i : I), poly_act (C i) X -> X)
           (c' : forall (i : I), poly_act (C i) Y -> Y)
           (e : endpoint P Q)
           (h : X -> Y)
           (H : forall i z, c' i (poly_map (C i) h z) = h(c i z))
    : forall (x : poly_act P X),
      endpoint_act c' e (poly_map P h x) = poly_map Q h (endpoint_act c e x)
    := match e with
       | endpoint_var _ =>
         fun _ => reflexivity _
       | endpoint_const _ _ t =>
         fun _ => reflexivity t
       | endpoint_constr _ i e =>
         fun x =>
           ap (c' i) (endpoint_act_compute c c' e h H x) @ H i _
       | endpoint_fst _ _ _ e =>
         fun x =>
           ap fst (endpoint_act_compute c c' e h H x)
       | endpoint_snd _ _ _ e =>
         fun x =>
           ap snd (endpoint_act_compute c c' e h H x)
       | endpoint_pair _ _ _ e₁ e₂ =>
         fun x => path_prod'
                    (endpoint_act_compute c c' e₁ h H x)
                    (endpoint_act_compute c c' e₂ h H x)
       | endpoint_inl _ _ _ e =>
         fun x =>
           ap inl (endpoint_act_compute c c' e h H x)
       | endpoint_inr _ _ _ e =>
         fun x =>
           ap inr (endpoint_act_compute c c' e h H x)
       end.

  Variable (A : Type)
           (F : A -> Type)
           (c : forall (i : I), poly_act (C i) A -> A)
           (f : forall (i : I) (u : poly_act (C i) A), poly_fam (C i) F u -> F (c i u)).

  (* The dependent action of an endpoint, this is used for
   "lifting" the path constructors in the elimination principle. *)
  Fixpoint endpoint_dact
           {P Q : polynomial}
           (e : endpoint P Q)
    : forall (x : poly_act P A), poly_fam P F x -> poly_fam Q F (endpoint_act c e x)
    := match e with
       | endpoint_var _ => fun _ h => h
       | endpoint_const _ _ t => fun _ _ => t
       | endpoint_constr _ i u => fun x h => f i (endpoint_act c u x) (endpoint_dact u x h)
       | endpoint_fst p p0 p1 e => fun x h => fst (@endpoint_dact p (poly_times p0 p1) e x h)
       | endpoint_snd p p0 p1 e => fun x h => snd (@endpoint_dact p (poly_times p0 p1) e x h)
       | endpoint_pair _ _ _ e1 e2 => fun x h => (endpoint_dact e1 x h, endpoint_dact e2 x h)
       | endpoint_inl p p0 _ e => fun x h => @endpoint_dact p p0 e x h
       | endpoint_inr p _ p1 e => fun x h => @endpoint_dact p p1 e x h
       end.

  (* If [h] commutes with constructors, then it commutes with all endpoints. *)
  Fixpoint endpoint_dact_compute
           {P Q : polynomial}
           (e : endpoint P Q)
    : forall (x : poly_act P A)
             (h : forall x, F x)
             (H : forall i u, h (c i u) = f i u (poly_dmap (C i) h u)),
      endpoint_dact e x (poly_dmap P h x) = poly_dmap Q h (endpoint_act c e x)
    := match e with
       | endpoint_var _ => fun _ _ _ => reflexivity _
       | endpoint_const _ _ t => fun _ _ _ => reflexivity t
       | endpoint_constr _ i e' =>
         fun x h H => let u := (endpoint_act c e' x) in
                      ap (f i u) (endpoint_dact_compute e' x h H) @ (H i u)^
       | endpoint_fst _ _ _ e' =>
         fun x h H =>
           ap fst (endpoint_dact_compute e' x h H)
       | endpoint_snd _ _ _ e' =>
         fun x h H =>
           ap snd (endpoint_dact_compute e' x h H)
       | endpoint_pair _ _ _ e1 e2 =>
         fun x h H =>
           path_prod'
             (endpoint_dact_compute e1 x h H)
             (endpoint_dact_compute e2 x h H)
       | endpoint_inl _ _ _ e' => endpoint_dact_compute e'
       | endpoint_inr _ _ _ e' => endpoint_dact_compute e'
       end.

  (* A general HIT might have an arbitrary number of endpoints and therefore an arbitrarily
   nested point constructors. Our construction of a HIT presumes that there is a bound to
   the nesting. We define here what it means for an endpoint to have such a bound. *)
  Inductive endpoint_rank : forall {P Q : polynomial}, endpoint P Q -> nat -> Type :=
  | rank_var :
      forall {P : polynomial} (n : nat),
        endpoint_rank (@endpoint_var P) n
  | rank_const :
      forall {P : polynomial} {T : Type} (t : T) (n : nat),
        endpoint_rank (@endpoint_const P _ t) n
  | rank_constr :
      forall {P : polynomial} (i : I) (n : nat) (e : endpoint P (C i)),
        endpoint_rank e n -> endpoint_rank (endpoint_constr i e) (S n)
  | rank_fst :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P (poly_times Q R)),
        endpoint_rank e n -> endpoint_rank (endpoint_fst e) n
  | rank_snd :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P (poly_times Q R)),
        endpoint_rank e n -> endpoint_rank (endpoint_snd e) n
  | rank_inl :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P Q),
        endpoint_rank e n -> endpoint_rank (@endpoint_inl _ _ R e) n
  | rank_inr :
      forall {P Q R : polynomial} (n : nat) (e : endpoint P R),
        endpoint_rank e n -> endpoint_rank (@endpoint_inr _ Q _ e) n.
End Endpoints.

Arguments endpoint {_} _ _ _.
Arguments endpoint_var {_ _} {_}.
Arguments endpoint_const {_ _} {_} {_} _.
Arguments endpoint_constr {_ _} {_} _ _ .
Arguments endpoint_fst {_ _} {_ _ _} _.
Arguments endpoint_snd {_ _} {_ _ _} _.
Arguments endpoint_pair {_ _} {_ _ _} _ _.
Arguments endpoint_inl {_ _} {_ _ _} _.
Arguments endpoint_inr {_ _} {_ _ _} _.

Arguments endpoint_act {I C P Q X} _ _ _.
Arguments endpoint_dact {I C A F} c _ {P Q} _ _ _.
Arguments endpoint_act_compute {_ _ _ _ _ _} _ _ _ _ _ _.
Arguments endpoint_dact_compute {_ _ _} _ _ _ {P Q} _ _ _ _.

Arguments endpoint_rank {_} _ {_ _} _ _.

Section endpoint_const.
  Variable (I : Type) (C : I -> polynomial)
           (A : Type) (B : Type)
           (c : forall i : I, poly_act (C i) A -> A).

  Definition endpoint_dact_nondep
             (f : forall i (u : poly_act (C i) A), poly_fam (C i) (fun _ => B) u -> B)
             {P Q : polynomial}
             (e : endpoint C P Q)
             (x : poly_act P A) (h : poly_fam P (fun _ => B) x)
    := @endpoint_dact I C A (fun _ => B) c f P Q e x h.

  Variable (f : forall i, poly_act (C i) B -> B).

  Definition endpoint_dact_rec
             {P Q : polynomial}
             (e : endpoint C P Q)
             (x : poly_act P A) (h : poly_fam P (fun _ => B) x)
    := @endpoint_dact I C A (fun _ => B) c (fun i _ u => f i (fam_const _ u)) P Q e x h.

  Fixpoint endpoint_dact_const
           {P Q : polynomial}
           (e : endpoint C P Q)
    : forall (x : poly_act P A) (h : poly_fam P (fun _ => B) x),
      fam_const _ (@endpoint_dact I C A _ c (fun i _ u => f i (fam_const _ u)) P Q e x h)
      =
      @endpoint_act I C P Q B f e (fam_const _ h)
    := match e with
       | endpoint_var _ => fun _ _ =>  reflexivity _
       | endpoint_const _ _ t => fun _ _ => reflexivity t
       | endpoint_constr _ i e =>
         fun x h =>
           ap (f i) (endpoint_dact_const e x h)
       | endpoint_fst _ _ _ e =>
         fun x h =>
           ap fst (endpoint_dact_const e x h)
       | endpoint_snd _ _ _ e =>
         fun x h =>
           ap snd (endpoint_dact_const e x h)
       | endpoint_pair _ _ _ e₁ e₂ =>
         fun x h =>
           path_prod' (endpoint_dact_const e₁ x h) (endpoint_dact_const e₂ x h)
       | endpoint_inl _ _ _ e =>
         fun x h =>
           ap inl (endpoint_dact_const e x h)
       | endpoint_inr _ _ _ e =>
         fun x h =>
           ap inr (endpoint_dact_const e x h)
       end.
End endpoint_const.

Arguments endpoint_dact_nondep {I C A B} c f {P Q}.
Arguments endpoint_dact_rec {I C A B} c f {P Q}.
Arguments endpoint_dact_const {I C A B} c f {P Q}.


(*
 - Polynomial codes
 - Action of polynomials on the universe
 - Path endpoints
 - Interpretation of path endpoints as functions
 - Homotopy endpoint type
 - Interpretation of homotopy endpoints as paths
 - Signature for higher inductive types
From 'GrpdHITs/code/signature/hit_signature.v'
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

(** Type of polynomials **)
Inductive poly_code : UU :=
| C : UU → poly_code
| Id : poly_code
| plus : poly_code → poly_code → poly_code
| times : poly_code → poly_code → poly_code.

Notation "P + Q" := (plus P Q).
Notation "P * Q" := (times P Q).

(** Action of polynomials on the universe *)
Definition act
           (P : poly_code)
           (A : UU)
  : UU.
Proof.
  induction P as [X | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - exact X.
  - exact A.
  - exact (IHP₁ ⨿ IHP₂).
  - exact (IHP₁ × IHP₂).
Defined.

(** Type of endpoints **)
Inductive endpoint (A : poly_code) : poly_code → poly_code → UU :=
(** endpoints for identity and composition *)
| id_e : ∏ (P : poly_code), endpoint A P P
| comp : ∏ (P Q R : poly_code), endpoint A P Q → endpoint A Q R → endpoint A P R
(** endpoints for sums *)
| ι₁ : ∏ (P Q : poly_code), endpoint A P (P + Q)
| ι₂ : ∏ (P Q : poly_code), endpoint A Q (P + Q)
(** endpoints for products *)
| π₁ : ∏ (P Q : poly_code), endpoint A (P * Q) P
| π₂ : ∏ (P Q : poly_code), endpoint A (P * Q) Q
| pair : ∏ (P Q R : poly_code),
    endpoint A P Q -> endpoint A P R → endpoint A P (Q * R)
(** endpoints for constant *)
| c : ∏ (P : poly_code) (X : UU), X → endpoint A P (C X)
| fmap : ∏ {X Y : UU} (f : X → Y), endpoint A (C X) (C Y)
(** constructor *)
| constr : endpoint A A Id.

Arguments id {_} _.
Arguments comp {A} {P} {Q} {R} _ _.
Arguments ι₁ {_} P Q.
Arguments ι₂ {_} P Q.
Arguments π₁ {_} P Q.
Arguments π₂ {_} P Q.
Arguments pair {A} {P} {Q} {R} _ _.
Arguments c {_} P {_} _.
Arguments fmap {_} {X Y} f.
Arguments constr {_}.

(** Endpoints induce functions **)
Definition sem_endpoint_UU
           {A P Q : poly_code}
           (e : endpoint A P Q)
           {X : UU}
           (c : act A X → X)
  : act P X → act Q X.
Proof.
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q
                  | P Q | P Q | P Q R e₁ IHe₁ e₂ IHe₂
                  | P T t | C₁ C₂ f | ].
  - (* Identity *)
    exact (λ x, x).
  - (* Composition *)
    exact (λ x, IHe₂ (IHe₁ x)).
  - (* Left inclusion *)
    exact inl.
  - (* Right inclusion *)
    exact inr.
  - (* Left projection *)
    exact pr1.
  - (* Right projection *)
    exact pr2.
  - (* Pairing *)
    exact (λ x, IHe₁ x ,, IHe₂ x).
  - (* Constant *)
    exact (λ _, t).
  - (* Constant map *)
    exact f.
  - (* Constructor *)
    exact c.
Defined.

(**
Homotopy endpoints
Here:
- `A` is arguments of point constructor
- `I` is index for path constructors
- `S` is arguments for path constructors
- `l` and `r` are the left and right endpoint of the path constructors
- `R` is the point argument
- `T` is the path argument target
 *)
Inductive homot_endpoint
          {A : poly_code}
          {I : UU}
          {S : I → poly_code}
          (l : ∏ (j : I), endpoint A (S j) Id)
          (r : ∏ (j : I), endpoint A (S j) Id)
          {R : poly_code}
          {T : poly_code}
          (a b : endpoint A R T)
  : ∏ {W : poly_code},
    endpoint A R W → endpoint A R W → UU
  :=
  (** operations on 2-cells *)
  | refl_e : ∏ (P : poly_code)
               (e : endpoint A R P),
             homot_endpoint l r a b e e
  | inv_e : ∏ (P : poly_code)
              (e₁ e₂ : endpoint A R P),
            homot_endpoint l r a b e₁ e₂
            →
            homot_endpoint l r a b e₂ e₁
  | trans_e : ∏ (P : poly_code)
                (e₁ e₂ e₃ : endpoint A R P),
              homot_endpoint l r a b e₁ e₂
              →
              homot_endpoint l r a b e₂ e₃
              →
              homot_endpoint l r a b e₁ e₃
  | ap_e : ∏ (P₁ P₂ : poly_code)
             (e₁ e₂ : endpoint A R P₁)
             (e : endpoint A P₁ P₂),
           homot_endpoint
             l r a b
             e₁ e₂
           →
           homot_endpoint
             l r a b
             (comp e₁ e) (comp e₂ e)
  (** Associator and unitors *)
  | comp_assoc : ∏ (P₁ P₂ P₃ : poly_code)
                   (e₁ : endpoint A R P₁)
                   (e₂ : endpoint A P₁ P₂)
                   (e₃ : endpoint A P₂ P₃),
                 homot_endpoint
                   l r a b
                   (comp e₁ (comp e₂ e₃))
                   (comp (comp e₁ e₂) e₃)
  | comp_id_l : ∏ (P : poly_code)
                  (e : endpoint A R P),
                homot_endpoint
                  l r a b
                  (comp (id_e _ _) e)
                  e
  | comp_id_r : ∏ (P : poly_code)
                  (e : endpoint A R P),
                homot_endpoint
                  l r a b
                  (comp e (id_e _ _))
                  e
  (** Beta rules for product *)
  | pair_π₁ : ∏ (P₁ P₂ : poly_code)
                (e₁ : endpoint A R P₁)
                (e₂ : endpoint A R P₂),
              homot_endpoint
                l r a b
                (comp (pair e₁ e₂) (π₁ _ _))
                e₁
  | pair_π₂ : ∏ (P₁ P₂ : poly_code)
                (e₁ : endpoint A R P₁)
                (e₂ : endpoint A R P₂),
              homot_endpoint
                l r a b
                (comp (pair e₁ e₂) (π₂ _ _))
                e₂
  | path_pair : ∏ (P₁ P₂ : poly_code)
                  (e₁ e₂ : endpoint A R P₁)
                  (e₃ e₄ : endpoint A R P₂),
                homot_endpoint l r a b e₁ e₂
                →
                homot_endpoint l r a b e₃ e₄
                →
                homot_endpoint
                  l r a b
                  (pair e₁ e₃) (pair e₂ e₄)
  (** In categories, this one follows from uniqueness *)
  | comp_pair : ∏ {P₁ P₂ P₃ : poly_code}
                  (e₁ : endpoint A R P₁)
                  (e₂ : endpoint A P₁ P₂)
                  (e₃ : endpoint A P₁ P₃),
                homot_endpoint
                  l r
                  a b
                  (comp e₁ (pair e₂ e₃))
                  (pair (comp e₁ e₂) (comp e₁ e₃))
  (** Rules for constant *)
  | comp_constant : ∏ (X : UU)
                      (x : X)
                      (P : poly_code)
                      (e : endpoint A R P),
                    homot_endpoint
                      l r a b
                      (comp e (c P x)) (c R x)
  (** Path constructor and path argument *)
  | path_constr : ∏ (j : I)
                    (e : endpoint A R (S j)),
                  homot_endpoint
                    l r a b
                    (comp e (l j))
                    (comp e (r j))
  | path_arg : homot_endpoint l r a b a b.

Arguments refl_e {_ _ _ _ _ _ _ _ _ _}.
Arguments inv_e {_ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments trans_e {_ _ _ _ _ _ _ _ _ _ _ _ _} _ _.
Arguments ap_e {_ _ _ _ _ _ _ _ _ _ _ _ _} _ _.
Arguments comp_assoc {_ _ _ _ _ _ _ _ _ _ _ _} _ _ _.
Arguments comp_id_l {_ _ _ _ _ _ _ _ _ _} _.
Arguments comp_id_r {_ _ _ _ _ _ _ _ _ _} _.
Arguments pair_π₁ {_ _ _ _ _ _ _ _ _ _ _} _ _.
Arguments pair_π₂ {_ _ _ _ _ _ _ _ _ _ _} _ _.
Arguments path_pair {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _.
Arguments comp_pair {_ _ _ _ _ _ _ _ _ _ _ _} _ _ _.
Arguments comp_constant {_ _ _ _ _ _ _ _ _ _} _ {_} _.
Arguments path_constr {_ _ _ _ _ _ _ _ _} _ _.
Arguments path_arg {_ _ _ _ _ _ _ _ _}.

(** Interpretation of homotopy endpoints as paths **)
Definition sem_homot_endpoint_UU
           {A : poly_code}
           {I : UU}
           {S : I → poly_code}
           {l : ∏ (j : I), endpoint A (S j) Id}
           {r : ∏ (j : I), endpoint A (S j) Id}
           {R : poly_code}
           {T : poly_code}
           {a b : endpoint A R T}
           {W : poly_code}
           {s t : endpoint A R W}
           (h : homot_endpoint l r a b s t)
           (X : UU)
           (c : act A X → X)
           (pX : ∏ (i : I),
                 sem_endpoint_UU (l i) c
                 ~
                 sem_endpoint_UU (r i) c)
           (z : act R X)
           (p_arg : sem_endpoint_UU a c z = sem_endpoint_UU b c z)
  : sem_endpoint_UU s c z = sem_endpoint_UU t c z.
Proof.
  induction h as [P e | P e₁ e₂ p IHp | P e₁ e₂ e₃ p₁ IHP₁ p₂ IHP₂
                  | T₁ T₂ e₁ e₂ e₃ h IHh
                  | R₁ R₂ P e₁ e₂ e₃ | P e | P e
                  | P₁ P₂ e₁ e₂ | P₁ P₂ e₁ e₂
                  | T₁ T₂ e₁ e₂ e₃ e₄ p₁ IHp₁ p₂ IHp₂
                  | P₁ P₂ P₃ e₁ e₂ e₃
                  | Z x P e | j e | ].
  - (** identity path *)
    exact (idpath _).
  - (** inverse path *)
    exact (!IHp).
  - (** concatenation of paths *)
    exact (IHP₁ @ IHP₂).
  - (** ap on paths *)
    exact (maponpaths (sem_endpoint_UU e₃ c) IHh).
  - (** associator *)
    apply idpath.
  - (** left unitor *)
    apply idpath.
  - (** right unitor *)
    apply idpath.
  - (** first projection *)
    apply idpath.
  - (** second projection *)
    apply idpath.
  - (** pairing *)
    exact (pathsdirprod IHp₁ IHp₂).
  - (** composition before pair *)
    apply idpath.
  - (** composition with constant *)
    apply idpath.
  - (** path constructor *)
    exact (pX j _).
  - (** path argument *)
    exact p_arg.
Defined.

(**
The definition of a HIT signature for HITs of the shape:
Inductive H :=
| c : A H → H
| p : ∏ (j : I) (x : S j H), l j x = r j x
| s : ∏ (j : J) (x : R j H) (w : a j x = b j x), p j x w = q j x w
where we have    p j x w, q j x w : s j x = t j x
 *)
Definition hit_signature
  : UU
  := ∑ (A : poly_code),
     ∑ (I : UU),
     ∑ (S : I → poly_code),
     ∑ (l r : ∏ (j : I), endpoint A (S j) Id),
     ∑ (J : UU),
     ∑ (R : J → poly_code),
     ∑ (T : J → poly_code),
     ∑ (a b : ∏ (j : J), endpoint A (R j) (T j)),
     ∑ (s t : ∏ (j : J), endpoint A (R j) Id),
     (∏ (j : J), homot_endpoint l r (a j) (b j) (s j) (t j))
     ×
     (∏ (j : J), homot_endpoint l r (a j) (b j) (s j) (t j)).

(** Projections of HIT signature *)
Section Projections.
  Variable (Σ : hit_signature).

  Definition point_constr
    : poly_code
    := pr1 Σ.

  Definition path_label
    : UU
    := pr12 Σ.

  Definition path_source
    : path_label → poly_code
    := pr122 Σ.

  Definition path_left
    : ∏ (j : path_label), endpoint point_constr (path_source j) Id
    := pr1 (pr222 Σ).

  Definition path_right
    : ∏ (j : path_label), endpoint point_constr (path_source j) Id
    := pr12 (pr222 Σ).

  Definition homot_label
    : UU
    := pr122 (pr222 Σ).

  Definition homot_point_arg
    : homot_label → poly_code
    := pr1 (pr222 (pr222 Σ)).

  Definition homot_path_arg_target
    : homot_label → poly_code
    := pr12 (pr222 (pr222 Σ)).

  Definition homot_path_arg_left
    : ∏ (j : homot_label),
      endpoint
        point_constr
        (homot_point_arg j)
        (homot_path_arg_target j)
    := pr122 (pr222 (pr222 Σ)).

  Definition homot_path_arg_right
    : ∏ (j : homot_label),
      endpoint
        point_constr
        (homot_point_arg j)
        (homot_path_arg_target j)
    := pr1 (pr222 (pr222 (pr222 Σ))).

  Definition homot_left_endpoint
    : ∏ (j : homot_label),
      endpoint
        point_constr
        (homot_point_arg j)
        Id
    := pr12 (pr222 (pr222 (pr222 Σ))).

  Definition homot_right_endpoint
    : ∏ (j : homot_label),
      endpoint
        point_constr
        (homot_point_arg j)
        Id
    := pr122 (pr222 (pr222 (pr222 Σ))).

  Definition homot_left_path
    : ∏ (j : homot_label),
      homot_endpoint
        path_left path_right
        (homot_path_arg_left j)
        (homot_path_arg_right j)
        (homot_left_endpoint j)
        (homot_right_endpoint j)
    := pr1 (pr222 (pr222 (pr222 (pr222 Σ)))).

  Definition homot_right_path
    : ∏ (j : homot_label),
      homot_endpoint
        path_left path_right
        (homot_path_arg_left j)
        (homot_path_arg_right j)
        (homot_left_endpoint j)
        (homot_right_endpoint j)
    := pr2 (pr222 (pr222 (pr222 (pr222 Σ)))).
End Projections.


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

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

Print Assumptions opp.


Require Import Categories.Essentials.Notations.
Require Import Categories.Essentials.Types.
Require Import Categories.Essentials.Facts_Tactics.
Require Import Categories.Category.Main.
Require Import Categories.Functor.Main.
Require Import Categories.Coq_Cats.Type_Cat.Type_Cat.
Require Import Categories.Ext_Cons.Prod_Cat.Main.

Local Open Scope morphism_scope.
Local Open Scope object_scope.

Section fib.
  Context {E B} (p : (E –≻ B)%functor).

  Section iscart.
    Context {e' e : E} (φ : (e' –≻ e)%morphism).

    Record iscart_for e'' (ψ : e'' –≻ e) (g : p _o e'' –≻ p _o e')
           (Heq : p _a φ ∘ g = p _a ψ) :=
      { iscart_mor : (e'' –≻ e');
        iscart_mor_eq1 : φ ∘ iscart_mor = ψ;
        iscart_mor_eq2 : p _a iscart_mor = g;
        iscart_mor_unique f : φ ∘ f = ψ → p _a f = g → f = iscart_mor }.

    Definition iscartesian :=
      ∀ e'' (ψ : e'' –≻ e) (g : p _o e'' –≻ p _o e')
        (Heq : p _a φ ∘ g = p _a ψ),
        iscart_for e'' ψ g Heq.
  End iscart.

  Record isFib_for {e : E} {b : B} (f : b –≻ p _o e) :=
    { isfib_obj : E;
      isfib_obj_eq : p _o isfib_obj = b;
      isfib_mor : isfib_obj –≻ e;
      isfib_cart : iscartesian isfib_mor;
      isfib_mor_eq : f =
      match isfib_obj_eq in _ = y return y –≻ _ with
        eq_refl => p _a isfib_mor
      end }.

  Definition isFib := ∀ {e : E} {b : B} (f : b –≻ p _o e), isFib_for f.

End fib.

Definition isOpFib {E B} (p : (E –≻ B)%functor) := isFib (p ^op).

Definition isBiFib {E B} (p : (E –≻ B)%functor) := (isFib p * isOpFib p)%type.

Record Fibration (E B : Category) :=
  {
    FibFunc :> Functor E B;
    FibFunc_isFib : isFib FibFunc
  }.

Record OpFibration (E B : Category) :=
  {
    OpFibFunc :> Functor E B;
    OpFibFunc_isOpFib : isOpFib OpFibFunc
  }.

Record BiFibration (E B : Category) :=
  {
    BiFibFunc :> Functor E B;
    BiFibFunc_isBiFib : isBiFib BiFibFunc
  }.


(** This file contains the main accuracy theorem **)

From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.

Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

From Iterative Require Import inf_norm_properties local_float_error real_model float_model.
From Iterative Require Import model_mat_lemmas lemmas vcfloat_lemmas.

From mathcomp Require Import matrix bigop all_algebra all_ssreflect.
From mathcomp.analysis Require Import Rstruct.
From Coquelicot Require Import Lub Rbar.

Local Open Scope float32_scope.

Section WITHNANS.
Context {NANS: Nans}.

Import Interval.Tactic.

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

(** We will open the real scope and the Ring scope
  separately **)

Open Scope ring_scope.

(** We instantiate the ring scope with real scope using
  Delimit Scope ... **)
Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

(** We next import the ring theory so that we can use
  it for reals **)
Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Theorem iterative_round_off_error:
  forall (x_l: list (ftype Tsingle)),
  boundsmap_denote bmap (varmap x_l) ->
  let x0 := listR_to_vecR (FT2R_list x_l) in
  let b := listR_to_vecR b_real in
  @vec_inf_norm 3 x0 <= 48 -> @vec_inf_norm 3 b <= 1 ->
  let h := 1 in
  let h_f := 1%F32 in
  let len := 3%nat in
  forall k: nat,
  (k <= 100)%nat ->
  let varmap_k := (varmap (X_m k x_l b_float h_f)) in
  vec_inf_norm (@X_m_real k len x0 b h - listR_to_vecR (FT2R_list (X_m k x_l b_float h_f))) <=
  round_off_error *
  error_sum k.+1 (@matrix_inf_norm len (S_mat _ h)) /\ boundsmap_denote bmap varmap_k.
Proof.
intros ? ? ? ? ? Hx0 ? ? ?  ? Hk. intros.
induction k.
(* base case*)
-
split.
+
rewrite /error_sum big_ord_recr //= expr0 big_ord0 add0r mulr1.
  rewrite /x0 x_minus_x_is_0.
  assert ( @vec_inf_norm (len.-1.+1) 0 = 0%Re).
  { apply vec_inf_norm_0_is_0. }
  assert (@vec_inf_norm (len.-1.+1) 0 = @vec_inf_norm len 0).
  { assert ((len.-1.+1) = len).
    { by rewrite prednK. } auto.
  } rewrite H1. apply /RleP.  apply roundoff_pos.
+
simpl in varmap_k; subst varmap_k; auto.
-
match goal with |-context [?A /\ ?B] =>
assert A;
try split; auto
end.
simpl in IHk; destruct IHk as (IHk & BMDk); try apply ltnW; auto.
try interval.
set (xkr := (X_m_real k x0 (listR_to_vecR b_real) h)) in *.
assert (X_m_real k.+1 x0 b h = X_m_real 1 xkr b h) by (apply X_m_real_iter).
set (xkf :=  @listR_to_vecR len (FT2R_list (X_m k x_l b_float h_f))) in *.
set (xkpf := @listR_to_vecR len (FT2R_list (X_m k.+1 x_l b_float h_f))).
assert ((X_m_real k.+1 x0 b h - listR_to_vecR (FT2R_list (X_m k.+1 x_l b_float h_f)))
=
X_m_real 1 xkr b h - X_m_real 1 xkf b h + X_m_real 1 xkf b h - xkpf
).
rewrite H1.
subst xkpf.
apply vec_sum_simpl.
rewrite H2.
apply /RleP.
eapply Rle_trans.

apply /RleP.
apply cs_ineq_vec_inf_norm; auto.

eapply Rle_trans; auto.
apply /RleP.
eapply ler_add.

assert (Hlen: len = len.-1.+1) by (rewrite prednK; auto).
assert (Hlen2 : (0 < len)%nat). by unfold len.
pose proof ( @matrix_norm_submult len Hlen2 xkr xkf b 1) as submult.
apply submult.

pose proof step_round_off_error as Hstep.
set (sk:= (X_m k x_l b_float h_f)).
specialize (Hstep sk BMDk).
cbv zeta in Hstep.
unfold xkf.
assert (
H_Flist: listR_to_vecR (FT2R_list (X_m 1 (X_m k x_l b_float h_f) b_float 1%F32)) =
xkpf
).
+
unfold xkpf.
rewrite /h_f.
by rewrite /X_m.
+
rewrite <- H_Flist .
unfold h in H1.
unfold len.
apply Hstep.
+
(* invoke lemma relating VCFloat bound (LHS) and analytic bound (RHS) *)
eapply Rle_trans.
eapply Rplus_le_compat.
eapply Rmult_le_compat.
(* matrix norm positive definite *)
apply /RleP. apply matrix_norm_pd.
(* vector norm positive definite *)
apply /RleP. apply vec_norm_pd.
apply Rle_refl.
unfold xkr.
unfold len in *.
apply /RleP.
apply IHk.
apply Rle_refl.
unfold h; subst len.
rewrite -!RmultE.
assert (Hsums : error_sum k.+2 (matrix_inf_norm (S_mat 3 1)) =
                 error_sum_ind (matrix_inf_norm (S_mat 3 1)) k.+2).
{ by rewrite error_sum_equiv. }
rewrite Hsums.
rewrite <- error_sum_aux2.
rewrite_scope.

rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
rewrite_scope.
eapply Rplus_le_compat.
rewrite <- error_sum_equiv.
rewrite_scope.
rewrite_scope.
rewrite Rmult_comm.
rewrite !Rmult_assoc.
apply Rmult_le_compat_l.
apply roundoff_pos.
rewrite Rmult_comm.
apply Rmult_le_compat_l.
rewrite_scope.
apply matrix_norm_pd.
all : (apply Req_le; auto).
+
simpl in IHk; destruct IHk as (IHk & BMDk); try apply ltnW; auto.
apply boundsmap_succ_step; auto.
unfold h in *; repeat fold x0 f_list b.
set (xkp:=
    (X_m_real k.+1 x0 b 1)).
set (xk :=
    (@X_m_real k len x0 b 1)).
exists 99; split; unfold xkp.
apply sol_up_bound_exists; auto.
exists (round_off_error * error_sum k.+2 (@matrix_inf_norm len (S_mat len 1))).
split.
apply H1.
rewrite_scope.
eapply Rle_trans.
eapply Rplus_le_compat_r.
rewrite_scope.
apply concrete_roundoff_k; try apply ltnW; auto.
compute; lra.
Qed.

End WITHNANS.