Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_ABE_CDE.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_equalitysymmetric.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ABD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ACD.
Require Import ProofCheckingEuclid.lemma_otherside_betweenness_PABC_RPQ_QABC.
Require Import ProofCheckingEuclid.lemma_otherside_betweenness_PABC_RQP_QABC.
Require Import ProofCheckingEuclid.lemma_outerconnectivity.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.
Require Import ProofCheckingEuclid.lemma_s_os.
Require Import ProofCheckingEuclid.lemma_twolines2.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_planeseparation_Col_C_Q_D :
	forall A B C D E Q G H,
	OS D A B E ->
	Col A B G ->
	Col A B H ->
	BetS C G Q ->
	BetS D H Q ->
	nCol A B C ->
	nCol A B D ->
	Col C Q D ->
	neq C D ->
	OS C A B E.
Proof.
	intros A B C D E Q G H.
	intros OS_D_AB_E.
	intros Col_A_B_G.
	intros Col_A_B_H.
	intros BetS_C_G_Q.
	intros BetS_D_H_Q.
	intros nCol_A_B_C.
	intros nCol_A_B_D.
	intros Col_C_Q_D.
	intros neq_C_D.

	assert (OS_D_AB_E2 := OS_D_AB_E).
	destruct OS_D_AB_E2 as (W & BetS_D_W_E & Col_A_B_W & _).

	pose proof (lemma_betweennotequal _ _ _ BetS_D_W_E) as (neq_W_E & neq_D_W & neq_D_E).
	assert (Col D W E) as Col_D_W_E by (unfold Col; one_of_disjunct BetS_D_W_E).
	pose proof (lemma_collinearorder _ _ _ Col_D_W_E) as (Col_W_D_E & Col_W_E_D & Col_E_D_W & Col_D_E_W & Col_E_W_D).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_W_E) as BetS_E_W_D.
	pose proof (lemma_collinearorder _ _ _ Col_A_B_W) as (Col_B_A_W & Col_B_W_A & Col_W_A_B & Col_A_W_B & Col_W_B_A).

	pose proof (lemma_collinearorder _ _ _ Col_A_B_G) as (Col_B_A_G & Col_B_G_A & Col_G_A_B & Col_A_G_B & Col_G_B_A).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_H) as (Col_B_A_H & Col_B_H_A & Col_H_A_B & Col_A_H_B & Col_H_B_A).

	pose proof (lemma_betweennotequal _ _ _ BetS_C_G_Q) as (neq_G_Q & neq_C_G & neq_C_Q).
	pose proof (lemma_betweennotequal _ _ _ BetS_D_H_Q) as (neq_H_Q & neq_D_H & neq_D_Q).
	assert (Col C G Q) as Col_C_G_Q by (unfold Col; one_of_disjunct BetS_C_G_Q).
	assert (Col D H Q) as Col_D_H_Q by (unfold Col; one_of_disjunct BetS_D_H_Q).
	pose proof (lemma_collinearorder _ _ _ Col_C_G_Q) as (Col_G_C_Q & Col_G_Q_C & Col_Q_C_G & Col_C_Q_G & Col_Q_G_C).
	pose proof (lemma_collinearorder _ _ _ Col_D_H_Q) as (Col_H_D_Q & Col_H_Q_D & Col_Q_D_H & Col_D_Q_H & Col_Q_H_D).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_C_G_Q) as BetS_Q_G_C.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_H_Q) as BetS_Q_H_D.

	pose proof (lemma_NCdistinct _ _ _ nCol_A_B_C) as (neq_A_B & neq_B_C & neq_A_C & neq_B_A & neq_C_B & neq_C_A).
	pose proof (lemma_NCdistinct _ _ _ nCol_A_B_D) as (_ & neq_B_D & neq_A_D & _ & neq_D_B & neq_D_A).
	pose proof (lemma_NCorder _ _ _ nCol_A_B_C) as (nCol_B_A_C & nCol_B_C_A & nCol_C_A_B & nCol_A_C_B & nCol_C_B_A).
	pose proof (lemma_NCorder _ _ _ nCol_A_B_D) as (nCol_B_A_D & nCol_B_D_A & nCol_D_A_B & nCol_A_D_B & nCol_D_B_A).

	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_D) as n_Col_A_B_D.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_C_A_B) as n_Col_C_A_B.

	pose proof (lemma_inequalitysymmetric _ _ neq_C_G) as neq_G_C.
	pose proof (lemma_inequalitysymmetric _ _ neq_C_Q) as neq_Q_C.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_E) as neq_E_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_H) as neq_H_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_Q) as neq_Q_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_W) as neq_W_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_H_Q) as neq_Q_H.
	pose proof (lemma_inequalitysymmetric _ _ neq_W_E) as neq_E_W.

	pose proof (lemma_collinearorder _ _ _ Col_C_Q_D) as (Col_Q_C_D & Col_Q_D_C & Col_D_C_Q & Col_C_D_Q & Col_D_Q_C).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_Q_C_G Col_Q_C_D neq_Q_C) as Col_C_G_D.
	pose proof (lemma_collinearorder _ _ _ Col_C_G_D) as (Col_G_C_D & Col_G_D_C & Col_D_C_G & Col_C_D_G & Col_D_G_C).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_Q_H Col_D_Q_C neq_D_Q) as Col_Q_H_C.
	pose proof (lemma_collinearorder _ _ _ Col_Q_H_C) as (Col_H_Q_C & Col_H_C_Q & Col_C_Q_H & Col_Q_C_H & Col_C_H_Q).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_Q_D_C Col_Q_D_H neq_Q_D) as Col_D_C_H.
	pose proof (lemma_collinearorder _ _ _ Col_D_C_H) as (Col_C_D_H & Col_C_H_D & Col_H_D_C & Col_D_H_C & Col_H_C_D).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_W Col_A_B_G neq_A_B) as Col_B_W_G.
	pose proof (lemma_collinearorder _ _ _ Col_B_W_G) as (Col_W_B_G & Col_W_G_B & Col_G_B_W & Col_B_G_W & Col_G_W_B).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_W Col_B_A_G neq_B_A) as Col_A_W_G.
	pose proof (lemma_collinearorder _ _ _ Col_A_W_G) as (Col_W_A_G & Col_W_G_A & Col_G_A_W & Col_A_G_W & Col_G_W_A).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_H Col_B_A_G neq_B_A) as Col_A_H_G.
	pose proof (lemma_collinearorder _ _ _ Col_A_H_G) as (Col_H_A_G & Col_H_G_A & Col_G_A_H & Col_A_G_H & Col_G_H_A).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_H Col_A_B_G neq_A_B) as Col_B_H_G.
	pose proof (lemma_collinearorder _ _ _ Col_B_H_G) as (Col_H_B_G & Col_H_G_B & Col_G_B_H & Col_B_G_H & Col_G_H_B).

	assert (~ (Col C A B /\ Col D A B)) as n_Col_C_A_B_and_Col_D_A_B.
	{
		intros (Col_C_A_B & Col_D_A_B).
		contradict n_Col_C_A_B.
		exact Col_C_A_B.
	}
	pose proof (
		lemma_twolines2
		C D A B G H
		neq_C_D neq_A_B
		Col_G_C_D Col_G_A_B
		Col_H_C_D Col_H_A_B
		n_Col_C_A_B_and_Col_D_A_B
	) as eq_G_H.

	assert (BetS Q G D) as BetS_Q_G_D by (rewrite eq_G_H; exact BetS_Q_H_D).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_Q_G_D) as BetS_D_G_Q.
	pose proof (lemma_betweennotequal _ _ _ BetS_Q_G_D) as (neq_G_D & _ & _).
	pose proof (lemma_inequalitysymmetric _ _ neq_G_D) as neq_D_G.

	assert (Col Q G D) as Col_Q_G_D by (unfold Col; one_of_disjunct BetS_Q_G_D).
	pose proof (lemma_collinearorder _ _ _ Col_Q_G_D) as (Col_G_Q_D & Col_G_D_Q & Col_D_Q_G & Col_Q_D_G & Col_D_G_Q).

	assert (Col E D G \/ ~ Col E D G) as [Col_E_D_G|n_Col_E_D_G] by (apply Classical_Prop.classic).
	{
		(* case Col_E_D_G *)
		pose proof (lemma_collinearorder _ _ _ Col_E_D_G) as (Col_D_E_G & Col_D_G_E & Col_G_E_D & Col_E_G_D & Col_G_D_E).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_G_E Col_D_G_Q neq_D_G) as Col_G_E_Q.
		pose proof (lemma_collinearorder _ _ _ Col_G_E_Q) as (Col_E_G_Q & Col_E_Q_G & Col_Q_G_E & Col_G_Q_E & Col_Q_E_G).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_E_W Col_D_E_G neq_D_E) as Col_E_W_G.
		pose proof (lemma_collinearorder _ _ _ Col_E_W_G) as (Col_W_E_G & Col_W_G_E & Col_G_E_W & Col_E_G_W & Col_G_W_E).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_E_W_G Col_E_W_D neq_E_W) as Col_W_G_D.
		pose proof (lemma_collinearorder _ _ _ Col_W_G_D) as (Col_G_W_D & Col_G_D_W & Col_D_W_G & Col_W_D_G & Col_D_G_W).

		assert (~ ~ eq W G) as eq_W_G.
		{
			intros neq_W_G.

			assert (~ ~ eq G B) as eq_G_B.
			{
				intros neq_G_B.
				(* case neq_G_B *)
				pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_W_G_D Col_W_G_B neq_W_G) as Col_G_D_B.
				pose proof (lemma_collinearorder _ _ _ Col_G_D_B) as (Col_D_G_B & Col_D_B_G & Col_B_G_D & Col_G_B_D & Col_B_D_G).
				pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_B_D Col_G_B_A neq_G_B) as Col_B_D_A.
				pose proof (lemma_collinearorder _ _ _ Col_B_D_A) as (_ & _ & Col_A_B_D & _ & _).

				contradict Col_A_B_D.
				exact n_Col_A_B_D.
			}
			apply Classical_Prop.NNPP in eq_G_B.

			pose proof (lemma_equalitysymmetric _ _ eq_G_B) as eq_B_G.

			assert (~ eq G A) as neq_G_A.
			{
				intros eq_G_A.

				assert (eq B A) as eq_B_A by (rewrite eq_B_G; exact eq_G_A).

				contradict eq_B_A.
				exact neq_B_A.
			}
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_W_G_D Col_W_G_A neq_W_G) as Col_G_D_A.
			pose proof (lemma_collinearorder _ _ _ Col_G_D_A) as (_ & _ & _ & Col_G_A_D & _).
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_A_D Col_G_A_B neq_G_A) as Col_A_D_B.
			pose proof (lemma_collinearorder _ _ _ Col_A_D_B) as (_ & _ & _ & Col_A_B_D & _).

			contradict Col_A_B_D.
			exact n_Col_A_B_D.
		}
		apply Classical_Prop.NNPP in eq_W_G.

		pose proof (lemma_equalitysymmetric _ _ eq_W_G) as eq_G_W.
		assert (BetS D G E) as BetS_D_G_E by (rewrite eq_G_W; exact BetS_D_W_E).
		pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_G_E) as BetS_E_G_D.

		assert (BetS G C D \/ ~ BetS G C D) as [BetS_G_C_D|nBetS_G_C_D] by (apply Classical_Prop.classic).
		{
			(* case BetS_G_C_D *)
			pose proof (axiom_orderofpoints_ABD_BCD_ABC _ _ _ _ BetS_E_G_D BetS_G_C_D) as BetS_E_G_C.
			pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_G_C) as BetS_C_G_E.

			pose proof (lemma_s_os _ _ _ _ _ BetS_C_G_E Col_A_B_G nCol_A_B_C) as OS_C_AB_E.

			exact OS_C_AB_E.
		}
		{
			(* case nBetS_G_C_D *)
			assert (BetS G D C \/ ~ BetS G D C) as [BetS_G_D_C|nBetS_G_D_C] by (apply Classical_Prop.classic).
			{
				(* case BetS_G_D_C *)
				pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_E_G_D BetS_G_D_C) as BetS_E_G_C.
				pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_G_C) as BetS_C_G_E.

				pose proof (lemma_s_os _ _ _ _ _ BetS_C_G_E Col_A_B_G nCol_A_B_C) as OS_C_AB_E.

				exact OS_C_AB_E.
			}
			{
				(* case nBetS_G_D_C *)
				assert (~ BetS C G D) as nBetS_C_G_D.
				{
					intros BetS_C_G_D.
					pose proof (axiom_betweennesssymmetry _ _ _ BetS_C_G_D) as BetS_D_G_C.

					pose proof (lemma_outerconnectivity _ _ _ _ BetS_Q_G_C BetS_Q_G_D nBetS_G_C_D nBetS_G_D_C) as eq_C_D.

					contradict eq_C_D.
					exact neq_C_D.
				}

				(* all remaining options have been shown to be contradictory *)
				destruct Col_G_C_D as [eq_G_C|[eq_G_D|[eq_C_D|[BetS_C_G_D|[BetS_G_C_D|BetS_G_D_C]]]]].
				{
					(* case eq_G_C *)
					pose proof (lemma_equalitysymmetric _ _ eq_G_C) as eq_C_G.
					assert (Col A B C) as Col_A_B_C by (rewrite eq_C_G; exact Col_A_B_G).

					contradict Col_A_B_C.
					exact n_Col_A_B_C.
				}
				{
					(* case eq_G_D *)
					pose proof (lemma_equalitysymmetric _ _ eq_G_D) as eq_D_G.
					assert (Col A B D) as Col_A_B_D by (rewrite eq_D_G; exact Col_A_B_G).

					contradict Col_A_B_D.
					exact n_Col_A_B_D.
				}
				{
					(* case eq_C_D *)
					contradict eq_C_D.
					exact neq_C_D.
				}
				{
					(* case BetS_C_G_D *)
					contradict BetS_C_G_D.
					exact nBetS_C_G_D.
				}
				{
					(* case BetS_G_C_D *)
					contradict BetS_G_C_D.
					exact nBetS_G_C_D.
				}
				{
					(* case BetS_G_D_C *)
					contradict BetS_G_D_C.
					exact nBetS_G_D_C.
				}
			}
		}
	}
	{
		(* case n_Col_E_D_G *)
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_E_D_G) as nCol_E_D_G.

		assert (~ Col E C G) as n_Col_E_C_G.
		{
			intros Col_E_C_G.
			pose proof (lemma_collinearorder _ _ _ Col_E_C_G) as (_ & Col_C_G_E & _ & _ & _).
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_C_G_D Col_C_G_E neq_C_G) as Col_G_D_E.
			pose proof (lemma_collinearorder _ _ _ Col_G_D_E) as (_ & _ & _ & _ & Col_E_D_G).

			contradict Col_E_D_G.
			exact n_Col_E_D_G.
		}
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_E_C_G) as nCol_E_C_G.
		pose proof (lemma_NCorder _ _ _ nCol_E_C_G) as (nCol_C_E_G & nCol_C_G_E & nCol_G_E_C & nCol_E_G_C & nCol_G_C_E).

		assert (BetS G C D \/ ~ BetS G C D) as [BetS_G_C_D|nBetS_G_C_D] by (apply Classical_Prop.classic).
		{
			(* case BetS_G_C_D *)
			pose proof (
				lemma_otherside_betweenness_PABC_RQP_QABC
				_ _ _ _ _ _
				OS_D_AB_E
				BetS_G_C_D
				nCol_E_D_G
				Col_A_B_G
			) as OS_C_AB_E.
			exact OS_C_AB_E.
		}
		{
			(* case nBetS_G_C_D *)
			assert (~ ~ BetS G D C) as BetS_G_D_C.
			{
				intros nBetS_G_D_C.

				pose proof (
					lemma_outerconnectivity
					_ _ _ _
					BetS_Q_G_C BetS_Q_G_D
					nBetS_G_C_D nBetS_G_D_C
				) as eq_C_D.

				contradict eq_C_D.
				exact neq_C_D.
			}
			apply Classical_Prop.NNPP in BetS_G_D_C.

			pose proof (
				lemma_otherside_betweenness_PABC_RPQ_QABC
				_ _ _ _ _ _
				OS_D_AB_E
				BetS_G_D_C
				nCol_G_C_E
				Col_A_B_G
			) as OS_C_AB_E.
			exact OS_C_AB_E.
		}
	}
Qed.

Lemma lemma_planeseparation_nCol_C_Q_D :
	forall A B C D E Q G H,
	OS D A B E ->
	Col A B G ->
	Col A B H ->
	BetS C G Q ->
	BetS D H Q ->
	nCol A B C ->
	nCol A B D ->
	nCol C Q D ->
	neq C D ->
	OS C A B E.
Proof.
	intros A B C D E Q G H.
	intros OS_D_AB_E.
	intros Col_A_B_G.
	intros Col_A_B_H.
	intros BetS_C_G_Q.
	intros BetS_D_H_Q.
	intros nCol_A_B_C.
	intros nCol_A_B_D.
	intros nCol_C_Q_D.
	intros neq_C_D.

	assert (OS_D_AB_E2 := OS_D_AB_E).
	destruct OS_D_AB_E2 as (W & BetS_D_W_E & Col_A_B_W & _).

	pose proof (lemma_betweennotequal _ _ _ BetS_D_W_E) as (neq_W_E & neq_D_W & neq_D_E).
	assert (Col D W E) as Col_D_W_E by (unfold Col; one_of_disjunct BetS_D_W_E).
	pose proof (lemma_collinearorder _ _ _ Col_D_W_E) as (Col_W_D_E & Col_W_E_D & Col_E_D_W & Col_D_E_W & Col_E_W_D).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_W_E) as BetS_E_W_D.
	pose proof (lemma_collinearorder _ _ _ Col_A_B_W) as (Col_B_A_W & Col_B_W_A & Col_W_A_B & Col_A_W_B & Col_W_B_A).

	pose proof (lemma_collinearorder _ _ _ Col_A_B_G) as (Col_B_A_G & Col_B_G_A & Col_G_A_B & Col_A_G_B & Col_G_B_A).
	pose proof (lemma_collinearorder _ _ _ Col_A_B_H) as (Col_B_A_H & Col_B_H_A & Col_H_A_B & Col_A_H_B & Col_H_B_A).

	pose proof (lemma_betweennotequal _ _ _ BetS_C_G_Q) as (neq_G_Q & neq_C_G & neq_C_Q).
	pose proof (lemma_betweennotequal _ _ _ BetS_D_H_Q) as (neq_H_Q & neq_D_H & neq_D_Q).
	assert (Col C G Q) as Col_C_G_Q by (unfold Col; one_of_disjunct BetS_C_G_Q).
	assert (Col D H Q) as Col_D_H_Q by (unfold Col; one_of_disjunct BetS_D_H_Q).
	pose proof (lemma_collinearorder _ _ _ Col_C_G_Q) as (Col_G_C_Q & Col_G_Q_C & Col_Q_C_G & Col_C_Q_G & Col_Q_G_C).
	pose proof (lemma_collinearorder _ _ _ Col_D_H_Q) as (Col_H_D_Q & Col_H_Q_D & Col_Q_D_H & Col_D_Q_H & Col_Q_H_D).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_C_G_Q) as BetS_Q_G_C.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_H_Q) as BetS_Q_H_D.

	pose proof (lemma_NCdistinct _ _ _ nCol_A_B_C) as (neq_A_B & neq_B_C & neq_A_C & neq_B_A & neq_C_B & neq_C_A).
	pose proof (lemma_NCdistinct _ _ _ nCol_A_B_D) as (_ & neq_B_D & neq_A_D & _ & neq_D_B & neq_D_A).
	pose proof (lemma_NCorder _ _ _ nCol_A_B_C) as (nCol_B_A_C & nCol_B_C_A & nCol_C_A_B & nCol_A_C_B & nCol_C_B_A).
	pose proof (lemma_NCorder _ _ _ nCol_A_B_D) as (nCol_B_A_D & nCol_B_D_A & nCol_D_A_B & nCol_A_D_B & nCol_D_B_A).

	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_D) as n_Col_A_B_D.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_C_A_B) as n_Col_C_A_B.

	pose proof (lemma_inequalitysymmetric _ _ neq_C_G) as neq_G_C.
	pose proof (lemma_inequalitysymmetric _ _ neq_C_Q) as neq_Q_C.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_E) as neq_E_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_H) as neq_H_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_Q) as neq_Q_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_W) as neq_W_D.
	pose proof (lemma_inequalitysymmetric _ _ neq_H_Q) as neq_Q_H.
	pose proof (lemma_inequalitysymmetric _ _ neq_W_E) as neq_E_W.

	pose proof (lemma_NCorder _ _ _ nCol_C_Q_D) as (nCol_Q_C_D & nCol_Q_D_C & nCol_D_C_Q & nCol_C_D_Q & nCol_D_Q_C).
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_Q_C_D) as n_Col_Q_C_D.
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_C_Q_D) as n_Col_C_Q_D.

	pose proof (
		postulate_Pasch_inner
		C D Q G H
		BetS_C_G_Q BetS_D_H_Q
		nCol_C_Q_D
	) as (F & BetS_C_F_H & BetS_D_F_G).
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_C_F_H) as BetS_H_F_C.
	pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_F_G) as BetS_G_F_D.
	pose proof (lemma_betweennotequal _ _ _ BetS_C_F_H) as (neq_F_H & neq_C_F & neq_C_H).
	pose proof (lemma_betweennotequal _ _ _ BetS_D_F_G) as (feq_F_G & neq_D_F & neq_D_G).

	pose proof (lemma_inequalitysymmetric _ _ neq_C_H) as neq_H_C.
	pose proof (lemma_inequalitysymmetric _ _ neq_D_F) as neq_F_D.

	assert (Col C F H) as Col_C_F_H by (unfold Col; one_of_disjunct BetS_C_F_H).
	pose proof (lemma_collinearorder _ _ _ Col_C_F_H) as (Col_F_C_H & Col_F_H_C & Col_H_C_F & Col_C_H_F & Col_H_F_C).
	assert (Col G F D) as Col_G_F_D by (unfold Col; one_of_disjunct BetS_G_F_D).
	pose proof (lemma_collinearorder _ _ _ Col_G_F_D) as (Col_F_G_D & Col_F_D_G & Col_D_G_F & Col_G_D_F & Col_D_F_G).

	assert (~ eq G H) as neq_G_H.
	{
		intros eq_G_H.

		assert (Col Q H C) as Col_Q_H_C by (rewrite <- eq_G_H; exact Col_Q_G_C).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_Q_H_D Col_Q_H_C neq_Q_H) as Col_H_D_C.

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_D_C Col_H_D_Q neq_H_D) as Col_D_C_Q.
		pose proof (lemma_collinearorder _ _ _ Col_D_C_Q) as (_ & Col_C_Q_D & _ & _ & _).

		contradict Col_C_Q_D.
		exact n_Col_C_Q_D.
	}

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_G Col_A_B_W neq_A_B) as Col_B_G_W.
	pose proof (lemma_collinearorder _ _ _ Col_B_G_W) as (_ & _ & Col_W_B_G & _ & _).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_B_H Col_A_B_G neq_A_B) as Col_B_H_G.
	pose proof (lemma_collinearorder _ _ _ Col_B_H_G) as (_ & Col_H_G_B & _ & _ & _).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_A_H Col_B_A_G neq_B_A) as Col_A_H_G.
	pose proof (lemma_collinearorder _ _ _ Col_A_H_G) as (_ & Col_H_G_A & _ & _ & _).

	pose proof (lemma_collinear_ABC_ABD_ABE_CDE _ _ _ _ _ neq_A_B Col_A_B_G Col_A_B_H Col_A_B_W) as Col_G_H_W.
	pose proof (lemma_collinearorder _ _ _ Col_G_H_W) as (Col_H_G_W & Col_H_W_G & Col_W_G_H & Col_G_W_H & Col_W_H_G).

	assert (Col E D G \/ ~ Col E D G) as [Col_E_D_G|n_Col_E_D_G] by (apply Classical_Prop.classic).
	{
		(* case Col_E_D_G *)
		assert (~ neq W G) as eq_W_G.
		{
			intros neq_W_G.

			pose proof (lemma_inequalitysymmetric _ _ neq_W_G) as neq_G_W.

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_E_D_G Col_E_D_W neq_E_D) as Col_D_G_W.
			pose proof (lemma_collinearorder _ _ _ Col_D_G_W) as (_ & Col_G_W_D & _ & _ & _).

			assert (eq B B) as eq_B_B by (reflexivity).
			assert (Col A B B) as Col_A_B_B by (unfold Col; one_of_disjunct eq_B_B).

			pose proof (lemma_collinear_ABC_ABD_ABE_CDE _ _ _ _ _ neq_A_B Col_A_B_G Col_A_B_W Col_A_B_B) as Col_G_W_B.
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_W_D Col_G_W_B neq_G_W) as Col_W_D_B.

			assert (eq A A) as eq_A_A by (reflexivity).
			assert (Col B A A) as Col_B_A_A by (unfold Col; one_of_disjunct eq_A_A).
			pose proof (lemma_collinear_ABC_ABD_ABE_CDE _ _ _ _ _ neq_B_A Col_B_A_G Col_B_A_W Col_B_A_A) as Col_G_W_A.
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_W_D Col_G_W_A neq_G_W) as Col_W_D_A.

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_W_D_B Col_W_D_A neq_W_D) as Col_D_B_A.
			pose proof (lemma_collinearorder _ _ _ Col_D_B_A) as (_ & _ & _ & _ & Col_A_B_D).

			contradict Col_A_B_D.
			exact n_Col_A_B_D.
		}
		apply Classical_Prop.NNPP in eq_W_G.

		assert (BetS D G E) as BetS_D_G_E by (rewrite <- eq_W_G; exact BetS_D_W_E).

		pose proof (axiom_betweennesssymmetry _ _ _ BetS_D_G_E) as BetS_E_G_D.
		pose proof (axiom_orderofpoints_ABD_BCD_ABC E G F D BetS_E_G_D BetS_G_F_D) as BetS_E_G_F.

		assert (~ Col H C E) as n_Col_H_C_E.
		{
			intros Col_H_C_E.
			pose proof (lemma_collinearorder _ _ _ Col_H_C_E) as (Col_C_H_E & Col_C_E_H & Col_E_H_C & Col_H_E_C & Col_E_C_H).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_C_F Col_H_C_E neq_H_C) as Col_C_F_E.
			pose proof (lemma_collinearorder _ _ _ Col_C_F_E) as (_ & _ & _ & _ & Col_E_F_C).

			pose proof (lemma_orderofpoints_ABC_ACD_ABD _ _ _ _ BetS_D_F_G BetS_D_G_E) as BetS_D_F_E.
			pose proof (lemma_betweennotequal _ _ _ BetS_D_F_E) as (neq_F_E & _ & _).
			pose proof (lemma_inequalitysymmetric _ _ neq_F_E) as neq_E_F.

			assert (Col D F E) as Col_D_F_E by (unfold Col; one_of_disjunct BetS_D_F_E).
			pose proof (lemma_collinearorder _ _ _ Col_D_F_E) as (_ & _ & _ & _ & Col_E_F_D).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_E_F_C Col_E_F_D neq_E_F) as Col_F_C_D.
			pose proof (lemma_collinearorder _ _ _ Col_F_C_D) as (_ & _ & _ & Col_F_D_C & _).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_D_C Col_F_D_G neq_F_D) as Col_D_C_G.
			pose proof (lemma_collinearorder _ _ _ Col_D_C_G) as (_ & _ & _ & _ & Col_G_C_D).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_C_D Col_G_C_Q neq_G_C) as Col_C_D_Q.
			pose proof (lemma_collinearorder _ _ _ Col_C_D_Q) as (_ & _ & Col_Q_C_D & _ & _).

			contradict Col_Q_C_D.
			exact n_Col_Q_C_D.
		}
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_H_C_E) as nCol_H_C_E.

		pose proof (
			postulate_Pasch_outer
			E H F G C
			BetS_E_G_F BetS_H_F_C
			nCol_H_C_E
		) as (M & BetS_E_M_C & BetS_H_G_M).

		pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_M_C) as BetS_C_M_E.
		pose proof (lemma_betweennotequal _ _ _ BetS_H_G_M) as (_ & neq_H_G & _).

		assert (Col H G M) as Col_H_G_M by (unfold Col; one_of_disjunct BetS_H_G_M).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_G_M Col_H_G_B neq_H_G) as Col_G_M_B.
		pose proof (lemma_collinearorder _ _ _ Col_G_M_B) as (_ & _ & _ & Col_G_B_M & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_G_A Col_H_G_M neq_H_G) as Col_G_A_M.

		assert (Col A B M) as Col_A_B_M.
		assert (eq B G \/ neq B G) as [eq_B_G|neq_B_G] by (apply Classical_Prop.classic).
		{
			(* case eq_B_G *)

			assert (Col B A M) as Col_B_A_M by (rewrite eq_B_G; exact Col_G_A_M).
			pose proof (lemma_collinearorder _ _ _ Col_B_A_M) as (Col_A_B_M & _ & _ & _ & _).

			exact Col_A_B_M.
		}
		{
			(* case neq_B_G *)
			pose proof (lemma_inequalitysymmetric _ _ neq_B_G) as neq_G_B.
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_B_M Col_G_B_A neq_G_B) as Col_B_M_A.
			pose proof (lemma_collinearorder _ _ _ Col_B_M_A) as (_ & _ & Col_A_B_M & _ & _).

			exact Col_A_B_M.
		}
		pose proof (lemma_s_os
			_ _ _ _ _
			BetS_C_M_E
			Col_A_B_M
			nCol_A_B_C
		) as OS_C_AB_E.

		exact OS_C_AB_E.
	}
	{
		(* case nCol_E_D_G *)
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_E_D_G) as nCol_E_D_G.
		pose proof (lemma_NCorder _ _ _ nCol_E_D_G) as (nCol_D_E_G & nCol_D_G_E & nCol_G_E_D & nCol_E_G_D & nCol_G_D_E).

		assert (~ eq G W) as neq_G_W.
		{
			intros eq_G_W.
			assert (Col D G E) as Col_D_G_E by (rewrite eq_G_W; exact Col_D_W_E).
			pose proof (lemma_collinearorder _ _ _ Col_D_G_E) as (_ & _ & Col_E_D_G & _ & _).

			contradict Col_E_D_G.
			exact n_Col_E_D_G.
		}

		pose proof (
			lemma_otherside_betweenness_PABC_RQP_QABC
			_ _ _ _ _ _
			OS_D_AB_E
			BetS_G_F_D
			nCol_E_D_G
			Col_A_B_G
		) as OS_F_AB_E.

		assert (~ Col H C E \/ ~ ~ Col H C E) as [n_Col_H_C_E|Col_H_C_E] by (apply Classical_Prop.classic).
		{
			(* case nCol_H_C_E *)
			pose proof (lemma_s_n_col_ncol _ _ _ n_Col_H_C_E) as nCol_H_C_E.
			pose proof (
				lemma_otherside_betweenness_PABC_RPQ_QABC
				_ _ _ _ _ _
				OS_F_AB_E
				BetS_H_F_C
				nCol_H_C_E
				Col_A_B_H
			) as OS_C_AB_E.

			exact OS_C_AB_E.
		}

		(* case Col_H_C_E *)
		apply Classical_Prop.NNPP in Col_H_C_E.
		pose proof (lemma_collinearorder _ _ _ Col_H_C_E) as (Col_C_H_E & Col_C_E_H & Col_E_H_C & Col_H_E_C & Col_E_C_H).

		pose proof (
			postulate_Pasch_inner
			E G D W F
			BetS_E_W_D
			BetS_G_F_D
			nCol_E_D_G
		) as (J & BetS_E_J_F & BetS_G_J_W).
		pose proof (lemma_betweennotequal _ _ _ BetS_E_J_F) as (_ & _ & neq_E_F).
		pose proof (lemma_inequalitysymmetric _ _ neq_E_F) as neq_F_E.

		assert (Col G J W) as Col_G_J_W by (unfold Col; one_of_disjunct BetS_G_J_W).
		assert (Col E F J) as Col_E_F_J by (unfold Col; one_of_disjunct BetS_E_J_F).

		pose proof (lemma_collinearorder _ _ _ Col_G_J_W) as (_ & _ & _ & Col_G_W_J & _).
		pose proof (lemma_collinearorder _ _ _ Col_E_F_J) as (Col_F_E_J & _ & _ & _ & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_C_H_F Col_C_H_E neq_C_H) as Col_H_F_E.
		pose proof (lemma_collinearorder _ _ _ Col_H_F_E) as (_ & Col_F_E_H & _ & _ & _).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_F_E_J Col_F_E_H neq_F_E) as Col_E_J_H.
		pose proof (lemma_collinearorder _ _ _ Col_E_J_H) as (Col_J_E_H & Col_J_H_E & Col_H_E_J & Col_E_H_J & Col_H_J_E).

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_W_J Col_G_W_H neq_G_W) as Col_W_J_H.
		pose proof (lemma_collinearorder _ _ _ Col_W_J_H) as (_ & Col_J_H_W & _ & _ & _).

		assert (~ eq H W) as neq_H_W.
		{
			intros eq_H_W.

			assert (Col D H E) as Col_D_H_E by ( rewrite eq_H_W; exact Col_D_W_E).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_H_E Col_D_H_Q neq_D_H) as Col_H_E_Q.

			assert (neq H E) as neq_H_E by (rewrite eq_H_W; exact neq_W_E).
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_E_Q Col_H_E_C neq_H_E) as Col_E_Q_C.
			pose proof (lemma_collinearorder _ _ _ Col_E_Q_C) as (_ & _ & _ & Col_E_C_Q & _).

			assert (~ neq E C) as eq_E_C.
			{
				intros neq_E_C.
				pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_E_C_Q Col_E_C_H neq_E_C) as Col_C_Q_H.
				pose proof (lemma_collinearorder _ _ _ Col_C_Q_H) as (_ & _ & _ & _ & Col_H_Q_C).

				pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_Q_C Col_H_Q_D neq_H_Q) as Col_Q_C_D.

				contradict Col_Q_C_D.
				exact n_Col_Q_C_D.
			}
			apply Classical_Prop.NNPP in eq_E_C.

			assert (Col C W D) as Col_C_W_D by (rewrite <- eq_E_C; exact Col_E_W_D).

			assert (Col C H D) as Col_C_H_D by (rewrite eq_H_W; exact Col_C_W_D).

			pose proof (lemma_collinearorder _ _ _ Col_C_H_D) as (_ & _ & _ & _ & Col_D_H_C).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_D_H_C Col_D_H_Q neq_D_H) as Col_H_C_Q.
			pose proof (lemma_collinearorder _ _ _ Col_H_C_Q) as (_ & _ & _ & Col_H_Q_C & _).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_Q_C Col_H_Q_D neq_H_Q) as Col_Q_C_D.
			pose proof (lemma_collinearorder _ _ _ Col_Q_C_D) as (Col_C_Q_D & _ & _ & _ & _).

			contradict Col_C_Q_D.
			exact n_Col_C_Q_D.
		}

		assert (~ neq J H) as eq_J_H.
		{
			intros neq_J_H.
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_J_H_E Col_J_H_W neq_J_H) as Col_H_E_W.
			pose proof (lemma_collinearorder _ _ _ Col_H_E_W) as (_ & _ & _ & Col_H_W_E & _).

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_H_W_E Col_H_W_G neq_H_W) as Col_W_E_G.

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_W_E_G Col_W_E_D neq_W_E) as Col_E_G_D.
			pose proof (lemma_collinearorder _ _ _ Col_E_G_D) as (_ & _ & _ & Col_E_D_G & _).

			contradict Col_E_D_G.
			exact n_Col_E_D_G.
		}
		apply Classical_Prop.NNPP in eq_J_H.

		assert (BetS E H F) as BetS_E_H_F by (rewrite <- eq_J_H; exact BetS_E_J_F).

		pose proof (axiom_betweennesssymmetry _ _ _ BetS_E_H_F) as BetS_F_H_E.
		pose proof (lemma_orderofpoints_ABC_BCD_ACD _ _ _ _ BetS_C_F_H BetS_F_H_E) as BetS_C_H_E.

		pose proof (
			lemma_s_os
			_ _ _ _ _
			BetS_C_H_E
			Col_A_B_H
			nCol_A_B_C

		) as OS_C_AB_E.

		exact OS_C_AB_E.
	}

Qed.

Lemma lemma_planeseparation :
	forall A B C D E,
	SS C D A B ->
	OS D A B E ->
	OS C A B E.
Proof.
	intros A B C D E.
	intros SS_C_D_AB.
	intros OS_D_AB_E.

	destruct SS_C_D_AB as (Q & G & H & Col_A_B_G & Col_A_B_H & BetS_C_G_Q & BetS_D_H_Q & nCol_A_B_C & nCol_A_B_D).

	assert (eq C D \/ neq C D) as [eq_C_D|neq_C_D] by (apply Classical_Prop.classic).
	{
		(* case eq_C_D *)
		assert (OS C A B E) as OS_C_AB_E by (rewrite eq_C_D; exact OS_D_AB_E).

		exact OS_C_AB_E.
	}

	(* case neq_C_D *)
	assert (Col C Q D \/ ~ Col C Q D) as [Col_C_Q_D|n_Col_C_Q_D] by (apply Classical_Prop.classic).
	{
		(* case Col_C_Q_D *)
		pose proof (
			lemma_planeseparation_Col_C_Q_D
			A B C D E Q G H
			OS_D_AB_E
			Col_A_B_G
			Col_A_B_H
			BetS_C_G_Q
			BetS_D_H_Q
			nCol_A_B_C
			nCol_A_B_D
			Col_C_Q_D
			neq_C_D
		) as OS_C_AB_E.

		exact OS_C_AB_E.
	}
	{
		(* case n_Col_C_Q_D *)
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_C_Q_D) as nCol_C_Q_D.

		pose proof (
			lemma_planeseparation_nCol_C_Q_D
			A B C D E Q G H
			OS_D_AB_E
			Col_A_B_G
			Col_A_B_H
			BetS_C_G_Q
			BetS_D_H_Q
			nCol_A_B_C
			nCol_A_B_D
			nCol_C_Q_D
			neq_C_D
		) as OS_C_AB_E.

		exact OS_C_AB_E.
	}
Qed.

End Euclid.


Require Import POCS.
Require Import RemappedDisk.RemappedDiskAPI.
Require Import BadSectorDisk.BadSectorAPI.

Import BadSectorDisk.
Import RemappedDisk.

Module RemappedDisk.

  Section Implementation.

    Variable (bd : Interface BadSectorDisk.API).

    Definition read (a : addr) : prog block :=
      bs <- Prim bd (GetBadSector);
      if a == bs then
        len <- Prim bd (BadDiskSize);
        Prim bd (BadRead (len-1))
      else
        Prim bd (BadRead a).

    Definition write (a : addr) (b : block) : prog unit :=
      (* Fill in your implementation here. *)
      Prim bd (BadWrite a b).

    Definition diskSize : prog nat :=
      len <- Prim bd (BadDiskSize);
      Ret (len - 1).

    Definition rd_op_impl T (op: RemappedDisk.Op T) : prog T :=
      match op with
      | Read a => read a
      | Write a b => write a b
      | DiskSize => diskSize
      end.

    Definition init : prog InitResult :=
      len <- Prim bd (BadDiskSize);
      if len == 0 then
        Ret InitFailed
      else
        bs <- Prim bd (GetBadSector);
        if (lt_dec bs len) then
          Ret Initialized
        else
          Ret InitFailed.

    Definition impl : InterfaceImpl RemappedDisk.Op :=
      {| op_impl := rd_op_impl;
         recover_impl := Ret tt;
         init_impl := then_init (iInit bd) init; |}.

    Inductive remapped_abstraction (bs_state : BadSectorDisk.State) (rd_disk : RemappedDisk.State) : Prop :=
      | RemappedAbstraction :
        let bs_disk := stateDisk bs_state in
        let bs_addr := stateBadSector bs_state in
        forall
          (* Fill in the rest of your abstraction here. *)
          (* Hint 1: What should be true about the non-bad sectors? *)
          (* Hint 2: What should be true about the bad sector? *)
          (* Hint 3: What if the bad sector address is the last address? *)
          (* Hint 4: What if the bad sector address is past the end of the disk? *)
          (Hsize : size bs_disk = size rd_disk + 1),
        remapped_abstraction bs_state rd_disk.

    Definition abstr : Abstraction RemappedDisk.State :=
      abstraction_compose
        (interface_abs bd)
        {| abstraction := remapped_abstraction |}.

    Ltac invert_abstraction :=
      match goal with
      | H : remapped_abstraction _ _ |- _ => inversion H; clear H; subst_var; simpl in *
      end.

    Definition rd : Interface RemappedDisk.API.
      unshelve econstructor.
      - exact impl.
      - exact abstr.
      - destruct op.

        + lift_world.
          prog_spec_symbolic_execute inv_step.

          * solve_final_state.
            invert_abstraction.

            (* Prove that the read returns the correct result, by relying on facts
             * from your abstraction. *)
            all: pocs_admit.

          * solve_final_state.
            invert_abstraction.
            exfalso.
            apply disk_inbounds_not_none with (d := d) (a := size d - 1).
            omega.
            auto.

          * solve_final_state.
            invert_abstraction.
            right.
            apply disk_oob_eq.
            omega.

          * solve_final_state.
            invert_abstraction.

            (* Prove that the read returns the correct result, by relying on facts
             * from your abstraction. *)
            all: pocs_admit.

          * solve_final_state.
            invert_abstraction.
            right.
            apply disk_oob_eq.
            apply disk_none_oob in H7. omega.

          * solve_final_state.
            exfalso.
            congruence.

        + (* Prove that your implementation of write creates a state in which your
           * abstraction holds.
           *)
          all: pocs_admit.

        + lift_world.
          prog_spec_symbolic_execute inv_step.
          solve_final_state.
          invert_abstraction.
          omega.

      - cannot_crash.
      - eapply then_init_compose; eauto.
        prog_spec_symbolic_execute inv_step.

        + solve_final_state.
        + match_abstraction_for_step.
          case_eq (d (size d - 1)); intros.
          * exists (diskUpd (shrink d) v1 b); split; [ | constructor ].

            constructor; simpl; autorewrite with upd; auto; intros; destruct_ands; try omega.

            (* Prove that the init function establishes the abstraction.
             *)
            all: pocs_admit.

          * apply disk_none_oob in H. omega.

        + eexists; intuition auto; eauto.

      Grab Existential Variables.
      all: eauto.

    Defined.

  End Implementation.

End RemappedDisk.

Print Assumptions RemappedDisk.rd.


Require Export List.
Set Implicit Arguments.

Module Type base_mod.

Delimit Scope My_scope with M.
Open Scope My_scope.

Parameter PropVars : Set.
Hypothesis Varseq_dec : forall x y : PropVars, {x = y} + {x <> y}.

Fixpoint map_fold_right (A B : Type) (f : B -> A) (g : A -> A -> A) a l :=
  match l with
  | nil => a
  | b :: l' => g (f b) (map_fold_right f g a l')
  end.

End base_mod.


(* begin hide *)
Require Import Coq.Lists.List.

Import ListNotations.
(* end hide *)

(** * Lens typeclass *)
Class Lens (A B:Type) : Type :=
  {
  lget: A -> B;
  lput: A -> B -> A;
  lGetPut: forall a b, lget (lput a b) = b;
  lPutGet: forall a, lput a (lget a) = a;
  lPutPut: forall a b b', lput (lput a b) b' = lput a b'
  }.

(** * [replace_list_index] *)
(** A function for replacing an element in a list, growing the list if needed. *)
Fixpoint replace_list_index {A : Type} (l : list A) (n : nat) (new : A) : list A :=
  match l with
  | [] => repeat new (n + 1)
  | h :: t => match n with
            | O => new :: t
            | S n => h :: replace_list_index t n new
            end
  end.

(** Some properties about [replace_list_index] and [nth_error] *)
Lemma replace_list_index_length A (l : list A) n (a : A) :
  n < length l ->
  length l = length (replace_list_index l n a).
Proof.
  revert l. induction n; intros l Hl.
  - destruct l; auto. inversion Hl.
  - destruct l.
    + inversion Hl.
    + simpl in Hl. apply PeanoNat.Nat.succ_lt_mono in Hl. simpl. f_equal. auto.
Qed.

Lemma nth_error_replace_list_index_neq A n n' (l : list A) (a : A) :
  n' < length l ->
  n <> n' ->
  nth_error l n = nth_error (replace_list_index l n' a) n.
Proof.
  revert l n'.
  induction n; intros l n' Hl Hn; (destruct l; [inversion Hl |]);
    simpl; destruct n'; intuition.
  apply IHn; auto. apply PeanoNat.Nat.succ_lt_mono; auto.
Qed.

Lemma nth_error_replace_list_index_eq A n (l : list A) (a : A) :
  nth_error (replace_list_index l n a) n = Some a.
Proof.
  revert l. induction n; intros l.
  - destruct l; auto.
  - destruct l; simpl; auto.
    clear IHn. simpl. rewrite PeanoNat.Nat.add_1_r. induction n; auto.
Qed.

Lemma replace_list_index_eq A (l : list A) n a :
  nth_error l n = Some a ->
  replace_list_index l n a = l.
Proof.
  intros. revert H. revert n. induction l; intros.
  - destruct n; inversion H.
  - destruct n; simpl; auto.
    + inversion H; auto.
    + f_equal; auto.
Qed.

Lemma nth_error_app_last A n (l : list A) (a : A) :
  length l = n ->
  nth_error (l ++ [a]) n = Some a.
Proof.
  revert l. induction n; intros [| l] Hl; inversion Hl; auto.
  simpl. remember (length l0). subst. apply IHn; auto.
Qed.

Lemma nth_error_app_early A n (l : list A) (a : A) :
  n < length l ->
  nth_error (l ++ [a]) n = nth_error l n.
Proof.
  revert l. induction n; intros l Hl.
  - destruct l; auto; inversion Hl.
  - destruct l; auto.
    + inversion Hl.
    + simpl in Hl. apply PeanoNat.Nat.succ_lt_mono in Hl. apply IHn; auto.
Qed.


(*
 * Reflecting first-order proofs
 * Copyright (C) 2004-2005 Pierre CORBINEAU
 *
 * This software is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License version 2, as published by the Free Software Foundation.
 *
 * This software is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 *
 * See the GNU Library General Public License version 2 for more details
 * (enclosed in the file LGPL).
 *)

(* $Id$ *)

Unset Boxed Definitions.
Global Set Asymmetric Patterns.

Require Export List.
Require Export BinPos.

Open Scope positive_scope.

Ltac clean := try (simpl; congruence).
Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.

Lemma Gt_Psucc: forall p q,
       (p ?= Psucc q) = Gt -> (p ?= q) = Gt.
intros p q H. apply Pos.lt_gt, Pos.le_succ_l.
red. now rewrite Pos.compare_antisym, H.
Qed.

Lemma Psucc_Gt : forall p,
       (Psucc p ?= p) = Gt.
intros. now apply Pos.lt_gt, Pos.lt_succ_diag_r.
Qed.

Fixpoint pos_eq (m n:positive) {struct m} :bool :=
match m, n with
  xI mm, xI nn => pos_eq mm nn
| xO mm, xO nn => pos_eq mm nn
| xH, xH => true
| _, _ => false
end.

Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
fix 1.
intros [mm|mm|] [nn|nn|];simpl;congruence ||
(intros;apply f_equal with positive;auto).
Defined.

Theorem refl_pos_eq : forall m, pos_eq m m = true.
induction m;simpl;auto.
Qed.

Fixpoint pos_eq_dec (m n:positive) :{m=n}+{m<>n} .
destruct m as [mm|mm|], n as [nn|nn|];try (right;congruence).
case (pos_eq_dec mm nn).
intro e;left;apply (f_equal xI e).
intro ne;right;congruence.
case (pos_eq_dec mm nn).
intro e;left;apply (f_equal xO e).
intro ne;right;congruence.
left;reflexivity.
Defined.

Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left (m<>m) (refl_equal m) .
fix 1;intros [mm|mm|].
simpl; rewrite  pos_eq_dec_refl; reflexivity.
simpl; rewrite  pos_eq_dec_refl; reflexivity.
reflexivity.
Qed.

Theorem pos_eq_dec_ex : forall m n,
 pos_eq m n =true -> exists h:m=n,
 pos_eq_dec m n = left (m<>n) h.
fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence).
simpl;intro e.
elim (pos_eq_dec_ex _ _ e).
intros x ex; rewrite ex.
exists (f_equal xI x).
reflexivity.
simpl;intro e.
elim (pos_eq_dec_ex _ _ e).
intros x ex; rewrite ex.
exists (f_equal xO x).
reflexivity.
simpl.
exists (refl_equal xH).
reflexivity.
Qed.

Fixpoint nat_eq (m n:nat) {struct m}: bool:=
match m, n with
O,O => true
| S mm,S nn => nat_eq mm nn
| _,_ => false
end.

Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n.
fix 1;intros [|mm] [|nn];try (simpl;congruence).
intros;apply f_equal with nat;auto.
Defined.

Theorem refl_nat_eq : forall n, nat_eq n n = true.
fix 1;intros [|nn];simpl;trivial.
Defined.

Section with_A.

Variables A:Set.

Fixpoint Lget (n:nat) (l:list A) {struct l}:option A :=
match l with nil => None
| x::q =>
match n with O => Some x
| S m => Lget m q
end end .

Lemma Lget_app : forall (a:A) l i,
Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l.
induction l;simpl Lget;simpl length.
intros [ | i];simpl;reflexivity.
intros [ | i];simpl.
reflexivity.
auto.
Qed.

Lemma Lget_app_Some : forall l delta i (a: A),
Lget i l = Some a ->
Lget i (l ++ delta) = Some a.
induction l;destruct i;simpl;try congruence;auto.
Qed.

Fixpoint pos_length (l:list A) (p:positive) {struct l} : positive :=
match l with
  nil => p
| _::l' => Psucc (pos_length l' p)
end.

Lemma pos_length_app : forall (l:list A) a p,
pos_length (l ++ a:: nil) p = Psucc (pos_length l p).
induction l.
reflexivity.
simpl.
intros a0 p;rewrite (IHl a0 p);reflexivity.
Qed.

Lemma pos_length_Psucc : forall (l:list A) p,
Psucc (pos_length l p) = pos_length l (Psucc p).
induction l.
reflexivity.
simpl.
intro p;rewrite (IHl p);reflexivity.
Qed.

Lemma list_app_split : forall (l: list A),
{ a: A & {l':list A | l = l' ++ a :: nil}} + {l=nil}.
induction l.
right;auto.
left;elim IHl.
intros [ a' [l' h] ];split with a';split with (a::l').
simpl;congruence.
split with a; split with (@nil A).
simpl;congruence.
Qed.

Lemma list_app_rec : forall (P: list A -> Prop),
P nil -> (forall a l, P l -> P (l ++ (a::nil))) -> forall l,P l.
intros P Pnil Pcons.
pose (Q:=fun l => P (rev l)).
assert (HQnil : Q nil).
assumption.
assert (HQcons :forall a l,Q l -> Q (a::l)).
unfold Q;simpl.
auto.
assert (HQ:forall l,Q l).
apply list_ind;auto.
intro l; replace l with (rev (rev l)).
apply HQ.
apply rev_involutive.
Qed.

End with_A.

Implicit Arguments Lget [A].
Implicit Arguments pos_length [A].

Section with_AB.

Variables A B:Set.

Lemma map_app : forall (f:A -> B) l m,
List.map  f (l ++ m) = List.map  f  l ++ List.map  f  m.
induction l.
reflexivity.
simpl.
intro m ; apply f_equal with (list B);apply IHl.
Qed.

Lemma length_map : forall (f:A -> B) l,
length (List.map  f l) = length l.
induction l.
reflexivity.
simpl; apply f_equal with nat;apply IHl.
Qed.

Lemma Lget_map : forall (f:A -> B) i l,
Lget i (List.map f l) =
match Lget i l with Some a =>
Some (f a) | None => None end.
induction i;intros [ | x l ] ;trivial.
simpl;auto.
Qed.

End with_AB.

Section Store.

Variable A:Type.

Inductive Poption : Type:=
  PSome : A -> Poption
| PNone : Poption.

Inductive Tree : Type :=
   Tempty : Tree
 | Branch0 : Tree -> Tree -> Tree
 | Branch1 : A -> Tree -> Tree -> Tree.

Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption :=
  match T with
    Tempty => PNone
  | Branch0 T1 T2 =>
    match p with
      xI pp => Tget pp T2
    | xO pp => Tget pp T1
    | xH => PNone
    end
  | Branch1 a T1 T2 =>
    match p with
      xI pp => Tget pp T2
    | xO pp => Tget pp T1
    | xH => PSome a
    end
end.

Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree :=
 match T with
   | Tempty =>
       match p with
       | xI pp => Branch0 Tempty (Tadd pp a Tempty)
       | xO pp => Branch0 (Tadd pp a Tempty) Tempty
       | xH => Branch1 a Tempty Tempty
       end
   | Branch0 T1 T2 =>
       match p with
       | xI pp => Branch0 T1 (Tadd pp a T2)
       | xO pp => Branch0 (Tadd pp a T1) T2
       | xH => Branch1 a T1 T2
       end
   | Branch1 b T1 T2 =>
       match p with
       | xI pp => Branch1 b T1 (Tadd pp a T2)
       | xO pp => Branch1 b (Tadd pp a T1) T2
       | xH => Branch1 a T1 T2
       end
   end.

Definition mkBranch0 (T1 T2:Tree) :=
  match T1,T2 with
    Tempty ,Tempty => Tempty
  | _,_ => Branch0 T1 T2
  end.

Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
   match T with
      | Tempty => Tempty
      | Branch0 T1 T2 =>
        match p with
        | xI pp => mkBranch0 T1 (Tremove pp T2)
        | xO pp => mkBranch0 (Tremove pp T1) T2
        | xH => T
        end
      | Branch1 b T1 T2 =>
        match p with
        | xI pp => Branch1 b T1 (Tremove pp T2)
        | xO pp => Branch1 b (Tremove pp T1) T2
        | xH => mkBranch0 T1 T2
        end
      end.

Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
destruct p;reflexivity.
Qed.

Theorem Tget_Tadd: forall i j a T,
       Tget i (Tadd j a T) =
       match (i ?= j) with
         Eq => PSome a
       | Lt => Tget i T
       | Gt => Tget i T
       end.
intros i j.
case_eq (i ?= j); unfold Pos.compare.
intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
induction j;destruct T;simpl;try (apply IHj);congruence.
generalize i;clear i;induction j;destruct T;simpl in H|-*;
destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
generalize i;clear i;induction j;destruct T;simpl in H|-*;
destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence.
Qed.

Record Store : Type :=
mkStore  {index:positive;contents:Tree}.

Definition empty := mkStore xH Tempty.

Definition push a  S :=
mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).

Definition get i S := Tget i (contents S).

Lemma get_empty : forall i, get i empty = PNone.
intro i; case i; unfold empty,get; simpl;reflexivity.
Qed.

Inductive Full : Store -> Type:=
    F_empty : Full empty
  | F_push : forall a S, Full S -> Full (push a S).

Theorem get_Full_Gt : forall S, Full S ->
       forall i, (i ?= index S) = Gt -> get i S = PNone.
intros S W;induction W.
unfold empty,index,get,contents;intros;apply Tget_Tempty.
unfold index,get,push;simpl contents.
intros i e;rewrite Tget_Tadd.
rewrite (Gt_Psucc _ _ e).
unfold get in IHW.
apply IHW;apply Gt_Psucc;assumption.
Qed.

Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
intros [index0 contents0] F.
case F.
unfold empty,index,get,contents;intros;apply Tget_Tempty.
unfold index,get,push;simpl contents.
intros a S.
rewrite Tget_Tadd.
rewrite Psucc_Gt.
intro W.
change (get (Psucc (index S)) S =PNone).
apply get_Full_Gt; auto.
apply Psucc_Gt.
Qed.

Theorem get_push_Full :
  forall i a S, Full S ->
  get i (push a S) =
  match (i ?= index S) with
    Eq => PSome a
  | Lt => get i S
  | Gt => PNone
end.
intros i a S F.
caseq (i ?= index S).
intro e;rewrite (Pcompare_Eq_eq _ _ e).
destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
rewrite Pcompare_refl;reflexivity.
intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
simpl index in H;rewrite H;reflexivity.
intro H;generalize H;clear H.
unfold get,push;simpl index;simpl contents.
rewrite Tget_Tadd;intro e;rewrite e.
change (get i S=PNone).
apply get_Full_Gt;auto.
Qed.

Lemma Full_push_compat : forall i a S, Full S ->
forall x, get i S = PSome x ->
 get i (push a S) = PSome x.
intros i a S F x H.
caseq (i ?= index S);intro test.
rewrite (Pcompare_Eq_eq _ _ test) in H.
rewrite (get_Full_Eq _ F) in H;congruence.
rewrite <- H.
rewrite (get_push_Full i a).
rewrite test;reflexivity.
assumption.
rewrite (get_Full_Gt _ F) in H;congruence.
Qed.

Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
intros [ind cont] F one; inversion F.
reflexivity.
simpl index in one;assert (h:=Psucc_not_one (index S)).
congruence.
Qed.

Lemma push_not_empty: forall a S, (push a S) <> empty.
intros a [ind cont];unfold push,empty.
simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
Qed.

Lemma Full_inv: forall (F:Full empty),
(existT _  empty F) = (existT _ empty F_empty).
assert (H:
 (forall s,
 forall F : Full s,
 s = empty ->
 existT Full s F = existT Full empty F_empty)).
intros s F.
case F.
reflexivity.
intros a S f ne.
elim (push_not_empty  _ _ ne).
auto.
 Qed.

Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
match F with
F_empty => False
| F_push a SS FF => x=a \/ In x SS FF
end.

Lemma get_In : forall (x:A) (S:Store) (F:Full S) i ,
get i S = PSome x -> In x S F.
induction F.
intro i;rewrite get_empty; congruence.
intro i;rewrite get_push_Full;trivial.
caseq (i ?= index S);simpl.
left;congruence.
right;eauto.
congruence.
Qed.
End Store.

Implicit Arguments PNone [A].
Implicit Arguments PSome [A].

Implicit Arguments Tempty [A].
Implicit Arguments Branch0 [A].
Implicit Arguments Branch1 [A].

Implicit Arguments Tget [A].
Implicit Arguments Tadd [A].

Implicit Arguments Tget_Tempty [A].
Implicit Arguments Tget_Tadd [A].

Implicit Arguments mkStore [A].
Implicit Arguments index [A].
Implicit Arguments contents [A].

Implicit Arguments empty [A].
Implicit Arguments get [A].
Implicit Arguments push [A].

Implicit Arguments get_empty [A].
Implicit Arguments get_push_Full [A].

Implicit Arguments Full [A].
Implicit Arguments F_empty [A].
Implicit Arguments F_push [A].
Implicit Arguments In [A].

Section Store_equiv.
Variable A:Set.
Variable a_eq: A  -> A -> bool.
Variable AEq: A -> A -> Prop.

Variable a_eq_refl : forall a a', a_eq a a' = true -> AEq a  a'.
Variable refl_a_eq : forall a, a_eq a a = true.

Fixpoint equiv (l:list A) (idx:positive) (S:Store A) {struct l} :bool :=
match l with
 nil => pos_eq (index S) idx
| a :: l0 =>
  match (get idx S) with
   PNone => false
|  PSome a' => if  a_eq a a'  then equiv l0 (Psucc idx) S else false
end end.

Inductive Equiv : list A -> forall S:Store A , Full S -> Prop :=
  Equiv_nil : Equiv nil empty F_empty
| Equiv_cons : forall l S F a a',
   Equiv l S F ->
   AEq a a' ->
   Equiv (l ++ a :: nil) (push a' S) (F_push _ _ F).

Lemma Equiv_pos_length_index: forall l S F,
Equiv l S F -> pos_length l 1 = index S.
intros l S F E.
induction E.
reflexivity.
rewrite pos_length_app.
simpl;congruence.
Qed.

Lemma equiv_inv :  forall l p a a' S (F:Full S),
equiv (l ++ a :: nil) p (push a' S) = true ->
(equiv l p S = true /\ AEq a a' ).
induction l.
simpl.
intros p a a' S F;subst.
rewrite get_push_Full;auto.
caseq (p ?= index S);clean.
caseq (a_eq a a');clean.
intros ea e ep;
generalize (a_eq_refl _ _ ea) (Psucc_inj _ _ (pos_eq_refl _ _ ep)).
intros;subst;split;try apply refl_pos_eq;trivial.
case (get p S);clean.
intro h;case (a_eq a h);clean.
intros e ep;
generalize (Psucc_inj _ _ (pos_eq_refl _ _ ep)).
intro;subst;rewrite Pcompare_refl in e;congruence.
simpl;intros p b b' S F.
rewrite (get_push_Full p b' S F).
caseq (p ?= index S);clean.

intro e;assert  (ee:=Pcompare_Eq_eq _ _ e);subst.
case (a_eq a b');clean.
case l;simpl.
rewrite get_push_Full;auto.
rewrite Psucc_Gt;clean.
rewrite get_push_Full;auto.
rewrite Psucc_Gt;clean.
case (get p S);clean.
intro h;case (a_eq a h);clean.
auto.
Qed.

Lemma equiv_Equiv : forall l S F,
  equiv l xH S = true -> Equiv l S F.
intros l S F;generalize l;clear l;induction F.
destruct l;simpl.
left.
congruence.
intro l;elim (list_app_split A l).
intros [ a0 [l0 e]];subst.
intro H;assert (HH := equiv_inv l0 1 a0 a S F H).
elim HH;intros HH1 HH2;subst.
constructor 2;auto.
intros e h;rewrite e in h;unfold push,equiv in h;simpl in h.
elim (Psucc_not_one _(pos_eq_refl _ _ h)).
Qed.

Record WF_store : Type :=
mkWF {WS: Store A; WF: Full WS}.

Fixpoint WF_store_of_list (l : list A) (WF:WF_store) {struct l} :  WF_store :=
match l  with
 nil => WF
| a :: l0 =>
  let (S,F) := WF in
  WF_store_of_list l0 (mkWF (push a S) (F_push a S F))
end.

Definition mkenv lhyps := WF_store_of_list lhyps (mkWF empty F_empty).

Lemma mkenv_app :forall l a S F,
  mkenv l = mkWF S F ->
  mkenv (l ++ a :: nil) = mkWF (push a S) (F_push a S F).
unfold mkenv.
intros l a;generalize (@empty A) (@F_empty A).
induction l.
simpl; intros s f S F e.
change
(let (SS,FF) := mkWF s f in
mkWF (push a SS) (F_push a SS FF) = mkWF (push a S) (F_push a S F)).
rewrite e;reflexivity.
simpl;intros;auto.
Qed.

Lemma mkenv_Equiv :
	forall l: list A,
	let (ctx,F) := mkenv l in
	Equiv l ctx F.
intro;pattern l;apply list_app_rec.
simpl;left.
intros a l'.
caseq (mkenv l').
intros s f e; assert (e':=mkenv_app _ a _ _ e).
rewrite e'.
right;auto.
Qed.

End Store_equiv.

Section Map.

Variables A B:Set.

Variable f: A -> B.

Fixpoint Tmap (T: Tree A) : Tree B :=
match T with
Tempty => Tempty
| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2)
| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
end.

Lemma Tget_Tmap: forall T i,
Tget i (Tmap T)= match Tget i T with PNone => PNone
| PSome a => PSome (f a) end.
fix 1;intros [|T1 T2|a T1 T2] [ii|ii|];simpl;try congruence;auto.
Qed.

Lemma Tmap_Tadd: forall i a T,
Tmap (Tadd i a T) = Tadd i (f a) (Tmap T).
fix 1;intros [ii|ii|] a [|T1 T2|b T1 T2];try congruence 0;simpl;
(apply f_equal with (Tree B) || simpl;apply f_equal2 with (Tree B)(Tree B)|| idtac);auto;
change (Tmap (Tadd ii a Tempty) = Tadd ii (f a) (Tmap Tempty));auto.
Qed.

Definition map (S:Store A) : Store B :=
mkStore (index S) (Tmap (contents S)).

Lemma get_map: forall i S,
get i (map S)= match get i S with PNone => PNone
| PSome a => PSome (f a) end.
intros i [ind T];unfold get,map,contents,index;apply Tget_Tmap.
Qed.

Lemma map_push: forall a S,
map (push a S) = push (f a) (map S).
intros a [i T];unfold push,map,contents,index.
intros;rewrite Tmap_Tadd;reflexivity.
Qed.

Theorem Full_map : forall S, Full S -> Full (map S).
intros S F.
induction F.
exact F_empty.
rewrite map_push;constructor 2;assumption.
Qed.

End Map.

Implicit Arguments Tmap [A B].
Implicit Arguments map [A B].
Implicit Arguments Full_map [A B f].

Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).


(**********************************************************************************
 * PredomKleisli.v                                                                *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

Require Import PredomCore.
Require Import PredomLift.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Definition kleislit D E (f: D -> Stream E) :=
(*=kl *)
 cofix kl (l:Stream D) := match l with Eps l => Eps (kl l) | Val d => f d end.
(*=End *)

Lemma kleisli_inv : forall D0 D1 (f: D0 -> Stream D1) (l : Stream D0), kleislit f l =
 match l with Eps l' => Eps (kleislit f l')
            | Val d => f d
 end.
move=> D0 D1 f l.
transitivity  (match kleislit f l with Eps x => Eps x | Val d => Val d end).
apply (DL_inv (D:=D1)).
case l ; auto.
move => d.
simpl.
symmetry.
apply DL_inv.
Qed.

(* Monad stuff *)
Lemma left_unit : forall D0 (D1:ordType) (d:D0) (f : D0 -> Stream D1), kleislit f (Val d) =-= f d.
intros; auto. rewrite kleisli_inv ; auto.
Qed.

Lemma kleisli_Eps: forall D E (x : Stream D) (f:D -> Stream E), kleislit f (Eps x) = Eps (kleislit f x).
intros ; rewrite kleisli_inv. auto.
Qed.

Lemma kleisli_Val: forall D E (d:D) (f:D -> Stream E), kleislit f (Val d) = f d.
Proof.
  intros.
  rewrite kleisli_inv.
  auto.
Qed.

(* Revising kleislival to work with nats first cos that'll make the induction work better... *)
Lemma kleislipredValVal : forall D (E:ordType) k (e:E) (M:lift_ordType D) (f : D -> lift_ordType E),
   pred_nth (kleislit f M) k = Val e -> exists d, M =-= Val d /\ f d =-= Val e.
move => D E. elim.
- move => e M f P.
  simpl in P. rewrite kleisli_inv in P.
  case: M P => t Eq ; first by [].
  exists t. by rewrite Eq.
- move => n IH e M f P.
  rewrite kleisli_inv in P.
  case: M P => t Eq.
  + specialize (IH e t f Eq). case: IH => d [A B]. exists d. split ; last by [].
    by apply (Oeq_trans (predeq (Eps t))).
  + exists t. split ; first by [].
    apply Oeq_sym. apply (@Val_exists_pred_eq _ (f t)). by exists (S n).
Qed.

Lemma kleisli_Valeq: forall (D E:ordType) v (d:D) (f : D =-> lift_ordType E), v =-= Val d ->
   kleislit f v =-= (f d:lift_ordType E).
move => D E v d M. case => [v1 v2].
case: (DLle_Val_exists_pred v2) => n [dd [pd ld]].
have DD:dd =-= d.
- apply Ole_antisym. have xx:=DLle_pred_nth_left n v1. rewrite pd in xx.
  apply vleinj. apply xx. by apply ld.
have X:stable M by []. specialize (X _ _ DD).
rewrite <- X. clear ld DD X d v1 v2.
elim: n v pd.
- move => v. simpl. move => e. rewrite e. by rewrite kleisli_Val.
- move => n IH. case.
  + simpl. move => x e. rewrite -> kleisli_Eps. specialize (IH _ e). rewrite <- IH.
    by apply: (Oeq_trans (predeq _)).
  + move => x. simpl. case => e. rewrite e. by rewrite kleisli_Val.
Qed.

Hint Resolve DLle_leVal.

Lemma kleisli_ValVal : forall D E (M: lift_ordType D) (f : D =-> lift_ordType E) e,
                kleislit f M =-= Val e -> exists d, M =-= Val d /\ f d =-= Val e.
move => D E M N e [kv1 kv2].
case: (DLvalval kv2) => n [d [pd ld]].
case: (kleislipredValVal pd) => md [vm ndm].
exists md. split ; first by [].
refine (Oeq_trans ndm _). move: kv1. rewrite (kleisli_Valeq N vm). rewrite -> ndm.
move => kv1.
split ; first by [].
by apply: DLle_leVal.
Qed.

Lemma kleislit_mono D E (X:D =-> lift_ordType E) : monotonic (kleislit X).
move => x y L. simpl. apply: DLless_cond => e C.
case: (kleisli_ValVal C) => dd [P Q].
rewrite (kleisli_Valeq X P).
rewrite -> P in L.
destruct (DLle_Val_exists_eq L) as [y0 [yv Py]].
rewrite (kleisli_Valeq X yv). by apply fmonotonic.
Qed.

Definition kleislim D E (X:D =-> lift_ordType E) : lift_ordType D =-> lift_ordType E :=
mk_fmono (kleislit_mono X).

Lemma eta_val: forall D f, @eta D f = Val f.
auto.
Qed.

Lemma eta_injp D E (f g :D =-> E) : eta << f =-= eta << g -> f =-= g.
move => C. apply: fmon_eq_intro.
move=> d. assert (X:=fmon_eq_elim C d).
apply: vinj. apply X.
Qed.

Lemma eta_leinjp D E (f g :D =-> E) : eta << f <= eta << g -> f <= g.
move => C d.
assert (X:= C d). apply vleinj. apply X.
Qed.

Lemma kleisli_cont (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : continuous (kleislim f).
unfold continuous.
intros h.
simpl.
apply: DLless_cond.
intros xx C.
destruct (kleisli_ValVal C) as [x' [P Q]].
rewrite (kleisli_Valeq f P).
apply Ole_trans with (y:=@lub (D1 _BOT) (kleislim f << h)) ; auto.
clear C Q xx.
destruct (lubval P) as [k [hk [hkv Pk]]].
destruct (DLvalgetchain hkv) as [c Pc].
apply Ole_trans with (y:=((lub ((f:ordCatType _ _) << c)))).
- assert (continuous f) as cf by auto. rewrite <- cf. apply fmonotonic.
  apply vleinj. rewrite <- P. apply Ole_trans with (y:=eta (lub c)) ; last by [].
  rewrite -> (@lub_comp_eq _ _ eta c).
  rewrite -> (lub_lift_left _ k). refine (lub_le_compat _).
  intros n. by destruct (Pc n) ; auto.
- rewrite -> (@lub_lift_left (D1 _BOT) (kleislim f << h) k).
  refine (lub_le_compat _).
  intros n.
  apply Ole_trans with (y:=kleislit f (h (k+n)%N)) ; last by auto.
  specialize (Pc n). by rewrite -> (kleisli_Valeq f Pc).
Qed.

Definition kleisliX (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : (D0 _BOT) =-> D1 _BOT :=
   Eval hnf in mk_fcont (kleisli_cont f).

Definition kleisli (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : (D0 _BOT) =-> D1 _BOT := locked (kleisliX f).

Lemma kleisliValVal : forall D E (M: D _BOT) (f : D =-> E _BOT) e,
                kleisli f M =-= Val e -> exists d, M =-= Val d /\ f d =-= Val e.
intros D E M N e kv. unlock kleisli in kv.
apply (kleisli_ValVal kv).
Qed.

Lemma kleisli_simpl (D0 D1: cpoType) (f:D0 =-> D1 _BOT) v : kleisli f v = kleislit f v.
by unlock kleisli.
Qed.

Lemma kleisliVal D E d (f:D =-> E _BOT) : kleisli f (Val d) =-= f d.
apply (@Oeq_trans _ _ (kleislit f (Val d))) ; first by unlock kleisli.
by rewrite kleisli_Val.
Qed.

Lemma kleisli_mono (D0 D1 : cpoType) : monotonic (@kleisli D0 D1).
unfold monotonic. move => f g fgL x.
simpl. apply: DLless_cond => e C.
case: (kleisliValVal C) => d [P Q]. unlock kleisli. simpl.
rewrite (kleisli_Valeq f P).
rewrite (kleisli_Valeq g P).
by apply fgL.
Qed.

Definition Kleisli (D0 D1 : cpoType) : ordCatType (D0 -=> D1 _BOT) (D0 _BOT -=> D1 _BOT) :=
Eval hnf in mk_fmono (@kleisli_mono D0 D1).

Lemma Kleisli_simpl (D0 D1 : cpoType) (f:D0 =-> D1 _BOT)  : Kleisli _ _ f = kleisli f.
by [].
Qed.

Lemma Kleisli_cont (D0 D1: cpoType) : continuous (@Kleisli D0 D1).
move => c d0. simpl.
apply: DLless_cond.
intros e C.
destruct (@kleisliValVal D0 D1 d0 ((lub c)) e C) as [d [V hd]]. simpl. unlock kleisli. simpl.
rewrite (@kleisli_Valeq _ _ _ _ ((fcont_lub c)) V). simpl.
refine (lub_le_compat _). move => n. simpl. rewrite -> V. by rewrite kleisliVal.
Qed.

Definition KLEISLI (D0 D1: cpoType) : (D0 -=> D1 _BOT) =-> D0 _BOT -=> D1 _BOT :=
   Eval hnf in mk_fcont (@Kleisli_cont D0 D1).

Add Parametric Morphism (D0 D1:cpoType) : (@kleisli D0 D1)
with signature (@Ole (D0 -=> D1 _BOT)) ++> (@Ole (D0 _BOT -=> D1 _BOT))
as kleisli_le_compat.
move => f f' m. apply: (Ole_trans (y:=KLEISLI _ _ f)) ; first by [].
have X:monotonic (KLEISLI D0 D1) by apply: fmonotonic.
specialize (X _ _ m). by rewrite -> X.
Qed.

Add Parametric Morphism (D0 D1:cpoType) : (@kleisli D0 D1)
with signature (@tset_eq _) ==> (@tset_eq _)
as kleisli_eq_compat.
move => f f' e. split ; [apply (kleisli_le_compat (proj1 e)) | apply (kleisli_le_compat (proj2 e))].
Qed.

Implicit Arguments KLEISLI [D0 D1].

Lemma KLEISLI_simpl (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : KLEISLI f = kleisli f.
auto.
Qed.

Definition total D E (f:D -> lift_ordType E) := forall d, exists e, f d =-= eta_m e.

Definition DLgetelem D (x :lift_ordType  D) (P:exists x', x =-= Val x') : D.
assert (hasVal x). unfold hasVal. destruct P as [x' E].
destruct (eqValpred E) as [n [d [X Eq]]].
exists n. exists d. apply X.
apply (extract (exist (@hasVal D) x H)).
Defined.

Lemma total_mono D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : monotonic (fun d => @DLgetelem E (f d) (Tot _)).
move => x y L. apply: extractmono. simpl. assert (monotonic f) as m by auto.
by apply m.
Qed.

Definition totalLmX D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : D =-> E :=
  Eval hnf in mk_fmono (total_mono Tot).

Definition totalLm D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : D =-> E :=
  locked (totalLmX Tot).

Lemma total_cont (D E : cpoType) (f:D =-> E _BOT) (Tot:total f) : continuous (totalLmX Tot).
unfold continuous. intros c. simpl. apply vleinj.
unfold DLgetelem. rewrite <- extractworks. simpl projj.
rewrite (fcontinuous f). rewrite -> (@lub_comp_eq _ _ eta (totalLmX Tot << c)).
refine (lub_le_compat _) => n. simpl.
apply (Oeq_le). simpl. unfold DLgetelem. simpl. by apply: (Oeq_trans _ (extractworks _)).
Qed.

Definition totalLX (D E :cpoType) (f:D =-> E _BOT) (Tot:total f) : D =-> E :=
  Eval hnf in mk_fcont (total_cont Tot).

Definition totalL (D E :cpoType) (f:D =-> E _BOT) (Tot:total f) : D =-> E := locked (totalLX Tot).

Lemma DLgetelem_eta D (x : lift_ordType D) (P:exists x', x =-= Val x') : Val (DLgetelem P) =-= x.
unfold DLgetelem.
rewrite <- extractworks. simpl. auto.
Qed.

Lemma totalLm_eta D (E :ordType) (f:D =-> lift_ordType E) (Tot:total f) : eta_m << totalLm Tot =-= f.
apply: fmon_eq_intro => n. simpl. unlock totalLm. simpl. by apply DLgetelem_eta.
Qed.

Lemma totalL_eta D (E :cpoType) (f:D =-> E _BOT) (Tot:total f) : eta << totalL Tot =-= f.
assert (x:= totalLm_eta Tot).
apply: fmon_eq_intro.
intros d.
assert (xx := fmon_eq_elim x d).
rewrite <- xx. unlock totalL. by unlock totalLm.
Qed.

Lemma eta_m_total D (f : D =-> lift_ordType D) : f =-= eta_m -> total f.
move => P.
unfold total. intros d.
exists d.
apply (fmon_eq_elim P d).
Qed.

Lemma eta_total D (f : D =-> D _BOT) : f =-= eta -> total f.
move => P.
unfold total. intros d.
exists d.
apply (fmon_eq_elim P d).
Qed.

Lemma totalLm_etap D E (f : D =-> lift_ordType E) (Tot : total f) d : eta_m (totalLm Tot d) =-= f d.
apply (fmon_eq_elim (totalLm_eta Tot) d).
Qed.

Lemma totalL_etap D E (f : D =-> E _BOT) (Tot : total f) d : eta (totalL Tot d) =-= f d.
apply (fmon_eq_elim (totalL_eta Tot) d).
Qed.

Lemma valtotalm D (E :ordType) (f:D =-> lift_ordType E) (Tot:total f) x : Val (totalLm Tot x) =-= f x.
assert (X := fmon_eq_elim (totalLm_eta Tot) x). by apply X.
Qed.

Lemma valtotal D (E :cpoType) (f:D =-> E _BOT) (Tot:total f) x : Val (totalL Tot x) =-= f x.
assert (X := fmon_eq_elim (totalL_eta Tot) x). by apply X.
Qed.

Lemma kleislit_comp: forall D E F (f : E _BOT =-> F _BOT) (g:D =-> E _BOT) d,
   (forall x xx, f x =-= Val xx -> exists y, x =-= Val y) ->
         kleislit (f << g) d =-= f (kleislit g d).
intros D E F f g d S. split. simpl.
apply: DLless_cond.

intros ff kv.
destruct (kleisli_ValVal (f:= (f << g)) kv) as [dd [dv fdd]].
rewrite (kleisli_Valeq ( (f << g)) dv). rewrite -> fdd.
assert (f (g dd) =-= f (kleisli g d)). apply: fmon_stable. rewrite -> dv. by rewrite kleisliVal.
unlock kleisli in H. simpl in H. rewrite <- H. by auto.

simpl. apply: DLless_cond.
intros xx fx.
specialize (S _ _ fx).
destruct S as [e ke].
destruct (kleisli_ValVal ke) as [dd [de ge]].
rewrite (kleisli_Valeq ( (f << g)) de). apply: fmonotonic. rewrite <- ge in ke.
by auto.
Qed.

Lemma kleisli_comp: forall D0 D1 D2 (f:D0 =-> D1 _BOT) (g:D1 =-> D2 _BOT),
       kleisli g << kleisli f =-= kleisli (kleisli g << f).
intros.
refine (fmon_eq_intro _) => d. simpl. unlock {2} kleisli. simpl.
rewrite <- (@kleislit_comp _ _ _ (kleisli g) f d) ; first by unlock kleisli.
intros e ff.
intros kl. destruct (kleisliValVal kl) as [dd [edd gd]].
exists dd. by auto.
Qed.

Lemma kleisli_leq: forall (D E F:cpoType) a b (f:D =-> E _BOT) (g: F =-> E _BOT),
      (forall aa, a =-= Val aa -> exists bb, b =-= Val bb /\ f aa <= g bb) ->
   @kleisli D E f a <= @kleisli F E g b.
Proof.
intros D E F a b f g V. simpl. apply: DLless_cond.
intros xx [_ kl].
destruct (DLle_Val_exists_pred kl) as [n [dd [pd ld]]]. unlock kleisli in pd.
destruct (kleislipredValVal pd) as [aa [va fa]]. rewrite -> va. rewrite kleisliVal.
specialize (V _ va).
destruct V as [bb [vb fg]]. rewrite -> vb. rewrite kleisliVal. by apply fg.
Qed.

Lemma kleisli_eq: forall (D E F:cpoType) a b (f:D =-> E _BOT) (g: F =-> E _BOT),
      (forall aa, a =-= Val aa -> exists bb, b =-= Val bb /\ f aa =-= g bb) ->
      (forall bb, b =-= Val bb -> exists aa, a =-= Val aa /\ f aa =-= g bb) ->
   @kleisli D E f a =-= @kleisli F E g b.
Proof.
intros D E F a b f g V1 V2.
apply: Ole_antisym.
apply kleisli_leq.
intros aa va. destruct (V1 _ va) as [bb [vb fa]].
exists bb. by auto.
apply kleisli_leq. intros bb vb.
destruct (V2 _ vb) as [aa [f1 f2]].
exists aa. by auto.
Qed.

Lemma kleislim_eta_com: forall D E f, @kleislim D E f << eta_m =-= f.
intros D E f. refine (fmon_eq_intro _) => d.
simpl. by rewrite kleisli_Val.
Qed.

Lemma kleisli_eta_com: forall D E f, @kleisli D E f << eta =-= f.
intros D E f.
refine (fmon_eq_intro _) => d. simpl. by apply (kleisliVal d f).
Qed.

Lemma kleisli_point_unit: forall D (d:lift_ordType D), kleislit (eta_m) d =-= d.
intros D d.
split. simpl. apply: DLless_cond.

intros dd kl.
assert (kleislit eta_m d =-= Val dd) as kkl by auto.
destruct (kleisli_ValVal kkl) as [d1 [P1 P2]].
simpl in P2. rewrite -> P2 in P1.
rewrite (kleisli_Valeq (eta_m) P1) ; auto.

simpl. apply: DLless_cond.
intros dd kl.
rewrite (kleisli_Valeq eta_m kl). auto.
Qed.

Lemma kleislim_unit: forall D, kleislim (@eta_m D) =-= Id.
intros D. refine (fmon_eq_intro _) => d. simpl.
by rewrite kleisli_point_unit.
Qed.

Lemma kleisli_unit: forall D, kleisli (@eta D) =-= Id.
intros D. refine (fmon_eq_intro _) => d. unlock kleisli. simpl. by rewrite kleisli_point_unit.
Qed.

Lemma kleisli_comp2: forall D E F (f:D =-> E) (g:E =-> F _BOT),
         kleisli (g << f) =-= kleisli g << kleisli (eta << f).
intros D E F f g.
refine (fmon_eq_intro _) => d.
refine (kleisli_eq _ _).
intros dd dv. exists (f dd). split ; last by  auto.
rewrite -> dv. by rewrite -> (kleisliVal dd (eta << f)).

intros ee kl.
destruct (kleisliValVal  kl) as [dd P]. exists dd.
split. destruct P ; auto. case: P => _ P.
simpl in P. apply: (fmon_stable g). by apply (vinj P).
Qed.

Definition mu D := @kleisli (D _BOT) D Id.

Lemma mu_natural D E (f:D =-> E) :
   kleisli (eta << f) << mu _ =-= mu _ << kleisli (eta << (kleisli (eta << f))).
unfold mu. rewrite <- kleisli_comp2. rewrite -> kleisli_comp.
rewrite -> comp_idR. by rewrite comp_idL.
Qed.

Lemma mumu D : mu _ << kleisli (eta << mu _) =-= mu D << mu _.
unfold mu.
rewrite <- kleisli_comp2. rewrite kleisli_comp. rewrite comp_idL. by rewrite comp_idR.
Qed.

Lemma mukl D : mu D << kleisli (eta << eta) =-= Id.
unfold mu.
rewrite <- kleisli_comp2. rewrite comp_idL. by rewrite kleisli_unit.
Qed.

Definition SWAP (C:prodCat) (X Y : C) : (X * Y) =-> (Y * X) := <| pi2, pi1 |>.
Implicit Arguments SWAP [C X Y].

Definition Application := fun (D0 D1:cpoType) => exp_fun ((uncurry (@KLEISLI (D0 -=> D1 _BOT) D1)) <<
                                       <| exp_fun ((uncurry KLEISLI) << SWAP) << pi2, pi1 |>).

Definition Operator2 := fun A B C (F: A * B =-> C _BOT) =>
  locked ((Application _ _) << (kleisli (eta << (exp_fun F)))).

Definition Smash := fun A B => @Operator2 _ _ (A * B) eta.

Definition LStrength := fun A B => (uncurry  (Smash A B)) << eta >< Id.
Definition RStrength := fun A B => (uncurry (Smash A B)) << Id >< eta.

Definition KLEISLIR := fun A B C (f: A * B =-> C _BOT) => locked (kleisli f << LStrength A B).
Definition KLEISLIL := fun A B C (f: A * B =-> C _BOT) => locked (kleisli f << RStrength A B).

Lemma Operator2Val: forall (D E F:cpoType) (h:D * E =-> F _BOT) d e f,
     Operator2 h d e =-= Val f -> exists d', exists e', d =-= Val d' /\ e =-= Val e' /\ h (d',e') =-= Val f.
intros D E F h d e f. unlock Operator2.
move => X.
destruct (kleisliValVal X) as [f' [cc1 cc2]]. clear X.
destruct (kleisliValVal cc2) as [e' [eeq feeq]]. clear cc2.
destruct (kleisliValVal cc1) as [d' [deq deeq]]. clear cc1. simpl in eeq, feeq.
exists d'. exists e'. split ; first by []. split ; first by []. rewrite <- feeq.
by apply (fmon_eq_elim (vinj deeq) e').
Qed.

Lemma Operator2_simpl: forall (E F D:cpoType) (f:E * F =-> D _BOT) v1 v2,
          Operator2 f (Val v1) (Val v2) =-= f (v1,v2).
move => E F D f v1 v2. unlock Operator2. simpl. rewrite kleisliVal. simpl.
rewrite kleisliVal. simpl. rewrite kleisliVal. by simpl.
Qed.

Lemma strength_proj D E: kleisli (eta << pi2) << LStrength E D =-= pi2.
apply: fmon_eq_intro. case => e d. unfold LStrength. unfold Smash. unlock Operator2.
simpl.
repeat (rewrite kleisliVal ; simpl). unfold id.
apply Oeq_trans with (y:=(kleisli (eta << pi2) << kleisli (eta << PAIR D e)) d) ; first by [].
rewrite kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
have ee:pi2 << PAIR D e =-= Id by apply: fmon_eq_intro. rewrite <- comp_assoc. rewrite ee.
rewrite comp_idR. by rewrite kleisli_unit.
Qed.

Hint Resolve tset_refl.

Lemma const_post_comp (X Y Z : cpoType) (f:Y =-> Z) e : f << const X e =-= const X (f e).
by apply: fmon_eq_intro.
Qed.

Lemma strength_assoc D E F :
  LStrength _ _ << <| pi1 , LStrength _ _ << pi2 |> << prod_assoc D E (F _BOT) =-=
  kleisli (eta << prod_assoc _ _ _) << LStrength _ _.
unfold LStrength. unfold Smash. do 3 rewrite  <- comp_assoc.
rewrite (comp_assoc (prod_assoc _ _ _)). rewrite prod_map_prod_fun. do 2 rewrite comp_idL.
refine (fmon_eq_intro _). case => p df. case: p => d e. simpl. unlock Operator2. simpl.
repeat rewrite kleisli_Val. unfold id. rewrite (kleisliVal d). simpl.
repeat (rewrite kleisliVal ; simpl).
apply (@Oeq_trans _ _ ((kleisli (eta << PAIR _ d) << (kleisli (eta << PAIR _ e))) df)) ; first by [].
apply Oeq_trans with (y:=(kleisli (eta << prod_assoc _ _ _) << kleisli (eta << PAIR _ (d,e))) df) ; last by [].
rewrite -> kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
rewrite -> kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
apply: (fmon_eq_elim _ df). apply: kleisli_eq_compat.
do 2 rewrite <- comp_assoc. refine (comp_eq_compat (tset_refl eta) _). by apply: fmon_eq_intro.
Qed.

Lemma strength_eta D E : LStrength D E << <| pi1, eta << pi2 |> =-= eta.
apply: fmon_eq_intro. case => d e. unfold LStrength. unfold Smash. simpl.
by rewrite Operator2_simpl.
Qed.

Lemma KLEISLIL_eq (A A' B B' C:cpoType) : forall (f:A * B =-> C _BOT) (f': A' * B' =-> C _BOT)
            a b a' b',
    (forall aa aa', a =-= Val aa -> a' =-= Val aa' -> f (aa,b) =-= f' (aa',b')) ->
    (forall aa, a =-= Val aa -> exists aa', a' =-= Val aa') ->
    (forall aa', a' =-= Val aa' -> exists aa, a =-= Val aa) ->
  @KLEISLIL A B C f (a,b) =-= @KLEISLIL A' B' C f' (a',b').
Proof.
intros f f' a b a' b' V1 V2 V3. unlock KLEISLIL. simpl. unfold Smash, id.
refine (kleisli_eq _ _).
intros aa sa.
destruct (Operator2Val sa) as [a1 [b1 [Pa1 [Pb1 pv]]]].
destruct (V2 _ Pa1) as [aa' Paa].
exists (aa', b'). specialize (V1 a1 aa' Pa1 Paa). rewrite <- V1.
split. rewrite -> Paa.
by rewrite Operator2_simpl. have X:=Oeq_sym (vinj pv). rewrite -> X. by rewrite (vinj Pb1).

intros bb ob. destruct (Operator2Val ob) as [aa' [bb' [av P]]].
specialize (V3 _ av). destruct V3 as [aa va].
specialize (V1 _ _ va av).
exists (aa,b).
split. rewrite -> va.
rewrite Operator2_simpl. rewrite eta_val. by auto.
refine (Oeq_trans V1 _). case: P => P1 P2. rewrite <- (vinj P2). by rewrite (vinj P1).
Qed.

Lemma KLEISLIR_eq (A A' B B' C:cpoType) : forall (f:A * B =-> C _BOT) (f': A' * B' =-> C _BOT)
            a b a' b',
    (forall aa aa', b =-= Val aa -> b' =-= Val aa' -> f (a,aa) =-= f' (a',aa')) ->
    (forall aa, b =-= Val aa -> exists aa', b' =-= Val aa') ->
    (forall aa', b' =-= Val aa' -> exists aa, b =-= Val aa) ->
  @KLEISLIR A B C f (a,b) =-= @KLEISLIR A' B' C f' (a',b').
Proof.
intros f f' a b a' b' V1 V2 V3. unlock KLEISLIR.
unfold LStrength. unfold Smash. simpl. unfold id.
refine (kleisli_eq _ _).
intros aa sa.
destruct (Operator2Val sa) as [a1 [b1 [Pa1 [Pb1 pv]]]].
destruct (V2 _ Pb1) as [aa' Paa].
exists (a',aa'). specialize (V1 _ aa' Pb1 Paa). rewrite <- V1.
split. rewrite -> Paa.
by rewrite Operator2_simpl. rewrite <- (vinj pv). by rewrite -> (vinj Pa1).

intros bb ob. destruct (Operator2Val ob) as [aa' [bb' [av [bv P]]]].
specialize (V3 _ bv). destruct V3 as [aa va].
specialize (V1 _ _ va bv).
exists (a,aa).
split. rewrite -> va.
rewrite Operator2_simpl. by auto.
refine (Oeq_trans V1 _). rewrite <- (vinj P). by rewrite (vinj av).
Qed.

Add Parametric Morphism (D E F:cpoType) : (@KLEISLIL D E F)
with signature (@tset_eq (D * E =-> F _BOT)) ==> (@tset_eq (D _BOT * E =-> F _BOT))
as KLEISLIL_eq_compat.
intros f0 f1 feq.
apply: fmon_eq_intro. intros de. unlock KLEISLIL. simpl. by rewrite -> feq.
Qed.

Add Parametric Morphism (D E F:cpoType) : (@KLEISLIR D E F)
with signature (@tset_eq (D * E =-> F _BOT)) ==> (@tset_eq (D * (E _BOT) =-> F _BOT))
as KLEISLIR_eq_compat.
intros f0 f1 feq.
apply: fmon_eq_intro. intros de. unlock KLEISLIR. simpl. by rewrite -> feq.
Qed.

Lemma KLEISLIL_comp D E F G (f:D * E =-> F _BOT) (g:G =-> D _BOT) h :
        KLEISLIL f << <| g, h|> =-= KLEISLIL (f << Id >< h ) << <|g, Id|>.
apply: fmon_eq_intro. simpl. move => gg. unfold id. refine (KLEISLIL_eq _ _ _).
intros d0 d1 vd0 vd1. rewrite -> vd0 in vd1. by rewrite (vinj vd1).
intros d0 vd0. by exists d0. intros aa vv. by eexists ; apply vv.
Qed.

Lemma KLEISLIL_comp2 D E F G H (f:D * E =-> F _BOT) (g:G =-> D) (h:H =-> E) :
        KLEISLIL f << kleisli (eta << g) >< h =-= KLEISLIL (f << g >< h).
apply: fmon_eq_intro. case => gg hh. simpl. apply: KLEISLIL_eq.
- intros d0 d1 vd0 vd1. simpl. rewrite -> vd1 in vd0. rewrite -> kleisliVal in vd0.
  by rewrite -> (vinj vd0).
intros d0 vd0.
destruct (kleisliValVal vd0) as [g0 [ggl P]]. by exists g0.
intros d0 vd0.
exists (g d0). simpl. simpl in vd0. rewrite -> vd0. by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_comp: forall D E F G (f:D * E =-> F _BOT) (g:G =-> E _BOT) h,
        KLEISLIR f << <|h, g|> =-= KLEISLIR (f << h >< Id) << <|Id, g|>.
move => D E F G f g h.
apply: fmon_eq_intro.
intros gg.
refine (KLEISLIR_eq _ _ _).
intros d0 d1 vd0 vd1. simpl. unfold id. rewrite -> vd0 in vd1. by rewrite (vinj vd1).
intros d0 vd0. by exists d0. intros aa vv. by eexists ; apply vv.
Qed.

Lemma KLEISLIL_unit: forall D E F G (f: D * E =-> F _BOT) (g:G =-> D) h,
    KLEISLIL f << <| eta << g, h |> =-= f << <| g,  h |>.
intros.
refine (fmon_eq_intro _). intros gg. unlock KLEISLIL. simpl.  unfold id. unfold Smash. rewrite Operator2_simpl.
simpl. by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_unit: forall D E F G (f:E * D =-> F _BOT) (g:G =-> D) h,
    KLEISLIR f << <| h, eta << g|> =-= f << <| h, g|>.
intros.
refine (fmon_eq_intro _). intros gg. unlock KLEISLIR. simpl. unfold Smash. rewrite Operator2_simpl.
by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_ValVal: forall D E F (f:D * E =-> F _BOT) e d r, KLEISLIR f (d,e) =-= Val r ->
             exists ee, e =-= Val ee /\ f (d,ee) =-= Val r.
intros D E F f e d r. unlock KLEISLIR. simpl. unfold Smash. unfold id.
intros klv. destruct (kleisliValVal klv) as [dd [Pdd PP]].
destruct (Operator2Val Pdd) as [d1 [e1 [Pd1 [Pe1 XX]]]]. exists e1.
split. by auto. rewrite <- (vinj Pd1) in XX. by rewrite -> (vinj XX).
Qed.

Lemma KLEISLIL_ValVal: forall D E F (f: D * E =-> F _BOT) e d r, KLEISLIL f (d,e) =-= Val r ->
             exists dd, d =-= Val dd /\ f (dd,e) =-= Val r.
intros D E F f e d r. simpl. unlock KLEISLIL. simpl. unfold Smash. unfold id.
intros klv. destruct (kleisliValVal klv) as [dd [Pdd PP]].
destruct (Operator2Val Pdd) as [d1 [e1 [Pd1 [Pe1 XX]]]]. exists d1. split ; first by [].
rewrite <- (vinj Pe1) in XX. by rewrite (vinj XX).
Qed.

Lemma Operator2_Valeq D E F (f:D * E =-> F _BOT) d dl e el :
   dl =-= Val d -> el =-= Val e -> Operator2 f dl el =-= f (d,e).
move => X Y. rewrite -> X. rewrite -> Y. by rewrite Operator2_simpl.
Qed.

Lemma KLEISLIL_Valeq D E F (g:D * E =-> F _BOT) dl d e : dl =-= Val d -> KLEISLIL g (dl,e) =-= g (d,e).
move => X. unlock KLEISLIL. simpl. unfold Smash. unfold id. rewrite -> X. rewrite Operator2_simpl.
by rewrite kleisliVal.
Qed.

Lemma KLEISLIL_simpl D E F (g:D * E =-> F _BOT) d e : KLEISLIL g (Val d,e) =-= g (d,e).
intros. refine (KLEISLIL_Valeq g _ (Oeq_refl _)).
Qed.

Lemma KLEISLIL_comp3 D E F G (g : F =-> G _BOT) (f:D * E =-> F) : KLEISLIL (g << f) =-= kleisli g << KLEISLIL (eta << f).
apply:fmon_eq_intro => x. case: x => dl e. simpl.
split ;  apply: DLless_cond.
- intros gg kl. destruct (KLEISLIL_ValVal kl) as [d [Pdl P]]. rewrite -> (pair_eq_compat Pdl (tset_refl e)).
  do 2 rewrite KLEISLIL_simpl. simpl. by rewrite kleisliVal.
- move => gg k. destruct (kleisliValVal k) as [ff [Pk P]].
  destruct (KLEISLIL_ValVal Pk) as [d [dlv Pd]]. rewrite -> (pair_eq_compat dlv (tset_refl e)).
  do 2 rewrite KLEISLIL_simpl. simpl. by rewrite kleisliVal.
Qed.

Lemma KLEISLIL_comp4 D E F G H (f:E * G =-> H _BOT) (g:D =-> E _BOT) (h:F =-> G) :
     KLEISLIL (KLEISLIL f << g >< h) =-= KLEISLIL f << kleisli g >< h.
intros. apply: fmon_eq_intro => x. case: x => dl df.
split ; simpl ; apply: DLless_cond ; unfold id, Smash.
intros hh kh. destruct (KLEISLIL_ValVal kh) as [d0 [dlv Pd]].
destruct (KLEISLIL_ValVal Pd) as [e0 [elv Pe]]. unlock KLEISLIL.
simpl. rewrite -> dlv. rewrite Operator2_simpl. by do 2 rewrite kleisliVal.

intros hh hv. destruct (KLEISLIL_ValVal hv) as [e0 [elv Pe]].
destruct (kleisliValVal elv) as [d0 [dlv Pd]]. unlock KLEISLIL. simpl. rewrite -> dlv. rewrite Operator2_simpl.
do 2 rewrite kleisliVal. simpl. rewrite -> Pd. by rewrite Operator2_simpl.
Qed.

Definition liftCppoType (D:cpoType) := Eval hnf in CppoType (Pointed.class (@liftOrdPointedType D)).

Lemma strictVal: forall D E (f: D _BOT =-> E _BOT), (forall d e, f d =-= Val e -> exists dd, d =-= Val dd) -> strict f.
intros. unfold strict. split ; last by apply: leastP.
simpl. apply: DLless_cond.
intros xxx Fx. specialize (H _ _ Fx). destruct H as [d incon].
simpl in incon.
assert (yy := eqValpred incon).
destruct yy as [n [dd [pp _]]]. have F:False ; last by [].
move: pp. clear. elim: n ; unfold Pointed.least ; simpl.
- by rewrite DL_bot_eq.
- move => n IH X. apply IH. by apply X.
Qed.

Lemma kleisli_bot: forall D E (f:D =-> E _BOT), kleisli f PBot =-= PBot.
intros.
refine (strictVal (f:=kleisli f) _).
intros d e.
intros kl. destruct (kleisliValVal kl) as [dd [P _]]. by exists dd.
Qed.


(* Refine and let-in's *)

Goal exists x : nat, x = 0.
 refine (let y := 0 + 0 in _).
exists y; auto.
Save test1.

Goal exists x : nat, x = 0.
 refine (let y := 0 + 0 in ex_intro _ (y + y) _).
auto.
Save test2.

Goal nat.
 refine (let y := 0 in 0 + _).
exact 1.
Save test3.

(* Example submitted by Yves on coqdev *)

Require Import List.

Goal forall l : list nat, l = l.
Proof.
 refine
 (fun l =>
  match l return (l = l) with
  | nil => _
  | O :: l0 => _
  | S _ :: l0 => _
  end).
Abort.

(* Submitted by Roland Zumkeller (BZ#888) *)

(* The Fix and CoFix rules expect a subgoal even for closed components of the
   (co-)fixpoint *)

Goal nat -> nat.
 refine (fix f (n : nat) : nat := S _
         with pred (n : nat) : nat := n
         for f).
exact 0.
Qed.

(* Submitted by Roland Zumkeller (BZ#889) *)

(* The types of metas were in metamap and they were not updated when
   passing through a binder *)

Goal forall n : nat, nat -> n = 0.
 refine
 (fun n => fix f (i : nat) : n = 0 := match i with
                                      | O => _
                                      | S _ => _
                                      end).
Abort.

(* Submitted by Roland Zumkeller (BZ#931) *)
(* Don't turn dependent evar into metas *)

Goal (forall n : nat, n = 0 -> Prop) -> Prop.
intro P.
 refine (P _ _).
reflexivity.
Abort.

(* Submitted by Jacek Chrzaszcz (BZ#1102) *)

(* le problème a été résolu ici par normalisation des evars présentes
   dans les types d'evars, mais le problème reste a priori ouvert dans
   le cas plus général d'evars non instanciées dans les types d'autres
   evars *)

Goal exists n:nat, n=n.
refine (ex_intro _ _ _).
Abort.

(* Used to failed with error not clean *)

Definition div :
  forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) ->
     forall n:nat, {q:nat | x = q*n}.
refine
  (fun m div_rec n =>
     match div_rec m n with
     | exist _ _ _ => _
     end).
Abort.

(* Use to fail because sigma was not propagated to get_type_of *)
(* Revealed by r9310, fixed in r9359 *)

Goal
  forall f : forall a (H:a=a), Prop,
 (forall a (H:a = a :> nat), f a H -> True /\ True) ->
  True.
intros.
refine (@proj1 _ _ (H 0 _ _)).
Abort.

(* Use to fail because let-in with metas in the body where rejected
   because a priori considered as dependent *)

Require Import Peano_dec.

Definition fact_F :
  forall (n:nat),
  (forall m, m<n -> nat) ->
  nat.
refine
  (fun n fact_rec =>
     if eq_nat_dec n 0 then
        1
     else
	let fn := fact_rec (n-1) _ in
        n * fn).
Abort.

(* Wish 1988: that fun forces unfold in refine *)

Goal (forall A : Prop, A -> ~~A).
Proof. refine(fun A a f => _). Abort.

(* Checking beta-iota normalization of hypotheses in created evars *)

Goal {x|x=0} -> True.
refine (fun y => let (x,a) := y in _).
match goal with a:_=0 |- _ => idtac end.
Abort.

Goal (forall P, {P 0}+{P 1}) -> True.
refine (fun H => if H (fun x => x=x) then _ else _).
match goal with _:0=0 |- _ => idtac end.
Abort.