Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__3__6a.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel.
Require Export lemma__equalanglesflip.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglesreflexive.
Require Export lemma__equalanglessymmetric.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelNC.
Require Export lemma__paralleldef2B.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export lemma__sameside2.
Require Export lemma__samesidecollinear.
Require Export lemma__samesideflip.
Require Export lemma__samesidesymmetric.
Require Export lemma__samesidetransitive.
Require Export lemma__supplements2.
Require Export logic.
Require Export proposition__28D.
Require Export proposition__29C.
Definition proposition__43B : forall A B C D E F G H K, (euclidean__defs.PG A B C D) -> ((euclidean__axioms.BetS A H D) -> ((euclidean__axioms.BetS A E B) -> ((euclidean__axioms.BetS D F C) -> ((euclidean__axioms.BetS B G C) -> ((euclidean__defs.PG E A H K) -> ((euclidean__defs.PG G K F C) -> (euclidean__defs.PG E K G B))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro G.
intro H.
intro K.
intro H0.
intro H1.
intro H2.
intro H3.
intro H4.
intro H5.
intro H6.
assert (* Cut *) (euclidean__defs.Par A D B C) as H7.
- destruct H6 as [H7 H8].
destruct H5 as [H9 H10].
destruct H0 as [H11 H12].
exact H12.
- assert (* Cut *) (euclidean__defs.Par A B C D) as H8.
-- destruct H6 as [H8 H9].
destruct H5 as [H10 H11].
destruct H0 as [H12 H13].
exact H12.
-- assert (* Cut *) (euclidean__defs.Par E A H K) as H9.
--- destruct H6 as [H9 H10].
destruct H5 as [H11 H12].
destruct H0 as [H13 H14].
exact H11.
--- assert (* Cut *) (euclidean__defs.Par E K A H) as H10.
---- destruct H6 as [H10 H11].
destruct H5 as [H12 H13].
destruct H0 as [H14 H15].
exact H13.
---- assert (* Cut *) (euclidean__defs.Par G K F C) as H11.
----- destruct H6 as [H11 H12].
destruct H5 as [H13 H14].
destruct H0 as [H15 H16].
exact H11.
----- assert (* Cut *) (euclidean__defs.Par F C G K) as H12.
------ apply (@lemma__parallelsymmetric.lemma__parallelsymmetric G K F C H11).
------ assert (* Cut *) (euclidean__defs.Par C F G K) as H13.
------- assert (* Cut *) ((euclidean__defs.Par C F G K) /\ ((euclidean__defs.Par F C K G) /\ (euclidean__defs.Par C F K G))) as H13.
-------- apply (@lemma__parallelflip.lemma__parallelflip F C G K H12).
-------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H14.
------- assert (* Cut *) (euclidean__defs.Par G C K F) as H14.
-------- destruct H6 as [H14 H15].
destruct H5 as [H16 H17].
destruct H0 as [H18 H19].
exact H15.
-------- assert (* Cut *) (euclidean__defs.Par B C A D) as H15.
--------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A D B C H7).
--------- assert (* Cut *) (euclidean__defs.Par C D A B) as H16.
---------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B C D H8).
---------- assert (* Cut *) (euclidean__defs.Par A H E K) as H17.
----------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric E K A H H10).
----------- assert (* Cut *) (euclidean__defs.TP A B C D) as H18.
------------ apply (@lemma__paralleldef2B.lemma__paralleldef2B A B C D H8).
------------ assert (* Cut *) (euclidean__defs.TP E A H K) as H19.
------------- apply (@lemma__paralleldef2B.lemma__paralleldef2B E A H K H9).
------------- assert (* Cut *) (euclidean__defs.TP G C K F) as H20.
-------------- apply (@lemma__paralleldef2B.lemma__paralleldef2B G C K F H14).
-------------- assert (* Cut *) (euclidean__defs.TP B C A D) as H21.
--------------- apply (@lemma__paralleldef2B.lemma__paralleldef2B B C A D H15).
--------------- assert (* Cut *) (euclidean__defs.OS A D B C) as H22.
---------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H20 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H19 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H18 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H27.
---------------- assert (* Cut *) (euclidean__defs.OS A D C B) as H23.
----------------- apply (@lemma__samesideflip.lemma__samesideflip B C A D H22).
----------------- assert (* Cut *) (euclidean__defs.OS D A C B) as H24.
------------------ assert (* Cut *) ((euclidean__defs.OS D A C B) /\ ((euclidean__defs.OS A D B C) /\ (euclidean__defs.OS D A B C))) as H24.
------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric C B A D H23).
------------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H25.
------------------ assert (* Cut *) (euclidean__defs.OS C D A B) as H25.
------------------- destruct H21 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H20 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H19 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H18 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
exact H48.
------------------- assert (* Cut *) (euclidean__defs.OS H K E A) as H26.
-------------------- destruct H21 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H20 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H19 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H18 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H43.
-------------------- assert (* Cut *) (euclidean__defs.OS K F G C) as H27.
--------------------- destruct H21 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H20 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H19 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H18 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H38.
--------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H28.
---------------------- assert (* Cut *) ((euclidean__axioms.neq E B) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A B))) as H28.
----------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A E B H2).
----------------------- destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H31.
---------------------- assert (* Cut *) (euclidean__axioms.neq A H) as H29.
----------------------- assert (* Cut *) ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.neq A H) /\ (euclidean__axioms.neq A D))) as H29.
------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal A H D H1).
------------------------ destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H32.
----------------------- assert (* Cut *) (euclidean__axioms.neq B G) as H30.
------------------------ assert (* Cut *) ((euclidean__axioms.neq G C) /\ ((euclidean__axioms.neq B G) /\ (euclidean__axioms.neq B C))) as H30.
------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B G C H4).
------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H33.
------------------------ assert (* Cut *) (euclidean__axioms.neq A B) as H31.
------------------------- assert (* Cut *) ((euclidean__axioms.neq E B) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A B))) as H31.
-------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A E B H2).
-------------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H35.
------------------------- assert (* Cut *) (euclidean__axioms.neq B A) as H32.
-------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H31).
-------------------------- assert (* Cut *) (exists e, (euclidean__axioms.BetS B A e) /\ (euclidean__axioms.Cong A e B A)) as H33.
--------------------------- apply (@lemma__extension.lemma__extension B A B A H32 H32).
--------------------------- destruct H33 as [e H34].
destruct H34 as [H35 H36].
assert (* Cut *) (euclidean__axioms.BetS e A B) as H37.
---------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B A e H35).
---------------------------- assert (* Cut *) (euclidean__defs.OS D C A B) as H38.
----------------------------- assert (* Cut *) ((euclidean__defs.OS D C A B) /\ ((euclidean__defs.OS C D B A) /\ (euclidean__defs.OS D C B A))) as H38.
------------------------------ apply (@lemma__samesidesymmetric.lemma__samesidesymmetric A B C D H25).
------------------------------ destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H39.
----------------------------- assert (* Cut *) (euclidean__defs.RT D A B A B C) as H39.
------------------------------ assert (* Cut *) (forall B0 D0 E0 G0 H39, (euclidean__defs.Par G0 B0 H39 D0) -> ((euclidean__defs.OS B0 D0 G0 H39) -> ((euclidean__axioms.BetS E0 G0 H39) -> (euclidean__defs.RT B0 G0 H39 G0 H39 D0)))) as H39.
------------------------------- intro B0.
intro D0.
intro E0.
intro G0.
intro H39.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA E0 G0 B0 G0 H39 D0) /\ (euclidean__defs.RT B0 G0 H39 G0 H39 D0)) as __2.
-------------------------------- apply (@proposition__29C.proposition__29C B0 D0 E0 G0 H39 __ __0 __1).
-------------------------------- destruct __2 as [__2 __3].
exact __3.
------------------------------- apply (@H39 D C e A B H7 H38 H37).
------------------------------ assert (* Cut *) (euclidean__axioms.BetS B E A) as H40.
------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A E B H2).
------------------------------- assert (* Cut *) (euclidean__axioms.BetS E A e) as H41.
-------------------------------- apply (@lemma__3__6a.lemma__3__6a B E A e H40 H35).
-------------------------------- assert (* Cut *) (euclidean__axioms.BetS e A E) as H42.
--------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry E A e H41).
--------------------------------- assert (* Cut *) (euclidean__defs.OS H K A E) as H43.
---------------------------------- assert (* Cut *) ((euclidean__defs.OS K H E A) /\ ((euclidean__defs.OS H K A E) /\ (euclidean__defs.OS K H A E))) as H43.
----------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric E A H K H26).
----------------------------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H46.
---------------------------------- assert (* Cut *) (euclidean__defs.RT H A E A E K) as H44.
----------------------------------- assert (* Cut *) (forall B0 D0 E0 G0 H44, (euclidean__defs.Par G0 B0 H44 D0) -> ((euclidean__defs.OS B0 D0 G0 H44) -> ((euclidean__axioms.BetS E0 G0 H44) -> (euclidean__defs.RT B0 G0 H44 G0 H44 D0)))) as H44.
------------------------------------ intro B0.
intro D0.
intro E0.
intro G0.
intro H44.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA E0 G0 B0 G0 H44 D0) /\ (euclidean__defs.RT B0 G0 H44 G0 H44 D0)) as __2.
------------------------------------- apply (@proposition__29C.proposition__29C B0 D0 E0 G0 H44 __ __0 __1).
------------------------------------- destruct __2 as [__2 __3].
exact __3.
------------------------------------ apply (@H44 H K e A E H17 H43 H42).
----------------------------------- assert (* Cut *) (euclidean__defs.Out A E B) as H45.
------------------------------------ apply (@lemma__ray4.lemma__ray4 A E B).
-------------------------------------right.
right.
exact H2.

------------------------------------- exact H28.
------------------------------------ assert (* Cut *) (euclidean__defs.Out A H D) as H46.
------------------------------------- apply (@lemma__ray4.lemma__ray4 A H D).
--------------------------------------right.
right.
exact H1.

-------------------------------------- exact H29.
------------------------------------- assert (* Cut *) (euclidean__axioms.nCol A H E) as H47.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol A H E) /\ ((euclidean__axioms.nCol A E K) /\ ((euclidean__axioms.nCol H E K) /\ (euclidean__axioms.nCol A H K)))) as H47.
--------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC A H E K H17).
--------------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H48.
-------------------------------------- assert (* Cut *) (euclidean__axioms.nCol E A H) as H48.
--------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol H A E) /\ ((euclidean__axioms.nCol H E A) /\ ((euclidean__axioms.nCol E A H) /\ ((euclidean__axioms.nCol A E H) /\ (euclidean__axioms.nCol E H A))))) as H48.
---------------------------------------- apply (@lemma__NCorder.lemma__NCorder A H E H47).
---------------------------------------- destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H53.
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA E A H E A H) as H49.
---------------------------------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive E A H H48).
---------------------------------------- assert (* Cut *) (euclidean__defs.CongA E A H B A D) as H50.
----------------------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper E A H E A H B D H49 H45 H46).
----------------------------------------- assert (* Cut *) (euclidean__defs.CongA H A E D A B) as H51.
------------------------------------------ apply (@lemma__equalanglesflip.lemma__equalanglesflip E A H B A D H50).
------------------------------------------ assert (* Cut *) (euclidean__defs.CongA A E K A B C) as H52.
------------------------------------------- assert (* Cut *) ((euclidean__defs.RT H A E A E K) -> ((euclidean__defs.CongA H A E D A B) -> ((euclidean__defs.RT D A B A B C) -> (euclidean__defs.CongA A E K A B C)))) as H52.
-------------------------------------------- intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA A E K A B C) /\ (euclidean__defs.CongA A B C A E K)) as __2.
--------------------------------------------- apply (@lemma__supplements2.lemma__supplements2 H A E A B C D A B A E K __ __0 __1).
--------------------------------------------- destruct __2 as [__2 __3].
exact __2.
-------------------------------------------- apply (@H52 H44 H51 H39).
------------------------------------------- assert (* Cut *) (euclidean__defs.OS C D B A) as H53.
-------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip A B C D H25).
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A E B) as H54.
--------------------------------------------- right.
right.
right.
right.
left.
exact H2.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B A E) as H55.
---------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E A B) /\ ((euclidean__axioms.Col E B A) /\ ((euclidean__axioms.Col B A E) /\ ((euclidean__axioms.Col A B E) /\ (euclidean__axioms.Col B E A))))) as H55.
----------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A E B H54).
----------------------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H60.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.neq E B) as H56.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq E B) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A B))) as H56.
------------------------------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal A E B H2).
------------------------------------------------ destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
exact H57.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B E) as H57.
------------------------------------------------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric E B H56).
------------------------------------------------ assert (* Cut *) (euclidean__defs.OS C D B E) as H58.
------------------------------------------------- apply (@lemma__samesidecollinear.lemma__samesidecollinear B A E C D H53 H55 H57).
------------------------------------------------- assert (euclidean__defs.Out A H D) as H59 by exact H46.
assert (* Cut *) (euclidean__defs.Out A D H) as H60.
-------------------------------------------------- apply (@lemma__ray5.lemma__ray5 A H D H59).
-------------------------------------------------- assert (* Cut *) (euclidean__defs.OS C H B E) as H61.
--------------------------------------------------- apply (@lemma__sameside2.lemma__sameside2 B A E C D H H58 H55 H60).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E A B) as H62.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B E) /\ ((euclidean__axioms.Col A E B) /\ ((euclidean__axioms.Col E B A) /\ ((euclidean__axioms.Col B E A) /\ (euclidean__axioms.Col E A B))))) as H62.
----------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A E H55).
----------------------------------------------------- destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
exact H70.
---------------------------------------------------- assert (* Cut *) (euclidean__defs.OS H K E B) as H63.
----------------------------------------------------- apply (@lemma__samesidecollinear.lemma__samesidecollinear E A B H K H26 H62 H56).
----------------------------------------------------- assert (* Cut *) (euclidean__defs.OS H K B E) as H64.
------------------------------------------------------ apply (@lemma__samesideflip.lemma__samesideflip E B H K H63).
------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS C K B E) as H65.
------------------------------------------------------- apply (@lemma__samesidetransitive.lemma__samesidetransitive B E C H K H61 H64).
------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K C B E) as H66.
-------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS K C B E) /\ ((euclidean__defs.OS C K E B) /\ (euclidean__defs.OS K C E B))) as H66.
--------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B E C K H65).
--------------------------------------------------------- destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
exact H67.
-------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B G C) as H67.
--------------------------------------------------------- apply (@lemma__ray4.lemma__ray4 B G C).
----------------------------------------------------------right.
right.
exact H4.

---------------------------------------------------------- exact H30.
--------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B C G) as H68.
---------------------------------------------------------- apply (@lemma__ray5.lemma__ray5 B G C H67).
---------------------------------------------------------- assert (* Cut *) (B = B) as H69.
----------------------------------------------------------- apply (@logic.eq__refl Point B).
----------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B B E) as H70.
------------------------------------------------------------ left.
exact H69.
------------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS K G B E) as H71.
------------------------------------------------------------- apply (@lemma__sameside2.lemma__sameside2 B B E K C G H66 H70 H68).
------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K G E B) as H72.
-------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip B E K G H71).
-------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B E A) as H73.
--------------------------------------------------------------- apply (@lemma__ray4.lemma__ray4 B E A).
----------------------------------------------------------------right.
right.
exact H40.

---------------------------------------------------------------- exact H57.
--------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B A E) as H74.
---------------------------------------------------------------- apply (@lemma__ray5.lemma__ray5 B E A H73).
---------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA A E K E B G) as H75.
----------------------------------------------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper A E K A B C E G H52 H74 H68).
----------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E K B G) as H76.
------------------------------------------------------------------ apply (@proposition__28D.proposition__28D K G A E B H2 H75 H72).
------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.Par E K G B) as H77.
------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par K E B G) /\ ((euclidean__defs.Par E K G B) /\ (euclidean__defs.Par K E G B))) as H77.
-------------------------------------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip E K B G H76).
-------------------------------------------------------------------- destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
exact H80.
------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H78.
-------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq G C) /\ ((euclidean__axioms.neq B G) /\ (euclidean__axioms.neq B C))) as H78.
--------------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B G C H4).
--------------------------------------------------------------------- destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H82.
-------------------------------------------------------------------- assert (* Cut *) (exists c, (euclidean__axioms.BetS B C c) /\ (euclidean__axioms.Cong C c B C)) as H79.
--------------------------------------------------------------------- apply (@lemma__extension.lemma__extension B C B C H78 H78).
--------------------------------------------------------------------- destruct H79 as [c H80].
destruct H80 as [H81 H82].
assert (* Cut *) (euclidean__axioms.BetS c C B) as H83.
---------------------------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B C c H81).
---------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par C D B A) as H84.
----------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par D C A B) /\ ((euclidean__defs.Par C D B A) /\ (euclidean__defs.Par D C B A))) as H84.
------------------------------------------------------------------------ apply (@lemma__parallelflip.lemma__parallelflip C D A B H16).
------------------------------------------------------------------------ destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
exact H87.
----------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.RT D C B C B A) as H85.
------------------------------------------------------------------------ assert (* Cut *) (forall B0 D0 E0 G0 H85, (euclidean__defs.Par G0 B0 H85 D0) -> ((euclidean__defs.OS B0 D0 G0 H85) -> ((euclidean__axioms.BetS E0 G0 H85) -> (euclidean__defs.RT B0 G0 H85 G0 H85 D0)))) as H85.
------------------------------------------------------------------------- intro B0.
intro D0.
intro E0.
intro G0.
intro H85.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA E0 G0 B0 G0 H85 D0) /\ (euclidean__defs.RT B0 G0 H85 G0 H85 D0)) as __2.
-------------------------------------------------------------------------- apply (@proposition__29C.proposition__29C B0 D0 E0 G0 H85 __ __0 __1).
-------------------------------------------------------------------------- destruct __2 as [__2 __3].
exact __3.
------------------------------------------------------------------------- apply (@H85 D A c C B H84 H24 H83).
------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.OS K F C G) as H86.
------------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip G C K F H27).
------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS F K C G) as H87.
-------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS F K C G) /\ ((euclidean__defs.OS K F G C) /\ (euclidean__defs.OS F K G C))) as H87.
--------------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric C G K F H86).
--------------------------------------------------------------------------- destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
exact H88.
-------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS C G B) as H88.
--------------------------------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B G C H4).
--------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS c C G) as H89.
---------------------------------------------------------------------------- apply (@euclidean__axioms.axiom__innertransitivity c C G B H83 H88).
---------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.RT F C G C G K) as H90.
----------------------------------------------------------------------------- assert (* Cut *) (forall B0 D0 E0 G0 H90, (euclidean__defs.Par G0 B0 H90 D0) -> ((euclidean__defs.OS B0 D0 G0 H90) -> ((euclidean__axioms.BetS E0 G0 H90) -> (euclidean__defs.RT B0 G0 H90 G0 H90 D0)))) as H90.
------------------------------------------------------------------------------ intro B0.
intro D0.
intro E0.
intro G0.
intro H90.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA E0 G0 B0 G0 H90 D0) /\ (euclidean__defs.RT B0 G0 H90 G0 H90 D0)) as __2.
------------------------------------------------------------------------------- apply (@proposition__29C.proposition__29C B0 D0 E0 G0 H90 __ __0 __1).
------------------------------------------------------------------------------- destruct __2 as [__2 __3].
exact __3.
------------------------------------------------------------------------------ apply (@H90 F K c C G H13 H87 H89).
----------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol D B C) as H91.
------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.nCol A D B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol D B C) /\ (euclidean__axioms.nCol A D C)))) as H91.
------------------------------------------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC A D B C H7).
------------------------------------------------------------------------------- destruct H91 as [H92 H93].
destruct H93 as [H94 H95].
destruct H95 as [H96 H97].
exact H96.
------------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol D C B) as H92.
------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol D C B) /\ (euclidean__axioms.nCol C B D))))) as H92.
-------------------------------------------------------------------------------- apply (@lemma__NCorder.lemma__NCorder D B C H91).
-------------------------------------------------------------------------------- destruct H92 as [H93 H94].
destruct H94 as [H95 H96].
destruct H96 as [H97 H98].
destruct H98 as [H99 H100].
exact H99.
------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA D C B D C B) as H93.
-------------------------------------------------------------------------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive D C B H92).
-------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS C F D) as H94.
--------------------------------------------------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry D F C H3).
--------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C F) as H95.
---------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq F D) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C D))) as H95.
----------------------------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F D H94).
----------------------------------------------------------------------------------- destruct H95 as [H96 H97].
destruct H97 as [H98 H99].
exact H98.
---------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out C F D) as H96.
----------------------------------------------------------------------------------- apply (@lemma__ray4.lemma__ray4 C F D).
------------------------------------------------------------------------------------right.
right.
exact H94.

------------------------------------------------------------------------------------ exact H95.
----------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out C D F) as H97.
------------------------------------------------------------------------------------ apply (@lemma__ray5.lemma__ray5 C F D H96).
------------------------------------------------------------------------------------ assert (euclidean__axioms.BetS C G B) as H98 by exact H88.
assert (* Cut *) (euclidean__axioms.neq C G) as H99.
------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq C G) /\ (euclidean__axioms.neq C B))) as H99.
-------------------------------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C G B H98).
-------------------------------------------------------------------------------------- destruct H99 as [H100 H101].
destruct H101 as [H102 H103].
exact H102.
------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out C G B) as H100.
-------------------------------------------------------------------------------------- apply (@lemma__ray4.lemma__ray4 C G B).
---------------------------------------------------------------------------------------right.
right.
exact H98.

--------------------------------------------------------------------------------------- exact H99.
-------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out C B G) as H101.
--------------------------------------------------------------------------------------- apply (@lemma__ray5.lemma__ray5 C G B H100).
--------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA D C B F C G) as H102.
---------------------------------------------------------------------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper D C B D C B F G H93 H97 H101).
---------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B A C G K) as H103.
----------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.RT D C B C B A) -> ((euclidean__defs.CongA D C B F C G) -> ((euclidean__defs.RT F C G C G K) -> (euclidean__defs.CongA C B A C G K)))) as H103.
------------------------------------------------------------------------------------------ intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__defs.CongA C B A C G K) /\ (euclidean__defs.CongA C G K C B A)) as __2.
------------------------------------------------------------------------------------------- apply (@lemma__supplements2.lemma__supplements2 D C B C G K F C G C B A __ __0 __1).
------------------------------------------------------------------------------------------- destruct __2 as [__2 __3].
exact __2.
------------------------------------------------------------------------------------------ apply (@H103 H85 H102 H90).
----------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.CongA C G K C B A) as H104.
------------------------------------------------------------------------------------------ apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric C B A C G K H103).
------------------------------------------------------------------------------------------ assert (* Cut *) (A = A) as H105.
------------------------------------------------------------------------------------------- apply (@logic.eq__refl Point A).
------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Out B A A) as H106.
-------------------------------------------------------------------------------------------- apply (@lemma__ray4.lemma__ray4 B A A).
---------------------------------------------------------------------------------------------right.
left.
exact H105.

--------------------------------------------------------------------------------------------- exact H32.
-------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B G) as H107.
--------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq C G) /\ (euclidean__axioms.neq C B))) as H107.
---------------------------------------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C G B H98).
---------------------------------------------------------------------------------------------- destruct H107 as [H108 H109].
destruct H109 as [H110 H111].
exact H30.
--------------------------------------------------------------------------------------------- assert (euclidean__defs.Out B G C) as H108 by exact H67.
assert (euclidean__defs.Out B C G) as H109 by exact H68.
assert (* Cut *) (euclidean__defs.CongA C G K G B A) as H110.
---------------------------------------------------------------------------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper C G K C B A G A H104 H109 H106).
---------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B G C) as H111.
----------------------------------------------------------------------------------------------- right.
right.
right.
right.
left.
exact H4.
----------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C B G) as H112.
------------------------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col G B C) /\ ((euclidean__axioms.Col G C B) /\ ((euclidean__axioms.Col C B G) /\ ((euclidean__axioms.Col B C G) /\ (euclidean__axioms.Col C G B))))) as H112.
------------------------------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B G C H111).
------------------------------------------------------------------------------------------------- destruct H112 as [H113 H114].
destruct H114 as [H115 H116].
destruct H116 as [H117 H118].
destruct H118 as [H119 H120].
exact H117.
------------------------------------------------------------------------------------------------ assert (euclidean__axioms.BetS C F D) as H113 by exact H94.
assert (* Cut *) (euclidean__axioms.neq C F) as H114.
------------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq F D) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C D))) as H114.
-------------------------------------------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F D H113).
-------------------------------------------------------------------------------------------------- destruct H114 as [H115 H116].
destruct H116 as [H117 H118].
exact H117.
------------------------------------------------------------------------------------------------- assert (euclidean__defs.Out C F D) as H115 by exact H96.
assert (euclidean__defs.Out C D F) as H116 by exact H97.
assert (* Cut *) (C = C) as H117.
-------------------------------------------------------------------------------------------------- apply (@logic.eq__refl Point C).
-------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B C C) as H118.
--------------------------------------------------------------------------------------------------- right.
right.
left.
exact H117.
--------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS A F B C) as H119.
---------------------------------------------------------------------------------------------------- apply (@lemma__sameside2.lemma__sameside2 B C C A D F H22 H118 H116).
---------------------------------------------------------------------------------------------------- assert (euclidean__defs.TP G C K F) as H120 by exact H20.
assert (* Cut *) (euclidean__defs.OS K F G C) as H121.
----------------------------------------------------------------------------------------------------- destruct H120 as [H121 H122].
destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
destruct H21 as [H127 H128].
destruct H128 as [H129 H130].
destruct H130 as [H131 H132].
destruct H20 as [H133 H134].
destruct H134 as [H135 H136].
destruct H136 as [H137 H138].
destruct H19 as [H139 H140].
destruct H140 as [H141 H142].
destruct H142 as [H143 H144].
destruct H18 as [H145 H146].
destruct H146 as [H147 H148].
destruct H148 as [H149 H150].
exact H126.
----------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C G B) as H122.
------------------------------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col B C G) /\ ((euclidean__axioms.Col B G C) /\ ((euclidean__axioms.Col G C B) /\ ((euclidean__axioms.Col C G B) /\ (euclidean__axioms.Col G B C))))) as H122.
------------------------------------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B G H112).
------------------------------------------------------------------------------------------------------- destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
destruct H126 as [H127 H128].
destruct H128 as [H129 H130].
exact H129.
------------------------------------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.neq C B) as H123.
------------------------------------------------------------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H78).
------------------------------------------------------------------------------------------------------- assert (euclidean__defs.OS K F C G) as H124 by exact H86.
assert (* Cut *) (euclidean__defs.OS K F C B) as H125.
-------------------------------------------------------------------------------------------------------- apply (@lemma__samesidecollinear.lemma__samesidecollinear C G B K F H124 H122 H123).
-------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K F B C) as H126.
--------------------------------------------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip C B K F H125).
--------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS F K B C) as H127.
---------------------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.OS F K B C) /\ ((euclidean__defs.OS K F C B) /\ (euclidean__defs.OS F K C B))) as H127.
----------------------------------------------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B C K F H126).
----------------------------------------------------------------------------------------------------------- destruct H127 as [H128 H129].
destruct H129 as [H130 H131].
exact H128.
---------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS A K B C) as H128.
----------------------------------------------------------------------------------------------------------- apply (@lemma__samesidetransitive.lemma__samesidetransitive B C A F K H119 H127).
----------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K A B C) as H129.
------------------------------------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__defs.OS K A B C) /\ ((euclidean__defs.OS A K C B) /\ (euclidean__defs.OS K A C B))) as H129.
------------------------------------------------------------------------------------------------------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B C A K H128).
------------------------------------------------------------------------------------------------------------- destruct H129 as [H130 H131].
destruct H131 as [H132 H133].
exact H130.
------------------------------------------------------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col B C G) as H130.
------------------------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col G C B) /\ ((euclidean__axioms.Col G B C) /\ ((euclidean__axioms.Col B C G) /\ ((euclidean__axioms.Col C B G) /\ (euclidean__axioms.Col B G C))))) as H130.
-------------------------------------------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C G B H122).
-------------------------------------------------------------------------------------------------------------- destruct H130 as [H131 H132].
destruct H132 as [H133 H134].
destruct H134 as [H135 H136].
destruct H136 as [H137 H138].
exact H135.
------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K A B G) as H131.
-------------------------------------------------------------------------------------------------------------- apply (@lemma__samesidecollinear.lemma__samesidecollinear B C G K A H129 H130 H107).
-------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.OS K A G B) as H132.
--------------------------------------------------------------------------------------------------------------- apply (@lemma__samesideflip.lemma__samesideflip B G K A H131).
--------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par G K B A) as H133.
---------------------------------------------------------------------------------------------------------------- apply (@proposition__28D.proposition__28D K A C G B H98 H110 H132).
---------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par G K A B) as H134.
----------------------------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par K G B A) /\ ((euclidean__defs.Par G K A B) /\ (euclidean__defs.Par K G A B))) as H134.
------------------------------------------------------------------------------------------------------------------ apply (@lemma__parallelflip.lemma__parallelflip G K B A H133).
------------------------------------------------------------------------------------------------------------------ destruct H134 as [H135 H136].
destruct H136 as [H137 H138].
exact H137.
----------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B E) as H135.
------------------------------------------------------------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col A E B) /\ ((euclidean__axioms.Col A B E) /\ ((euclidean__axioms.Col B E A) /\ ((euclidean__axioms.Col E B A) /\ (euclidean__axioms.Col B A E))))) as H135.
------------------------------------------------------------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder E A B H62).
------------------------------------------------------------------------------------------------------------------- destruct H135 as [H136 H137].
destruct H137 as [H138 H139].
destruct H139 as [H140 H141].
destruct H141 as [H142 H143].
exact H138.
------------------------------------------------------------------------------------------------------------------ assert (* Cut *) (euclidean__defs.Par G K E B) as H136.
------------------------------------------------------------------------------------------------------------------- apply (@lemma__collinearparallel.lemma__collinearparallel G K E A B H134 H135 H56).
------------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E B G K) as H137.
-------------------------------------------------------------------------------------------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric G K E B H136).
-------------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Par E B K G) as H138.
--------------------------------------------------------------------------------------------------------------------- assert (* Cut *) ((euclidean__defs.Par B E G K) /\ ((euclidean__defs.Par E B K G) /\ (euclidean__defs.Par B E K G))) as H138.
---------------------------------------------------------------------------------------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip E B G K H137).
---------------------------------------------------------------------------------------------------------------------- destruct H138 as [H139 H140].
destruct H140 as [H141 H142].
exact H141.
--------------------------------------------------------------------------------------------------------------------- assert (* Cut *) (euclidean__defs.PG E K G B) as H139.
---------------------------------------------------------------------------------------------------------------------- split.
----------------------------------------------------------------------------------------------------------------------- exact H77.
----------------------------------------------------------------------------------------------------------------------- exact H138.
---------------------------------------------------------------------------------------------------------------------- exact H139.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo43:
  prime  64035967->
  prime  25422596557.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      25422596557
      397
      ((64035967,1)::nil)
      0
      2058
      7
      49)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enriched.Enriched.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section Opposite.

Context {Mon_V : monoidal_cat}.

Definition opposite_enriched_precat (A : enriched_precat Mon_V) : enriched_precat (_ ,, monoidal_swapped Mon_V).
Proof.
  use make_enriched_precat.
  - use make_enriched_precat_data.
    + exact A.
    + intros x y.
      exact (enriched_cat_mor y x).
    + intro x.
      simpl.
      exact (enriched_cat_identity x).
    + intros x y z.
      exact (enriched_cat_comp z y x).
  - split; simpl in a, b; simpl.
    + refine (_ @ enriched_id_right b a).
      apply maponpaths_2.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
    + refine (_ @ enriched_id_left b a).
      apply maponpaths_2.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
  - intros a b c d ; cbn.
    refine (!(id_left _) @ _).
    etrans.
    {
      apply maponpaths_2.
      exact (!(mon_rassociator_lassociator _ _ _)).
    }
    rewrite !assoc'.
    apply maponpaths.
    refine (_ @ !(enriched_assoc d c b a) @ _).
    + apply maponpaths.
      apply maponpaths_2.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
    + apply maponpaths_2.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
Defined.

Definition opposite_enriched_functor {A B : enriched_precat Mon_V} (F : enriched_functor A B) : enriched_functor (opposite_enriched_precat A) (opposite_enriched_precat B).
Proof.
  use make_enriched_functor.
  - use make_enriched_functor_data.
    + intro x.
      exact (F x).
    + intros x y.
      exact (enriched_functor_on_morphisms F y x).
  - intro x.
    cbn.
    apply enriched_functor_on_identity.
  - intros x y z.
    cbn.
    refine (enriched_functor_on_comp F z y x @ _).
    apply maponpaths_2.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    cbn.
    rewrite whiskerscommutes ; [ apply idpath | ].
    apply (pr2 Mon_V).
Defined.

(* note the direction *)
Definition opposite_enriched_nat_trans {A B : enriched_precat Mon_V} {F G : enriched_functor A B} (a : enriched_nat_trans F G) : enriched_nat_trans (opposite_enriched_functor G) (opposite_enriched_functor F).
Proof.
  use make_enriched_nat_trans.
  - intro x.
    exact (a x).
  - intros x y.
    cbn.
    apply pathsinv0.
    refine (_ @ enriched_nat_trans_ax a y x @ _).
    + apply maponpaths.
      unfold precompose_underlying_morphism, postcompose_underlying_morphism.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite <- whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
    + apply maponpaths.
      unfold precompose_underlying_morphism, postcompose_underlying_morphism.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      cbn.
      rewrite <- whiskerscommutes ; [ apply idpath | ].
      apply (pr2 Mon_V).
Defined.

End Opposite.


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

Require Import NSub ZAxioms.
Require Export Ring.

Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Local Open Scope pair_scope.

Module ZPairsAxiomsMod (Import N : NAxiomsMiniSig) <: ZAxiomsMiniSig.
 Module Import NProp.
   Include NSubProp N.
 End NProp.

Delimit Scope NScope with N.
Bind Scope NScope with N.t.
Infix "=="  := N.eq (at level 70) : NScope.
Notation "x ~= y" := (~ N.eq x y) (at level 70) : NScope.
Notation "0" := N.zero : NScope.
Notation "1" := N.one : NScope.
Notation "2" := N.two : NScope.
Infix "+" := N.add : NScope.
Infix "-" := N.sub : NScope.
Infix "*" := N.mul : NScope.
Infix "<" := N.lt : NScope.
Infix "<=" := N.le : NScope.
Local Open Scope NScope.

(** The definitions of functions ([add], [mul], etc.) will be unfolded
    by the properties functor. Since we don't want [add_comm] to refer
    to unfolded definitions of equality: [fun p1 p2 => (fst p1 +
    snd p2) = (fst p2 + snd p1)], we will provide an extra layer of
    definitions. *)

Module Z.

Definition t := (N.t * N.t)%type.
Definition zero : t := (0, 0).
Definition one : t := (1,0).
Definition two : t := (2,0).
Definition eq (p q : t) := (p#1 + q#2 == q#1 + p#2).
Definition succ (n : t) : t := (N.succ n#1, n#2).
Definition pred (n : t) : t := (n#1, N.succ n#2).
Definition opp (n : t) : t := (n#2, n#1).
Definition add (n m : t) : t := (n#1 + m#1, n#2 + m#2).
Definition sub (n m : t) : t := (n#1 + m#2, n#2 + m#1).
Definition mul (n m : t) : t :=
  (n#1 * m#1 + n#2 * m#2, n#1 * m#2 + n#2 * m#1).
Definition lt (n m : t) := n#1 + m#2 < m#1 + n#2.
Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2.
Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2).
Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2).

(** NB : We do not have [Zpred (Zsucc n) = n] but only [Zpred (Zsucc n) == n].
    It could be possible to consider as canonical only pairs where
    one of the elements is 0, and make all operations convert
    canonical values into other canonical values. In that case, we
    could get rid of setoids and arrive at integers as signed natural
    numbers. *)

(** NB : Unfortunately, the elements of the pair keep increasing during
    many operations, even during subtraction. *)

End Z.

Delimit Scope ZScope with Z.
Bind Scope ZScope with Z.t.
Infix "=="  := Z.eq (at level 70) : ZScope.
Notation "x ~= y" := (~ Z.eq x y) (at level 70) : ZScope.
Notation "0" := Z.zero : ZScope.
Notation "1" := Z.one : ZScope.
Notation "2" := Z.two : ZScope.
Infix "+" := Z.add : ZScope.
Infix "-" := Z.sub : ZScope.
Infix "*" := Z.mul : ZScope.
Notation "- x" := (Z.opp x) : ZScope.
Infix "<" := Z.lt : ZScope.
Infix "<=" := Z.le : ZScope.
Local Open Scope ZScope.

Lemma sub_add_opp : forall n m, Z.sub n m = Z.add n (Z.opp m).
Proof. reflexivity. Qed.

Instance eq_equiv : Equivalence Z.eq.
Proof.
split.
unfold Reflexive, Z.eq. reflexivity.
unfold Symmetric, Z.eq; now symmetry.
unfold Transitive, Z.eq. intros (n1,n2) (m1,m2) (p1,p2) H1 H2; simpl in *.
apply (add_cancel_r _ _ (m1+m2)%N).
rewrite add_shuffle2, H1, add_shuffle1, H2.
now rewrite add_shuffle1, (add_comm m1).
Qed.

Instance pair_wd : Proper (N.eq==>N.eq==>Z.eq) (@pair N.t N.t).
Proof.
intros n1 n2 H1 m1 m2 H2; unfold Z.eq; simpl; now rewrite H1, H2.
Qed.

Instance succ_wd : Proper (Z.eq ==> Z.eq) Z.succ.
Proof.
unfold Z.succ, Z.eq; intros n m H; simpl.
do 2 rewrite add_succ_l; now rewrite H.
Qed.

Instance pred_wd : Proper (Z.eq ==> Z.eq) Z.pred.
Proof.
unfold Z.pred, Z.eq; intros n m H; simpl.
do 2 rewrite add_succ_r; now rewrite H.
Qed.

Instance add_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.add.
Proof.
unfold Z.eq, Z.add; intros n1 m1 H1 n2 m2 H2; simpl.
now rewrite add_shuffle1, H1, H2, add_shuffle1.
Qed.

Instance opp_wd : Proper (Z.eq ==> Z.eq) Z.opp.
Proof.
unfold Z.eq, Z.opp; intros (n1,n2) (m1,m2) H; simpl in *.
now rewrite (add_comm n2), (add_comm m2).
Qed.

Instance sub_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.sub.
Proof.
intros n1 m1 H1 n2 m2 H2. rewrite 2 sub_add_opp. now do 2 f_equiv.
Qed.

Lemma mul_comm : forall n m, n*m == m*n.
Proof.
intros (n1,n2) (m1,m2); compute.
rewrite (add_comm (m1*n2)%N).
do 2 f_equiv; apply mul_comm.
Qed.

Instance mul_wd : Proper (Z.eq ==> Z.eq ==> Z.eq) Z.mul.
Proof.
assert (forall n, Proper (Z.eq ==> Z.eq) (Z.mul n)).
 unfold Z.mul, Z.eq. intros (n1,n2) (p1,p2) (q1,q2) H; simpl in *.
 rewrite add_shuffle1, (add_comm (n1*p1)%N).
 symmetry. rewrite add_shuffle1.
 rewrite <- ! mul_add_distr_l.
 rewrite (add_comm p2), (add_comm q2), H.
 reflexivity.
intros n n' Hn m m' Hm.
rewrite Hm, (mul_comm n), (mul_comm n'), Hn.
reflexivity.
Qed.

Section Induction.
Variable A : Z.t -> Prop.
Hypothesis A_wd : Proper (Z.eq==>iff) A.

Theorem bi_induction :
  A 0 -> (forall n, A n <-> A (Z.succ n)) -> forall n, A n.
Proof.
Open Scope NScope.
intros A0 AS n; unfold Z.zero, Z.succ, Z.eq in *.
destruct n as [n m].
cut (forall p, A (p, 0)); [intro H1 |].
cut (forall p, A (0, p)); [intro H2 |].
destruct (add_dichotomy n m) as [[p H] | [p H]].
rewrite (A_wd (n, m) (0, p)) by (rewrite add_0_l; now rewrite add_comm).
apply H2.
rewrite (A_wd (n, m) (p, 0)) by now rewrite add_0_r. apply H1.
induct p. assumption. intros p IH.
apply (A_wd (0, p) (1, N.succ p)) in IH; [| now rewrite add_0_l, add_1_l].
rewrite one_succ in IH. now apply AS.
induct p. assumption. intros p IH.
replace 0 with (snd (p, 0)); [| reflexivity].
replace (N.succ p) with (N.succ (fst (p, 0))); [| reflexivity]. now apply -> AS.
Close Scope NScope.
Qed.

End Induction.

(* Time to prove theorems in the language of Z *)

Theorem pred_succ : forall n, Z.pred (Z.succ n) == n.
Proof.
unfold Z.pred, Z.succ, Z.eq; intro n; simpl; now nzsimpl.
Qed.

Theorem succ_pred : forall n, Z.succ (Z.pred n) == n.
Proof.
intro n; unfold Z.succ, Z.pred, Z.eq; simpl; now nzsimpl.
Qed.

Theorem one_succ : 1 == Z.succ 0.
Proof.
unfold Z.eq; simpl. now nzsimpl'.
Qed.

Theorem two_succ : 2 == Z.succ 1.
Proof.
unfold Z.eq; simpl. now nzsimpl'.
Qed.

Theorem opp_0 : - 0 == 0.
Proof.
unfold Z.opp, Z.eq; simpl. now nzsimpl.
Qed.

Theorem opp_succ : forall n, - (Z.succ n) == Z.pred (- n).
Proof.
reflexivity.
Qed.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intro n; unfold Z.add, Z.eq; simpl. now nzsimpl.
Qed.

Theorem add_succ_l : forall n m, (Z.succ n) + m == Z.succ (n + m).
Proof.
intros n m; unfold Z.add, Z.eq; simpl. now nzsimpl.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intro n; unfold Z.sub, Z.eq; simpl. now nzsimpl.
Qed.

Theorem sub_succ_r : forall n m, n - (Z.succ m) == Z.pred (n - m).
Proof.
intros n m; unfold Z.sub, Z.eq; simpl. symmetry; now rewrite add_succ_r.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intros (n1,n2); unfold Z.mul, Z.eq; simpl; now nzsimpl.
Qed.

Theorem mul_succ_l : forall n m, (Z.succ n) * m == n * m + m.
Proof.
intros (n1,n2) (m1,m2); unfold Z.mul, Z.succ, Z.eq; simpl; nzsimpl.
rewrite <- (add_assoc _ m1), (add_comm m1), (add_assoc _ _ m1).
now rewrite <- (add_assoc _ m2), (add_comm m2), (add_assoc _ (n2*m1)%N m2).
Qed.

(** Order *)

Lemma lt_eq_cases : forall n m, n<=m <-> n<m \/ n==m.
Proof.
intros; apply N.lt_eq_cases.
Qed.

Theorem lt_irrefl : forall n, ~ (n < n).
Proof.
intros; apply N.lt_irrefl.
Qed.

Theorem lt_succ_r : forall n m, n < (Z.succ m) <-> n <= m.
Proof.
intros n m; unfold Z.lt, Z.le, Z.eq; simpl; nzsimpl. apply lt_succ_r.
Qed.

Theorem min_l : forall n m, n <= m -> Z.min n m == n.
Proof.
unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
rewrite min_l by assumption.
now rewrite <- add_assoc, (add_comm m2).
Qed.

Theorem min_r : forall n m, m <= n -> Z.min n m == m.
Proof.
unfold Z.min, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
rewrite min_r by assumption.
now rewrite add_assoc.
Qed.

Theorem max_l : forall n m, m <= n -> Z.max n m == n.
Proof.
unfold Z.max, Z.le, Z.eq; simpl; intros (n1,n2) (m1,m2) H; simpl in *.
rewrite max_l by assumption.
now rewrite <- add_assoc, (add_comm m2).
Qed.

Theorem max_r : forall n m, n <= m -> Z.max n m == m.
Proof.
unfold Z.max, Z.le, Z.eq; simpl; intros n m H.
rewrite max_r by assumption.
now rewrite add_assoc.
Qed.

Theorem lt_nge : forall n m, n < m <-> ~(m<=n).
Proof.
intros. apply lt_nge.
Qed.

Instance lt_wd : Proper (Z.eq ==> Z.eq ==> iff) Z.lt.
Proof.
assert (forall n, Proper (Z.eq==>iff) (Z.lt n)).
 intros (n1,n2). apply proper_sym_impl_iff; auto with *.
 unfold Z.lt, Z.eq; intros (r1,r2) (s1,s2) Eq H; simpl in *.
 apply le_lt_add_lt with (r1+r2)%N (r1+r2)%N; [apply le_refl; auto with *|].
 rewrite add_shuffle2, (add_comm s2), Eq.
 rewrite (add_comm s1 n2), (add_shuffle1 n2), (add_comm n2 r1).
 now rewrite <- add_lt_mono_r.
intros n n' Hn m m' Hm.
rewrite Hm. rewrite 2 lt_nge, 2 lt_eq_cases, Hn; auto with *.
Qed.

Definition t := Z.t.
Definition eq := Z.eq.
Definition zero := Z.zero.
Definition one := Z.one.
Definition two := Z.two.
Definition succ := Z.succ.
Definition pred := Z.pred.
Definition add := Z.add.
Definition sub := Z.sub.
Definition mul := Z.mul.
Definition opp := Z.opp.
Definition lt := Z.lt.
Definition le := Z.le.
Definition min := Z.min.
Definition max := Z.max.

End ZPairsAxiomsMod.

(* For example, let's build integers out of pairs of Peano natural numbers
and get their properties *)

(* The following lines increase the compilation time at least twice *)
(*
Require Import NPeano.

Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod NPeanoAxiomsMod.
Module Export ZPairsPropMod := ZPropFunct ZPairsPeanoAxiomsMod.

Eval compute in (3, 5) * (4, 6).
*)


(* Copyright (c) 2008, 2011, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* Types and notations presented in Chapter 6 *)

Set Implicit Arguments.

Notation "!" := (False_rec _ _) : specif_scope.
Notation "[ e ]" := (exist _ e _) : specif_scope.
Notation "x <== e1 ; e2" := (let (x, _) := e1 in e2)
(right associativity, at level 60) : specif_scope.

Local Open Scope specif_scope.
Delimit Scope specif_scope with specif.

Notation "'Yes'" := (left _ _) : specif_scope.
Notation "'No'" := (right _ _) : specif_scope.
Notation "'Reduce' x" := (if x then Yes else No) (at level 50) : specif_scope.

Notation "x || y" := (if x then Yes else Reduce y) (at level 50, left associativity) : specif_scope.

Section sumbool_and.
  Variables P1 Q1 P2 Q2 : Prop.

  Variable x1 : {P1} + {Q1}.
  Variable x2 : {P2} + {Q2}.

  Definition sumbool_and : {P1 /\ P2} + {Q1 \/ Q2} :=
    match x1 with
      | left HP1 =>
        match x2 with
          | left HP2 => left _ (conj HP1 HP2)
          | right HQ2 => right _ (or_intror _ HQ2)
        end
      | right HQ1 => right _ (or_introl _ HQ1)
    end.
End sumbool_and.

Infix "&&" := sumbool_and (at level 40, left associativity) : specif_scope.

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)) : specif_scope.
Notation "??" := (Unknown _) : specif_scope.
Notation "[| x |]" := (Found _ x _) : specif_scope.

Notation "x <- e1 ; e2" := (match e1 with
                             | Unknown => ??
                             | Found x _ => e2
                           end)
(right associativity, at level 60) : specif_scope.

Notation "!!" := (inright _ _) : specif_scope.
Notation "[|| x ||]" := (inleft _ [x]) : specif_scope.

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60) : specif_scope.

Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60) : specif_scope.

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60) : specif_scope.

Section partial.
  Variable P : Prop.

  Inductive partial : Set :=
  | Proved : P -> partial
  | Uncertain : partial.
End partial.

Notation "[ P ]" := (partial P) : type_scope.

Notation "'Yes'" := (Proved _) : partial_scope.
Notation "'No'" := (Uncertain _) : partial_scope.

Local Open Scope partial_scope.
Delimit Scope partial_scope with partial.

Notation "'Reduce' v" := (if v then Yes else No) : partial_scope.
Notation "x || y" := (if x then Yes else Reduce y) : partial_scope.
Notation "x && y" := (if x then Reduce y else No) : partial_scope.


(***
To successfully run this example, you need to install CoqExtLib.

This will work:

  cd ~
  git clone git@github.com:coq-community/coq-ext-lib.git --branch=v8.9
  cd coq-ext-lib
  make
  make install
***)

Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.Arith.
Require Import Omega.
Require Import List. Import ListNotations.
Local Open Scope string.

Require Export ExtLib.Structures.Monads.
Export MonadNotation.
Open Scope monad_scope.

(****
  State Monad
 ****)

Definition State := string -> nat.

Definition StateM X := State -> (X * State).

Definition initS : State :=
  (fun y => 0).

Definition updateS (s: State) (x: string) (v: nat) : State :=
  (fun y => if String.eqb x y then v else s x).

Instance StateMonad : Monad StateM :=
  {
    ret X x :=
      (fun s => (x, s));
    bind X Y (m: StateM X) (f: X -> StateM Y) :=
      (fun s =>
         let (x,s') := m s in
         f x s');
  }.

Definition runStateM {X} (m: StateM X) : X :=
  fst (m initS).

Fixpoint For (b n: nat) (body: nat -> StateM unit) : StateM unit :=
  match n with
  | 0 => ret tt
  | S n' => body b;;

Definition Read (name: string) : StateM nat :=
  (fun s => (s name, s)).

Definition Write (x: string) (v: nat) : StateM unit :=
  (fun s => (tt, updateS s x v)).

Definition summation n : StateM nat :=
  Write "sum" 0;;
  For 0 (n+1) (fun i =>
    sum <- Read "sum";;
    Write "sum" (sum + i)
  );;
  sum <- Read "sum";;
  ret sum
.

Compute (summation 100 : StateM nat).

Compute (runStateM (summation 100)).

(****
  IO Monad
 ****)

Inductive IOM (X: Type) : Type :=
| io_ret (x: X) : IOM X
| io_in (cont: nat -> IOM X) : IOM X
| io_out (n: nat) (cont: IOM X) : IOM X
.
Arguments io_ret {X}.
Arguments io_in {X}.
Arguments io_out {X}.

Fixpoint iobind {X Y} (m: IOM X) (f: X -> IOM Y) :=
  match m with
  | io_ret x => f x
  | io_in cont => io_in (fun n => iobind (cont n) f)
  | io_out n cont => io_out n (iobind cont f)
  end.

Instance IOMonad : Monad IOM :=
  {
    ret X x := io_ret x;
    bind X Y (m: IOM X) (f: X -> IOM Y) := iobind m f;
  }.

Fixpoint runIOM (m: IOM unit) (inputs: list nat) : list nat :=
  match m with
  | io_ret _ => []
  | io_in cont =>
    match inputs with
    | [] => []
    | n::inputs' => runIOM (cont n) inputs'
    end
  | io_out n cont =>
    n :: runIOM cont inputs
  end.

Definition Input : IOM nat :=
  io_in (fun n => io_ret n).

Definition Output (n: nat) : IOM unit :=
  io_out n (io_ret tt).

Fixpoint sum (n: nat) : nat :=
  match n with
  | 0 => 0
  | S n' => n + sum n'
  end.

Definition sumIO : IOM unit :=
  n <- Input;;
  Output (sum n);;
  m <- Input;;
  Output (sum (n+m)).

Compute runIOM sumIO [10; 10].

(****
  State Monad Transformer
 ****)

Definition StateMT (M: Type -> Type) X := State -> M (X * State)%type.

Instance StateMonadT {M} `{Monad M} : Monad (StateMT M) :=
  {
    ret X x :=
      (fun s => ret (x, s));
    bind X Y (m: StateMT M X) (f: X -> StateMT M Y) :=
      (fun s =>
         xs' <- m s;;
         f (fst xs') (snd xs'));
  }.

Definition runStateMT {M} `{Monad M} {X} (m: StateMT M X) : M X :=
  xs <- m initS;; ret (fst xs).

Definition LiftT {M} `{Monad M} {X} : M X -> StateMT M X :=
  (fun m s => x <- m;; ret (x, s)).

Fixpoint ForT {M} `{Monad M} (b n: nat) (body: nat -> StateMT M unit) : StateMT M unit :=
  match n with
  | 0 => ret tt
  | S n' => body b;;
            ForT (1+b) n' body
  end.

Definition ReadT {M} `{Monad M} (name: string) : StateMT M nat :=
  (fun s => ret (s name, s)).

Definition WriteT {M} `{Monad M} (x: string) (v: nat) : StateMT M unit :=
  (fun s => ret (tt, updateS s x v)).

Definition sumIOSt : StateMT IOM unit :=
  n <- LiftT Input;;
  WriteT "sum" 0;;
  ForT 0 (n+1) (fun i =>
    sum <- ReadT "sum";;
    WriteT "sum" (sum + i)
  );;
  sum <- ReadT "sum";;
  LiftT (Output sum).

Compute (runIOM (runStateMT sumIOSt) [100]).


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Language Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.

Set Printing Parentheses.

(** * Definitions *)

(** ** Arguments *)

Inductive arg :=
| Avt : type -> arg.

(** ** Applicative Subtyping (Binary) *)

Inductive auxas : option arg -> type -> Prop :=
| Aas_Refl : forall A,
    auxas None A
| Aas_Arr : forall A B C,
    sub C A ->
    auxas (Some (Avt C)) (Arr A B)
| Aas_And_L : forall A B S,
    auxas (Some S) A ->
    auxas (Some S) (And A B)
| Aas_And_R : forall A B S,
    auxas (Some S) B ->
    auxas (Some S) (And A B).

Hint Constructors auxas : core.
Notation "appsub? S A" := (auxas S A) (at level 40).

(** ** Applicative Subtyping *)

Inductive appsub : option arg -> type -> type -> Prop :=
| As_Refl : forall A,
    appsub None A A
| As_Arr : forall A B C,
    sub C A ->
    appsub (Some (Avt C)) (Arr A B) B
| As_And_L : forall A B C D,
    appsub (Some C) A D ->
    not (auxas (Some C) B) ->
    appsub (Some C) (And A B) D
| As_And_R : forall A B C D,
    appsub (Some C) B D ->
    not (auxas (Some C) A) ->
    appsub (Some C) (And A B) D
| As_And_P : forall A B C D1 D2,
    appsub (Some C) A D1 ->
    appsub (Some C) B D2 ->
    appsub (Some C) (And A B) (And D1 D2).

Hint Constructors appsub : core.
Notation "S ⊢ A <: B" := (appsub S A B) (at level 40).

(** * Automations *)

(** ** Structural Inversions *)

Ltac solve_auxas :=
  match goal with
  | [H: auxas _ Int |- _] => (inversion H)
  | [H: auxas _ Top |- _] => (inversion H)
  end.

Ltac solve_appsub :=
  match goal with
  | [H: appsub _ Int _ |- _] => (inversion H)
  | [H: appsub _ Top _ |- _] => (inversion H)
  end.

Hint Extern 5 => solve_auxas : core.
Hint Extern 5 => solve_appsub : core.

(** ** Contradictions *)

Lemma appsub_to_auxas :
  forall A B S,
    appsub S A B ->
    auxas S A.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve appsub_to_auxas : core.

Lemma auxas_false :
  forall A B S,
    not (auxas S A) ->
    appsub S A B ->
    False.
Proof.
  intros.
  eapply appsub_to_auxas in H0.
  contradiction.
Qed.

Ltac contra_appsub :=
  match goal with
  | [H1: not (auxas ?S ?A), H2: appsub ?S ?A _ |- _] =>
      (pose proof (auxas_false _ _ _ H1 H2) as Contra; inversion Contra)
  | [H1: not (auxas ?S ?A), H2: auxas ?S ?A |- _] =>
      (contradiction)
  end.

Hint Extern 5 => contra_appsub : core.

(** * Properties *)

(** ** Determinism *)

Lemma appsub_determinism :
  forall A B1 B2 S,
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  introv As1 As2. gen B2.
  dependent induction As1; intros;
    dependent destruction As2; eauto.
  pose proof (IHAs1_1 _ As2_1).
  pose proof (IHAs1_2 _ As2_2).
  congruence.
Qed.

(** ** Completeness *)

Lemma appsub_complete :
  forall A B C,
    appsub (Some (Avt B)) A C -> sub A (Arr B C).
Proof.
  introv As.
  dependent induction As; eauto.
  - pose proof (IHAs1 B).
    pose proof (IHAs2 B).
    eapply Sub_And; eauto.
Qed.

(** * Appsub & Isomorphic Subtyping *)

(** ** Inversion Lemmas *)

Lemma appsub_split_inversion :
  forall A B C B1 B2,
    appsub (Some A) B C ->
    splitable B B1 B2 ->
    (appsub (Some A) B1 C) /\ (not (auxas (Some A) B2)) \/
      (appsub (Some A) B2 C) /\ (not (auxas (Some A) B1)) \/
      (exists C1 C2, (appsub (Some A) B1 C1) /\ (appsub (Some A) B2 C2) /\ (isosub (And C1 C2) C)).
Proof.
  introv Has Hspl.
  gen A C B1 B2.
  proper_ind B; intros; eauto. subst_splitable.
  dependent destruction Hspl; eauto.
  - Case "And".
    dependent destruction Has; eauto.
    right. right. exists D1. exists D2.
    split; eauto.
  - Case "Arr".
    right. right.
    dependent destruction Has.
    pose proof (As_Arr _ B1 _ H) as As1.
    pose proof (As_Arr _ B2 _ H) as As2.
    pose proof (IHPr1 _ _ As1).
    pose proof (IHPr2 _ _ As2).
    dependent destruction Hspl.
    * exists A0. exists B. split; eauto.
    * exists (Arr A0 B1). exists (Arr A0 B2).
      split; eauto.
Qed.

(** ** Arguments *)

Lemma auxas_iso1 :
  forall A B H,
    auxas (Some (Avt A)) B ->
    isosub A H ->
    auxas (Some (Avt H)) B.
Proof.
  introv Aas Isub.
  gen A H.
  proper_ind B; intros; eauto.
  - Case "Arr".
    dependent destruction Aas.
    pose proof (isosub_sound _ _ Isub) as Isub'.
    destruct Isub'.
    eapply Aas_Arr.
    eapply sub_transitivity; eauto.
  - Case "Split".
    dependent destruction Aas.
    + econstructor.
      eapply isosub_to_sub2 in Isub.
      eapply sub_transitivity; eauto.
    + dependent destruction H; eauto.
    + dependent destruction H; eauto.
Qed.

Lemma appsub_iso1 :
  forall A B C H,
    appsub (Some (Avt A)) B C ->
    isosub H A ->
    exists D, appsub (Some (Avt H)) B D /\ isosub D C.
Proof.
  introv As Isub.
  pose proof (isosub_to_sub1 _ _ Isub).
  exists C. split; eauto.
  dependent induction As.
  - eapply As_Arr; eauto.
    eapply sub_transitivity; eauto.
  - eapply As_And_L; eauto.
    intros Contra. eapply auxas_iso1 in Contra; eauto.
  - eapply As_And_R; eauto.
    intros Contra. eapply auxas_iso1 in Contra; eauto.
  - eapply As_And_P; eauto.
Qed.

(** ** Functions *)

Lemma auxas_iso2 :
  forall A B H,
    auxas (Some (Avt A)) B ->
    isosub B H ->
    auxas (Some (Avt A)) H.
Proof.
  introv As Isub. gen A H.
  proper_ind B; intros; eauto.
  - Case "Arr".
    dependent destruction Isub. eauto.
  - Case "Split".
    dependent destruction H.
    + SCase "And".
      dependent destruction Isub.
      * SSCase "Refl".
        assumption.
      * SSCase "Split".
        (* H have two cases: arrow and intersection *)
        dependent destruction H.
        ** SSSCase "And".
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1). eauto.
           *** pose proof (IHPr2 _ As _ Isub2). eauto.
        ** SSSCase "Arr".
           eapply Aas_Arr; eauto.
           dependent destruction As.
           *** pose proof (IHPr1 _ As _ Isub1).
               dependent destruction H0; eauto.
           *** pose proof (IHPr2 _ As _ Isub2).
               dependent destruction H0; eauto.
    + SCase "Arr".
      dependent destruction Isub; eauto.
Qed.

Lemma appsub_iso2 :
  forall A B C H,
    appsub (Some (Avt A)) B C ->
    isosub H B ->
    (exists D, appsub (Some (Avt A)) H D /\ isosub D C).
Proof.
  introv As Isub. gen A C H.
  proper_ind B; intros; eauto.
  - Case "Arrow".
    dependent destruction Isub; eauto.
  - Case "Split".
    dependent destruction Isub; eauto.
    subst_splitable.
    eapply appsub_split_inversion in H0; eauto.
    destruct H0.
    + SCase "L".
      destruct H.
      pose proof (IHPr1 _ _ H _ Isub1).
      destruct H1. destruct H1.
      exists x. split; eauto. eapply As_And_L; eauto.
      intros Hcontra. eapply auxas_iso2 in Hcontra; eauto.
    + destruct H.
      * SCase "R".
        destruct H.
        pose proof (IHPr2 _ _ H _ Isub2).
        destruct H1. destruct H1.
        exists x. split; eauto. eapply As_And_R; eauto.
        intros Hcontra. eapply auxas_iso2 in Hcontra; eauto.
      * SCase "P".
        destruct H. destruct H. destruct H. destruct H0.
        pose proof (IHPr1 _ _ H _ Isub1).
        pose proof (IHPr2 _ _ H0 _ Isub2).
        destruct H2. destruct H2. destruct H3. destruct H3.
        exists (And x1 x2). split.
        ** eapply As_And_P; eauto.
        ** assert (isosub (And x1 x2) (And x x0)) by eauto.
           eapply isosub_transitivity; eauto.
Qed.

(** ** Generalization *)

Lemma appsub_iso :
  forall A B C H1 H2,
    appsub (Some (Avt A)) B C ->
    isosub H1 A ->
    isosub H2 B ->
    (exists D, appsub (Some (Avt H1)) H2 D /\ isosub D C).
Proof.
  introv As Isub1 Isub2.
  pose proof (appsub_iso1 A B C H1 As Isub1) as Iso1.
  destruct Iso1. destruct H.
  pose proof (appsub_iso2 _ _ _ _ H Isub2).
  destruct_conjs. eexists. split; eauto.
  eapply isosub_transitivity; eauto.
Qed.

(** * Unified Subtyping *)

(** ** Definition *)

Definition result := option type.

Inductive upartype : Set :=
| uT : type -> upartype
| uV : arg -> upartype
| uP : arg -> upartype.

Inductive uunisub : type -> upartype -> result -> Prop :=
| UUs_Int :
    uunisub Int (uT Int) None
| UUs_Top : forall A,
    uunisub A (uT Top) None
| UUs_Arr : forall A B C D,
    uunisub C (uT A) None ->
    uunisub B (uT D) None ->
    uunisub (Arr A B) (uT (Arr C D)) None
| UUs_And : forall A B B1 B2,
    splitable B B1 B2 ->
    uunisub A (uT B1) None ->
    uunisub A (uT B2) None ->
    uunisub A (uT B) None
| UUs_And_L : forall A B C,
    ordinary C ->
    uunisub A (uT C) None ->
    uunisub (And A B) (uT C) None
| UUs_And_R : forall A B C,
    ordinary C ->
    uunisub B (uT C) None ->
    uunisub (And A B) (uT C) None
| UUs_As_Arr : forall A1 A2 B,
    uunisub B (uT A1) None ->
    uunisub (Arr A1 A2) (uP (Avt B)) (Some A2)
| UUs_As_L : forall A1 A2 S C,
    uunisub A1 (uP S) (Some C) ->
    ~ (auxas (Some S) A2) ->
    uunisub (And A1 A2) (uP S) (Some C)
| UUs_As_R : forall A1 A2 S C,
    uunisub A2 (uP S) (Some C) ->
    ~ (auxas (Some S) A1) ->
    uunisub (And A1 A2) (uP S) (Some C)
| UUs_As_P : forall A1 A2 S C1 C2,
    uunisub A1 (uP S) (Some C1) ->
    uunisub A2 (uP S) (Some C2) ->
    uunisub (And A1 A2) (uP S) (Some (And C1 C2))
| UUs_V_As_Arr : forall A1 A2 B,
    uunisub B (uT A1) None ->
    uunisub (Arr A1 A2) (uV (Avt B)) None
| UUs_V_As_L : forall A1 A2 S,
    uunisub A1 (uV S) None ->
    uunisub (And A1 A2) (uV S) None
| UUs_V_As_R : forall A1 A2 S,
    uunisub A2 (uV S) None ->
    uunisub (And A1 A2) (uV S) None.

Hint Constructors uunisub : core.

(** ** Soundness *)

Lemma uunisub_sound_normal :
  forall A B,
    uunisub A (uT B) None ->
    sub A B.
Proof.
  introv Uusub.
  dependent induction Uusub; eauto.
Qed.

Lemma uunisub_sound_appsub :
  forall A S C,
    uunisub A (uP S) (Some C) ->
    appsub (Some S) A C.
Proof.
  introv UUsub.
  dependent induction UUsub; eauto.
  eapply As_Arr.
  now eapply uunisub_sound_normal.
Qed.

Lemma uunisub_sound_auxas :
  forall A S,
    uunisub A (uV S) None ->
    auxas (Some S) A.
Proof.
  introv Uusub.
  dependent induction Uusub; eauto.
  eapply Aas_Arr.
  now eapply uunisub_sound_normal.
Qed.

(** ** Completeness *)

Lemma uunisub_complete_normal :
  forall A B,
    sub A B ->
    uunisub A (uT B) None.
Proof.
  introv Sub.
  dependent induction Sub; eauto.
Qed.

Lemma uunisub_complete_appsub :
  forall A S B,
    appsub (Some S) A B ->
    uunisub A (uP S) (Some B).
Proof.
  introv As.
  dependent induction As; eauto.
  eapply UUs_As_Arr.
  now eapply uunisub_complete_normal.
Qed.

Lemma uunisub_complete_auxas :
  forall A S,
    auxas (Some S) A ->
    uunisub A (uV S) None.
Proof.
  introv Aas.
  dependent induction Aas; eauto.
  eapply UUs_V_As_Arr.
  now eapply uunisub_complete_normal.
Qed.

(** * Automations *)

Lemma uunisub_auxas_false1 :
  forall B S,
    ~ uunisub B (uV S) None ->
    auxas (Some S) B ->
    False.
Proof.
  introv nUs Aux.
  eapply uunisub_complete_auxas in Aux. contradiction.
Qed.

Lemma uunisub_auxas_false2 :
  forall S B,
    uunisub B (uV S) None ->
    ~ auxas (Some S) B ->
    False.
Proof.
  introv Us nAux.
  eapply nAux. now eapply uunisub_sound_auxas.
Qed.

Lemma uunisub_appsub_false :
  forall S B C,
    ~ uunisub B (uV S) None ->
    appsub (Some S) B C ->
    False.
Proof.
  introv nUs As.
  eapply appsub_to_auxas in As.
  eapply uunisub_auxas_false1; eauto.
Qed.

Ltac contra_uunisub :=
  match goal with
  | H1: ~ uunisub ?B (uV ?S) _, H2: auxas (Some ?S) ?B |- _ =>
      pose proof (uunisub_auxas_false1 _ _ H1 H2) as Contra; inversion Contra
  | H1: uunisub ?B (uV ?S) _, H2: ~ auxas (Some ?S) ?B |- _ =>
      pose proof (uunisub_auxas_false2 _ _ H1 H2) as Contra; inversion Contra
  | H1: ~ uunisub ?B (uV ?S) _, H2: appsub (Some ?S) ?B _ |- _ =>
      pose proof (uunisub_appsub_false _ _ _ H1 H2) as Contra; inversion Contra
  end.

Hint Extern 5 => contra_uunisub : core.

Lemma appsub_to_uunisub :
  forall S A C,
    appsub (Some S) A C ->
    uunisub A (uV S) None.
Proof.
  introv As.
  eapply appsub_to_auxas in As.
  now eapply uunisub_complete_auxas.
Qed.

Hint Resolve appsub_to_uunisub : core.