Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6b.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinear5.
Require Export lemma__collinearorder.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Definition lemma__parallelcollinear2 : forall A B C c d, (euclidean__defs.TP A B c d) -> ((euclidean__axioms.BetS c C d) -> (euclidean__defs.TP A B C d)).
Proof.
intro A.
intro B.
intro C.
intro c.
intro d.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.BetS d C c) as H1.
- apply (@euclidean__axioms.axiom__betweennesssymmetry c C d H0).
- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as H2.
-- assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as H2 by exact H.
assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (euclidean__defs.OS c d A B)))) as __TmpHyp by exact H2.
destruct __TmpHyp as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
split.
--- exact H3.
--- split.
---- exact H5.
---- split.
----- exact H7.
----- exact H8.
-- assert (* Cut *) (exists p q r, (euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col A B r) /\ ((euclidean__axioms.BetS c p q) /\ ((euclidean__axioms.BetS d r q) /\ ((euclidean__axioms.nCol A B c) /\ (euclidean__axioms.nCol A B d)))))) as H3.
--- assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (exists X U V, (euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.BetS c U X) /\ ((euclidean__axioms.BetS d V X) /\ ((euclidean__axioms.nCol A B c) /\ (euclidean__axioms.nCol A B d))))))))) as H3 by exact H2.
assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B c d)) /\ (exists X U V, (euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.BetS c U X) /\ ((euclidean__axioms.BetS d V X) /\ ((euclidean__axioms.nCol A B c) /\ (euclidean__axioms.nCol A B d))))))))) as __TmpHyp by exact H3.
destruct __TmpHyp as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [x H10].
destruct H10 as [x0 H11].
destruct H11 as [x1 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exists x0.
exists x.
exists x1.
split.
---- exact H13.
---- split.
----- exact H15.
----- split.
------ exact H17.
------ split.
------- exact H19.
------- split.
-------- exact H21.
-------- exact H22.
--- destruct H3 as [p H4].
destruct H4 as [q H5].
destruct H5 as [r H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H2 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
assert (* Cut *) (euclidean__axioms.neq C d) as H23.
---- assert (* Cut *) ((euclidean__axioms.neq C d) /\ ((euclidean__axioms.neq c C) /\ (euclidean__axioms.neq c d))) as H23.
----- apply (@lemma__betweennotequal.lemma__betweennotequal c C d H0).
----- destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H24.
---- assert (* Cut *) (euclidean__axioms.BetS q p c) as H24.
----- apply (@euclidean__axioms.axiom__betweennesssymmetry c p q H11).
----- assert (* Cut *) (euclidean__axioms.BetS q r d) as H25.
------ apply (@euclidean__axioms.axiom__betweennesssymmetry d r q H13).
------ assert (euclidean__axioms.BetS d C c) as H26 by exact H1.
assert (euclidean__axioms.BetS q p c) as H27 by exact H24.
assert (* Cut *) (euclidean__axioms.Col q p c) as H28.
------- right.
right.
right.
right.
left.
exact H27.
------- assert (* Cut *) (~(p = r)) as H29.
-------- intro H29.
assert (* Cut *) (euclidean__axioms.Col q r d) as H30.
--------- right.
right.
right.
right.
left.
exact H25.
--------- assert (euclidean__axioms.Col q p c) as H31 by exact H28.
assert (* Cut *) (euclidean__axioms.Col q p d) as H32.
---------- apply (@eq__ind__r euclidean__axioms.Point r (fun p0 => (euclidean__axioms.Col A B p0) -> ((euclidean__axioms.BetS c p0 q) -> ((euclidean__axioms.BetS q p0 c) -> ((euclidean__axioms.BetS q p0 c) -> ((euclidean__axioms.Col q p0 c) -> ((euclidean__axioms.Col q p0 c) -> (euclidean__axioms.Col q p0 d)))))))) with (x := p).
-----------intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
exact H30.

----------- exact H29.
----------- exact H7.
----------- exact H11.
----------- exact H24.
----------- exact H27.
----------- exact H28.
----------- exact H31.
---------- assert (* Cut *) (euclidean__axioms.neq q p) as H33.
----------- assert (* Cut *) ((euclidean__axioms.neq p c) /\ ((euclidean__axioms.neq q p) /\ (euclidean__axioms.neq q c))) as H33.
------------ apply (@lemma__betweennotequal.lemma__betweennotequal q p c H27).
------------ destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H36.
----------- assert (* Cut *) (euclidean__axioms.Col p c d) as H34.
------------ apply (@euclidean__tactics.not__nCol__Col p c d).
-------------intro H34.
apply (@euclidean__tactics.Col__nCol__False p c d H34).
--------------apply (@lemma__collinear4.lemma__collinear4 q p c d H31 H32 H33).

------------ assert (* Cut *) (euclidean__axioms.Col c d p) as H35.
------------- assert (* Cut *) ((euclidean__axioms.Col c p d) /\ ((euclidean__axioms.Col c d p) /\ ((euclidean__axioms.Col d p c) /\ ((euclidean__axioms.Col p d c) /\ (euclidean__axioms.Col d c p))))) as H35.
-------------- apply (@lemma__collinearorder.lemma__collinearorder p c d H34).
-------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H38.
------------- assert (* Cut *) (euclidean__defs.Meet A B c d) as H36.
-------------- exists p.
split.
--------------- exact H17.
--------------- split.
---------------- exact H19.
---------------- split.
----------------- exact H7.
----------------- exact H35.
-------------- apply (@H21 H36).
-------- assert (* Cut *) (euclidean__axioms.nCol p r c) as H30.
--------- apply (@euclidean__tactics.nCol__notCol p r c).
----------apply (@euclidean__tactics.nCol__not__Col p r c).
-----------apply (@lemma__NChelper.lemma__NChelper A B c p r H15 H7 H9 H29).

--------- assert (* Cut *) (euclidean__axioms.nCol p r d) as H31.
---------- apply (@euclidean__tactics.nCol__notCol p r d).
-----------apply (@euclidean__tactics.nCol__not__Col p r d).
------------apply (@lemma__NChelper.lemma__NChelper A B d p r H16 H7 H9 H29).

---------- assert (* Cut *) (euclidean__axioms.nCol r d p) as H32.
----------- assert (* Cut *) ((euclidean__axioms.nCol r p d) /\ ((euclidean__axioms.nCol r d p) /\ ((euclidean__axioms.nCol d p r) /\ ((euclidean__axioms.nCol p d r) /\ (euclidean__axioms.nCol d r p))))) as H32.
------------ apply (@lemma__NCorder.lemma__NCorder p r d H31).
------------ destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H35.
----------- assert (* Cut *) (euclidean__axioms.Col q r d) as H33.
------------ right.
right.
right.
right.
left.
exact H25.
------------ assert (* Cut *) (euclidean__axioms.Col r d q) as H34.
------------- assert (* Cut *) ((euclidean__axioms.Col r q d) /\ ((euclidean__axioms.Col r d q) /\ ((euclidean__axioms.Col d q r) /\ ((euclidean__axioms.Col q d r) /\ (euclidean__axioms.Col d r q))))) as H34.
-------------- apply (@lemma__collinearorder.lemma__collinearorder q r d H33).
-------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H37.
------------- assert (* Cut *) (d = d) as H35.
-------------- apply (@logic.eq__refl Point d).
-------------- assert (* Cut *) (euclidean__axioms.Col r d d) as H36.
--------------- right.
right.
left.
exact H35.
--------------- assert (* Cut *) (euclidean__axioms.neq q d) as H37.
---------------- assert (* Cut *) ((euclidean__axioms.neq r d) /\ ((euclidean__axioms.neq q r) /\ (euclidean__axioms.neq q d))) as H37.
----------------- apply (@lemma__betweennotequal.lemma__betweennotequal q r d H25).
----------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H41.
---------------- assert (* Cut *) (euclidean__axioms.nCol q d p) as H38.
----------------- apply (@euclidean__tactics.nCol__notCol q d p).
------------------apply (@euclidean__tactics.nCol__not__Col q d p).
-------------------apply (@lemma__NChelper.lemma__NChelper r d p q d H32 H34 H36 H37).

----------------- assert (* Cut *) (euclidean__axioms.nCol q p d) as H39.
------------------ assert (* Cut *) ((euclidean__axioms.nCol d q p) /\ ((euclidean__axioms.nCol d p q) /\ ((euclidean__axioms.nCol p q d) /\ ((euclidean__axioms.nCol q p d) /\ (euclidean__axioms.nCol p d q))))) as H39.
------------------- apply (@lemma__NCorder.lemma__NCorder q d p H38).
------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H46.
------------------ assert (euclidean__axioms.Col q p c) as H40 by exact H28.
assert (* Cut *) (c = c) as H41.
------------------- apply (@logic.eq__refl Point c).
------------------- assert (* Cut *) (~(c = p)) as H42.
-------------------- intro H42.
assert (* Cut *) (p = c) as H43.
--------------------- apply (@eq__ind__r euclidean__axioms.Point p (fun c0 => (euclidean__defs.TP A B c0 d) -> ((euclidean__axioms.BetS c0 C d) -> ((euclidean__axioms.BetS d C c0) -> ((euclidean__axioms.neq c0 d) -> ((~(euclidean__defs.Meet A B c0 d)) -> ((euclidean__defs.OS c0 d A B) -> ((euclidean__axioms.BetS c0 p q) -> ((euclidean__axioms.nCol A B c0) -> ((euclidean__axioms.BetS q p c0) -> ((euclidean__axioms.BetS d C c0) -> ((euclidean__axioms.BetS q p c0) -> ((euclidean__axioms.Col q p c0) -> ((euclidean__axioms.nCol p r c0) -> ((euclidean__axioms.Col q p c0) -> ((c0 = c0) -> (p = c0))))))))))))))))) with (x := c).
----------------------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 H57.

---------------------- exact H42.
---------------------- exact H.
---------------------- exact H0.
---------------------- exact H1.
---------------------- exact H19.
---------------------- exact H21.
---------------------- exact H22.
---------------------- exact H11.
---------------------- exact H15.
---------------------- exact H24.
---------------------- exact H26.
---------------------- exact H27.
---------------------- exact H28.
---------------------- exact H30.
---------------------- exact H40.
---------------------- exact H41.
--------------------- assert (* Cut *) (euclidean__axioms.Col p r c) as H44.
---------------------- right.
left.
exact H43.
---------------------- apply (@euclidean__tactics.Col__nCol__False q p d H39).
-----------------------apply (@euclidean__tactics.not__nCol__Col q p d).
------------------------intro H45.
apply (@euclidean__tactics.Col__nCol__False p r c H30 H44).

-------------------- assert (* Cut *) (p = p) as H43.
--------------------- apply (@logic.eq__refl Point p).
--------------------- assert (* Cut *) (euclidean__axioms.Col q p p) as H44.
---------------------- right.
right.
left.
exact H43.
---------------------- assert (* Cut *) (euclidean__axioms.nCol c p d) as H45.
----------------------- apply (@euclidean__tactics.nCol__notCol c p d).
------------------------apply (@euclidean__tactics.nCol__not__Col c p d).
-------------------------apply (@lemma__NChelper.lemma__NChelper q p d c p H39 H40 H44 H42).

----------------------- assert (* Cut *) (euclidean__axioms.Col c p q) as H46.
------------------------ assert (* Cut *) ((euclidean__axioms.Col p q c) /\ ((euclidean__axioms.Col p c q) /\ ((euclidean__axioms.Col c q p) /\ ((euclidean__axioms.Col q c p) /\ (euclidean__axioms.Col c p q))))) as H46.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder q p c H40).
------------------------- destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H54.
------------------------ assert (c = c) as H47 by exact H41.
assert (* Cut *) (euclidean__axioms.Col c p c) as H48.
------------------------- right.
left.
exact H47.
------------------------- assert (* Cut *) (euclidean__axioms.neq q c) as H49.
-------------------------- assert (* Cut *) ((euclidean__axioms.neq p c) /\ ((euclidean__axioms.neq q p) /\ (euclidean__axioms.neq q c))) as H49.
--------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal q p c H27).
--------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H53.
-------------------------- assert (* Cut *) (euclidean__axioms.nCol q c d) as H50.
--------------------------- apply (@euclidean__tactics.nCol__notCol q c d).
----------------------------apply (@euclidean__tactics.nCol__not__Col q c d).
-----------------------------apply (@lemma__NChelper.lemma__NChelper c p d q c H45 H46 H48 H49).

--------------------------- assert (euclidean__axioms.BetS q p c) as H51 by exact H27.
assert (* Cut *) (exists E, (euclidean__axioms.BetS q E C) /\ (euclidean__axioms.BetS d E p)) as H52.
---------------------------- apply (@euclidean__axioms.postulate__Pasch__inner q d c p C H51 H26 H50).
---------------------------- destruct H52 as [E H53].
destruct H53 as [H54 H55].
assert (* Cut *) (euclidean__axioms.BetS p E d) as H56.
----------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry d E p H55).
----------------------------- assert (euclidean__axioms.BetS q r d) as H57 by exact H25.
assert (* Cut *) (exists F, (euclidean__axioms.BetS q F E) /\ (euclidean__axioms.BetS p F r)) as H58.
------------------------------ apply (@euclidean__axioms.postulate__Pasch__inner q p d r E H57 H56 H38).
------------------------------ destruct H58 as [F H59].
destruct H59 as [H60 H61].
assert (* Cut *) (euclidean__axioms.Col p r F) as H62.
------------------------------- right.
right.
right.
right.
right.
exact H61.
------------------------------- assert (* Cut *) (euclidean__axioms.Col B r p) as H63.
-------------------------------- apply (@euclidean__tactics.not__nCol__Col B r p).
---------------------------------intro H63.
apply (@euclidean__tactics.Col__nCol__False B r p H63).
----------------------------------apply (@lemma__collinear4.lemma__collinear4 A B r p H9 H7 H17).

-------------------------------- assert (* Cut *) (euclidean__axioms.Col B A p) as H64.
--------------------------------- assert (* Cut *) ((euclidean__axioms.Col B A p) /\ ((euclidean__axioms.Col B p A) /\ ((euclidean__axioms.Col p A B) /\ ((euclidean__axioms.Col A p B) /\ (euclidean__axioms.Col p B A))))) as H64.
---------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B p H7).
---------------------------------- destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H65.
--------------------------------- assert (* Cut *) (euclidean__axioms.Col B A r) as H65.
---------------------------------- assert (* Cut *) ((euclidean__axioms.Col B A r) /\ ((euclidean__axioms.Col B r A) /\ ((euclidean__axioms.Col r A B) /\ ((euclidean__axioms.Col A r B) /\ (euclidean__axioms.Col r B A))))) as H65.
----------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B r H9).
----------------------------------- destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H66.
---------------------------------- assert (* Cut *) (euclidean__axioms.neq B A) as H66.
----------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H17).
----------------------------------- assert (* Cut *) (euclidean__axioms.Col B p r) as H67.
------------------------------------ assert (* Cut *) ((euclidean__axioms.Col r B p) /\ ((euclidean__axioms.Col r p B) /\ ((euclidean__axioms.Col p B r) /\ ((euclidean__axioms.Col B p r) /\ (euclidean__axioms.Col p r B))))) as H67.
------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B r p H63).
------------------------------------- destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
exact H74.
------------------------------------ assert (* Cut *) (euclidean__axioms.Col B p A) as H68.
------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col A p B) /\ ((euclidean__axioms.Col p B A) /\ ((euclidean__axioms.Col B p A) /\ (euclidean__axioms.Col p A B))))) as H68.
-------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A p H64).
-------------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
exact H75.
------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col A B C)) as H69.
-------------------------------------- intro H69.
assert (* Cut *) (euclidean__axioms.Col c C d) as H70.
--------------------------------------- right.
right.
right.
right.
left.
exact H0.
--------------------------------------- assert (* Cut *) (euclidean__axioms.Col c d C) as H71.
---------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C c d) /\ ((euclidean__axioms.Col C d c) /\ ((euclidean__axioms.Col d c C) /\ ((euclidean__axioms.Col c d C) /\ (euclidean__axioms.Col d C c))))) as H71.
----------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder c C d H70).
----------------------------------------- destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
exact H78.
---------------------------------------- assert (* Cut *) (euclidean__defs.Meet A B c d) as H72.
----------------------------------------- exists C.
split.
------------------------------------------ exact H17.
------------------------------------------ split.
------------------------------------------- exact H19.
------------------------------------------- split.
-------------------------------------------- exact H69.
-------------------------------------------- exact H71.
----------------------------------------- apply (@H21 H72).
-------------------------------------- assert (* Cut *) (euclidean__axioms.BetS q F C) as H70.
--------------------------------------- apply (@lemma__3__6b.lemma__3__6b q F E C H60 H54).
--------------------------------------- assert (* Cut *) (euclidean__axioms.BetS C F q) as H71.
---------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry q F C H70).
---------------------------------------- assert (* Cut *) (~(~(euclidean__defs.OS C d A B))) as H72.
----------------------------------------- intro H72.
assert (* Cut *) (~(euclidean__axioms.neq B p)) as H73.
------------------------------------------ intro H73.
assert (* Cut *) (euclidean__axioms.Col p r A) as H74.
------------------------------------------- apply (@euclidean__tactics.not__nCol__Col p r A).
--------------------------------------------intro H74.
apply (@euclidean__tactics.Col__nCol__False p r A H74).
---------------------------------------------apply (@lemma__collinear4.lemma__collinear4 B p r A H67 H68 H73).

------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A p r) as H75.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col r p A) /\ ((euclidean__axioms.Col r A p) /\ ((euclidean__axioms.Col A p r) /\ ((euclidean__axioms.Col p A r) /\ (euclidean__axioms.Col A r p))))) as H75.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder p r A H74).
--------------------------------------------- destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
exact H80.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A p B) as H76.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col p B A) /\ ((euclidean__axioms.Col p A B) /\ ((euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col B A p) /\ (euclidean__axioms.Col A p B))))) as H76.
---------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B p A H68).
---------------------------------------------- destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
exact H84.
--------------------------------------------- assert (* Cut *) (~(euclidean__axioms.neq A p)) as H77.
---------------------------------------------- intro H77.
assert (* Cut *) (euclidean__axioms.Col p r B) as H78.
----------------------------------------------- apply (@euclidean__tactics.not__nCol__Col p r B).
------------------------------------------------intro H78.
apply (@euclidean__tactics.Col__nCol__False p r B H78).
-------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 A p r B H75 H76 H77).

----------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H79.
------------------------------------------------ apply (@euclidean__tactics.not__nCol__Col A B F).
-------------------------------------------------intro H79.
apply (@euclidean__tactics.Col__nCol__False A B F H79).
--------------------------------------------------apply (@lemma__collinear5.lemma__collinear5 p r A B F H29 H74 H78 H62).

------------------------------------------------ assert (* Cut *) (euclidean__defs.OS C d A B) as H80.
------------------------------------------------- exists q.
exists F.
exists r.
split.
-------------------------------------------------- exact H79.
-------------------------------------------------- split.
--------------------------------------------------- exact H9.
--------------------------------------------------- split.
---------------------------------------------------- exact H71.
---------------------------------------------------- split.
----------------------------------------------------- exact H13.
----------------------------------------------------- split.
------------------------------------------------------ apply (@euclidean__tactics.nCol__notCol A B C H69).
------------------------------------------------------ exact H16.
------------------------------------------------- apply (@H69).
--------------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B C).
---------------------------------------------------intro H81.
apply (@H72 H80).

---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A r F) as H78.
----------------------------------------------- apply (@eq__ind__r euclidean__axioms.Point p (fun X => euclidean__axioms.Col X r F)) with (x := A).
------------------------------------------------ exact H62.
------------------------------------------------apply (@euclidean__tactics.NNPP (A = p) H77).

----------------------------------------------- assert (* Cut *) (euclidean__axioms.Col r A F) as H79.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col r A F) /\ ((euclidean__axioms.Col r F A) /\ ((euclidean__axioms.Col F A r) /\ ((euclidean__axioms.Col A F r) /\ (euclidean__axioms.Col F r A))))) as H79.
------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A r F H78).
------------------------------------------------- destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H80.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col r A B) as H80.
------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B r) /\ ((euclidean__axioms.Col A r B) /\ ((euclidean__axioms.Col r B A) /\ ((euclidean__axioms.Col B r A) /\ (euclidean__axioms.Col r A B))))) as H80.
-------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A r H65).
-------------------------------------------------- destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
exact H88.
------------------------------------------------- assert (* Cut *) (~(r = A)) as H81.
-------------------------------------------------- intro H81.
assert (* Cut *) (r = p) as H82.
--------------------------------------------------- assert (* Cut *) (A = p) as H82.
---------------------------------------------------- apply (@euclidean__tactics.NNPP (A = p) H77).
---------------------------------------------------- apply (@logic.eq__trans Point r A p H81 H82).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq p r) as H83.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq F q) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C q))) as H83.
----------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F q H71).
----------------------------------------------------- destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H29.
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq r p) as H84.
----------------------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric p r H83).
----------------------------------------------------- apply (@H69).
------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B C).
-------------------------------------------------------intro H85.
apply (@H84 H82).

-------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A F B) as H82.
--------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A F B).
----------------------------------------------------intro H82.
apply (@euclidean__tactics.Col__nCol__False A F B H82).
-----------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 r A F B H79 H80 H81).

--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H83.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col B A F) /\ ((euclidean__axioms.Col A B F) /\ (euclidean__axioms.Col B F A))))) as H83.
----------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A F B H82).
----------------------------------------------------- destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
exact H90.
---------------------------------------------------- assert (* Cut *) (euclidean__defs.OS C d A B) as H84.
----------------------------------------------------- exists q.
exists F.
exists r.
split.
------------------------------------------------------ exact H83.
------------------------------------------------------ split.
------------------------------------------------------- exact H9.
------------------------------------------------------- split.
-------------------------------------------------------- exact H71.
-------------------------------------------------------- split.
--------------------------------------------------------- exact H13.
--------------------------------------------------------- split.
---------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol A B C H69).
---------------------------------------------------------- exact H16.
----------------------------------------------------- apply (@H69).
------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B C).
-------------------------------------------------------intro H85.
apply (@H72 H84).

------------------------------------------ assert (* Cut *) (euclidean__axioms.neq A p) as H74.
------------------------------------------- assert (* Cut *) (B = p) as H74.
-------------------------------------------- apply (@euclidean__tactics.NNPP (B = p) H73).
-------------------------------------------- intro H75.
assert (* Cut *) (A = B) as Heq.
--------------------------------------------- apply (@logic.eq__trans Point A p B H75).
----------------------------------------------apply (@logic.eq__sym Point B p H74).

--------------------------------------------- assert False.
----------------------------------------------apply (@H17 Heq).
---------------------------------------------- contradiction.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A p B) as H75.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col p B A) /\ ((euclidean__axioms.Col p A B) /\ ((euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col B A p) /\ (euclidean__axioms.Col A p B))))) as H75.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B p A H68).
--------------------------------------------- destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
exact H83.
-------------------------------------------- assert (* Cut *) (A = A) as H76.
--------------------------------------------- apply (@logic.eq__refl Point A).
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B A A) as H77.
---------------------------------------------- right.
right.
left.
exact H76.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B A p) as H78.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col A B A) /\ ((euclidean__axioms.Col A A B) /\ ((euclidean__axioms.Col A B A) /\ ((euclidean__axioms.Col B A A) /\ (euclidean__axioms.Col A A B))))) as H78.
------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder B A A H77).
------------------------------------------------ destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
exact H64.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B A r) as H79.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col A p B) /\ ((euclidean__axioms.Col p B A) /\ ((euclidean__axioms.Col B p A) /\ (euclidean__axioms.Col p A B))))) as H79.
------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A p H78).
------------------------------------------------- destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H65.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col A p r) as H80.
------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A p r).
--------------------------------------------------intro H80.
apply (@euclidean__tactics.Col__nCol__False A p r H80).
---------------------------------------------------apply (@lemma__collinear5.lemma__collinear5 B A A p r H66 H77 H78 H79).

------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col p B r) as H81.
-------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col p B r).
---------------------------------------------------intro H81.
apply (@euclidean__tactics.Col__nCol__False p B r H81).
----------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 A p B r H75 H80 H74).

-------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col p r B) as H82.
--------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B p r) /\ ((euclidean__axioms.Col B r p) /\ ((euclidean__axioms.Col r p B) /\ ((euclidean__axioms.Col p r B) /\ (euclidean__axioms.Col r B p))))) as H82.
---------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder p B r H81).
---------------------------------------------------- destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
destruct H88 as [H89 H90].
exact H89.
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col p r A) as H83.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col p A r) /\ ((euclidean__axioms.Col p r A) /\ ((euclidean__axioms.Col r A p) /\ ((euclidean__axioms.Col A r p) /\ (euclidean__axioms.Col r p A))))) as H83.
----------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A p r H80).
----------------------------------------------------- destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
exact H86.
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H84.
----------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A B F).
------------------------------------------------------intro H84.
apply (@euclidean__tactics.Col__nCol__False A B F H84).
-------------------------------------------------------apply (@lemma__collinear5.lemma__collinear5 p r A B F H29 H83 H82 H62).

----------------------------------------------------- assert (* Cut *) (euclidean__defs.OS C d A B) as H85.
------------------------------------------------------ exists q.
exists F.
exists r.
split.
------------------------------------------------------- exact H84.
------------------------------------------------------- split.
-------------------------------------------------------- exact H9.
-------------------------------------------------------- split.
--------------------------------------------------------- exact H71.
--------------------------------------------------------- split.
---------------------------------------------------------- exact H13.
---------------------------------------------------------- split.
----------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol A B C H69).
----------------------------------------------------------- exact H16.
------------------------------------------------------ apply (@H69).
-------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col A B C).
--------------------------------------------------------intro H86.
apply (@H72 H85).

----------------------------------------- assert (* Cut *) (~(euclidean__defs.Meet A B C d)) as H73.
------------------------------------------ intro H73.
assert (exists R, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C d) /\ ((euclidean__axioms.Col A B R) /\ (euclidean__axioms.Col C d R)))) as H74 by exact H73.
destruct H74 as [R H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
assert (* Cut *) (euclidean__axioms.Col c C d) as H82.
------------------------------------------- assert (* Cut *) (euclidean__defs.OS C d A B) as H82.
-------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.OS C d A B) H72).
-------------------------------------------- right.
right.
right.
right.
left.
exact H0.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C d c) as H83.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col C c d) /\ ((euclidean__axioms.Col C d c) /\ ((euclidean__axioms.Col d c C) /\ ((euclidean__axioms.Col c d C) /\ (euclidean__axioms.Col d C c))))) as H83.
--------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder c C d H82).
--------------------------------------------- destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
exact H86.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.neq C d) as H84.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq F q) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C q))) as H84.
---------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F q H71).
---------------------------------------------- destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
exact H78.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Col d c R) as H85.
---------------------------------------------- assert (* Cut *) (euclidean__defs.OS C d A B) as H85.
----------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.OS C d A B) H72).
----------------------------------------------- apply (@euclidean__tactics.not__nCol__Col d c R).
------------------------------------------------intro H86.
apply (@euclidean__tactics.Col__nCol__False d c R H86).
-------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 C d c R H83 H81 H84).

---------------------------------------------- assert (* Cut *) (euclidean__axioms.Col c d R) as H86.
----------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col c d R) /\ ((euclidean__axioms.Col c R d) /\ ((euclidean__axioms.Col R d c) /\ ((euclidean__axioms.Col d R c) /\ (euclidean__axioms.Col R c d))))) as H86.
------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder d c R H85).
------------------------------------------------ destruct H86 as [H87 H88].
destruct H88 as [H89 H90].
destruct H90 as [H91 H92].
destruct H92 as [H93 H94].
exact H87.
----------------------------------------------- assert (* Cut *) (euclidean__defs.Meet A B c d) as H87.
------------------------------------------------ assert (* Cut *) (euclidean__defs.OS C d A B) as H87.
------------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.OS C d A B) H72).
------------------------------------------------- exists R.
split.
-------------------------------------------------- exact H76.
-------------------------------------------------- split.
--------------------------------------------------- exact H19.
--------------------------------------------------- split.
---------------------------------------------------- exact H80.
---------------------------------------------------- exact H86.
------------------------------------------------ apply (@H21 H87).
------------------------------------------ assert (* Cut *) (euclidean__defs.TP A B C d) as H74.
------------------------------------------- assert (* Cut *) (euclidean__defs.OS C d A B) as H74.
-------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.OS C d A B) H72).
-------------------------------------------- split.
--------------------------------------------- exact H17.
--------------------------------------------- split.
---------------------------------------------- exact H23.
---------------------------------------------- split.
----------------------------------------------- exact H73.
----------------------------------------------- exact H74.
------------------------------------------- exact H74.
Qed.


From isla Require Import opsem.

Definition a1824c : isla_trace :=
  WriteReg "R6" [] (RegVal_Base (Val_Bits (BV 64%N 0x200000%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Require Import Strings.String Lists.List ZArith.
From ExtLib.Structures Require Import Monad.
From FourCerty Require Import Utility Source StackLang.

Import Utility.

Import ListNotations.
Import MonadNotation.

Module SourceToStack.

Definition compile_val (v : SourceLang.val) :=
  match v with
  | SourceLang.V_Bool b => StackLang.V_Bool b
  | SourceLang.V_Int i => StackLang.V_Int i
  end.

Definition compile_prim1 (op : SourceLang.prim1) : StackLang.ins_uop :=
  match op with
  | SourceLang.P_add1 => StackLang.U_Add1
  | SourceLang.P_sub1 => StackLang.U_Sub1
  | SourceLang.P_not => StackLang.U_Not
  end.

Definition compile_prim2 (op : SourceLang.prim2) : StackLang.stk_ins :=
  match op with
  | SourceLang.P_add => StackLang.Bop StackLang.B_Add
  | SourceLang.P_sub => StackLang.Bop StackLang.B_Sub
  | SourceLang.P_and => StackLang.Bop StackLang.B_And
  | SourceLang.P_or => StackLang.Bop StackLang.B_Or
  | SourceLang.P_eq => StackLang.Cmp StackLang.C_Eq
  | SourceLang.P_lt => StackLang.Cmp StackLang.C_Lt
  | SourceLang.P_le => StackLang.Cmp StackLang.C_Le
  end.

Fixpoint lookup_depth (gamma : list (option string)) (x : string) :=
  match gamma with
  | nil => None
  | None :: gamma' => option_map S (lookup_depth gamma' x)
  | Some y :: gamma' => if eqb x y then Some 0 else option_map S (lookup_depth gamma' x)
  end.

Fixpoint compile_tm (gamma : list (option string)) (e : SourceLang.tm) k
    : StackLang.stk_tm :=
  match e with
  | SourceLang.Const v => StackLang.Ins (StackLang.Push (compile_val v)) k
  | SourceLang.Var x =>
    match lookup_depth gamma x with
    | None => StackLang.Ins StackLang.StkErr k
    | Some n => StackLang.Ins (StackLang.StkRef n) k
    end
  | SourceLang.Prim1 op e' =>
      compile_tm gamma e' (StackLang.Ins (StackLang.Uop (compile_prim1 op)) k)
  | SourceLang.Prim2 op e1 e2 =>
      compile_tm gamma e1 (compile_tm (None :: gamma) e2 (StackLang.Ins (compile_prim2 op) k))
  | SourceLang.App l e =>
      compile_tm gamma e (StackLang.Ins (StackLang.Call l 1) k)
  | SourceLang.If e1 e2 e3 =>
      compile_tm gamma e1 (StackLang.If (compile_tm gamma e2 StackLang.End)
                                        (compile_tm gamma e3 StackLang.End) k)
  | SourceLang.Let x e1 e2 =>
      compile_tm gamma e1 (compile_tm (Some x :: gamma) e2 (StackLang.Ins StackLang.Swap
                                                           (StackLang.Ins StackLang.Pop k)))
  end.

Definition compile_defn (defn: SourceLang.defn) : StackLang.stk_fun :=
  match defn with
  | SourceLang.Defn l x e =>
      StackLang.Fun l 1 (compile_tm [Some x] e (StackLang.Ins StackLang.Swap
                                                 (StackLang.Ins StackLang.Pop StackLang.End)))
  end.

Definition compile (src : SourceLang.prg) : StackLang.stk_prg :=
  match src with
  | SourceLang.Prg funs e =>
      StackLang.Prg (map compile_defn funs) (compile_tm [] e StackLang.End)
  end.

Definition compile_result (res : result SourceLang.val)
    : result (list StackLang.ins_val) :=
  v <- res;;
  ret [compile_val v].

(* Evaluation Lemmas *)

Lemma eval_if_false :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (inss1 : StackLang.stk_tm)
           (inss2 : StackLang.stk_tm)
           (inss3 : StackLang.stk_tm)
           (stk : list StackLang.ins_val),
  StackLang.eval' funs f (StackLang.If inss1 inss2 inss3) (StackLang.V_Bool false :: stk)
  =
  vs <- StackLang.eval' funs f inss2 stk;;
  StackLang.eval' funs f inss3 vs.
Proof.
  intros funs f inss1 inss2 inss3 stk.
  induction f; reflexivity.
Qed.

Lemma eval_if_true :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (inss1 : StackLang.stk_tm)
           (inss2 : StackLang.stk_tm)
           (inss3 : StackLang.stk_tm)
           (v : StackLang.ins_val)
           (stk : list StackLang.ins_val),
  v <> StackLang.V_Bool false ->
    StackLang.eval' funs f (StackLang.If inss1 inss2 inss3) (v :: stk)
    =
    vs <- StackLang.eval' funs f inss1 stk;;
    StackLang.eval' funs f inss3 vs.
Proof.
  intros funs f inss1 inss2 inss3 v stk H.
  destruct v.
  - induction f; reflexivity.
  - destruct b.
    + induction f; reflexivity.
    + contradiction.
Qed.

Lemma eval_prim1 : forall funs f op e env,
    SourceLang.eval' funs f (SourceLang.Prim1 op e) env
    =
    v <- SourceLang.eval' funs f e env;;
    SourceLang.do_prim1 op v.
Proof.
  intros funs f op e env.
  induction f; reflexivity.
Qed.

Lemma eval_prim2 : forall funs f op e1 e2 env,
    SourceLang.eval' funs f (SourceLang.Prim2 op e1 e2) env
    =
    v1 <- SourceLang.eval' funs f e1 env;;
    v2 <- SourceLang.eval' funs f e2 env;;
    SourceLang.do_prim2 op v1 v2.
Proof.
  intros funs f op e env.
  induction f; reflexivity.
Qed.

Lemma eval_app : forall funs f fn e env,
    SourceLang.eval' funs f (SourceLang.App fn e) env
    =
    v <- SourceLang.eval' funs f e env;;
    '(x, t) <- lookup funs fn;;
    match f with
    | O => Err OOF
    | S f' => SourceLang.eval' funs f' t (update empty x v)
    end.
Proof.
  intros funs f fn e env.
  induction f; reflexivity.
Qed.

Lemma eval_if : forall funs f e1 e2 e3 env,
    SourceLang.eval' funs f (SourceLang.If e1 e2 e3) env
    =
    v1 <- SourceLang.eval' funs f e1 env;;
    match v1 with
    | SourceLang.V_Bool false => SourceLang.eval' funs f e3 env
    | _ => SourceLang.eval' funs f e2 env
    end.
Proof.
  intros funs f e1 e2 e3 env.
  induction f; reflexivity.
Qed.

Lemma eval_let : forall funs f x e1 e2 env,
    SourceLang.eval' funs f (SourceLang.Let x e1 e2) env
    =
    v <- SourceLang.eval' funs f e1 env;;
    SourceLang.eval' funs f e2 (update env x v).
Proof.
  intros funs f x e1 e2 env.
  induction f; reflexivity.
Qed.

Lemma eval_var : forall funs f x env,
    SourceLang.eval' funs f (SourceLang.Var x) env = lookup env x.
Proof.
  intros funs f x env.
  induction f; reflexivity.
Qed.

(* Sequencing Lemmas *)

Lemma seq_eval_ins_end :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (ins : StackLang.stk_ins)
           (inss : StackLang.stk_tm)
           (stk : list StackLang.ins_val),
  StackLang.eval' funs f (StackLang.Ins ins inss) stk
  =
  vs <- StackLang.eval' funs f (StackLang.Ins ins StackLang.End) stk;;
  StackLang.eval' funs f inss vs.
Proof.
  intros funs f ins inss stk.
  destruct ins; try (induction f; reflexivity).
  - (* Call *)
    induction f.
    + simpl. destruct (Datatypes.length (firstn n stk) <? n); [reflexivity|].
      destruct (Utility.lookup funs l); [reflexivity|].
      destruct v. destruct (n0 =? n); reflexivity.
    + simpl. destruct (Datatypes.length (firstn n stk) <? n); [reflexivity|].
      destruct (Utility.lookup funs l); [reflexivity|].
      destruct v. destruct (n0 =? n); [|reflexivity].
      destruct (StackLang.eval' funs f s (firstn n stk)); reflexivity.
  - (* Pop *)
    induction f; destruct stk; reflexivity.
  - (* Swap *)
    induction f; simpl; destruct stk; [reflexivity| |reflexivity|];
    destruct stk; [reflexivity| |reflexivity|]; reflexivity.
  - (* StkRef *)
    induction f; simpl; destruct (nth_error stk n); reflexivity.
  - (* Uop *)
    induction f; simpl; destruct stk; [reflexivity| |reflexivity|];
    destruct (StackLang.do_uop _ _); reflexivity.
  - (* Bop *)
    induction f; simpl; destruct stk; [reflexivity| |reflexivity|];
    destruct stk; [reflexivity| |reflexivity|];
    destruct (StackLang.do_bop _ _); reflexivity.
  - (* Cmp *)
    induction f; simpl; destruct stk; [reflexivity| |reflexivity|]; destruct i;
    destruct stk; try reflexivity;
    destruct i0; reflexivity.
Qed.

Lemma seq_eval_if_end :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (inss1 : StackLang.stk_tm)
           (inss2 : StackLang.stk_tm)
           (inss3 : StackLang.stk_tm)
           (stk : list StackLang.ins_val),
  StackLang.eval' funs f (StackLang.If inss1 inss2 inss3) stk
  =
  vs <- StackLang.eval' funs f (StackLang.If inss1 inss2 StackLang.End) stk;;
  StackLang.eval' funs f inss3 vs.
Proof.
  intros funs f inss1 inss2 inss3 stk.
  destruct stk; [induction f; reflexivity|].
  destruct i.
  - induction f;
    rewrite eval_if_true; try discriminate;
    rewrite eval_if_true; try discriminate;
    destruct (StackLang.eval' funs _ inss1 stk); reflexivity.
  - destruct b.
    + induction f;
      rewrite eval_if_true; try discriminate;
      rewrite eval_if_true; try discriminate;
      destruct (StackLang.eval' funs _ inss1 stk); reflexivity.
    + induction f;
      rewrite eval_if_false; rewrite eval_if_false;
      destruct (StackLang.eval' funs _ inss2 stk); reflexivity.
Qed.

Fixpoint stk_append inss1 inss2 :=
  match inss1 with
  | StackLang.End => inss2
  | StackLang.Ins ins rst => StackLang.Ins ins (stk_append rst inss2)
  | StackLang.If thn els rst => StackLang.If thn els (stk_append rst inss2)
  end.

Lemma seq_eval_append :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (tm1 : StackLang.stk_tm)
           (tm2 : StackLang.stk_tm)
           (stk : list StackLang.ins_val),
  StackLang.eval' funs f (stk_append tm1 tm2) stk
  =
  vs <- StackLang.eval' funs f tm1 stk;;
  StackLang.eval' funs f tm2 vs.
Proof.
  intros funs f tm1.
  induction tm1.
  - induction f; reflexivity.
  - intros tm2 stk.
    simpl (stk_append (StackLang.Ins _ _) _).
    rewrite seq_eval_ins_end.
    rewrite seq_eval_ins_end with (inss:=tm1).
    destruct (StackLang.eval' _ _ (StackLang.Ins _ _) _); [reflexivity|].
    simpl. rewrite IHtm1.
    reflexivity.
  - intros tm2 stk.
    simpl (stk_append (StackLang.If _ _ _) _).
    rewrite seq_eval_if_end.
    rewrite seq_eval_if_end with (inss3:=tm1_3).
    destruct (StackLang.eval' _ _ (StackLang.If _ _ _) _); [reflexivity|].
    simpl. rewrite IHtm1_3.
    reflexivity.
Qed.

Lemma seq_eval_compile :
    forall (funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (e : SourceLang.tm)
           (inss : StackLang.stk_tm)
           (gamma : list (option string))
           (stk : list StackLang.ins_val),
  StackLang.eval' funs f (compile_tm gamma e inss) stk
  =
  vs <- StackLang.eval' funs f (compile_tm gamma e StackLang.End) stk;;
  StackLang.eval' funs f inss vs.
Proof.
  intros funs f e.
  induction e.
  - (* Const *)
    induction f; reflexivity.
  - (* Var *)
    intros inss gamma stk.
    simpl compile_tm.
    destruct (lookup_depth gamma x); rewrite seq_eval_ins_end; reflexivity.
  - (* Prim1 *)
    intros inss gamma stk.
    simpl compile_tm.
    rewrite IHe.
    rewrite IHe with (inss:=(StackLang.Ins _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e _) stk); [reflexivity|].
    simpl. rewrite seq_eval_ins_end. reflexivity.
  - (* Prim2 *)
    intros inss gamma stk.
    simpl compile_tm.
    rewrite IHe1.
    rewrite IHe1 with (inss:=(compile_tm _ _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e1 _) stk); [reflexivity|].
    simpl.
    rewrite IHe2.
    rewrite IHe2 with (inss:=(StackLang.Ins _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e2 _) v); [reflexivity|].
    simpl. rewrite seq_eval_ins_end. reflexivity.
  - (* App *)
    intros inss gamma stk.
    simpl compile_tm.
    rewrite IHe.
    rewrite IHe with (inss:=(StackLang.Ins _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e _)); [reflexivity|].
    simpl. rewrite seq_eval_ins_end. reflexivity.
  - (* If *)
    intros inss gamma stk.
    simpl compile_tm.
    rewrite IHe1.
    rewrite IHe1 with (inss:=(StackLang.If _ _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e1 _) stk); [reflexivity|].
    simpl. rewrite seq_eval_if_end. reflexivity.
  - (* Let *)
    intros inss gamma stk.
    simpl compile_tm.
    rewrite IHe1.
    rewrite IHe1 with (inss:=(compile_tm _ _ _)).
    destruct (StackLang.eval' funs f (compile_tm _ e1 _)); [reflexivity|].
    simpl.
    rewrite IHe2.
    rewrite IHe2 with (inss:=(StackLang.Ins StackLang.Swap
                               (StackLang.Ins StackLang.Pop StackLang.End))).
    destruct (StackLang.eval' _ _ (compile_tm _ e2 _)); [reflexivity|].
    simpl.
    assert (H: (StackLang.Ins StackLang.Swap (StackLang.Ins StackLang.Pop inss))
               = (stk_append (StackLang.Ins StackLang.Swap
                               (StackLang.Ins StackLang.Pop StackLang.End))
                             inss)). { reflexivity. }
    rewrite H. rewrite seq_eval_append. reflexivity.
Qed.

(* Consistency Lemmas *)

Inductive consistent_envs :
    SourceLang.environment -> list (option string) -> list StackLang.ins_val -> Prop :=
  | consistent_empty : consistent_envs empty [] []
  | consistent_var env gamma stk x v (c : consistent_envs env gamma stk) :
      consistent_envs (x |-> v; env) (Some x :: gamma) (compile_val v :: stk)
  | consistent_val env gamma stk v (c : consistent_envs env gamma stk) :
      consistent_envs env (None :: gamma) (v :: stk).

Lemma consistent_envs_in_scope :
    forall env gamma stk,
      consistent_envs env gamma stk ->
        forall x v, lookup env x = Ok v ->
          exists n, lookup_depth gamma x = Some n /\ nth_error stk n = Some (compile_val v).
Proof.
  intros env gamma stk HC.
  induction HC.
  - (* empty *)
    intros x v H. discriminate.
  - (* push var *)
    intros x0 v0 H. simpl.
    destruct (eqb x0 x) eqn:E.
    + (* var on top of stack *)
      apply eqb_eq in E as Heq.
      unfold lookup in H.
      rewrite Heq in H.
      rewrite update_eq in H.
      injection H as H.
      exists 0.
      simpl. rewrite H.
      split; reflexivity.
    + (* var lower *)
      apply eqb_neq in E as Hneq.
      unfold lookup in H, IHHC.
      rewrite update_neq in H; [|auto].
      apply IHHC in H as [n [H1 H2]].
      rewrite H1.
      exists (S n).
      split.
      * reflexivity.
      * assumption.
  - (* push unnamed value *)
    intros x v0 H. simpl.
    apply IHHC in H as [n [H1 H2]].
    rewrite H1.
    exists (S n).
    split.
    * reflexivity.
    * assumption.
Qed.

Lemma consistent_envs_err :
    forall env gamma stk,
      consistent_envs env gamma stk ->
        forall x, lookup env x = Err Error -> lookup_depth gamma x = None.
Proof.
  intros env gamma stk HC.
  induction HC.
  - (* empty *)
    intros x H. reflexivity.
  - (* push var *)
    intros x0 H. simpl.
    destruct (x0 =? x)%string eqn:E.
    + apply eqb_eq in E as Heq.
      unfold lookup in H.
      rewrite Heq in H.
      rewrite update_eq in H.
      discriminate.
    + apply eqb_neq in E as Hneq.
      unfold lookup in H, IHHC.
      rewrite update_neq in H; [|auto].
      specialize IHHC with x0.
      apply IHHC in H.
      rewrite H.
      reflexivity.
  - (* push val *)
    intros x H.
    simpl.
    rewrite (IHHC x H).
    reflexivity.
Qed.

Inductive consistent_funs :
    partial_map (string * SourceLang.tm) -> partial_map (nat * StackLang.stk_tm) -> Prop :=
  | consistent_funs_empty : consistent_funs empty empty
  | consistent_funs_update l x t s_funs sl_funs (c : consistent_funs s_funs sl_funs) :
      consistent_funs (l |-> (x, t); s_funs)
                      (l |-> (1, compile_tm [Some x] t
                                   (StackLang.Ins StackLang.Swap
                                   (StackLang.Ins StackLang.Pop StackLang.End)));
                             sl_funs).

Definition consistent_funs_consistent
    (s_funs : partial_map (string * SourceLang.tm))
    (sl_funs : partial_map (nat * StackLang.stk_tm)) :=
  consistent_funs s_funs sl_funs ->
  forall (x : string),
    (lookup s_funs x = Err Error /\ lookup sl_funs x = Err Error)
    \/
    (exists (y : string) (e : SourceLang.tm),
      lookup s_funs x = Ok (y, e)
      /\
      lookup sl_funs x = Ok (1, (compile_tm [Some y] e
                                  (StackLang.Ins StackLang.Swap
                                    (StackLang.Ins StackLang.Pop StackLang.End))))
      /\
      (forall (s_funs : partial_map (string * SourceLang.tm))
              (sl_funs : partial_map (nat * StackLang.stk_tm))
              (f : nat) (v : SourceLang.val),
        consistent_funs s_funs sl_funs
        ->
        compile_result (SourceLang.eval' s_funs f e (y |-> v))
        =
        StackLang.eval' sl_funs f (compile_tm [Some y] e
                                    (StackLang.Ins StackLang.Swap
                                      (StackLang.Ins StackLang.Pop StackLang.End)))
                        [compile_val v])).

(* Correctness Lemmas *)

Definition append_result (res : result (list StackLang.ins_val)) (rst : list StackLang.ins_val)
    : result (list StackLang.ins_val) :=
  vs <- res;;
  ret (vs ++ rst).

Lemma compile_prim1_correct : forall op v stk,
    append_result (compile_result (SourceLang.do_prim1 op v)) stk
    =
    v' <- StackLang.do_uop (compile_prim1 op) (compile_val v);;
    Ok (v' :: stk).
Proof.
  intros op v.
  destruct op.
  - (* Add1 *) destruct v; reflexivity.
  - (* Sub1 *) destruct v; reflexivity.
  - (* Not *)
    destruct v.
    + destruct b; reflexivity.
    + reflexivity.
Qed.

Lemma compile_prim2_correct : forall funs f op v1 v2 stk,
    append_result (compile_result (SourceLang.do_prim2 op v1 v2)) stk
    =
    StackLang.eval' funs f (StackLang.Ins (compile_prim2 op) StackLang.End)
      (compile_val v2 :: compile_val v1 :: stk).
Proof.
  intros funs f op v1 v2.
  destruct op; destruct v1; destruct v2; induction f; reflexivity.
Qed.

Lemma compile_tm_correct :
    forall (s_funs : partial_map (string * SourceLang.tm))
           (sl_funs : partial_map (nat * StackLang.stk_tm))
           (f : nat)
           (e : SourceLang.tm)
           (env : SourceLang.environment)
           (gamma : list (option string))
           (stk : list StackLang.ins_val),
  consistent_funs s_funs sl_funs ->
  consistent_funs_consistent s_funs sl_funs ->
  consistent_envs env gamma stk ->
    append_result (compile_result (SourceLang.eval' s_funs f e env)) stk
    =
    StackLang.eval' sl_funs f (compile_tm gamma e StackLang.End) stk.
Proof.
  intros s_funs sl_funs f e.
  induction e.
  - (* Const *)
    induction f; reflexivity.
  - (* Var *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite eval_var.
    destruct (lookup env x) eqn:E.
    + assert (Herr : e = Error).
      { unfold lookup in E.
        destruct (env x); [discriminate|].
        injection E as E. auto. }
      rewrite Herr in *.
      apply (consistent_envs_err env gamma stk HC) in E as Hdepth.
      rewrite Hdepth.
      induction f; reflexivity.
    + apply (consistent_envs_in_scope env gamma stk HC) in E as [n [H1 H2]].
      rewrite H1.
      induction f; simpl; rewrite H2; reflexivity.
  - (* Prim1 *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite seq_eval_compile.
    rewrite <- (IHe env gamma stk HF HF' HC).
    rewrite eval_prim1.
    destruct (SourceLang.eval' _ _ e _); [reflexivity|].
    simpl. rewrite compile_prim1_correct. induction f; reflexivity.
  - (* Prim2 *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite seq_eval_compile.
    rewrite <- (IHe1 env gamma stk HF HF' HC).
    rewrite eval_prim2.
    destruct (SourceLang.eval' _ _ e1 _); [reflexivity|].
    simpl.
    rewrite seq_eval_compile.
    rewrite <- (IHe2 env (None :: gamma) (compile_val v :: stk) HF HF'
                     (consistent_val env gamma stk (compile_val v) HC)).
    destruct (SourceLang.eval' _ _ e2 _); [reflexivity|].
    simpl. rewrite compile_prim2_correct with (funs:=sl_funs) (f:=f).
    induction f; reflexivity.
  - (* App *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite seq_eval_compile.
    rewrite <- (IHe env gamma stk HF HF' HC).
    rewrite eval_app.
    destruct (SourceLang.eval' s_funs f e env); [reflexivity|].
    simpl.
    destruct (HF' HF f0).
    destruct (lookup s_funs f0) eqn:E.
    + destruct H. injection H as H. rewrite H. destruct f; simpl; rewrite H0; reflexivity.
    + destruct H. discriminate.
    + destruct H as [x [e' [H1 [H2 H3]]]].
      rewrite H1.
      destruct f.
      * simpl. rewrite H2. reflexivity.
      * simpl. rewrite H2. simpl.
        rewrite H3 with (sl_funs:=sl_funs); [|assumption].
        induction f; reflexivity.
  - (* If *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite seq_eval_compile.
    rewrite <- (IHe1 env gamma stk HF HF' HC).
    rewrite eval_if.
    destruct (SourceLang.eval' _ _ e1 _); [reflexivity|].
    simpl. destruct v.
    + (* v is bool *)
      destruct b.
      * (* true *)
        rewrite (IHe2 env gamma stk HF HF' HC).
        simpl compile_val.
        rewrite eval_if_true; [|discriminate].
        destruct (StackLang.eval' _ _ (compile_tm _ e2 _) _); [reflexivity|].
        induction f; reflexivity.
      * (* false *)
        rewrite (IHe3 env gamma stk HF HF' HC).
        simpl compile_val.
        rewrite eval_if_false.
        destruct (StackLang.eval' _ _ (compile_tm _ e3 _) _); [reflexivity|].
        induction f; reflexivity.
    + rewrite (IHe2 env gamma stk HF HF' HC).
      simpl compile_val.
      rewrite eval_if_true; [|discriminate].
      destruct (StackLang.eval' _ _ (compile_tm _ e2 _) _); [reflexivity|].
      induction f; reflexivity.
  - (* Let *)
    intros env gamma stk HF HF' HC.
    simpl compile_tm.
    rewrite seq_eval_compile.
    rewrite <- (IHe1 env gamma stk HF HF' HC).
    rewrite eval_let.
    destruct (SourceLang.eval' _ _ e1 _); [reflexivity|].
    simpl. rewrite seq_eval_compile.
    simpl. rewrite <- (IHe2 (x |-> v; env) (Some x :: gamma) (compile_val v :: stk) HF HF'
                            (consistent_var env gamma stk x v HC)).
    destruct (SourceLang.eval' _ _ e2 _); [reflexivity|].
    induction f; reflexivity.
Qed.

(* Stronger Consistency Lemmas *)

Theorem append_result_empty : forall (res : result (list StackLang.ins_val)),
  res = append_result res [].
Proof.
  intros res.
  destruct res.
  - reflexivity.
  - unfold append_result. simpl.
    rewrite app_nil_r.
    reflexivity.
Qed.

Lemma compile_funs_consistent :
    forall (defns : list SourceLang.defn),
  consistent_funs (SourceLang.extract_funs defns)
                  (StackLang.extract_funs (map compile_defn defns)).
Proof.
  intros defns.
  induction defns.
  - simpl. apply consistent_funs_empty.
  - simpl. destruct a.
    apply consistent_funs_update.
    apply IHdefns.
Qed.

Lemma consistent_funs_indeed_consistent :
    forall (s_funs : partial_map (string * SourceLang.tm))
           (sl_funs : partial_map (nat * StackLang.stk_tm)),
  consistent_funs s_funs sl_funs ->
  consistent_funs_consistent s_funs sl_funs.
Proof.
  intros s_funs sl_funs H.
  induction H.
  - unfold consistent_funs_consistent.
    intros H x.
    left. split; reflexivity.
  - unfold consistent_funs_consistent.
    intros H' y.
    destruct (l =? y)%string eqn:E.
    + apply eqb_eq in E.
      right.
      exists x. exists t.
      rewrite E.
      split. { unfold lookup. rewrite update_eq. reflexivity. }
      split. { unfold lookup. rewrite update_eq. reflexivity. }
      intros.
      rewrite seq_eval_compile.
      rewrite <- compile_tm_correct with (s_funs:=s_funs0) (env:=(x |-> v)).
      * destruct (SourceLang.eval' _ _ _ _); [reflexivity|].
        destruct f; reflexivity.
      * assumption.
      * admit.
      * apply consistent_var.
        apply consistent_empty.
    + apply eqb_neq in E.
      apply IHconsistent_funs in H as H''.
      destruct (H'' y).
      * left. unfold lookup in *. simpl in *.
        rewrite update_neq; [|assumption].
        rewrite update_neq; [|assumption].
        assumption.
      * right. destruct H0 as [y0 [e [H1 [H2 H3]]]].
        exists y0. exists e.
        unfold lookup in *. simpl in *.
        rewrite update_neq; [|assumption].
        rewrite update_neq; [|assumption].
        split; [assumption|].
        split; [assumption|].
        assumption.
Admitted.

(* Full Correctness Theorem *)

Theorem compiler_correctness : forall (f : nat) (prg : SourceLang.prg),
  compile_result (SourceLang.eval f prg) = StackLang.eval f (compile prg).
Proof.
  intros f prg.
  rewrite (append_result_empty (compile_result _)).
  induction prg.
  unfold compile, SourceLang.eval, StackLang.eval.
  apply compile_tm_correct.
  - apply compile_funs_consistent.
  - apply consistent_funs_indeed_consistent.
    apply compile_funs_consistent.
  - apply consistent_empty.
Qed.

End SourceToStack.


Require Import CS Contractive ContractiveFacts Equiv NonEquiv Shape ShapeFacts
  Sty StyInd Subst SubstFacts Tac TL TLFacts Wf WfFacts.

Lemma cs_shape :
  forall S,
  Contractive S ->
  shape (cs S) = unitS \/
  shape (cs S) = sendS \/
  shape (cs S) = recvS \/
  shape (cs S) = ichoiceS \/
  shape (cs S) = echoiceS \/
  shape (cs S) = varS.
Proof.
  induction S using (well_founded_ind lt_Sty_mu_prefix_wf); intros;
    destruct S; cs_simpl; eauto 10 with contractive subst.
Qed.

Lemma cs_mu_absurd :
  forall S X S',
  Contractive S ->
  cs S <> mu X S'.
Proof.
  introv Hok H. eapply cs_shape in Hok. decompose_or_auto; shape_inv_auto;
  discriminate.
Qed.

Hint Extern 1 =>
  let step S X S' := (exfalso; apply (cs_mu_absurd S X S')) in
  match goal with
  | H : cs ?S = mu ?X ?S' |- _ => step S X S'
  | H : mu ?X ?S' = cs ?S |- _ => symmetry in H; step S X S'
  end
: subst.

Lemma cs_preserves_Sequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  Sequiv S S' ->
  Sequiv (cs S) (cs S').
Proof.
  apply (
    Sty_ind_mu_prefix2 (fun S S' =>
      Contractive S ->
      Contractive S' ->
      Sequiv S S' ->
      Sequiv (cs S) (cs S'))
  ).
  introv IH Hcontr Hcontr' Heq. inverts2 Heq; cs_simpl;
    eauto 10 with contractive subst.
Qed.
Hint Resolve cs_preserves_Sequiv : subst.

Lemma uncs_preserves_Sequiv_l :
  forall S S',
  Contractive S ->
  Sequiv (cs S) S' ->
  Sequiv S S'.
Proof.
  induction S using (well_founded_ind lt_Sty_mu_prefix_wf);
    intros; destruct S; cs_simpl; eauto 10 with contractive subst.
Qed.

Lemma uncs_preserves_Sequiv_r :
  forall S S',
  Contractive S' ->
  Sequiv S (cs S') ->
  Sequiv S S'.
Proof.
  induction S' using (well_founded_ind lt_Sty_mu_prefix_wf);
    intros; destruct S'; cs_simpl; eauto 10 with contractive subst.
Qed.

Lemma uncs_preserves_Sequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  Sequiv (cs S) (cs S') ->
  Sequiv S S'.
Proof.
  intros. eapply uncs_preserves_Sequiv_l; eauto.
  eapply uncs_preserves_Sequiv_r; eauto.
Qed.

Lemma cs_preserves_Sequiv_l :
  forall S S',
  Contractive S ->
  Contractive S' ->
  Sequiv S S' ->
  Sequiv (cs S) S'.
Proof.
  intros. eapply uncs_preserves_Sequiv_r; eauto.
  eapply cs_preserves_Sequiv; eauto.
Qed.

Lemma cs_preserves_Sequiv_r :
  forall S S',
  Contractive S ->
  Contractive S' ->
  Sequiv S S' ->
  Sequiv S (cs S').
Proof.
  intros. eapply uncs_preserves_Sequiv_l; eauto.
  eapply cs_preserves_Sequiv; eauto.
Qed.

Lemma cs_preserves_not_Sequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  ~ Sequiv S S' ->
  ~ Sequiv (cs S) (cs S').
Proof.
  introv Hok Hok' H contra. apply H. eapply uncs_preserves_Sequiv; eauto.
Qed.

Lemma uncs_preserves_not_Sequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  ~ Sequiv (cs S) (cs S') ->
  ~ Sequiv S S'.
Proof.
  introv Hok Hok' H contra. apply H. eapply cs_preserves_Sequiv; eauto.
Qed.

Lemma cs_preserves_NSequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  NSequiv S S' ->
  NSequiv (cs S) (cs S').
Proof.
  apply (Sty_ind_mu_prefix2 (fun S S' =>
    Contractive S ->
    Contractive S' ->
    NSequiv S S' ->
    NSequiv (cs S) (cs S')
  )).
  introv IH Hok Hok' Hneq. inverts Hneq; try cs_simpl;
    eauto 10 with contractive subst nsequiv.
  - destruct S; destruct S'; cs_simpl; auto with nsequiv; false.
Qed.

Lemma uncs_preserves_NSequiv :
  forall S S',
  Contractive S ->
  Contractive S' ->
  NSequiv (cs S) (cs S') ->
  NSequiv S S'.
Proof.
  apply (Sty_ind_mu_prefix2 (fun S S' =>
    Contractive S ->
    Contractive S' ->
    NSequiv (cs S) (cs S') ->
    NSequiv S S'
  )).
  introv IH Hok Hok' Hneq. destruct S; destruct S'; solve
    [ cs_simpl; auto
    | constructor; apply IH; eauto with contractive subst; cs_simpl;
        auto with nsequiv
    ].
Qed.

Lemma cs_preserves_Contractive :
  forall S,
  Contractive S ->
  Contractive (cs S).
Proof.
  induction S using (well_founded_ind lt_Sty_mu_prefix_wf); introv Hcontr;
    destruct S; cs_simpl; auto with contractive subst.
Qed.
Hint Resolve cs_preserves_Contractive : subst.

Lemma cs_preserves_Wf :
  forall S,
  Wf S ->
  Wf (cs S).
Proof.
  induction S using (well_founded_ind lt_Sty_mu_prefix_wf);
    introv Hwf; destruct S; cs_simpl; auto with subst wf.
Qed.
Hint Resolve cs_preserves_Wf : subst wf.

Lemma tl_eq :
  forall eta S S' c c',
  S = S' ->
  tl eta S c = tl eta S' c'.
Proof.
  introv Heq. gen c c'. rewrite Heq. apply tl_contractive_irrelevant.
Qed.

Lemma cs_preserves_tl :
  forall S eta c c',
  Wf S ->
  tl eta S c = tl eta (cs S) c'.
Proof.
  intros S eta. induction S using (well_founded_ind lt_Sty_mu_prefix_wf);
    introv Hwf; destruct S; try solve [apply tl_eq; cs_simpl; reflexivity].
  - erewrite tl_mu_subst. erewrite H with (y := subst v (mu v S) S).
    apply tl_eq. cs_simpl. reflexivity.
    all: auto 10 with subst wf.
Unshelve.
  all: auto with contractive subst.
Qed.
Hint Resolve cs_preserves_tl : subst.


Require Export Iron.Language.SystemF2Data.Type.Exp.
Require Export Iron.Language.SystemF2Data.Type.Relation.WfT.

(********************************************************************)
(* Type Utils *)
(* Get the type constructor of a type, if any *)
Fixpoint getCtorOfType (tt: ty) : option tycon :=
 match tt with
 | TCon tc   => Some tc
 | TApp t1 _ => getCtorOfType t1
 | _         => None
 end.

(* Construct a type application from a constructor type
   and a list of argument types. *)
Fixpoint makeTApps (t1: ty) (tt: list ty) : ty :=
 match tt with
 | nil     => t1
 | t :: ts => makeTApps (TApp t1 t) ts
 end.

(* Take the left most type along the in a tree of type applications. *)
Fixpoint takeTCon (tt: ty) : ty :=
 match tt with
 | TApp t1 t2 => takeTCon t1
 | _          => tt
 end.

(* Take the list of arguments in a nested type application,
   walking down the spine. *)
Fixpoint takeTArgs (tt: ty) : list ty :=
 match tt with
 | TApp t1 t2 => snoc t2 (takeTArgs t1)
 | _          => cons tt nil
 end.

(* Break apart a type application into the constructor type
   and a list of argument types. *)
Definition takeTApps (tt: ty) : (ty * list ty)
 := (takeTCon tt, takeTArgs tt).

(********************************************************************)
Lemma makeTApps_snoc
 : forall t1 t2 t3 ts
 , makeTApps (TApp t1 t2) (snoc t3 ts)
 = TApp (makeTApps t1 (cons t2 ts)) t3.
Proof.
 intros. gen t1 t2.
 induction ts; simpl; burn.
Qed.

Lemma makeTApps_snoc'
 :  forall t1 t2 ts
 ,  makeTApps t1 (snoc t2 ts)
 =  TApp (makeTApps t1 ts) t2.
Proof.
 intros. gen t1 t2.
 induction ts; intros.
  auto.
  simpl. auto.
Qed.

Lemma takeTCon_makeTApps
 :  forall t1 ts
 ,  takeTCon (makeTApps t1 ts) = takeTCon t1.
Proof.
 intros. gen t1.
 induction ts; intros; simpl; auto.
  rewrite IHts. burn.
Qed.
Hint Resolve takeTCon_makeTApps.

Lemma makeTApps_takeTCon
 :  forall t1 t2 ts
 ,  makeTApps t1 ts = t2
 -> takeTCon t1     = takeTCon t2.
Proof.
 intros. gen t1 t2.
 induction ts; intros.
 + simpl in H. subst. auto.
 + eapply IHts in H. simpl in H. auto.
Qed.
Hint Resolve makeTApps_takeTCon.

Lemma getCtorOfType_makeTApps
 :  forall tc t1 ts
 ,  getCtorOfType t1 = Some tc
 -> getCtorOfType (makeTApps t1 ts) = Some tc.
Proof.
 intros. gen t1.
 induction ts; intros.
 + auto.
 + snorm.
Qed.
Hint Resolve getCtorOfType_makeTApps.

Lemma makeTApps_rewind
 :  forall t1 t2 ts
 ,  makeTApps (TApp t1 t2) ts = makeTApps t1 (t2 :: ts).
Proof. intros. auto. Qed.

Lemma makeTApps_tycon_eq
 :  forall tc1 tc2 ts1 ts2
 ,  makeTApps (TCon tc1) ts1 = makeTApps (TCon tc2) ts2
 -> tc1 = tc2.
Proof.
 intros.
 have HT: ( takeTCon (makeTApps (TCon tc1) ts1)
          = takeTCon (makeTApps (TCon tc2) ts2))
  by (rewritess; snorm).
 repeat (rewrite takeTCon_makeTApps in HT).
 simpl in HT. inverts HT. auto.
Qed.

Lemma makeTApps_args_eq
 :  forall tc ts1 ts2
 ,  makeTApps (TCon tc) ts1  = makeTApps (TCon tc) ts2
 -> ts1 = ts2.
Proof.
 intros. gen ts2.
 induction ts1 using rev_ind; intros.
 - Case "ts1 = nil".
   simpl in H.
   destruct ts2.
   + SCase "ts2 ~ nil".
     auto.

   + SCase "ts2 ~ cons".
     simpl in H.
     lets D: @snocable ty ts2. inverts D.
     * simpl in H. nope.
     * destruct H0 as [t2].
       destruct H0 as [ts2'].
       subst.
       rewrite makeTApps_snoc in H. nope.

 - Case "ts1 ~ snoc".
   lets D: @snocable ty ts2. inverts D.
   + SCase "ts2 ~ nil".
     simpl in H.
     rewrite app_snoc in H.
     rewrite app_nil_right in H.
     rewrite makeTApps_snoc' in H.
     nope.

   + SCase "ts2 ~ snoc" .
     dest t. dest ts'. subst.
     rewrite app_snoc in H.
     rewrite app_snoc.
     snorm.
     rewrite makeTApps_snoc' in H.
     rewrite makeTApps_snoc' in H.
     inverts H.
     eapply IHts1 in H1. subst.
     auto.
Qed.

Lemma makeTApps_eq_params
 : forall tc1 tc2 ts1 ts2
 ,  makeTApps (TCon tc1) ts1 = makeTApps (TCon tc2) ts2
 -> tc1 = tc2 /\ ts1 = ts2.
Proof.
 intros.
 rrwrite (tc1 = tc2)
  by (eapply makeTApps_tycon_eq; eauto).
 rrwrite (ts1 = ts2)
  by (eapply makeTApps_args_eq; eauto).
 auto.
Qed.

Lemma makeTApps_wfT
 :  forall n t1 ts
 ,  wfT n t1
 -> Forall (wfT n) ts
 -> wfT n (makeTApps t1 ts).
Proof.
 intros. gen t1.
 induction ts; intros.
 - simpl. auto.
 - simpl.
   inverts H0.
   have HS: (ts = nil \/ (exists t ts', ts = t <: ts'))
    by (apply snocable).
   inverts HS.
   + simpl. auto.
   + dest H0. dest H0. subst.
     eapply IHts; auto.
Qed.