Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6a.
Require Export lemma__3__7a.
Require Export lemma__ABCequalsCBA.
Require Export lemma__betweennotequal.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__differenceofparts.
Require Export lemma__doublereverse.
Require Export lemma__equalanglesNC.
Require Export lemma__equalanglestransitive.
Require Export lemma__extensionunique.
Require Export lemma__layoffunique.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export lemma__outerconnectivity.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export logic.
Require Export proposition__04.
Require Export proposition__15.
Definition lemma__pointreflectionisometry : forall A B C P Q, (euclidean__defs.Midpoint A B C) -> ((euclidean__defs.Midpoint P B Q) -> ((euclidean__axioms.neq A P) -> (euclidean__axioms.Cong A P C Q))).
Proof.
intro A.
intro B.
intro C.
intro P.
intro Q.
intro H.
intro H0.
intro H1.
assert (* Cut *) ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H2.
- assert ((euclidean__axioms.BetS P B Q) /\ (euclidean__axioms.Cong P B B Q)) as H2 by exact H0.
assert ((euclidean__axioms.BetS P B Q) /\ (euclidean__axioms.Cong P B B Q)) as __TmpHyp by exact H2.
destruct __TmpHyp as [H3 H4].
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H5 by exact H.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp0 by exact H5.
destruct __TmpHyp0 as [H6 H7].
split.
-- exact H6.
-- exact H7.
- assert (* Cut *) ((euclidean__axioms.BetS P B Q) /\ (euclidean__axioms.Cong P B B Q)) as H3.
-- assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H3 by exact H2.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp by exact H3.
destruct __TmpHyp as [H4 H5].
assert ((euclidean__axioms.BetS P B Q) /\ (euclidean__axioms.Cong P B B Q)) as H6 by exact H0.
assert ((euclidean__axioms.BetS P B Q) /\ (euclidean__axioms.Cong P B B Q)) as __TmpHyp0 by exact H6.
destruct __TmpHyp0 as [H7 H8].
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H9 by exact H.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp1 by exact H9.
destruct __TmpHyp1 as [H10 H11].
split.
--- exact H7.
--- exact H8.
-- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H4.
--- assert (* Cut *) ((euclidean__axioms.Col A B P) \/ (euclidean__axioms.nCol A B P)) as H4.
---- apply (@euclidean__tactics.Col__or__nCol A B P).
---- assert ((euclidean__axioms.Col A B P) \/ (euclidean__axioms.nCol A B P)) as H5 by exact H4.
assert ((euclidean__axioms.Col A B P) \/ (euclidean__axioms.nCol A B P)) as __TmpHyp by exact H5.
destruct __TmpHyp as [H6|H6].
----- assert (* Cut *) ((A = B) \/ ((A = P) \/ ((B = P) \/ ((euclidean__axioms.BetS B A P) \/ ((euclidean__axioms.BetS A B P) \/ (euclidean__axioms.BetS A P B)))))) as H7.
------ destruct H3 as [H7 H8].
destruct H2 as [H9 H10].
exact H6.
------ assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H8.
------- assert ((A = B) \/ ((A = P) \/ ((B = P) \/ ((euclidean__axioms.BetS B A P) \/ ((euclidean__axioms.BetS A B P) \/ (euclidean__axioms.BetS A P B)))))) as H8 by exact H7.
assert ((A = B) \/ ((A = P) \/ ((B = P) \/ ((euclidean__axioms.BetS B A P) \/ ((euclidean__axioms.BetS A B P) \/ (euclidean__axioms.BetS A P B)))))) as __TmpHyp0 by exact H8.
destruct __TmpHyp0 as [H9|H9].
-------- assert (* Cut *) (~(~(euclidean__axioms.Cong A P C Q))) as H10.
--------- intro H10.
assert (* Cut *) (euclidean__axioms.BetS A B C) as H11.
---------- destruct H3 as [H11 H12].
destruct H2 as [H13 H14].
destruct H0 as [H15 H16].
destruct H as [H17 H18].
exact H13.
---------- assert (* Cut *) (euclidean__axioms.neq A B) as H12.
----------- destruct H3 as [H12 H13].
destruct H2 as [H14 H15].
assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A C))) as H16.
------------ apply (@lemma__betweennotequal.lemma__betweennotequal A B C H11).
------------ destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
----------- apply (@H12 H9).
--------- apply (@euclidean__tactics.NNPP (euclidean__axioms.Cong A P C Q)).
----------intro H11.
destruct H2 as [H12 H13].
destruct H3 as [H14 H15].
assert (* Cut *) (False) as H16.
----------- apply (@H10 H11).
----------- contradiction H16.

-------- destruct H9 as [H10|H10].
--------- assert (* Cut *) (~(~(euclidean__axioms.Cong A P C Q))) as H11.
---------- intro H11.
apply (@H1 H10).
---------- apply (@euclidean__tactics.NNPP (euclidean__axioms.Cong A P C Q)).
-----------intro H12.
destruct H2 as [H13 H14].
destruct H3 as [H15 H16].
assert (* Cut *) (False) as H17.
------------ apply (@H1 H10).
------------ assert (* Cut *) (False) as H18.
------------- apply (@H11 H12).
------------- contradiction H18.

--------- destruct H10 as [H11|H11].
---------- assert (* Cut *) (~(~(euclidean__axioms.Cong A P C Q))) as H12.
----------- intro H12.
assert (* Cut *) (euclidean__axioms.neq P B) as H13.
------------ destruct H3 as [H13 H14].
destruct H2 as [H15 H16].
assert (* Cut *) ((euclidean__axioms.neq B Q) /\ ((euclidean__axioms.neq P B) /\ (euclidean__axioms.neq P Q))) as H17.
------------- apply (@lemma__betweennotequal.lemma__betweennotequal P B Q H13).
------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H20.
------------ assert (* Cut *) (euclidean__axioms.neq B P) as H14.
------------- destruct H3 as [H14 H15].
destruct H2 as [H16 H17].
apply (@eq__ind__r euclidean__axioms.Point P (fun B0 => (euclidean__defs.Midpoint A B0 C) -> ((euclidean__defs.Midpoint P B0 Q) -> ((euclidean__axioms.BetS A B0 C) -> ((euclidean__axioms.Cong A B0 B0 C) -> ((euclidean__axioms.BetS P B0 Q) -> ((euclidean__axioms.Cong P B0 B0 Q) -> ((euclidean__axioms.Col A B0 P) -> ((euclidean__axioms.neq P B0) -> (euclidean__axioms.neq B0 P)))))))))) with (x := B).
--------------intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
intro H25.
exact H25.

-------------- exact H11.
-------------- exact H.
-------------- exact H0.
-------------- exact H16.
-------------- exact H17.
-------------- exact H14.
-------------- exact H15.
-------------- exact H6.
-------------- exact H13.
------------- apply (@H14 H11).
----------- apply (@euclidean__tactics.NNPP (euclidean__axioms.Cong A P C Q)).
------------intro H13.
destruct H2 as [H14 H15].
destruct H3 as [H16 H17].
assert (* Cut *) (False) as H18.
------------- apply (@H12 H13).
------------- contradiction H18.

---------- destruct H11 as [H12|H12].
----------- assert (* Cut *) (euclidean__axioms.Cong B C A B) as H13.
------------ destruct H3 as [H13 H14].
destruct H2 as [H15 H16].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B A B C H16).
------------ assert (* Cut *) (euclidean__axioms.Cong B C B A) as H14.
------------- destruct H3 as [H14 H15].
destruct H2 as [H16 H17].
assert (* Cut *) ((euclidean__axioms.Cong C B B A) /\ ((euclidean__axioms.Cong C B A B) /\ (euclidean__axioms.Cong B C B A))) as H18.
-------------- apply (@lemma__congruenceflip.lemma__congruenceflip B C A B H13).
-------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H22.
------------- assert (* Cut *) (euclidean__axioms.Cong Q B B P) as H15.
-------------- destruct H3 as [H15 H16].
destruct H2 as [H17 H18].
assert (* Cut *) ((euclidean__axioms.Cong Q B B P) /\ (euclidean__axioms.Cong B P Q B)) as H19.
--------------- apply (@lemma__doublereverse.lemma__doublereverse P B B Q H16).
--------------- destruct H19 as [H20 H21].
exact H20.
-------------- assert (* Cut *) (euclidean__axioms.Cong B Q B P) as H16.
--------------- destruct H3 as [H16 H17].
destruct H2 as [H18 H19].
assert (* Cut *) ((euclidean__axioms.Cong B Q P B) /\ ((euclidean__axioms.Cong B Q B P) /\ (euclidean__axioms.Cong Q B P B))) as H20.
---------------- apply (@lemma__congruenceflip.lemma__congruenceflip Q B B P H15).
---------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H23.
--------------- assert (* Cut *) (euclidean__axioms.Cong B A C B) as H17.
---------------- destruct H3 as [H17 H18].
destruct H2 as [H19 H20].
assert (* Cut *) ((euclidean__axioms.Cong B A C B) /\ (euclidean__axioms.Cong C B B A)) as H21.
----------------- apply (@lemma__doublereverse.lemma__doublereverse B C A B H13).
----------------- destruct H21 as [H22 H23].
exact H22.
---------------- assert (* Cut *) (euclidean__defs.Lt C B B P) as H18.
----------------- exists A.
split.
------------------ exact H12.
------------------ exact H17.
----------------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H19.
------------------ destruct H3 as [H19 H20].
destruct H2 as [H21 H22].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B Q P H16).
------------------ assert (* Cut *) (euclidean__defs.Lt C B B Q) as H20.
------------------- destruct H3 as [H20 H21].
destruct H2 as [H22 H23].
apply (@lemma__lessthancongruence.lemma__lessthancongruence C B B P B Q H18 H19).
------------------- assert (* Cut *) (euclidean__axioms.Cong C B B C) as H21.
-------------------- destruct H3 as [H21 H22].
destruct H2 as [H23 H24].
apply (@euclidean__axioms.cn__equalityreverse C B).
-------------------- assert (* Cut *) (euclidean__defs.Lt B C B Q) as H22.
--------------------- destruct H3 as [H22 H23].
destruct H2 as [H24 H25].
apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C B B Q B C H20 H21).
--------------------- assert (* Cut *) (euclidean__axioms.Cong B Q B Q) as H23.
---------------------- destruct H3 as [H23 H24].
destruct H2 as [H25 H26].
apply (@euclidean__axioms.cn__congruencereflexive B Q).
---------------------- assert (* Cut *) (euclidean__axioms.neq B Q) as H24.
----------------------- destruct H3 as [H24 H25].
destruct H2 as [H26 H27].
assert (* Cut *) ((euclidean__axioms.neq B Q) /\ ((euclidean__axioms.neq P B) /\ (euclidean__axioms.neq P Q))) as H28.
------------------------ apply (@lemma__betweennotequal.lemma__betweennotequal P B Q H24).
------------------------ destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H29.
----------------------- assert (* Cut *) (exists H25, (euclidean__axioms.BetS B H25 Q) /\ (euclidean__axioms.Cong B H25 B C)) as H25.
------------------------ destruct H3 as [H25 H26].
destruct H2 as [H27 H28].
exact H22.
------------------------ destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H3 as [H30 H31].
destruct H2 as [H32 H33].
assert (* Cut *) (euclidean__defs.Out B Q H26) as H34.
------------------------- apply (@lemma__ray4.lemma__ray4 B Q H26).
--------------------------left.
exact H28.

-------------------------- exact H24.
------------------------- assert (* Cut *) (euclidean__axioms.BetS P A B) as H35.
-------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B A P H12).
-------------------------- assert (* Cut *) (euclidean__axioms.BetS P B C) as H36.
--------------------------- apply (@lemma__3__7a.lemma__3__7a P A B C H35 H32).
--------------------------- assert (* Cut *) (euclidean__defs.Out B C Q) as H37.
---------------------------- exists P.
split.
----------------------------- exact H30.
----------------------------- exact H36.
---------------------------- assert (* Cut *) (euclidean__defs.Out B Q C) as H38.
----------------------------- apply (@lemma__ray5.lemma__ray5 B C Q H37).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong B C B H26) as H39.
------------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B H26 C H29).
------------------------------ assert (* Cut *) (C = H26) as H40.
------------------------------- apply (@lemma__layoffunique.lemma__layoffunique B Q C H26 H38 H34 H39).
------------------------------- assert (* Cut *) (euclidean__axioms.BetS B C Q) as H41.
-------------------------------- apply (@eq__ind__r euclidean__axioms.Point H26 (fun C0 => (euclidean__defs.Midpoint A B C0) -> ((euclidean__axioms.BetS A B C0) -> ((euclidean__axioms.Cong A B B C0) -> ((euclidean__axioms.Cong B C0 A B) -> ((euclidean__axioms.Cong B C0 B A) -> ((euclidean__axioms.Cong B A C0 B) -> ((euclidean__defs.Lt C0 B B P) -> ((euclidean__defs.Lt C0 B B Q) -> ((euclidean__axioms.Cong C0 B B C0) -> ((euclidean__defs.Lt B C0 B Q) -> ((euclidean__axioms.Cong B H26 B C0) -> ((euclidean__axioms.BetS P B C0) -> ((euclidean__defs.Out B C0 Q) -> ((euclidean__defs.Out B Q C0) -> ((euclidean__axioms.Cong B C0 B H26) -> (euclidean__axioms.BetS B C0 Q))))))))))))))))) with (x := C).
---------------------------------intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
exact H28.

--------------------------------- exact H40.
--------------------------------- exact H.
--------------------------------- exact H32.
--------------------------------- exact H33.
--------------------------------- exact H13.
--------------------------------- exact H14.
--------------------------------- exact H17.
--------------------------------- exact H18.
--------------------------------- exact H20.
--------------------------------- exact H21.
--------------------------------- exact H22.
--------------------------------- exact H29.
--------------------------------- exact H36.
--------------------------------- exact H37.
--------------------------------- exact H38.
--------------------------------- exact H39.
-------------------------------- assert (* Cut *) (euclidean__axioms.BetS B A P) as H42.
--------------------------------- apply (@eq__ind__r euclidean__axioms.Point H26 (fun C0 => (euclidean__defs.Midpoint A B C0) -> ((euclidean__axioms.BetS A B C0) -> ((euclidean__axioms.Cong A B B C0) -> ((euclidean__axioms.Cong B C0 A B) -> ((euclidean__axioms.Cong B C0 B A) -> ((euclidean__axioms.Cong B A C0 B) -> ((euclidean__defs.Lt C0 B B P) -> ((euclidean__defs.Lt C0 B B Q) -> ((euclidean__axioms.Cong C0 B B C0) -> ((euclidean__defs.Lt B C0 B Q) -> ((euclidean__axioms.Cong B H26 B C0) -> ((euclidean__axioms.BetS P B C0) -> ((euclidean__defs.Out B C0 Q) -> ((euclidean__defs.Out B Q C0) -> ((euclidean__axioms.Cong B C0 B H26) -> ((euclidean__axioms.BetS B C0 Q) -> (euclidean__axioms.BetS B A P)))))))))))))))))) with (x := C).
----------------------------------intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
exact H12.

---------------------------------- exact H40.
---------------------------------- exact H.
---------------------------------- exact H32.
---------------------------------- exact H33.
---------------------------------- exact H13.
---------------------------------- exact H14.
---------------------------------- exact H17.
---------------------------------- exact H18.
---------------------------------- exact H20.
---------------------------------- exact H21.
---------------------------------- exact H22.
---------------------------------- exact H29.
---------------------------------- exact H36.
---------------------------------- exact H37.
---------------------------------- exact H38.
---------------------------------- exact H39.
---------------------------------- exact H41.
--------------------------------- assert (* Cut *) (euclidean__axioms.Cong B A B C) as H43.
---------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B C A H14).
---------------------------------- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H44.
----------------------------------- apply (@lemma__differenceofparts.lemma__differenceofparts B A P B C Q H43 H19 H42 H41).
----------------------------------- exact H44.
----------- destruct H12 as [H13|H13].
------------ assert (* Cut *) (~(~(euclidean__axioms.Cong A P C Q))) as H14.
------------- intro H14.
assert (* Cut *) (~(euclidean__axioms.BetS B P C)) as H15.
-------------- intro H15.
assert (* Cut *) (euclidean__axioms.BetS C P B) as H16.
--------------- destruct H3 as [H16 H17].
destruct H2 as [H18 H19].
apply (@euclidean__axioms.axiom__betweennesssymmetry B P C H15).
--------------- assert (* Cut *) (euclidean__axioms.BetS C B Q) as H17.
---------------- destruct H3 as [H17 H18].
destruct H2 as [H19 H20].
apply (@lemma__3__7a.lemma__3__7a C P B Q H16 H17).
---------------- assert (* Cut *) (euclidean__axioms.Cong A B C B) as H18.
----------------- destruct H3 as [H18 H19].
destruct H2 as [H20 H21].
assert (* Cut *) ((euclidean__axioms.Cong B A C B) /\ ((euclidean__axioms.Cong B A B C) /\ (euclidean__axioms.Cong A B C B))) as H22.
------------------ apply (@lemma__congruenceflip.lemma__congruenceflip A B B C H21).
------------------ destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H26.
----------------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H19.
------------------ destruct H3 as [H19 H20].
destruct H2 as [H21 H22].
assert (* Cut *) ((euclidean__axioms.Cong B P Q B) /\ ((euclidean__axioms.Cong B P B Q) /\ (euclidean__axioms.Cong P B Q B))) as H23.
------------------- apply (@lemma__congruenceflip.lemma__congruenceflip P B B Q H20).
------------------- destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H26.
------------------ assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H20.
------------------- destruct H3 as [H20 H21].
destruct H2 as [H22 H23].
apply (@euclidean__axioms.cn__sumofparts A B P C B Q H18 H19 H13 H17).
------------------- apply (@H14 H20).
-------------- assert (* Cut *) (~(euclidean__axioms.BetS B C P)) as H16.
--------------- intro H16.
assert (* Cut *) (euclidean__axioms.BetS A B P) as H17.
---------------- destruct H3 as [H17 H18].
destruct H2 as [H19 H20].
exact H13.
---------------- assert (* Cut *) (euclidean__axioms.BetS Q B P) as H18.
----------------- destruct H3 as [H18 H19].
destruct H2 as [H20 H21].
apply (@euclidean__axioms.axiom__betweennesssymmetry P B Q H18).
----------------- assert (* Cut *) (euclidean__axioms.BetS Q B C) as H19.
------------------ destruct H3 as [H19 H20].
destruct H2 as [H21 H22].
apply (@euclidean__axioms.axiom__innertransitivity Q B C P H18 H16).
------------------ assert (* Cut *) (euclidean__axioms.BetS C B Q) as H20.
------------------- destruct H3 as [H20 H21].
destruct H2 as [H22 H23].
apply (@euclidean__axioms.axiom__betweennesssymmetry Q B C H19).
------------------- assert (* Cut *) (euclidean__axioms.Cong A B C B) as H21.
-------------------- destruct H3 as [H21 H22].
destruct H2 as [H23 H24].
assert (* Cut *) ((euclidean__axioms.Cong B A C B) /\ ((euclidean__axioms.Cong B A B C) /\ (euclidean__axioms.Cong A B C B))) as H25.
--------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A B B C H24).
--------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H29.
-------------------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H22.
--------------------- destruct H3 as [H22 H23].
destruct H2 as [H24 H25].
assert (* Cut *) ((euclidean__axioms.Cong B P Q B) /\ ((euclidean__axioms.Cong B P B Q) /\ (euclidean__axioms.Cong P B Q B))) as H26.
---------------------- apply (@lemma__congruenceflip.lemma__congruenceflip P B B Q H23).
---------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H29.
--------------------- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H23.
---------------------- destruct H3 as [H23 H24].
destruct H2 as [H25 H26].
apply (@euclidean__axioms.cn__sumofparts A B P C B Q H21 H22 H17 H20).
---------------------- apply (@H14 H23).
--------------- assert (* Cut *) (P = C) as H17.
---------------- destruct H3 as [H17 H18].
destruct H2 as [H19 H20].
apply (@lemma__outerconnectivity.lemma__outerconnectivity A B P C H13 H19 H15 H16).
---------------- assert (* Cut *) (euclidean__axioms.Cong A B B P) as H18.
----------------- destruct H3 as [H18 H19].
destruct H2 as [H20 H21].
apply (@eq__ind__r euclidean__axioms.Point C (fun P0 => (euclidean__defs.Midpoint P0 B Q) -> ((euclidean__axioms.neq A P0) -> ((euclidean__axioms.BetS P0 B Q) -> ((euclidean__axioms.Cong P0 B B Q) -> ((euclidean__axioms.Col A B P0) -> ((euclidean__axioms.BetS A B P0) -> ((~(euclidean__axioms.Cong A P0 C Q)) -> ((~(euclidean__axioms.BetS B P0 C)) -> ((~(euclidean__axioms.BetS B C P0)) -> (euclidean__axioms.Cong A B B P0))))))))))) with (x := P).
------------------intro H22.
intro H23.
intro H24.
intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
exact H21.

------------------ exact H17.
------------------ exact H0.
------------------ exact H1.
------------------ exact H18.
------------------ exact H19.
------------------ exact H6.
------------------ exact H13.
------------------ exact H14.
------------------ exact H15.
------------------ exact H16.
----------------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H19.
------------------ destruct H3 as [H19 H20].
destruct H2 as [H21 H22].
assert (* Cut *) ((euclidean__axioms.Cong B P Q B) /\ ((euclidean__axioms.Cong B P B Q) /\ (euclidean__axioms.Cong P B Q B))) as H23.
------------------- apply (@lemma__congruenceflip.lemma__congruenceflip P B B Q H20).
------------------- destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H26.
------------------ assert (* Cut *) (euclidean__axioms.Cong A B B Q) as H20.
------------------- destruct H3 as [H20 H21].
destruct H2 as [H22 H23].
apply (@lemma__congruencetransitive.lemma__congruencetransitive A B B P B Q H18 H19).
------------------- assert (* Cut *) (euclidean__axioms.BetS C B A) as H21.
-------------------- destruct H3 as [H21 H22].
destruct H2 as [H23 H24].
apply (@euclidean__axioms.axiom__betweennesssymmetry A B C H23).
-------------------- assert (* Cut *) (euclidean__axioms.BetS P B A) as H22.
--------------------- destruct H3 as [H22 H23].
destruct H2 as [H24 H25].
apply (@eq__ind__r euclidean__axioms.Point C (fun P0 => (euclidean__defs.Midpoint P0 B Q) -> ((euclidean__axioms.neq A P0) -> ((euclidean__axioms.BetS P0 B Q) -> ((euclidean__axioms.Cong P0 B B Q) -> ((euclidean__axioms.Col A B P0) -> ((euclidean__axioms.BetS A B P0) -> ((~(euclidean__axioms.Cong A P0 C Q)) -> ((~(euclidean__axioms.BetS B P0 C)) -> ((~(euclidean__axioms.BetS B C P0)) -> ((euclidean__axioms.Cong A B B P0) -> ((euclidean__axioms.Cong B P0 B Q) -> (euclidean__axioms.BetS P0 B A))))))))))))) with (x := P).
----------------------intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
exact H21.

---------------------- exact H17.
---------------------- exact H0.
---------------------- exact H1.
---------------------- exact H22.
---------------------- exact H23.
---------------------- exact H6.
---------------------- exact H13.
---------------------- exact H14.
---------------------- exact H15.
---------------------- exact H16.
---------------------- exact H18.
---------------------- exact H19.
--------------------- assert (* Cut *) (euclidean__axioms.Cong B Q A B) as H23.
---------------------- destruct H3 as [H23 H24].
destruct H2 as [H25 H26].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B A B Q H20).
---------------------- assert (* Cut *) (euclidean__axioms.Cong B Q B A) as H24.
----------------------- destruct H3 as [H24 H25].
destruct H2 as [H26 H27].
assert (* Cut *) ((euclidean__axioms.Cong Q B B A) /\ ((euclidean__axioms.Cong Q B A B) /\ (euclidean__axioms.Cong B Q B A))) as H28.
------------------------ apply (@lemma__congruenceflip.lemma__congruenceflip B Q A B H23).
------------------------ destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H32.
----------------------- assert (* Cut *) (Q = A) as H25.
------------------------ destruct H3 as [H25 H26].
destruct H2 as [H27 H28].
apply (@lemma__extensionunique.lemma__extensionunique P B Q A H25 H22 H24).
------------------------ assert (* Cut *) (euclidean__axioms.Cong A C C A) as H26.
------------------------- destruct H3 as [H26 H27].
destruct H2 as [H28 H29].
apply (@euclidean__axioms.cn__equalityreverse A C).
------------------------- assert (* Cut *) (euclidean__axioms.Cong A P C A) as H27.
-------------------------- destruct H3 as [H27 H28].
destruct H2 as [H29 H30].
apply (@eq__ind__r euclidean__axioms.Point A (fun Q0 => (euclidean__defs.Midpoint P B Q0) -> ((euclidean__axioms.BetS P B Q0) -> ((euclidean__axioms.Cong P B B Q0) -> ((~(euclidean__axioms.Cong A P C Q0)) -> ((euclidean__axioms.Cong B P B Q0) -> ((euclidean__axioms.Cong A B B Q0) -> ((euclidean__axioms.Cong B Q0 A B) -> ((euclidean__axioms.Cong B Q0 B A) -> (euclidean__axioms.Cong A P C A)))))))))) with (x := Q).
---------------------------intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
apply (@eq__ind__r euclidean__axioms.Point C (fun P0 => (euclidean__defs.Midpoint P0 B A) -> ((euclidean__axioms.neq A P0) -> ((euclidean__axioms.Cong P0 B B A) -> ((euclidean__axioms.BetS P0 B A) -> ((euclidean__axioms.Col A B P0) -> ((euclidean__axioms.BetS A B P0) -> ((~(euclidean__axioms.Cong A P0 C A)) -> ((~(euclidean__axioms.BetS B P0 C)) -> ((~(euclidean__axioms.BetS B C P0)) -> ((euclidean__axioms.Cong A B B P0) -> ((euclidean__axioms.Cong B P0 B A) -> ((euclidean__axioms.BetS P0 B A) -> (euclidean__axioms.Cong A P0 C A)))))))))))))) with (x := P).
----------------------------intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
exact H26.

---------------------------- exact H17.
---------------------------- exact H31.
---------------------------- exact H1.
---------------------------- exact H33.
---------------------------- exact H32.
---------------------------- exact H6.
---------------------------- exact H13.
---------------------------- exact H34.
---------------------------- exact H15.
---------------------------- exact H16.
---------------------------- exact H18.
---------------------------- exact H35.
---------------------------- exact H22.

--------------------------- exact H25.
--------------------------- exact H0.
--------------------------- exact H27.
--------------------------- exact H28.
--------------------------- exact H14.
--------------------------- exact H19.
--------------------------- exact H20.
--------------------------- exact H23.
--------------------------- exact H24.
-------------------------- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H28.
--------------------------- destruct H3 as [H28 H29].
destruct H2 as [H30 H31].
apply (@eq__ind__r euclidean__axioms.Point A (fun Q0 => (euclidean__defs.Midpoint P B Q0) -> ((euclidean__axioms.BetS P B Q0) -> ((euclidean__axioms.Cong P B B Q0) -> ((~(euclidean__axioms.Cong A P C Q0)) -> ((euclidean__axioms.Cong B P B Q0) -> ((euclidean__axioms.Cong A B B Q0) -> ((euclidean__axioms.Cong B Q0 A B) -> ((euclidean__axioms.Cong B Q0 B A) -> (euclidean__axioms.Cong A P C Q0)))))))))) with (x := Q).
----------------------------intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
apply (@eq__ind__r euclidean__axioms.Point C (fun P0 => (euclidean__defs.Midpoint P0 B A) -> ((euclidean__axioms.neq A P0) -> ((euclidean__axioms.Cong P0 B B A) -> ((euclidean__axioms.BetS P0 B A) -> ((euclidean__axioms.Col A B P0) -> ((euclidean__axioms.BetS A B P0) -> ((~(euclidean__axioms.Cong A P0 C A)) -> ((~(euclidean__axioms.BetS B P0 C)) -> ((~(euclidean__axioms.BetS B C P0)) -> ((euclidean__axioms.Cong A B B P0) -> ((euclidean__axioms.Cong B P0 B A) -> ((euclidean__axioms.BetS P0 B A) -> ((euclidean__axioms.Cong A P0 C A) -> (euclidean__axioms.Cong A P0 C A))))))))))))))) with (x := P).
-----------------------------intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
exact H52.

----------------------------- exact H17.
----------------------------- exact H32.
----------------------------- exact H1.
----------------------------- exact H34.
----------------------------- exact H33.
----------------------------- exact H6.
----------------------------- exact H13.
----------------------------- exact H35.
----------------------------- exact H15.
----------------------------- exact H16.
----------------------------- exact H18.
----------------------------- exact H36.
----------------------------- exact H22.
----------------------------- exact H27.

---------------------------- exact H25.
---------------------------- exact H0.
---------------------------- exact H28.
---------------------------- exact H29.
---------------------------- exact H14.
---------------------------- exact H19.
---------------------------- exact H20.
---------------------------- exact H23.
---------------------------- exact H24.
--------------------------- apply (@H14 H28).
------------- apply (@euclidean__tactics.NNPP (euclidean__axioms.Cong A P C Q)).
--------------intro H15.
destruct H2 as [H16 H17].
destruct H3 as [H18 H19].
assert (* Cut *) (False) as H20.
--------------- apply (@H14 H15).
--------------- contradiction H20.

------------ assert (* Cut *) (euclidean__axioms.Cong B Q P B) as H14.
------------- destruct H3 as [H14 H15].
destruct H2 as [H16 H17].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B P B Q H15).
------------- assert (* Cut *) (euclidean__axioms.Cong B Q B P) as H15.
-------------- destruct H3 as [H15 H16].
destruct H2 as [H17 H18].
assert (* Cut *) ((euclidean__axioms.Cong Q B B P) /\ ((euclidean__axioms.Cong Q B P B) /\ (euclidean__axioms.Cong B Q B P))) as H19.
--------------- apply (@lemma__congruenceflip.lemma__congruenceflip B Q P B H14).
--------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H23.
-------------- assert (* Cut *) (euclidean__axioms.Cong C B B A) as H16.
--------------- destruct H3 as [H16 H17].
destruct H2 as [H18 H19].
assert (* Cut *) ((euclidean__axioms.Cong C B B A) /\ (euclidean__axioms.Cong B A C B)) as H20.
---------------- apply (@lemma__doublereverse.lemma__doublereverse A B B C H19).
---------------- destruct H20 as [H21 H22].
exact H21.
--------------- assert (* Cut *) (euclidean__axioms.Cong B C B A) as H17.
---------------- destruct H3 as [H17 H18].
destruct H2 as [H19 H20].
assert (* Cut *) ((euclidean__axioms.Cong B C A B) /\ ((euclidean__axioms.Cong B C B A) /\ (euclidean__axioms.Cong C B A B))) as H21.
----------------- apply (@lemma__congruenceflip.lemma__congruenceflip C B B A H16).
----------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H24.
---------------- assert (* Cut *) (euclidean__axioms.BetS B P A) as H18.
----------------- destruct H3 as [H18 H19].
destruct H2 as [H20 H21].
apply (@euclidean__axioms.axiom__betweennesssymmetry A P B H13).
----------------- assert (* Cut *) (euclidean__axioms.Cong B P Q B) as H19.
------------------ destruct H3 as [H19 H20].
destruct H2 as [H21 H22].
assert (* Cut *) ((euclidean__axioms.Cong B P Q B) /\ (euclidean__axioms.Cong Q B B P)) as H23.
------------------- apply (@lemma__doublereverse.lemma__doublereverse B Q P B H14).
------------------- destruct H23 as [H24 H25].
exact H24.
------------------ assert (* Cut *) (euclidean__defs.Lt Q B B A) as H20.
------------------- exists P.
split.
-------------------- exact H18.
-------------------- exact H19.
------------------- assert (* Cut *) (euclidean__axioms.Cong B A B C) as H21.
-------------------- destruct H3 as [H21 H22].
destruct H2 as [H23 H24].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B C A H17).
-------------------- assert (* Cut *) (euclidean__defs.Lt Q B B C) as H22.
--------------------- destruct H3 as [H22 H23].
destruct H2 as [H24 H25].
apply (@lemma__lessthancongruence.lemma__lessthancongruence Q B B A B C H20 H21).
--------------------- assert (* Cut *) (euclidean__axioms.Cong Q B B Q) as H23.
---------------------- destruct H3 as [H23 H24].
destruct H2 as [H25 H26].
apply (@euclidean__axioms.cn__equalityreverse Q B).
---------------------- assert (* Cut *) (euclidean__defs.Lt B Q B C) as H24.
----------------------- destruct H3 as [H24 H25].
destruct H2 as [H26 H27].
apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 Q B B C B Q H22 H23).
----------------------- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H25.
------------------------ destruct H3 as [H25 H26].
destruct H2 as [H27 H28].
apply (@euclidean__axioms.cn__congruencereflexive B C).
------------------------ assert (* Cut *) (euclidean__axioms.neq B C) as H26.
------------------------- destruct H3 as [H26 H27].
destruct H2 as [H28 H29].
assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A C))) as H30.
-------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A B C H28).
-------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H31.
------------------------- assert (* Cut *) (exists H27, (euclidean__axioms.BetS B H27 C) /\ (euclidean__axioms.Cong B H27 B Q)) as H27.
-------------------------- destruct H3 as [H27 H28].
destruct H2 as [H29 H30].
exact H24.
-------------------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H3 as [H32 H33].
destruct H2 as [H34 H35].
assert (* Cut *) (euclidean__axioms.BetS P B C) as H36.
--------------------------- apply (@lemma__3__6a.lemma__3__6a A P B C H13 H34).
--------------------------- assert (* Cut *) (euclidean__defs.Out B C Q) as H37.
---------------------------- exists P.
split.
----------------------------- exact H32.
----------------------------- exact H36.
---------------------------- assert (* Cut *) (euclidean__defs.Out B C H28) as H38.
----------------------------- apply (@lemma__ray4.lemma__ray4 B C H28).
------------------------------left.
exact H30.

------------------------------ exact H26.
----------------------------- assert (* Cut *) (euclidean__axioms.Cong B Q B H28) as H39.
------------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B H28 Q H31).
------------------------------ assert (* Cut *) (Q = H28) as H40.
------------------------------- apply (@lemma__layoffunique.lemma__layoffunique B C Q H28 H37 H38 H39).
------------------------------- assert (* Cut *) (euclidean__axioms.BetS B Q C) as H41.
-------------------------------- apply (@eq__ind__r euclidean__axioms.Point H28 (fun Q0 => (euclidean__defs.Midpoint P B Q0) -> ((euclidean__axioms.BetS P B Q0) -> ((euclidean__axioms.Cong P B B Q0) -> ((euclidean__axioms.Cong B Q0 P B) -> ((euclidean__axioms.Cong B Q0 B P) -> ((euclidean__axioms.Cong B P Q0 B) -> ((euclidean__defs.Lt Q0 B B A) -> ((euclidean__defs.Lt Q0 B B C) -> ((euclidean__axioms.Cong Q0 B B Q0) -> ((euclidean__defs.Lt B Q0 B C) -> ((euclidean__axioms.Cong B H28 B Q0) -> ((euclidean__defs.Out B C Q0) -> ((euclidean__axioms.Cong B Q0 B H28) -> (euclidean__axioms.BetS B Q0 C))))))))))))))) with (x := Q).
---------------------------------intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
exact H30.

--------------------------------- exact H40.
--------------------------------- exact H0.
--------------------------------- exact H32.
--------------------------------- exact H33.
--------------------------------- exact H14.
--------------------------------- exact H15.
--------------------------------- exact H19.
--------------------------------- exact H20.
--------------------------------- exact H22.
--------------------------------- exact H23.
--------------------------------- exact H24.
--------------------------------- exact H31.
--------------------------------- exact H37.
--------------------------------- exact H39.
-------------------------------- assert (* Cut *) (euclidean__axioms.BetS B P A) as H42.
--------------------------------- apply (@eq__ind__r euclidean__axioms.Point H28 (fun Q0 => (euclidean__defs.Midpoint P B Q0) -> ((euclidean__axioms.BetS P B Q0) -> ((euclidean__axioms.Cong P B B Q0) -> ((euclidean__axioms.Cong B Q0 P B) -> ((euclidean__axioms.Cong B Q0 B P) -> ((euclidean__axioms.Cong B P Q0 B) -> ((euclidean__defs.Lt Q0 B B A) -> ((euclidean__defs.Lt Q0 B B C) -> ((euclidean__axioms.Cong Q0 B B Q0) -> ((euclidean__defs.Lt B Q0 B C) -> ((euclidean__axioms.Cong B H28 B Q0) -> ((euclidean__defs.Out B C Q0) -> ((euclidean__axioms.Cong B Q0 B H28) -> ((euclidean__axioms.BetS B Q0 C) -> (euclidean__axioms.BetS B P A)))))))))))))))) with (x := Q).
----------------------------------intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
exact H18.

---------------------------------- exact H40.
---------------------------------- exact H0.
---------------------------------- exact H32.
---------------------------------- exact H33.
---------------------------------- exact H14.
---------------------------------- exact H15.
---------------------------------- exact H19.
---------------------------------- exact H20.
---------------------------------- exact H22.
---------------------------------- exact H23.
---------------------------------- exact H24.
---------------------------------- exact H31.
---------------------------------- exact H37.
---------------------------------- exact H39.
---------------------------------- exact H41.
--------------------------------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H43.
---------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B Q P H15).
---------------------------------- assert (* Cut *) (euclidean__axioms.Cong P A Q C) as H44.
----------------------------------- apply (@lemma__differenceofparts.lemma__differenceofparts B P A B Q C H43 H21 H42 H41).
----------------------------------- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H45.
------------------------------------ assert (* Cut *) ((euclidean__axioms.Cong A P C Q) /\ ((euclidean__axioms.Cong A P Q C) /\ (euclidean__axioms.Cong P A C Q))) as H45.
------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip P A Q C H44).
------------------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H46.
------------------------------------ exact H45.
------- exact H8.
----- assert (* Cut *) (euclidean__defs.CongA A B P Q B C) as H7.
------ destruct H3 as [H7 H8].
destruct H2 as [H9 H10].
apply (@proposition__15.proposition__15a A C P Q B H9 H7 H6).
------ assert (* Cut *) (euclidean__axioms.nCol Q B C) as H8.
------- destruct H3 as [H8 H9].
destruct H2 as [H10 H11].
apply (@euclidean__tactics.nCol__notCol Q B C).
--------apply (@euclidean__tactics.nCol__not__Col Q B C).
---------apply (@lemma__equalanglesNC.lemma__equalanglesNC A B P Q B C H7).

------- assert (* Cut *) (euclidean__defs.CongA Q B C C B Q) as H9.
-------- destruct H3 as [H9 H10].
destruct H2 as [H11 H12].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA Q B C H8).
-------- assert (* Cut *) (euclidean__defs.CongA A B P C B Q) as H10.
--------- destruct H3 as [H10 H11].
destruct H2 as [H12 H13].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B P Q B C C B Q H7 H9).
--------- assert (* Cut *) (euclidean__axioms.Cong B A B C) as H11.
---------- destruct H3 as [H11 H12].
destruct H2 as [H13 H14].
assert (* Cut *) ((euclidean__axioms.Cong B A C B) /\ ((euclidean__axioms.Cong B A B C) /\ (euclidean__axioms.Cong A B C B))) as H15.
----------- apply (@lemma__congruenceflip.lemma__congruenceflip A B B C H14).
----------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H18.
---------- assert (* Cut *) (euclidean__axioms.Cong B P B Q) as H12.
----------- destruct H3 as [H12 H13].
destruct H2 as [H14 H15].
assert (* Cut *) ((euclidean__axioms.Cong B P Q B) /\ ((euclidean__axioms.Cong B P B Q) /\ (euclidean__axioms.Cong P B Q B))) as H16.
------------ apply (@lemma__congruenceflip.lemma__congruenceflip P B B Q H13).
------------ destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
----------- assert (* Cut *) (euclidean__axioms.Cong A P C Q) as H13.
------------ destruct H3 as [H13 H14].
destruct H2 as [H15 H16].
assert (* Cut *) (forall A0 B0 C0 a b c, (euclidean__axioms.Cong A0 B0 a b) -> ((euclidean__axioms.Cong A0 C0 a c) -> ((euclidean__defs.CongA B0 A0 C0 b a c) -> (euclidean__axioms.Cong B0 C0 b c)))) as H17.
------------- intro A0.
intro B0.
intro C0.
intro a.
intro b.
intro c.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__axioms.Cong B0 C0 b c) /\ ((euclidean__defs.CongA A0 B0 C0 a b c) /\ (euclidean__defs.CongA A0 C0 B0 a c b))) as __2.
-------------- apply (@proposition__04.proposition__04 A0 B0 C0 a b c __ __0 __1).
-------------- destruct __2 as [__2 __3].
exact __2.
------------- apply (@H17 B A P B C Q H11 H12 H10).
------------ exact H13.
--- exact H4.
Qed.


From AlphaPearl Require Import Util.PlfTactics.
From Coq Require Import Bool List ssreflect Strings.String.
Import ListNotations.
From mathcomp Require Import bigop eqtype seq ssrbool ssrnat.

Set Asymmetric Patterns.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Unset Printing Implicit Defensive.

#[local] Open Scope string_scope.

Lemma length_append :
  forall x y : string,
    length (x ++ y) = length x + length y.
Proof.
  intros.
  gen y. induction x; intros; auto.
  rewrite /= -[LHS]addn1 -[RHS]addn1. auto.
Qed.

Lemma length_concat_cons :
  forall (s : seq string) (sep x : string),
    length (concat sep s) <= length (concat sep (x :: s)).
Proof.
  intros.
  gen x. induction s; intros; auto.
  rewrite /= !length_append.
  apply leq_trans with (length sep + length (concat sep (a :: s)));
  rewrite leq_addl //.
Qed.


Module Type Terms.
  Parameter T : Set.
  Parameter IsVariable : T -> Prop.
  Definition Var : Set := { x : T & (IsVariable x) }.
(*
  Parameter var_dec : forall x y : Var, {x = y} + {x <> y }.
 *)
  Parameter Substitution : Set. (* Var -> T *)
  Parameter identity : Substitution.
  Parameter Apply : Substitution -> T -> T.
  Hypothesis identity_refl : forall t, (Apply identity t) = t.
  Parameter Update : Substitution -> Var -> T -> Substitution.
  Parameter notFreeT : Var -> T -> Prop.
End Terms.

Module Type Formulas (Export Base : Terms).

  Parameter Formula : Set.
  Parameter Equals : T -> T -> Formula.
  Parameter And  : Formula -> Formula -> Formula.
  Parameter Or  : Formula -> Formula -> Formula.
  Parameter Implies  : Formula -> Formula -> Formula.
  Parameter Exists : Var  -> Formula -> Formula.
  Parameter Pattern : T -> Formula.
  Parameter ApplyF : Substitution -> Formula -> Formula.

  Parameter notFree : Var -> Formula -> Prop.

  Parameter patternless : Formula -> Prop.
End Formulas.

Module Type Model(Export Base : Terms).

  Parameter M : Set.

  Parameter Valuation : Set. (* Var -> M *)
  Parameter value : Valuation -> T -> option M.
  Parameter UpdateV : Valuation -> Var -> M -> Valuation.

  Parameter Compose : Valuation -> Substitution -> Valuation.
End Model.

Definition SomeEqual A (l r : option A) : Prop :=
  match l, r with
  | Some lv, Some rv => lv = rv
  | _, _ => False
  end.

Module Type Satisfaction
  (Export Base : Terms)
  (Export BaseM : Model Base)
  (Export BaseF : Formulas Base).

  Parameter Satisfies : M -> Valuation -> Formula -> Prop.
  Axiom SatApply : forall rho f subst gamma,
    Satisfies gamma rho (ApplyF subst f) <->
    Satisfies gamma (Compose rho subst) f.

  Axiom patternless_sat : forall f, patternless f ->
    forall gamma gamma' rho,
      Satisfies gamma rho f -> Satisfies gamma' rho f.
  Axiom notFree_sat : forall x f,
    notFree x f ->
    forall gamma rho t,
      Satisfies gamma rho f
      <-> Satisfies gamma (UpdateV rho x t) f.

  Definition Valid phi :=
    forall gamma : M, forall rho : Valuation,
      Satisfies gamma rho phi.

  Axiom SatEquals : forall (rho : Valuation) (t t' : T) (gamma : M),
    SomeEqual _ (value rho t) (value rho t')
    <->
    Satisfies gamma rho (Equals t t').

  Axiom SatExists : forall (rho : Valuation) (x : Var) (phi : Formula) (gamma : M),
    (exists t : M, Satisfies gamma (UpdateV rho x t) phi)
    <->
    Satisfies gamma rho (Exists x phi).

  Axiom SatAnd : forall (rho : Valuation) (phi phi' : Formula) (gamma : M),
    (Satisfies gamma rho phi /\ Satisfies gamma rho phi')
    <->
    Satisfies gamma rho (And phi phi').

  Axiom SatOr : forall (rho : Valuation) (phi phi' : Formula) (gamma : M),
    (Satisfies gamma rho phi \/ Satisfies gamma rho phi')
    <->
    Satisfies gamma rho (Or phi phi').

  Axiom SatImplies : forall (rho : Valuation) (phi phi' : Formula) (gamma : M),
    (Satisfies gamma rho phi -> Satisfies gamma rho phi')
    <->
    Satisfies gamma rho (Implies phi phi').

  Axiom SatPattern : forall (rho : Valuation) (t : T) (gamma : M),
    (Some gamma = value rho t)
    <->
    Satisfies gamma rho (Pattern t).
End Satisfaction.

Module Type ObjectLanguage.
  Declare Module Export Base : Terms.
  Declare Module Export BaseM : Model Base.
  Declare Module Export BaseF : Formulas Base.
  Declare Module Export BaseS : Satisfaction Base BaseM BaseF.
End ObjectLanguage.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rle.
Require Export XR_total_order_T.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma inser_trans_R : forall r1 r2 r3 r4,
  r1 <= r2 < r3 -> {r1 <= r2 < r4} + {r4 <= r2 < r3}.
Proof.
  intros u v w x.
  intros [ huv hvw ].
  destruct (total_order_T v x) as [ [ hvx | heq ] | hxv ].
  {
    left.
    split.
    { exact huv. }
    { exact hvx. }
  }
  {
    subst v.
    right.
    split.
    { unfold "<=". right. reflexivity. }
    { exact hvw. }
  }
  {
    right.
    split.
    { unfold "<=". left. exact hxv. }
    { exact hvw. }
  }
Qed.


From HoTT Require Import Basics Types Truncations.

(** The "fiber" of a map with respect to a relation. *)
Definition rfiber {X Y : Type} (R : Relation Y) (f : X -> Y) (y : Y) : Type
  := exists x, R (f x) y.

Definition lfiber {X Y : Type} (R : Relation Y) (f : X -> Y) (y : Y) : Type
  := exists x, R y (f x).

(** * The equivalence relation generated by a relation. *)

(** We model the equivalence relation generated by a relation using alternating zig-zags, and by throwing in reflexivity relations. It's easy to show that the resulting relation is an equivalence relation. *)

(** The 'zig' goes forward, and the 'zag' goes backward *)
Fixpoint zig_or_zag {X : Type} (R : Relation X) (n : nat) (x0 x1 : X) : Type
  := match n with
     | 0%nat => x0 = x1
     | S n => exists x, zig_or_zag R n x0 x * (R x x1 + R x1 x)
     end.

(** The equivalence relation generated by a relation [R]. *)
Definition EqRel {X : Type} (R : Relation X) (x0 x1 : X) : Type
  := exists n, zig_or_zag R n x0 x1.

(** We can add ("cons") a zig or a zag at the end of a chain of such. *)

Definition zig_cons {X : Type} (R : Relation X) {x0 x1 x2 : X}
  (rho : EqRel R x0 x1) (zig : R x1 x2)
  : EqRel R x0 x2
  := (S rho.1; (x1; (rho.2, inl zig))).

Definition zag_cons {X : Type} (R : Relation X) {x0 x1 x2 : X}
  (rho : EqRel R x0 x1) (zag : R x2 x1)
  : EqRel R x0 x2
  := (S rho.1; (x1; (rho.2, inr zag))).

Global Instance reflexive_eqrel {X : Type} (R : Relation X)
  : Reflexive (EqRel R) := fun _ => (0%nat; idpath).

Definition zig_to_eqrel {X : Type} (R : Relation X)
  {x0 x1 : X} (zig : R x0 x1) : EqRel R x0 x1
  := zig_cons R (reflexivity _) zig.

Definition zag_to_eqrel {X : Type} (R : Relation X)
  {x0 x1 : X} (zag : R x1 x0) : EqRel R x0 x1
  := zag_cons R (reflexivity _) zag.

(** ** [EqRel R] is an equivalence relation. We saw reflexivity above. *)

Global Instance transitive_eqrel {X : Type} (R : Relation X)
  : Transitive (EqRel R).
Proof.
  intros x0 x1 x2 rho01 [m zzs].
  revert x1 x2 rho01 zzs.
  induction m as [|m IH]; intros.
  - by induction zzs.
  - destruct zzs as [x [zzs [zig|zag]]].
    + exact (zig_cons R (IH _ _ rho01 zzs) zig).
    + exact (zag_cons R (IH _ _ rho01 zzs) zag).
Defined.

Global Instance symmetric_eqrel {X : Type} (R : Relation X)
  : Symmetric (EqRel R).
Proof.
  intros x0 x1 [n zzs]; revert x0 x1 zzs.
  induction n as [|n IH].
  - intros ? ? p; exact (0%nat; p^).
  - intros ? ? [x [zzs zorz]].
    transitivity x.
    2: by apply IH.
    destruct zorz as [zig|zag].
    + exact (zag_to_eqrel R zig).
    + exact (zig_to_eqrel R zag).
Defined.

(** To check whether a map respects [EqRel R], we just need to check that it respects [R]. *)
Definition eqrel_generator {X Y : Type}
  (R : Relation X) (Q : Relation Y) (f : X -> Y)
  : (forall x0 x1, R x0 x1 -> Q (f x0) (f x1))
    -> (forall x0 x1, EqRel R x0 x1 -> EqRel Q (f x0) (f x1)).
Proof.
  intros f_resp x0 x1 [n zz].
  (* we need a free endpoint before inducting on [n] *)
  revert dependent x1.
  induction n as [|n IH].
  1: intros; by induction zz.
  intros x1 [x [zz [zig|zag]]].
  - exact (zig_cons _ (IH _ zz) (f_resp _ _ zig)).
  - exact (zag_cons _ (IH _ zz) (f_resp _ _ zag)).
Defined.

Definition MEqRel {X : Type} (R : Relation X) (x0 x1 : X) : Type
  := merely (EqRel R x0 x1).

Definition zig_to_meqrel {X : Type} (R : Relation X)
  : forall x0 x1, R x0 x1 -> MEqRel R x0 x1
  := fun _ _ rho => tr (zig_to_eqrel R rho).

Definition zag_to_meqrel {X : Type} (R : Relation X) {x0 x1 : X}
  (zag : R x1 x0) : MEqRel R x0 x1
  := tr (zag_to_eqrel R zag).

Global Instance reflexive_meqrel {X : Type} (R : Relation X)
  : Reflexive (MEqRel R) := fun _ => tr (0%nat; idpath).

Global Instance transitive_meqrel {X : Type} (R : Relation X)
  : Transitive (MEqRel R).
Proof.
Proof.
  intros x0 x1 x2 rho01 rho12; strip_truncations.
  destruct rho12 as [m zzs].
  revert x1 x2 rho01 zzs.
  induction m as [|m IH]; intros.
  - induction zzs.
    exact (tr rho01).
  - destruct zzs as [x [zzs [zig|zag]]];
      pose proof (IHz := IH _ _ rho01 zzs); strip_truncations.
    + exact (tr (zig_cons R IHz zig)).
    + exact (tr (zag_cons R IHz zag)).
Defined.

Global Instance symmetric_meqrel {X : Type} (R : Relation X)
  : Symmetric (MEqRel R).
Proof.
  intros x0 x1; apply Trunc_rec; intros [n zzs].
  revert x0 x1 zzs.
  induction n as [|n IH].
  - intros ? ? p; exact (tr (0%nat; p^)).
  - intros ? ? [x [zzs zorz]].
    transitivity x.
    2: by apply IH.
    destruct zorz as [zig|zag].
    + exact (tr (zag_to_eqrel R zig)).
    + exact (tr (zig_to_eqrel R zag)).
Defined.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.

Import ListNotations.
Import Nat.

Inductive fm : Type :=
| Impl (a : fm) (b : fm)
| Var (x : nat)
| Neg (a : fm).

Coercion Var : nat >-> fm.

Declare Custom Entry fm.
Declare Scope fm_scope.

Notation "<{ e }>" := e (at level 0, e custom fm at level 99) : fm_scope.
Notation "( x )" := x (in custom fm, x at level 99) : fm_scope.
Notation "x" := x (in custom fm at level 0, x constr at level 0) : fm_scope.
Notation "'#' x"  := (Var x) (in custom fm at level 77, right associativity).
Notation "'~' b"  := (Neg b) (in custom fm at level 75, right associativity).
Notation "x -> y" := (Impl x y) (in custom fm at level 80, right associativity).

Open Scope fm_scope.

Definition X : nat := 0.
Definition Y : nat := 1.
Definition Z : nat := 2.

Definition valuation := nat -> bool.

Fixpoint fm_val (v : valuation) (t : fm) :=
  match t with
  | <{a -> b}> => negb (fm_val v a) || fm_val v b
  | <{# x}> => v x
  | <{~ a}> => negb (fm_val v a)
  end.

(* A valuation v satisfies Γ if all formulas in Γ are true under v. *)
Definition Satisfies v Γ := forall A, In A Γ -> fm_val v A = true.
(* Γ models a formula A if for every valuation v that satisfies Γ, A
   is true under v. *)
Definition Models Γ A := forall v, Satisfies v Γ -> fm_val v A = true.
Hint Unfold Models : core.
Notation "Γ ⊨ A" := (Models Γ A) (at level 80).
(* A is a tautology if it holds under the empty context *)
Definition Tautology A := [] ⊨ A.

(** * L system *)

(** ** Axiom schemas of L *)
Inductive AxiomL : fm -> Type :=
| A1 : forall (A B : fm),   AxiomL <{A -> B -> A}>
| A2 : forall (A B C : fm), AxiomL <{(A -> B -> C) -> (A -> B) -> (A -> C)}>
| A3 : forall (A B : fm),   AxiomL <{(~ A -> ~ B) -> (B -> A)}>.

Reserved Notation "s '|-' t" (at level 101, t custom fm at level 0).

Theorem fm_eq_dec : forall (A B : fm), {A = B} + {A <> B}.
Proof.
  intros; decide equality. decide equality.
Defined.

(** ** Inference rules of L *)
Inductive ltheorem (S : list fm) : fm -> Type :=
| Lassmp : forall A, existsb (fun B => if fm_eq_dec A B then true else false) S = true
             (* ---------- *)
              -> S |- A

| Lax : forall {A}, AxiomL A
          (* ---------- *)
           -> S |- A

| Lmp : forall {A B} , S |- (A -> B)
                -> S |- A
               (* ------------- *)
                -> S |- B
where "s '|-' t" := (ltheorem s t).

Fixpoint proof_size {F B} (p : ltheorem F B) : nat  :=
  match p with
  | Lassmp _ A x => 1
  | Lax _ x => 1
  | Lmp _ x x0 => 1 + proof_size x + proof_size x0
  end.

(* An axiom is valid in any context. *)
Theorem M_ax : forall A S, AxiomL A -> S ⊨ A.
Proof.
  intros A S H.
  destruct H; unfold Models; simpl; intros v Hv.
  - destruct (fm_val v A), (fm_val v B); reflexivity.
  - destruct (fm_val v A), (fm_val v B), (fm_val v C); reflexivity.
  - destruct (fm_val v A), (fm_val v B); reflexivity.
Qed.

(* Modus ponens is semantically valid *)
Theorem M_MP : forall S A B,
    S ⊨ <{A -> B}> -> S ⊨ A -> S ⊨ B.
Proof.
  intros S a b Ha Hab.
  (* Fix a valuation v *)
  intros v satV.
  specialize (Ha _ satV).
  specialize (Hab _ satV).
  simpl in *.
  now destruct (fm_val v a); destruct (fm_val v b).
Qed.

(* Proof of soundness *)
Theorem l_sound : forall S A, S |- A -> S ⊨ A.
Proof.
  intros S A H.
  induction H.
  - apply existsb_exists in e.
    destruct e.
    unfold Models.
    unfold Satisfies.
    intros v H0.
    apply H0.
    destruct (fm_eq_dec A x); subst; try easy.
  - now apply M_ax.
  - eapply M_MP; eauto.
Qed.

(* Weakening *)
Theorem weak : forall S A B, (S |- A) -> (B::S) |- A.
Proof.
  intros S A B H.
  induction H.
  - apply Lassmp. simpl.
    now destruct (fm_eq_dec A B).
  - apply Lax. assumption.
  - eapply Lmp; eauto.
Qed.

Theorem weak_l : forall S A, [] |- A -> S |- A.
Proof.
  intros S A H.
  induction S; try apply weak; auto.
Qed.

Theorem proof_size_not_0 : forall A B (F : ltheorem A B), proof_size F <> 0.
Proof.
  intros. destruct F; easy.
Qed.

(* Deduction theorem, forward direction *)
Theorem dedl : forall S A B, (S |- <{A -> B}>) -> ((A::S) |- B).
Proof.
  intros S A B.
  intros H.
  - assert (A :: S |- A).
    {
      apply Lassmp. simpl. destruct (fm_eq_dec A A); auto.
    }
    assert (A :: S |- <{A -> B}>) by now apply weak.
    eapply Lmp; eauto.
Qed.

(* Example of a tautology *)
(* Note that this matches the paper proof of A -> A for all contexts G *)
Example id_proof : forall G A, G |- <{ A -> A }>.
Proof.
  intros.
  pose proof (Lax G (A2 A <{A -> A}> A)) as L1.
  pose proof (Lax G (A1 A <{A -> A}>)) as L2.
  pose proof (Lmp G L1 L2) as L3.
  pose proof (Lax G (A1 A A)) as L4.
  pose proof (Lmp G L3 L4) as L5.
  assumption.
Defined.

Require Import Wf_nat.
Theorem strong_ind : forall P : nat -> Set,
    (forall x : nat, (forall y : nat, y < x -> P y) -> P x) -> forall a : nat, P a.
Proof.
  apply (well_founded_induction lt_wf).
Defined.

Theorem dedr0 : forall S A B (H : (A::S) |- B), proof_size H = 0 -> (S |- <{A -> B}>).
Proof.
  intros. pose proof (proof_size_not_0 _ _ H). congruence.
Qed.

Theorem dedr1 : forall G A B (H : (A::G) |- B), proof_size H = 1 -> (G |- <{A -> B}>).
Proof.
  intros.
  destruct H.
  + clear H0.
    simpl in e.
    destruct (fm_eq_dec A0 A); subst.
    * apply id_proof.
    * simpl in e.
      assert (G |- A0) by now constructor.
      pose proof (Lax G (A1 A0 A)).
      pose proof (Lmp G H0 H).
      assumption.
  + clear H0.
    simpl in a.
    assert (G |- A0) by now apply Lax.
    pose proof (Lax G (A1 A0 A)).
    pose proof (Lmp G H0 H).
    assumption.
  + simpl in H0.
    inversion H0.
    symmetry in H0.
    pose proof (proof_size_not_0 _ _ H). apply Plus.plus_is_O in H3. now destruct H3.
Defined.

Require Import Psatz.
(* Given that we have a proof H of (A::G) |- B and assuming that we can perform DT
   for proofs less than H then DT holds for H *)

(* Deduction theorem, converse direction *)
Theorem dedr : forall S A B, ((A::S) |- B) -> (S |- <{A -> B}>).
Proof.
  intros G A B H.
  remember (proof_size H) as n.
  generalize dependent H.
  generalize dependent B.
  generalize dependent A.
  generalize dependent n.
  set (P n := forall (A B : fm) (H : A :: G |- B), n = proof_size H -> G |- (A -> B)).
  change (forall n, P n).
  (* Perform strong induction on the size of the proof *)
  apply strong_ind; unfold P; clear P; intros.
  destruct x as [|[|]].
  + (* proof size = 0 *) eapply dedr0; eauto.
  + (* proof size = 1 *) eapply dedr1; eauto.
  + destruct H0; try inversion H1.
    rename A0 into C.
    assert (proof_size H0_ < S (S n)) by lia.
    assert (proof_size H0_0 < S (S n)) by lia.
    pose proof (H _ H0 _ _ H0_ eq_refl).
    pose proof (H _ H3 _ _ H0_0 eq_refl).
    pose proof (Lax G (A2 A C B)).
    pose proof (Lmp _ H6 H4).
    pose proof (Lmp _ H7 H5).
    assumption.
Defined.

(* Example proof of A -> A using the deduction theorem . *)
Example id_proof2 : forall G A, G |- <{A -> A}>.
Proof.
  intros G A.
  apply dedr.
  apply Lassmp.
  simpl; now destruct (fm_eq_dec A A).
Defined.

(* Fun example: since we're in a constructive setting, we can ask Coq
   what the derivation for X -> X is *)
Eval cbv in (id_proof [] X).
     (* = Lmp [] *)
     (*     (Lmp [] (Lax [] (A2 <{ # "X" }> <{ # "X" -> # "X" }> <{ # "X" }>)) *)
     (*        (Lax [] (A1 <{ # "X" }> <{ # "X" -> # "X" }>))) *)
     (*     (Lax [] (A1 <{ # "X" }> <{ # "X" }>)) *)
     (* : [] |- (# X -> # X) *)

(* Likewise for the second proof of X -> X using the deduction theorem. *)
Eval cbv in (id_proof2 [] X).
     (* = Lmp [] *)
     (*     (Lmp [] (Lax [] (A2 <{ # "X" }> <{ # "X" -> # "X" }> <{ # "X" }>)) *)
     (*        (Lax [] (A1 <{ # "X" }> <{ # "X" -> # "X" }>))) *)
     (*     (Lax [] (A1 <{ # "X" }> <{ # "X" }>)) *)
     (* : [] |- (# X -> # X) *)

(* In fact the proofs are equal for a concrete variable X under the
   empty context. *)
Lemma id_proofs_same : id_proof [] X = id_proof2 [] X.
Proof. reflexivity. Qed.

(* Note that they're not necessarily equal when X is an arbitrary formula or when
  the context is non-empty. *)

Lemma lemma21 : forall A B, [] |- <{(A -> (A -> B)) -> (A -> B)}>.
Proof.
  intros A B.
  apply dedr, dedr.
  assert ([A;<{A -> A -> B}>] |- A).
  {
    apply Lassmp. simpl. destruct (fm_eq_dec A A); auto.
  }
  assert ([A;<{A -> A -> B}>] |- <{A -> A -> B}>).
  {
    apply Lassmp. unfold existsb.
    destruct (fm_eq_dec _ _); destruct (fm_eq_dec _ _); auto.
  }
  pose proof (Lmp _ H0 H) as L3.
  pose proof (Lmp _ L3 H) as L4.
  assumption.
Qed.

Lemma lemma22 : forall A B, [] |- <{(A -> B) -> (A -> (A -> B))}>.
Proof.
  intros A B.
  apply dedr, dedr, weak, dedl, id_proof.
Qed.

Lemma lemma31 : forall A, [] |- <{~ ~ A -> A}>.
Proof.
  intros A.
  apply dedr.
  assert ([<{ ~ ~ A }>] |- <{~ ~ A -> A}>).
  {
    apply dedr, weak.
    remember [<{ ~ ~ A }>] as G.
    assert (G |- ~ ~ A) as L1.
    {
      rewrite HeqG.
      apply dedl, id_proof.
    }
    pose proof (Lax G (A1 <{~ ~ A}> <{~ ~ ~ ~A}>)) as L2.
    pose proof (Lmp _ L2 L1) as L3.
    pose proof (Lax G (A3 <{~ ~ ~ A}> <{~ A}>)) as L4.
    pose proof (Lmp _ L4 L3) as L5.
    pose proof (Lax G (A3 A <{~ ~ A}>)) as L6.
    pose proof (Lmp _ L6 L5) as L7.
    pose proof (Lmp _ L7 L1) as L8.
    assumption.
  }
  assert ([<{~ ~ A}>] |- <{~ ~ A}>) by apply dedl, id_proof.
  exact (Lmp _ H H0).
Qed.

Lemma lemma32 : forall A, [] |- <{A -> ~ ~ A}>.
Proof.
  intros A.
  pose proof (lemma31 <{~ A}>).
  pose proof (Lax [] (A3 <{~ ~ A}> A)).
  eapply Lmp; eauto.
Qed.

Lemma contraction : forall A B S, [A;A] ++ S |- B -> A::S |- B.
Proof.
  intros A B S H.
  apply dedr in H.
  assert (A :: S |- A).
  {
    apply Lassmp.
    simpl; now destruct (fm_eq_dec _ _).
  }
  pose proof (Lmp _ H H0).
  assumption.
Qed.

Lemma lemma4 : forall A, [] |- <{(~ A -> A) -> A}>.
Proof.
  intros A.
  assert ([<{~ A}>] |- <{(~ A -> A) -> A}>).
  {
    apply dedr.
    remember [<{ ~ A -> A }>; <{ ~ A }>] as G.
    assert (G |- <{~ A -> A}>).
    {
      apply Lassmp. rewrite HeqG. simpl.
      destruct (fm_eq_dec _ _); auto.
    }
    assert (G |- <{~ A}>).
    {
      rewrite HeqG.
      apply weak, dedl, id_proof.
    }
    exact (Lmp _ H H0).
  }
  pose proof (lemma32 A).
  pose proof (lemma31 <{~ A -> A}>).
  assert ([<{(~ A -> A) -> A}>] |- ~ ~ (~ A -> A) -> ~ ~ A).
  {
    apply dedr.
    remember [<{ ~ ~ (~ A -> A) }>; <{ (~ A -> A) -> A }>] as G.
    assert (G |- A).
    {
      subst.
      apply Lmp with <{~ A -> A}>.
      - apply Lassmp. simpl. now destruct (fm_eq_dec _ _).
      - assert ([<{ ~ ~ (~ A -> A) }>; <{ (~ A -> A) -> A }>] |- ~ ~ (~ A -> A)).
        {
          apply Lassmp. simpl. now destruct (fm_eq_dec _ _).
        }
        apply (weak_l [<{ ~ ~ (~ A -> A) }>; <{ (~ A -> A) -> A }>]) in H1.
        apply (Lmp _ H1 H2).
    }
    apply weak_l with (S := G) in H0.
    apply (Lmp _ H0 H2).
  }
  pose proof (Lax [] (A3 <{~ (~ A -> A)}> <{~ A}>)).
  assert ([<{~ A}>] |- <{~ A -> ~ (~ A -> A)}>).
  {
    apply dedr in H2.
    apply weak_l with (S := [<{ ~ A }>]) in H2.
    apply weak_l with (S := [<{ ~ A }>]) in H3.
    pose proof (Lmp _ H2 H).
    pose proof (Lmp _ H3 H4).
    assumption.
  }
  apply dedl in H4.
  assert ([<{ ~ A }>] |- (~ (~ A -> A))) by (exact (contraction _ _ _ H4)).
  pose proof (Lax [] (A3 A <{~ A -> A}>)).
  apply dedr in H5.
  pose proof (Lmp _ H6 H5).
  assumption.
Qed.

Lemma lemma5 : forall A B, [] |- <{~ A -> (A -> B)}>.
Proof.
  intros A B.
  epose proof (Lax [] (A2 _ _ _)) as L1.
  epose proof (Lax [] (A1 _ _)) as L2.
  epose proof (Lax [] (A3 _ _)) as L3.
  epose proof (Lmp [] L2 L3) as L4.
  epose proof (Lmp [] L1 L4) as L5.
  epose proof (Lax [] (A1 _ _)) as L6.
  epose proof (Lmp [] L5 L6) as L7.
  eassumption.
Qed.

(* Note: we'd like to write exists A, S |- A /\ S |- <{~A}> but we
   can't because we need to be in Set not Prop *)
Definition inconsistent (S : list fm) := {A : fm & S |- A & S |- <{~ A}>}.
Definition consistent S := inconsistent S -> False.

(* An inconsistent set proves any formula *)
Lemma inconsistent_proves_all : forall S, inconsistent S -> forall A, S |- A.
Proof.
  intros S H A.
  destruct H as [x Hx HNx].
  pose proof ((lemma5 x A)).
  apply weak_l with (S := S) in H.
  pose proof (Lmp _ H HNx).
  pose proof (Lmp _ H0 Hx).
  assumption.
Qed.

Lemma lemma6r : forall S A, S |- A -> inconsistent (<{~ A}>::S).
Proof.
  intros S A H.
  apply (weak _ _ <{~ A}>) in H.
  assert (<{~ A }> :: S |- <{~A}>) by apply dedl, id_proof.
  unfold inconsistent.
  now exists A.
Qed.

Lemma lemma6l : forall S A, inconsistent (<{~ A}>::S) -> S |- A.
Proof.
  intros S A H.
  pose proof (inconsistent_proves_all _ H A).
  assert (S |- <{~ A -> A}>) by (now apply dedr).
  pose proof (weak_l S _ (lemma4 A)).
  pose proof (Lmp _ H2 H1).
  assumption.
Qed.

Require Import Decidable.

(* A subset of a consistent set is consistent. *)
Theorem consistent_drop : forall S A, consistent (A :: S) -> consistent S.
Proof.
  intros S A H.
  unfold consistent, inconsistent in *.
  intros [x Hx HNx].
  apply H.
  exists x; apply weak; auto.
Qed.


Require Export Coq.Init.Datatypes.
Require Export List.
Export ListNotations.
Require Export tactics.
Open Scope type_scope.

Inductive term : Type :=
|lambda : term -> term
|loc : nat -> term
|unit : term
|var : nat -> term
|app : term -> term -> term
|get : term -> term
|put : term -> term -> term
|alloc : term -> term
|fork : term -> term
|atomic : term -> term
|inatomic : term -> term.

Inductive value : term -> Prop :=
|v_lam : forall e, value (lambda e)
|v_loc : forall n, value (loc n)
|v_unit : value unit.

(*Evaluation context*)
Inductive ctxt : Type :=
|hole : ctxt
|appCtxt : term -> ctxt -> ctxt
|appValCtxt (t:term) : value t -> ctxt -> ctxt
|getCtxt : ctxt -> ctxt
|putCtxt : term -> ctxt -> ctxt
|putValCtxt (t:term) : value t -> ctxt -> ctxt
|allocCtxt : ctxt -> ctxt
|inatomicCtxt : ctxt -> ctxt.

(*location (address)*)
Definition location := nat.

(*timestamp used by the STM*)
Definition stamp := nat.

(*log entry for STM metadata*)
Inductive logItem : Type :=
|readItem : location -> ctxt -> term -> logItem
|writeItem : location -> term -> logItem
.

Definition log := list logItem.

Definition thread := option (nat * term) * log * term.

Inductive pool : Type :=
|Single : thread -> pool
|Par : pool -> pool -> pool.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Permutation Arith Omega.

Require Import utils ill_form.

Set Implicit Arguments.

Local Infix "~p" := (@perm_t _) (at level 70).

Reserved Notation "l '⊢' x" (at level 70, no associativity).

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ *)

Inductive ill_proof : list ill_form -> ill_form -> Type :=

  (* These are the SILL rules in the paper *)

  | in_llp_ax     : forall A,                         A::∅ ⊢ A

  | in_llp_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                      ->                 Δ ⊢ A

  | in_llp_limp_l : forall Γ Δ A B C,          Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A -o B::Γ++Δ ⊢ C

  | in_llp_limp_r : forall Γ A B,                    A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->            Γ ⊢ A -o B

  | in_llp_with_l1 : forall Γ A B C,                  A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A﹠B::Γ ⊢ C

  | in_llp_with_l2 : forall Γ A B C,                  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A﹠B::Γ ⊢ C

  | in_llp_with_r : forall Γ A B,               Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A﹠B

  | in_llp_bang_l : forall Γ A B,                    A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->            !A::Γ ⊢ B

  | in_llp_bang_r : forall Γ A,                       ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

  | in_llp_weak : forall Γ A B,                        Γ ⊢ B
                                           (*-----------------------------*)
                                      ->           !A::Γ ⊢ B

  | in_llp_cntr : forall Γ A B,                    !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

  (* These are the other rule for a complete sequent calculus for the whole ILL *)

  | in_llp_cut : forall Γ Δ A B,                 Γ ⊢ A    ->   A::Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ B

  | in_llp_times_l : forall Γ A B C,               A::B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊗B::Γ ⊢ C

  | in_llp_times_r : forall Γ Δ A B,             Γ ⊢ A    ->   Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ A⊗B

  | in_llp_plus_l :  forall Γ A B C,            A::Γ ⊢ C  ->  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊕B::Γ ⊢ C

  | in_llp_plus_r1 : forall Γ A B,                    Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

  | in_llp_plus_r2 : forall Γ A B,                    Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

  | in_llp_bot_l : forall Γ A,                     ⟘::Γ ⊢ A

  | in_llp_top_r : forall Γ,                          Γ ⊢ ⟙

  | in_llp_unit_l : forall Γ A,                       Γ ⊢ A
                                           (*-----------------------------*)
                                      ->           𝝐 ::Γ ⊢ A

  | in_llp_unit_r :                                   ∅ ⊢ 𝝐

where "l ⊢ x" := (ill_proof l x).

Fixpoint ill_cut_free Γ A (p : Γ ⊢ A) :=
  match p with
    | in_llp_ax _          => True
    | in_llp_perm H1 p     => ill_cut_free p
    | in_llp_limp_l p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_limp_r p      => ill_cut_free p
    | in_llp_with_l1 _ p   => ill_cut_free p
    | in_llp_with_l2 _ p   => ill_cut_free p
    | in_llp_with_r p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_bang_l p      => ill_cut_free p
    | in_llp_bang_r _ p    => ill_cut_free p
    | in_llp_weak _ p      => ill_cut_free p
    | in_llp_cntr p        => ill_cut_free p
    | in_llp_cut _ _       => False
    | in_llp_times_l p     => ill_cut_free p
    | in_llp_times_r p q   => ill_cut_free p /\ ill_cut_free q
    | in_llp_plus_l p q    => ill_cut_free p /\ ill_cut_free q
    | in_llp_plus_r1 _ p   => ill_cut_free p
    | in_llp_plus_r2 _ p   => ill_cut_free p
    | in_llp_bot_l _ _     => True
    | in_llp_top_r _       => True
    | in_llp_unit_l p      => ill_cut_free p
    | in_llp_unit_r        => True
  end.

Definition ill_cf_provable Γ A := { p : Γ ⊢ A | ill_cut_free p }.

Notation "Γ '⊢cf' A" := (ill_cf_provable Γ A) (at level 70, no associativity).

Fact ill_cf_ax A : A::∅ ⊢cf A.
Proof. exists (in_llp_ax A); simpl; auto. Qed.

Fact ill_cf_perm Γ Δ A : Γ ~p Δ -> Γ ⊢cf A -> Δ ⊢cf A.
Proof. intros H1 [p]; exists (in_llp_perm H1 p); simpl; auto. Qed.

Fact ill_cf_limp_l Γ Δ A B C : Γ ⊢cf A -> B::Δ ⊢cf C -> A -o B::Γ++Δ ⊢cf C.
Proof. intros [p] [q]; exists (in_llp_limp_l p q); simpl; auto. Qed.

Fact ill_cf_limp_r Γ A B : A::Γ ⊢cf B -> Γ ⊢cf A -o B.
Proof. intros [p]; exists (in_llp_limp_r p); simpl; auto. Qed.

Fact ill_cf_with_l1 Γ A B C : A::Γ ⊢cf C -> A﹠B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_with_l1 B p); simpl; auto. Qed.

Fact ill_cf_with_l2 Γ A B C : B::Γ ⊢cf C -> A﹠B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_with_l2 A p); simpl; auto. Qed.

Fact ill_cf_with_r Γ A B : Γ ⊢cf A -> Γ ⊢cf B -> Γ ⊢cf A﹠B.
Proof. intros [p] [q]; exists (in_llp_with_r p q); simpl; auto. Qed.

Fact ill_cf_bang_l Γ A B : A::Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_bang_l p); simpl; auto. Qed.

Fact ill_cf_bang_r Γ A : ‼Γ ⊢cf A -> ‼Γ ⊢cf !A.
Proof. intros [p]; exists (in_llp_bang_r _ p); simpl; auto. Qed.

Fact ill_cf_weak Γ A B : Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_weak A p); simpl; auto. Qed.

Fact ill_cf_cntr Γ A B : !A::!A::Γ ⊢cf B -> !A::Γ ⊢cf B.
Proof. intros [p]; exists (in_llp_cntr p); simpl; auto. Qed.

Fact ill_cf_times_l Γ A B C : A::B::Γ ⊢cf C -> A⊗B::Γ ⊢cf C.
Proof. intros [p]; exists (in_llp_times_l p); simpl; auto. Qed.

Fact ill_cf_times_r Γ Δ A B : Γ ⊢cf A -> Δ ⊢cf B -> Γ++Δ ⊢cf A⊗B.
Proof. intros [p] [q]; exists (in_llp_times_r p q); simpl; auto. Qed.

Fact ill_cf_plus_l Γ A B C : A::Γ ⊢cf C -> B::Γ ⊢cf C -> A⊕B::Γ ⊢cf C.
Proof. intros [p] [q]; exists (in_llp_plus_l p q); simpl; auto. Qed.

Fact ill_cf_plus_r1 Γ A B : Γ ⊢cf A -> Γ ⊢cf A⊕B.
Proof. intros [p]; exists (in_llp_plus_r1 _ p); simpl; auto. Qed.

Fact ill_cf_plus_r2 Γ A B : Γ ⊢cf B -> Γ ⊢cf A⊕B.
Proof. intros [p]; exists (in_llp_plus_r2 _ p); simpl; auto. Qed.

Fact ill_cf_bot_l Γ A : ⟘::Γ ⊢cf A.
Proof. exists (in_llp_bot_l _ _); simpl; auto. Qed.

Fact ill_cf_top_r Γ : Γ ⊢cf ⟙.
Proof. exists (in_llp_top_r _); simpl; auto. Qed.

Fact ill_cf_unit_l Γ A : Γ ⊢cf A -> 𝝐 ::Γ ⊢cf A.
Proof. intros [p]; exists (in_llp_unit_l p); simpl; auto. Qed.

Fact ill_cf_unit_r : ∅ ⊢cf 𝝐.
Proof. exists (in_llp_unit_r); simpl; auto. Qed.

Fact ill_cf_weak_ctx Γ Δ A : Δ ⊢cf A -> ‼Γ++Δ ⊢cf A.
Proof.
  intros H.
  induction Γ as [ | B ga IH ]; simpl; auto.
  apply ill_cf_weak; auto.
Qed.

Fact ill_cf_cntr_ctx Γ Δ A : ‼Γ++‼Γ++Δ ⊢cf A -> ‼Γ++Δ ⊢cf A.
Proof.
  revert Δ.
  induction Γ as [ | B ga IH ]; simpl; auto; intros de H.
  apply ill_cf_perm with (‼ga++!B::de).
  { apply perm_t_sym, perm_t_middle. }
  apply IH.
  apply ill_cf_perm with (!B::‼ga++‼ga++de).
  { apply perm_t_sym; focus (!B); apply perm_t_sym.
    rewrite app_assoc; apply perm_t_middle. }
  apply ill_cf_cntr.
  revert H; apply ill_cf_perm.
  constructor 2.
  apply perm_t_sym, perm_t_middle.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL B FREE SOFTWARE LICENSE AGREEMENT           *)
(**************************************************************)

From Coq
  Require Import Arith List Lia Eqdep_dec Utf8.

From Coq
  Require Vector.

From KruskalTrees
  Require Import notations tactics idx.

Set Implicit Arguments.

Import idx_notations.

#[local] Reserved Notation "v ⦃ p ⦄" (at level 1, format "v ⦃ p ⦄").
#[local] Reserved Notation "x '##' y" (at level 60, right associativity).
#[local] Reserved Notation "x '∈ᵥ' v" (at level 70, format "x  ∈ᵥ  v").
#[local] Reserved Notation "'⦑' i ',' v '⦒'"  (at level 0, format "⦑ i , v ⦒").

Notation vec := Vector.t.
Notation vec_nil := Vector.nil.
Notation vec_cons := Vector.cons.

Arguments vec_nil {A}.
Arguments vec_cons {A} _ {n}.

#[local] Notation "∅" := vec_nil.
#[local] Infix "##" := vec_cons.

Create HintDb vec_db.

Section vec_invert.

  Variable X : Type.

  (** General induction principle for vec 0 and vec (S n).
      Following Smaller inversions by JF Monin (TYPES 2022)
    *)

  Inductive vec_shape_O : vec X 0 -> Type :=
    | vec_shape_O_nil : vec_shape_O ∅.

  Inductive vec_shape_S {n} : vec X (S n) -> Type :=
    | vec_shape_S_cons x v : vec_shape_S (x##v).

  Definition vec_invert_t {n} : vec X n -> Type :=
    match n with
      | 0   => vec_shape_O
      | S n => vec_shape_S
    end.

  Definition vec_invert {n} v : @vec_invert_t n v :=
    match v return vec_invert_t v with
      | ∅    => vec_shape_O_nil
      | x##v => vec_shape_S_cons x v
    end.

  Definition vec_head n (v : vec X (S n)) :=
    match vec_invert v with
      | vec_shape_S_cons x _ => x
    end.

  Definition vec_tail n (v : vec X (S n)) :=
    match vec_invert v with
      | vec_shape_S_cons _ w => w
    end.

  Fact vec_head_tail n (v : vec X (S n)) : v = vec_head v##vec_tail v.
  Proof. now destruct (vec_invert v). Qed.

End vec_invert.

Arguments vec_head {_ _} _ /.
Arguments vec_tail {_ _} _ /.

Tactic Notation "vec" "invert" hyp(v) :=
  destruct (vec_invert v).

Tactic Notation "vec" "invert" hyp(v) "as" simple_intropattern(x) ident(w) :=
  destruct (vec_invert v) as [ x w ].

Section vec_in.

  Variable X : Type.

  (** vector membership, via an inductive definition, to allow for
      nesting in other induction definitions (strict positivity) *)

  Inductive vec_in x : ∀n, vec X n → Prop :=
    | vec_in_hd n (v : vec _ n)   :          x ∈ᵥ x##v
    | vec_in_tl n y (v : vec _ n) : x ∈ᵥ v → x ∈ᵥ y##v
  where "x ∈ᵥ v" := (vec_in x v).

  Hint Constructors vec_in : core.

  Fact vec_in_inv x n (v : vec _ n) :
         x ∈ᵥ v
       → match v with
           | ∅    => False
           | y##v => x = y \/ x ∈ᵥ v
         end.
  Proof. induction 1; auto. Qed.

  Fact vec_in_nil_inv x (v : vec X 0) : x ∈ᵥ v ↔ False.
  Proof. split; inversion 1. Qed.

  Fact vec_in_cons_inv x y n (v : vec _ n) : x ∈ᵥ y##v ↔ x = y ∨ vec_in x v.
  Proof.
    split.
    + apply vec_in_inv.
    + intros [ <- | ]; constructor; auto.
  Qed.

End vec_in.

Arguments vec_in {_} _ {_} _.

#[local] Notation "x ∈ᵥ v" := (vec_in x v).
#[global] Hint Constructors vec_in : vec_db.

(* 𝕆𝕊 λ ∀∃ → ↔ ∧ ∨ *)

Section vec_prj.

  Variable (X : Type).

  (** A nice implementation is *critical* here when using nested defs
      Notice that pos_O_rect is implemented with

                   match _ : Empty_set with end

      which allows vec_pos v p to be recognized as a sub-term of v *)

  Fixpoint vec_prj n (v : vec _ n) : idx n → X :=
    match v with
      | ∅    => idx_O_rect _
      | x##v => λ i,
      match idx_S_inv i with
        | None   => x
        | Some j => v⦃j⦄
      end
    end
  where "v ⦃ i ⦄" := (@vec_prj _ v i).

  (** The following fixpoint equations hold *by reduction*
      and v⦃i⦄ is effectivelly recognised as a sub-term of v
      by the guardness checker of Coq, so you can implement
      recursive fixpoint calls on these, for instance
      using vec in trees. *)

  Goal ∀n x (v : vec _ n),   (x##v)⦃𝕆⦄   = x.   Proof. reflexivity. Qed.
  Goal ∀n x (v : vec _ n) i, (x##v)⦃𝕊 i⦄ = v⦃i⦄. Proof. reflexivity. Qed.

  (** unlike idx n → X, vectors in vec X n are equal
      iff there components are *)

  Fact vec_prj_ext n (v w : vec X n) : (∀p, v⦃p⦄ = w⦃p⦄) → v = w.
  Proof.
    revert v w; induction n as [ | n IHn ]; intros v w.
    + vec invert v; vec invert w; trivial.
    + vec invert v as x v.
      vec invert w as y w.
      intros H; f_equal.
      * apply (H 𝕆).
      * apply IHn; intros; apply (H (𝕊 _)).
  Qed.

  Variable (n : nat).

  Fact vec_prj_fix_1 (v : vec X (S n)) : v⦃𝕆⦄ = vec_head v.
  Proof. now vec invert v as ? v. Qed.

  Fact vec_prj_fix_2 (v : vec X (S n)) p : v⦃𝕊 p⦄ = (vec_tail v)⦃p⦄.
  Proof. now vec invert v as ? v. Qed.

  Definition vec_nxt := vec_prj_fix_2.

  Fact vec_in_iff_prj x v : @vec_in X x n v ↔ ∃p, x = v⦃p⦄.
  Proof.
    split.
    + induction 1 as [ n v | n y v _ (p & Hp) ].
      * now exists 𝕆.
      * now exists (𝕊 p).
    + intros (p & ->).
      revert v p; induction n; intros v p;
        idx invert p; vec invert v as ? v; simpl; eauto with vec_db.
  Qed.

End vec_prj.

Arguments vec_prj {X n}.
#[local] Notation "v ⦃ i ⦄" := (vec_prj v i).

Tactic Notation "vec" "ext" "with" ident(p) :=
  apply vec_prj_ext; intros p.

Tactic Notation "vec" "ext" :=
  apply vec_prj_ext; intro.

Section vec_basics.

  Variable X : Type.

  (** Inversion lemmas for v _ 0 and vec _ (S n)

      Beware that the vec invert tactic is the preferred choice
   *)

  Fact vec_0_inv (v : vec X 0) : v = ∅.
  Proof. now vec invert v. Qed.

  Fact vec_S_inv n (v : vec X (S n)) : { x : _ & { w | v = x##w } }.
  Proof. now vec invert v as x w; eauto. Qed.

  (** vec_cons is injective *)

  Fact vec_cons_inj n x y (v w : vec X n) : x##v = y##w → x = y ∧ v = w.
  Proof.
     intros H; split.
     + now apply f_equal with (f := vec_head) in H.
     + now apply f_equal with (f := vec_tail) in H.
  Qed.

  (**    vec_prj : vec X n → (idx n → X)
     and vec_set : (idx n → X) → vec X n *)

  Fixpoint vec_set n : (idx n → X) → vec X n :=
    match n return (idx n → _) → vec _ n with
      | 0   => λ _, ∅
      | S n => λ f, f 𝕆##vec_set (fun p => f (𝕊 p))
    end.

  Fact vec_prj_set n (f : idx n → X) p : (vec_set f)⦃p⦄  = f p.
  Proof.
    revert f p; induction n as [ | n IHn ]; intros g p; idx invert p; auto.
    apply IHn.
  Qed.

  Fact vec_set_prj n v : @vec_set n (vec_prj v) = v.
  Proof. now vec ext; rewrite vec_prj_set. Qed.

  (** From vectors to lists *)

  Fixpoint vec_list n (v : vec X n) : list X :=
    match v with
      | ∅    => nil
      | x##v => x::vec_list v
    end.

  Fact vec_list_length n v : length (@vec_list n v) = n.
  Proof. induction v; simpl; f_equal; auto. Qed.

  Fact vec_list_idx n (v : vec X n) : vec_list v = map (vec_prj v) (idx_list n).
  Proof. induction v; simpl; f_equal; rewrite map_map; auto. Qed.

  Fact in_vec_list n v x : In x (@vec_list n v) ↔ ∃i, v⦃i⦄ = x.
  Proof.
    induction v as [ | n y v IH ]; simpl.
    * split; try tauto; intros (p & _); idx invert p.
    * split.
      + intros [ H | H ].
        - exists idx_fst; auto.
        - rewrite IH in H.
          destruct H as (p & Hp); exists (idx_nxt p); auto.
      + intros (p & Hp); idx invert p; auto.
        rewrite IH; firstorder.
  Qed.

  Fixpoint list_vec l : vec X ⌊l⌋ :=
    match l return vec X ⌊l⌋ with
      | nil  => ∅
      | x::l => x##list_vec l
    end.

  Fact vec_list_vec l : vec_list (list_vec l) = l.
  Proof. induction l; simpl; f_equal; auto. Qed.

  Fact list_vec_sig l : { n : nat & { v : vec _ n | vec_list v = l } }.
  Proof. exists (length l), (list_vec l); apply vec_list_vec. Qed.

  Fact list_vec_list n v : ∃e, v↺e = list_vec (@vec_list n v).
  Proof.
    induction v as [ | n x v (e & IHv) ]; simpl.
    + exists eq_refl; auto.
    + revert e IHv.
      generalize (vec_list v).
      intros l ->; simpl; intros ->.
      exists eq_refl; auto.
  Qed.

  Fact vec_list_split_inv n v l x r :
        @vec_list n v = l++x::r → { i | v⦃i⦄ = x /\ idx2nat i = ⌊l⌋ }.
  Proof.
    revert l x r.
    induction v as [ | n x v IHv ].
    + now intros [] ? ?.
    + intros [ | y l ] z r; simpl.
      * inversion 1; exists idx_fst; auto.
      * intros H; injection H; clear H; intros H1 <-.
        apply IHv in H1 as (p & H1 & H2).
        exists (idx_nxt p); split; simpl; auto.
  Qed.

  (** vector append *)

  Fixpoint vec_app n (v : vec X n) m (w : vec X m) : vec X (n+m) :=
    match v with
      | ∅    => w
      | x##v => x##vec_app v w
    end.

  Fact vec_app_idx_left n v m w p : (@vec_app n v m w)⦃idx_left _ p⦄ = v⦃p⦄.
  Proof. induction v; idx invert p; auto. Qed.

  Fact vec_app_idx_right n v m w p : (@vec_app n v m w)⦃idx_right _ p⦄ = w⦃p⦄.
  Proof. induction v; simpl; auto. Qed.

End vec_basics.

#[export] Hint Rewrite vec_prj_set vec_app_idx_left vec_app_idx_right : vec_db.

Tactic Notation "vec" "rew" := autorewrite with vec_db.

(* 𝕆𝕊 λ ∀∃ → ↔ ∧ ∨ *)

Section vec_map.

  Variables (X Y : Type) (f : X → Y).

  Fixpoint vec_map n (v : vec X n) : vec Y n :=
    match v with
      | ∅    => ∅
      | x##v => f x##vec_map v
    end.

  Fact vec_prj_map n v : ∀i : idx n, (vec_map v)⦃i⦄ = f v⦃i⦄.
  Proof. induction v; intro; idx invert all; auto. Qed.

  Fact vec_list_map n v : vec_list (@vec_map n v) = map f (vec_list v).
  Proof. induction v; simpl; f_equal; auto. Qed.

End vec_map.

#[export] Hint Rewrite vec_prj_map : vec_db.

Arguments vec_map {_ _} _ {_} _.

Fact vec_set_map X Y f n v : vec_set (fun i => f v⦃i⦄) = @vec_map X Y f n v.
Proof. now vec ext; vec rew. Qed.

Fact vec_map_map X Y Z (f : X -> Y) (g : Y -> Z) n (v : vec X n) :
    vec_map g (vec_map f v) = vec_map (fun x => g (f x)) v.
Proof. induction v; simpl; f_equal; auto. Qed.

Section lvec_hvec.

  Variable X : Type.

  (* isomorphic to list X but with length pre-computed *)

  Inductive lvec : Type :=
    | lvec_pack n : vec X n → lvec.

  Definition lvec_len l :=
    match l with
      | @lvec_pack n _ => n
    end.

  Definition lvec_vec l : vec _ (lvec_len l) :=
    match l with
      | lvec_pack v => v
    end.

  Fact lvec_pair_eq l : l = @lvec_pack (lvec_len l) (lvec_vec l).
  Proof. destruct l; auto. Qed.

  Definition hvec := vec lvec.

  Fixpoint hvec_size n (w : hvec n) :=
    match w with
      | ∅ => 0
      | v##w => 1+(lvec_len v+hvec_size w)
    end.

  Fact hvec_size_ge n w : n <= @hvec_size n w.
  Proof. induction w as [  | [] ]; simpl; tlia. Qed.

End lvec_hvec.

Arguments lvec_pack {X} n v.

Module vec_notations.

  Notation "∅" := vec_nil.
  Notation "x ## v" := (vec_cons x v).
  Notation "v ⦃ p ⦄" := (vec_prj v p).
  Notation "x ∈ᵥ v" := (@vec_in _ x _ v).
  Notation "⦑ i , v ⦒" := (lvec_pack i v).

End vec_notations.

Import vec_notations.

Theorem vec_eq_dec_ext X n (u v : vec X n) :
       (forall i, { u⦃i⦄ = v⦃i⦄ } + { u⦃i⦄ <> v⦃i⦄ })
    -> { u = v } + { u <> v }.
Proof.
  induction u as [ | x n u IH ] in v |- *.
  + vec invert v; eauto.
  + vec invert v as y v; intros H.
    destruct (H 𝕆) as [ C | C ]; simpl in C; subst.
    2: now right; contradict C; apply vec_cons_inj in C.
    specialize (fun i => H (𝕊 i)); simpl in H.
    apply IH in H as [ <- | C ]; auto.
    now right; contradict C; apply vec_cons_inj in C.
Qed.

Definition lvec_map {X Y} f v := match v with ⦑n,v⦒ => ⦑n,@vec_map X Y f n v⦒ end.

Section vec_reif.

  (** Finitary choice functions *)

  Variable (n : nat) (X : Type) (R : idx n → X → Prop).

  Fact vec_reif : (∀p, ∃x, R p x) → ∃v, ∀p, R p v⦃p⦄.
  Proof.
    intros H; idx reif H as (f & Hf).
    exists (vec_set f).
    now intro; vec rew.
  Qed.

  Fact vec_reif_t : (∀p, { x | R p x }) → { v | ∀p, R p v⦃p⦄ }.
  Proof.
    intros H; idx reif H as (f & Hf).
    exists (vec_set f).
    now intro; vec rew.
  Qed.

  Definition vec_reif_tt : (∀p, { x : _ & R p x }) → { v | ∀p, R p v⦃p⦄ }.
  Proof. intro; apply vec_reif_t; firstorder. Qed.

End vec_reif.

Tactic Notation "vec" "reif" hyp(H) "as" simple_intropattern(P) :=
  match type of H with
    | ∀_ : idx _, ex _ => apply vec_reif in H as P
    | ∀_ : idx _, sig _ => apply vec_reif_t in H as P
    | ∀_ : idx _, sigT _ => apply vec_reif_tt in H as P
  end.

Section vec_cond_reif.

  Variable (X Y : Type) (P : Y → Prop) (f : X → Y)
           (P_inv : ∀y, P y → { x | f x = y}).

  Fact vec_cond_reif n (w : vec _ n) :
      (∀i, P w⦃i⦄) → { v | vec_map f v = w }.
  Proof.
    intros H.
    generalize (fun i => P_inv (H i)); intros H'.
    vec reif H' as (v & Hv).
    exists v.
    now vec ext; vec rew.
  Qed.

End vec_cond_reif.

Section vec_fall.

  Variable (X : Type) (P : X → Prop).

  Definition vec_fall n (v : vec _ n) := ∀i, P v⦃i⦄.

  Fact vec_fall_nil : vec_fall ∅.
  Proof. intro; idx invert all. Qed.

  Fact vec_fall_cons n x (v : vec _ n) : P x → vec_fall v → vec_fall (x##v).
  Proof. intros H1 H2 p; idx invert p; auto. Qed.

  Hint Resolve vec_fall_nil vec_fall_cons : core.

  Fact vec_fall_nil_iff (v : vec _ 0) : vec_fall v ↔ True.
  Proof. vec invert v; split; auto. Qed.

  Fact vec_fall_cons_iff n x (v : vec _ n) : vec_fall (x##v) ↔ P x ∧ vec_fall v.
  Proof. unfold vec_fall; rewrite forall_idx_Sn; simpl; tauto. Qed.

  Section vec_fall_rect.

    Variables (Q : ∀n, vec _ n → Type)
              (Qnil : Q ∅)
              (Qcons : ∀n x (v : vec _ n), vec_fall v → Q v → Q (x##v)).

    Theorem vec_fall_rect n (v : vec _ n) : vec_fall v -> Q v.
    Proof.
      induction v as [ | n x v IH ]; intros H; auto.
      apply vec_fall_cons_iff in H as []; auto.
    Qed.

  End vec_fall_rect.

End vec_fall.

#[global] Hint Resolve vec_fall_nil vec_fall_cons : vec_db.

Section vec_fall2.

  Variables (X Y : Type) (R : X → Y → Prop).

  Definition vec_fall2 n (u : vec _ n) v := ∀i, R u⦃i⦄ v⦃i⦄.

  Fact vec_fall2_nil (v w : vec _ 0) : vec_fall2 v w.
  Proof. intro; idx invert all. Qed.

  Fact vec_fall2_cons n x (v : vec _ n) y w :
        R x y → vec_fall2 v w → vec_fall2 (x##v) (y##w).
  Proof. intros ? ? p; idx invert p; auto. Qed.

  Hint Resolve vec_fall2_nil vec_fall2_cons : core.

  Fact vec_fall2_cons_inv n x (v : vec _ n) y w :
         vec_fall2 (x##v) (y##w) ↔ R x y ∧ vec_fall2 v w.
  Proof.
    split.
    + intros H; split.
      * apply (H idx_fst).
      * intro; apply (H (idx_nxt _)).
    + intros []; apply vec_fall2_cons; auto.
  Qed.

  Section vec_fall2_rect.

    Variable (P : ∀n, vec X n → vec Y n → Type)
             (HP0 : P ∅ ∅)
             (HP1 : ∀ n x y v w, R x y → vec_fall2 v w → @P n v w → P (x##v) (y##w)).

    Fact vec_fall2_rect n : ∀ v w : vec _ n, vec_fall2 v w → P v w.
    Proof.
      induction n as [ | n IHn ]; intros v w.
      + vec invert v; vec invert w; auto.
      + vec invert v as x v; vec invert w as y w; intros Hw.
        apply vec_fall2_cons_inv in Hw as []; auto.
    Qed.

  End vec_fall2_rect.

End vec_fall2.

#[global] Hint Resolve vec_fall2_nil vec_fall2_cons : vec_db.

Fact vec_fall2_swap X Y R n u v :
     @vec_fall2 X Y R n u v → vec_fall2 (λ x y, R y x) v u.
Proof. induction 1 using vec_fall2_rect; auto with vec_db. Qed.


(***************************************************************************
* Formalization of ES calculi						   *
*									   *
* Generic Variables for Programming Language Metatheory                    *
* Brian Aydemir & Arthur Chargueraud, July 2007, 	                   *
* Fabien Renaud, 2011	                                                   *
* Flávio L. C. de Moura, 2015                     			   *
***************************************************************************)

Set Implicit Arguments.
Require Import List Max Omega Equalities Arith LibTactics.
Require Import MSetList MSetProperties MSetFacts MSetDecide.
Require Import Eqdep_dec.

(** * Definitions *)

Definition var := nat.

Declare Module Var_as_OT : UsualOrderedType
  with Definition t := var.
Module Import VarSet := MSetList.Make Var_as_OT.

Definition vars := VarSet.t.

Notation "{}" := (VarSet.empty).
Notation "{{ x }}" := (VarSet.singleton x).
Notation "s [=] t " := (VarSet.Equal s t) (at level 70, no associativity).
Notation "E \u F" := (VarSet.union E F)  (at level 68, left associativity).
Notation "x \in E" := (VarSet.In x E) (at level 69).
Notation "x \notin E" := (~ VarSet.In x E) (at level 69).
Notation "E << F" := (VarSet.Subset E F) (at level 70, no associativity).
Notation "E \rem F" := (VarSet.remove F E) (at level 70).

(* Properties on variables sets *)
Module Import VSP := WPropertiesOn Var_as_OT VarSet.
(* Facts on variables sets *)
Module Import VSF := WFactsOn Var_as_OT VarSet.
(* Some decision procedures on variables sets *)
Module Import VSD := WDecideOn Var_as_OT VarSet.

(** * Basic properties on sets.
The following lemmas already exist in the MSet library.
But it's long to find them and replace them everywhere so we keep them for the moment *)

Lemma in_empty : forall x,   x \in {} -> False.
Proof. VSD.fsetdec. Qed.

Lemma notin_singleton : forall x y,
  x \notin {{y}} <-> x <> y.
Proof. intros ; split ; VSD.fsetdec. Qed.

Lemma in_singleton : forall x y,  x \in {{y}} <-> x = y.
Proof. VSD.fsetdec. Qed.

Lemma in_union : forall x E F,
  x \in (E \u F) <-> (x \in E) \/ (x \in F).
Proof. intros ; split ; VSD.fsetdec. Qed.

Lemma notin_empty : forall x,
  x \notin {}.
Proof. VSD.fsetdec. Qed.

Lemma notin_same : forall x,
  x \notin {{x}} -> False.
Proof. VSD.fsetdec. Qed.

Lemma union_comm : forall E F,
  E \u F [=] F \u E.
Proof. intros. VSD.fsetdec. Qed.

Lemma notin_singleton_r : forall x y,
  x \notin {{y}} -> x <> y.
Proof. intros. VSD.fsetdec. Qed.

Lemma notin_singleton_l : forall x y,
  x <> y -> x \notin {{y}}.
Proof. intros. VSD.fsetdec. Qed.

Lemma notin_singleton_swap : forall x y,
  x \notin {{y}} -> y \notin {{x}}.
Proof.
  intros. apply notin_singleton_l.
  apply sym_not_eq. apply~ notin_singleton_r.
Qed.

Lemma notin_union : forall x E F,
  x \notin (E \u F) <-> (x \notin E) /\ (x \notin F).
Proof. intros. VSD.fsetdec. Qed.

Lemma notin_union_r : forall x E F,
  x \notin (E \u F) -> (x \notin E) /\ (x \notin F).
Proof. introv. rewrite* notin_union. Qed.

Lemma notin_union_r1 : forall x E F,
  x \notin (E \u F) -> (x \notin E).
Proof. introv. rewrite* notin_union. Qed.

Lemma notin_union_r2 : forall x E F,
  x \notin (E \u F) -> (x \notin F).
Proof. introv. rewrite* notin_union. Qed.

Lemma notin_union_l : forall x E F,
  x \notin E -> x \notin F -> x \notin (E \u F).
Proof. intros. rewrite~ notin_union. Qed.

Lemma union_comm_assoc : forall E F G,
  E \u (F \u G) [=] F \u (E \u G).
Proof. VSD.fsetdec. Qed.

Lemma union_assoc : forall E F G,
  E \u (F \u G) [=] (E \u F) \u G.
Proof. VSD.fsetdec. Qed.

Lemma union_same : forall E,
  E \u E [=] E.
Proof. VSD.fsetdec. Qed.

Lemma union_eq : forall E F E' F', E [=] E' -> F [=] F' -> E \u F [=] E' \u F'.
Proof. VSD.fsetdec. Qed.

Lemma union_empty_r : forall E,
  E \u {} [=] E.
Proof. VSD.fsetdec. Qed.

Lemma union_empty_l : forall E,
  {} \u E [=] E.
 Proof.  VSD.fsetdec. Qed.

Lemma subset_refl : forall E,
  E << E.
Proof. intros_all~. Qed.

Lemma subset_trans : forall F E G,
  E << F -> F << G -> E << G.
Proof. VSD.fsetdec. Qed.

Lemma subset_empty_l : forall E,
  {} << E.
Proof. VSD.fsetdec. Qed.

Lemma subset_singleton : forall x E,
  x \in E <-> {{x}} << E.
Proof. intros ; split ; VSD.fsetdec. Qed.

Lemma subset_union_weak_l : forall E F,
  E << (E \u F).
Proof. VSD.fsetdec. Qed.

Lemma subset_union_weak_r : forall E F,
  F << (E \u F).
Proof. VSD.fsetdec. Qed.

Lemma subset_union_trans_l : forall E F F', F << F' -> F \u E << F' \u E.
Proof. VSD.fsetdec. Qed.

Lemma subset_union_trans_r : forall E F F', F << F' -> E \u F << E \u F'.
Proof. VSD.fsetdec. Qed.

Lemma subset_union_l : forall E F G,
  (E \u F) << G <-> (E << G) /\ (F << G).
Proof. intros ; split ; intros ; try split ; VSD.fsetdec. Qed.

Lemma max_lt_l :
  forall (x y z : nat), x <= y -> x <= max y z.
Proof.
  induction x; auto with arith.
  induction y; induction z; simpl; auto with arith.
Qed.

(** * About lists *)
Require Import List.
Open Scope list_scope.

Lemma finite_nat_list_max : forall (l : list nat),
  { n : nat | forall x, In x  l -> x <= n }.
Proof.
  induction l as [ | l ls IHl ].
  exists 0; intros x H; inversion H.
  inversion IHl as [x H].
  exists (max x l); intros y J; simpl in J; inversion J.
    subst; auto with arith.
    assert (y <= x); auto using max_lt_l.
Qed.

Lemma finite_nat_list_max' : forall (l : list nat),
  { n : nat | ~ In n l }.
Proof.
  intros l. case (finite_nat_list_max l); intros x H.
  exists (S x). intros J. assert (K := H _ J); omega.
Qed.

Close Scope list_scope.

(** Finally, we have a means of generating fresh variables. *)
Definition var_gen (L : vars) : var :=
  proj1_sig (finite_nat_list_max' (elements L)).

Lemma var_gen_spec : forall E, (var_gen E) \notin E.
Proof.
  unfold var_gen. intros E.
  destruct (finite_nat_list_max' (elements E)) as [n pf].
  simpl. intros a.
  destruct pf.
  rewrite elements_iff in a.
  rewrite InA_alt in a.
  destruct a as [y [H1 H2]].
  subst.
  assumption.
Qed.

Lemma notin_var_gen : forall E F,
  (forall x, x \notin E -> x \notin F) ->
  (var_gen E) \notin F.
Proof. intros. auto~ var_gen_spec. Qed.

Lemma var_fresh : forall (L : vars), { x : var | x \notin L }.
Proof.
  intros L. exists (var_gen L). apply var_gen_spec.
Qed.

(* ********************************************************************** *)
(** * Properties of variables *)

Require Import Arith.
Lemma eq_var_dec : forall x y : var, {x = y} + {x <> y}.
Proof. exact eq_nat_dec. Defined.

Lemma subset_union_var : forall (E F : vars) (x:var), x \notin E -> x \notin F -> E \u {{x}} << F \u {{x}} -> E << F.
Proof. VSD.fsetdec. Qed.

(* Attention, conditions x \notin E and x \notin F are necessary, otherwise it's false *)
Lemma fset_union_notin : forall E F x, x \notin E -> x \notin F -> E \u {{x}} [=] F \u {{x}} -> E [=] F.
Proof. VSD.fsetdec. Qed.

(* ********************************************************************** *)
(** * Dealing with list of variables *)
Open Scope list_scope.

(** Freshness of n variables from a set L and from one another. *)
Fixpoint fresh (L : vars) (n : nat) (xs : list var) {struct xs} : Prop :=
  match xs, n with
  | nil, O => True
  | x::xs', S n' => x \notin L /\ fresh (L \u {{x}}) n' xs'
  | _,_ => False
  end.

Hint Extern 1 (fresh _ _ _) => simpl.

(** Triviality : If a list xs contains n fresh variables, then
    the length of xs is n. *)
Lemma fresh_length : forall xs L n,
  fresh L n xs -> n = length xs.
Proof.
  induction xs; simpl; intros; destruct n;
  try solve [ false~ | fequals* ].
Qed.

(* It is possible to build a list of n fresh variables. *)
Lemma var_freshes : forall L n,
  { xs : list var | fresh L n xs }.
Proof.
  intros. gen L. induction n; intros L.
  exists* (nil : list var).
  destruct (var_fresh L) as [x Fr].
   destruct (IHn (L \u {{x}})) as [xs Frs].
   exists* (x::xs).
Qed.