Load "preamble3D.v".

(* dans la couche 0 *)
Lemma LABCMP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(A :: B :: C :: M :: P ::  nil) = 3.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 3 <= rg <= 4 pour ABCMP requis par la preuve de (?)ABCMP pour la règle 1  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 4 pour ABCMP requis par la preuve de (?)ABCMP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCMPm3 : rk(A :: B :: C :: M :: P :: nil) >= 3).
{
	assert(HABCmtmp : rk(A :: B :: C :: nil) >= 3) by (solve_hyps_min HABCeq HABCm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (A :: B :: C :: nil) (A :: B :: C :: M :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: B :: C :: nil) (A :: B :: C :: M :: P :: nil) 3 3 HABCmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 1 code (5 dans la thèse) conclusion AUB *)
(* marque des antécédents A B AiB : -4 -4 et -4*)
assert(HABCMPM3 : rk(A :: B :: C :: M :: P :: nil) <= 3).
{
	assert(HABCMMtmp : rk(A :: B :: C :: M :: nil) <= 3) by (solve_hyps_max HABCMeq HABCMM3).
	assert(HABCPMtmp : rk(A :: B :: C :: P :: nil) <= 3) by (solve_hyps_max HABCPeq HABCPM3).
	assert(HABCmtmp : rk(A :: B :: C :: nil) >= 3) by (solve_hyps_min HABCeq HABCm3).
	assert(Hincl : incl (A :: B :: C :: nil) (list_inter (A :: B :: C :: M :: nil) (A :: B :: C :: P :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (A :: B :: C :: M :: P :: nil) (A :: B :: C :: M :: A :: B :: C :: P :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (A :: B :: C :: M :: A :: B :: C :: P :: nil) ((A :: B :: C :: M :: nil) ++ (A :: B :: C :: P :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (A :: B :: C :: M :: nil) (A :: B :: C :: P :: nil) (A :: B :: C :: nil) 3 3 3 HABCMMtmp HABCPMtmp HABCmtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}

assert(HABCMPM : rk(A :: B :: C :: M :: P ::  nil) <= 4) by (apply rk_upper_dim).
assert(HABCMPm : rk(A :: B :: C :: M :: P ::  nil) >= 1) by (solve_hyps_min HABCMPeq HABCMPm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LApBpCpMP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M :: P ::  nil) = 3.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 3 <= rg <= 4 pour ApBpCpMP requis par la preuve de (?)ApBpCpMP pour la règle 1  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 4 pour ApBpCpMP requis par la preuve de (?)ApBpCpMP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HApBpCpMPm3 : rk(Ap :: Bp :: Cp :: M :: P :: nil) >= 3).
{
	assert(HApBpCpmtmp : rk(Ap :: Bp :: Cp :: nil) >= 3) by (solve_hyps_min HApBpCpeq HApBpCpm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (Ap :: Bp :: Cp :: nil) (Ap :: Bp :: Cp :: M :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (Ap :: Bp :: Cp :: nil) (Ap :: Bp :: Cp :: M :: P :: nil) 3 3 HApBpCpmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 1 code (5 dans la thèse) conclusion AUB *)
(* marque des antécédents A B AiB : -4 -4 et -4*)
assert(HApBpCpMPM3 : rk(Ap :: Bp :: Cp :: M :: P :: nil) <= 3).
{
	assert(HApBpCpMMtmp : rk(Ap :: Bp :: Cp :: M :: nil) <= 3) by (solve_hyps_max HApBpCpMeq HApBpCpMM3).
	assert(HApBpCpPMtmp : rk(Ap :: Bp :: Cp :: P :: nil) <= 3) by (solve_hyps_max HApBpCpPeq HApBpCpPM3).
	assert(HApBpCpmtmp : rk(Ap :: Bp :: Cp :: nil) >= 3) by (solve_hyps_min HApBpCpeq HApBpCpm3).
	assert(Hincl : incl (Ap :: Bp :: Cp :: nil) (list_inter (Ap :: Bp :: Cp :: M :: nil) (Ap :: Bp :: Cp :: P :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (Ap :: Bp :: Cp :: M :: P :: nil) (Ap :: Bp :: Cp :: M :: Ap :: Bp :: Cp :: P :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (Ap :: Bp :: Cp :: M :: Ap :: Bp :: Cp :: P :: nil) ((Ap :: Bp :: Cp :: M :: nil) ++ (Ap :: Bp :: Cp :: P :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (Ap :: Bp :: Cp :: M :: nil) (Ap :: Bp :: Cp :: P :: nil) (Ap :: Bp :: Cp :: nil) 3 3 3 HApBpCpMMtmp HApBpCpPMtmp HApBpCpmtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}

assert(HApBpCpMPM : rk(Ap :: Bp :: Cp :: M :: P ::  nil) <= 4) by (apply rk_upper_dim).
assert(HApBpCpMPm : rk(Ap :: Bp :: Cp :: M :: P ::  nil) >= 1) by (solve_hyps_min HApBpCpMPeq HApBpCpMPm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LABCMNP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(A :: B :: C :: M :: N :: P ::  nil) = 3.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 3 <= rg <= 4 pour ABCMNP requis par la preuve de (?)ABCMNP pour la règle 1  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 4 pour ABCMNP requis par la preuve de (?)ABCMNP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCMNPm3 : rk(A :: B :: C :: M :: N :: P :: nil) >= 3).
{
	assert(HABCmtmp : rk(A :: B :: C :: nil) >= 3) by (solve_hyps_min HABCeq HABCm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (A :: B :: C :: nil) (A :: B :: C :: M :: N :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: B :: C :: nil) (A :: B :: C :: M :: N :: P :: nil) 3 3 HABCmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 1 code (5 dans la thèse) conclusion AUB *)
(* marque des antécédents A B AiB : -4 4 et -4*)
assert(HABCMNPM3 : rk(A :: B :: C :: M :: N :: P :: nil) <= 3).
{
	assert(HABCNMtmp : rk(A :: B :: C :: N :: nil) <= 3) by (solve_hyps_max HABCNeq HABCNM3).
	assert(HABCMPeq : rk(A :: B :: C :: M :: P :: nil) = 3) by (apply LABCMP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption).
	assert(HABCMPMtmp : rk(A :: B :: C :: M :: P :: nil) <= 3) by (solve_hyps_max HABCMPeq HABCMPM3).
	assert(HABCmtmp : rk(A :: B :: C :: nil) >= 3) by (solve_hyps_min HABCeq HABCm3).
	assert(Hincl : incl (A :: B :: C :: nil) (list_inter (A :: B :: C :: N :: nil) (A :: B :: C :: M :: P :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (A :: B :: C :: M :: N :: P :: nil) (A :: B :: C :: N :: A :: B :: C :: M :: P :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (A :: B :: C :: N :: A :: B :: C :: M :: P :: nil) ((A :: B :: C :: N :: nil) ++ (A :: B :: C :: M :: P :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (A :: B :: C :: N :: nil) (A :: B :: C :: M :: P :: nil) (A :: B :: C :: nil) 3 3 3 HABCNMtmp HABCMPMtmp HABCmtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}

assert(HABCMNPM : rk(A :: B :: C :: M :: N :: P ::  nil) <= 4) by (apply rk_upper_dim).
assert(HABCMNPm : rk(A :: B :: C :: M :: N :: P ::  nil) >= 1) by (solve_hyps_min HABCMNPeq HABCMNPm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LApBpCpMNP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M :: N :: P ::  nil) = 3.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 3 <= rg <= 4 pour ApBpCpMNP requis par la preuve de (?)ApBpCpMNP pour la règle 1  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 4 pour ApBpCpMNP requis par la preuve de (?)ApBpCpMNP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HApBpCpMNPm3 : rk(Ap :: Bp :: Cp :: M :: N :: P :: nil) >= 3).
{
	assert(HApBpCpmtmp : rk(Ap :: Bp :: Cp :: nil) >= 3) by (solve_hyps_min HApBpCpeq HApBpCpm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (Ap :: Bp :: Cp :: nil) (Ap :: Bp :: Cp :: M :: N :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (Ap :: Bp :: Cp :: nil) (Ap :: Bp :: Cp :: M :: N :: P :: nil) 3 3 HApBpCpmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 1 code (5 dans la thèse) conclusion AUB *)
(* marque des antécédents A B AiB : -4 4 et -4*)
assert(HApBpCpMNPM3 : rk(Ap :: Bp :: Cp :: M :: N :: P :: nil) <= 3).
{
	assert(HApBpCpNMtmp : rk(Ap :: Bp :: Cp :: N :: nil) <= 3) by (solve_hyps_max HApBpCpNeq HApBpCpNM3).
	assert(HApBpCpMPeq : rk(Ap :: Bp :: Cp :: M :: P :: nil) = 3) by (apply LApBpCpMP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption).
	assert(HApBpCpMPMtmp : rk(Ap :: Bp :: Cp :: M :: P :: nil) <= 3) by (solve_hyps_max HApBpCpMPeq HApBpCpMPM3).
	assert(HApBpCpmtmp : rk(Ap :: Bp :: Cp :: nil) >= 3) by (solve_hyps_min HApBpCpeq HApBpCpm3).
	assert(Hincl : incl (Ap :: Bp :: Cp :: nil) (list_inter (Ap :: Bp :: Cp :: N :: nil) (Ap :: Bp :: Cp :: M :: P :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (Ap :: Bp :: Cp :: M :: N :: P :: nil) (Ap :: Bp :: Cp :: N :: Ap :: Bp :: Cp :: M :: P :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (Ap :: Bp :: Cp :: N :: Ap :: Bp :: Cp :: M :: P :: nil) ((Ap :: Bp :: Cp :: N :: nil) ++ (Ap :: Bp :: Cp :: M :: P :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (Ap :: Bp :: Cp :: N :: nil) (Ap :: Bp :: Cp :: M :: P :: nil) (Ap :: Bp :: Cp :: nil) 3 3 3 HApBpCpNMtmp HApBpCpMPMtmp HApBpCpmtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}

assert(HApBpCpMNPM : rk(Ap :: Bp :: Cp :: M :: N :: P ::  nil) <= 4) by (apply rk_upper_dim).
assert(HApBpCpMNPm : rk(Ap :: Bp :: Cp :: M :: N :: P ::  nil) >= 1) by (solve_hyps_min HApBpCpMNPeq HApBpCpMNPm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LABCApBpCpMNP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P ::  nil) = 4.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 3 <= rg <= 4 pour ABCApBpCpMNP requis par la preuve de (?)ABCApBpCpMNP pour la règle 5  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 4 pour ABCApBpCpMNP requis par la preuve de (?)ABCApBpCpMNP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCApBpCpMNPm3 : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) >= 3).
{
	assert(HABCmtmp : rk(A :: B :: C :: nil) >= 3) by (solve_hyps_min HABCeq HABCm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (A :: B :: C :: nil) (A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: B :: C :: nil) (A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) 3 3 HABCmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HABCApBpCpMNPm4 : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) >= 4).
{
	assert(HABCApBpCpmtmp : rk(A :: B :: C :: Ap :: Bp :: Cp :: nil) >= 4) by (solve_hyps_min HABCApBpCpeq HABCApBpCpm4).
	assert(Hcomp : 4 <= 4) by (repeat constructor).
	assert(Hincl : incl (A :: B :: C :: Ap :: Bp :: Cp :: nil) (A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (A :: B :: C :: Ap :: Bp :: Cp :: nil) (A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) 4 4 HABCApBpCpmtmp Hcomp Hincl);apply HT.
}

assert(HABCApBpCpMNPM : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P ::  nil) <= 4) by (apply rk_upper_dim).
assert(HABCApBpCpMNPm : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P ::  nil) >= 1) by (solve_hyps_min HABCApBpCpMNPeq HABCApBpCpMNPm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LMNP : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 -> rk(M :: N :: P ::  nil) = 2.
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.

(* dans constructProofaux(), preuve de 2 <= rg <= 3 pour MNP requis par la preuve de (?)MNP pour la règle 3  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 3 pour MNP requis par la preuve de (?)MNP pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : -4 *)
assert(HMNPm2 : rk(M :: N :: P :: nil) >= 2).
{
	assert(HMNmtmp : rk(M :: N :: nil) >= 2) by (solve_hyps_min HMNeq HMNm2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (M :: N :: nil) (M :: N :: P :: nil)) by (repeat clear_all_rk;my_inO).
	assert(HT := rule_5 (M :: N :: nil) (M :: N :: P :: nil) 2 2 HMNmtmp Hcomp Hincl);apply HT.
}

(* Application de la règle 3 code (6 dans la thèse) *)
(* marque des antécédents A B AUB: 4 4 et 4*)
assert(HMNPM2 : rk(M :: N :: P :: nil) <= 2).
{
	assert(HABCMNPeq : rk(A :: B :: C :: M :: N :: P :: nil) = 3) by (apply LABCMNP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption).
	assert(HABCMNPMtmp : rk(A :: B :: C :: M :: N :: P :: nil) <= 3) by (solve_hyps_max HABCMNPeq HABCMNPM3).
	assert(HApBpCpMNPeq : rk(Ap :: Bp :: Cp :: M :: N :: P :: nil) = 3) by (apply LApBpCpMNP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption).
	assert(HApBpCpMNPMtmp : rk(Ap :: Bp :: Cp :: M :: N :: P :: nil) <= 3) by (solve_hyps_max HApBpCpMNPeq HApBpCpMNPM3).
	assert(HABCApBpCpMNPeq : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) = 4) by (apply LABCApBpCpMNP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption).
	assert(HABCApBpCpMNPmtmp : rk(A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) >= 4) by (solve_hyps_min HABCApBpCpMNPeq HABCApBpCpMNPm4).
	assert(Hincl : incl (M :: N :: P :: nil) (list_inter (A :: B :: C :: M :: N :: P :: nil) (Ap :: Bp :: Cp :: M :: N :: P :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (A :: B :: C :: Ap :: Bp :: Cp :: M :: N :: P :: nil) (A :: B :: C :: M :: N :: P :: Ap :: Bp :: Cp :: M :: N :: P :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (A :: B :: C :: M :: N :: P :: Ap :: Bp :: Cp :: M :: N :: P :: nil) ((A :: B :: C :: M :: N :: P :: nil) ++ (Ap :: Bp :: Cp :: M :: N :: P :: nil))) by (clear_all_rk;my_inO).
	try rewrite HT1 in HABCApBpCpMNPmtmp;try rewrite HT2 in HABCApBpCpMNPmtmp.
	assert(HT := rule_3 (A :: B :: C :: M :: N :: P :: nil) (Ap :: Bp :: Cp :: M :: N :: P :: nil) (M :: N :: P :: nil) 3 3 4 HABCMNPMtmp HApBpCpMNPMtmp HABCApBpCpMNPmtmp Hincl);apply HT.
}

assert(HMNPM : rk(M :: N :: P ::  nil) <= 3) (* dim : 3 *) by (solve_hyps_max HMNPeq HMNPM3).
assert(HMNPm : rk(M :: N :: P ::  nil) >= 1) by (solve_hyps_min HMNPeq HMNPm1).
intuition.
Qed.

(* dans la couche 0 *)
Theorem def_Conclusion : forall A B C Ap Bp Cp M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(Ap :: Bp :: Cp ::  nil) = 3 -> rk(A :: B :: C :: Ap :: Bp :: Cp ::  nil) = 4 ->
rk(A :: B :: C :: M ::  nil) = 3 -> rk(Ap :: Bp :: Cp :: M ::  nil) = 3 -> rk(A :: B :: C :: N ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: N ::  nil) = 3 -> rk(M :: N ::  nil) = 2 -> rk(A :: B :: C :: P ::  nil) = 3 ->
rk(Ap :: Bp :: Cp :: P ::  nil) = 3 ->
	 rk(M :: N :: P ::  nil) = 2  .
Proof.

intros A B C Ap Bp Cp M N P
HABCeq HApBpCpeq HABCApBpCpeq HABCMeq HApBpCpMeq HABCNeq HApBpCpNeq HMNeq HABCPeq HApBpCpPeq
.
repeat split.

	apply LMNP with (A := A) (B := B) (C := C) (Ap := Ap) (Bp := Bp) (Cp := Cp) (M := M) (N := N) (P := P) ; assumption.
Qed .


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*                   Proof of functional correctness                   *)
(*       for the C functions implemented in the MShareIntro layer      *)
(*                                                                     *)
(*                        Xiongnan (Newman) Wu                         *)
(*                                                                     *)
(*                          Yale University                            *)
(*                                                                     *)
(* *********************************************************************)
Require Import TacticsForTesting.
Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import MemoryX.
Require Import EventsX.
Require Import Globalenvs.
Require Import Locations.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import ZArith.Zwf.
Require Import RealParams.
Require Import LoopProof.
Require Import VCGen.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import CompatClightSem.
Require Import PrimSemantics.
Require Import ShareOpGenSpec.
Require Import Clight.
Require Import CDataTypes.
Require Import Ctypes.
Require Import CLemmas.
Require Import AbstractDataType.
Require Import MShareIntroCSource.
Require Import MShareIntro.
Require Import CalRealSMSPool.
Require Import XOmega.

Module MSHAREINTROCODESHAREDMEMINIT.

  Section WithPrimitives.

    Context `{real_params: RealParams}.
    Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
    Context `{Hmwd: UseMemWithData memb}.

    Let mem := mwd (cdata RData).

    Context `{Hstencil: Stencil}.
    Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
    Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

    Local Open Scope Z_scope.

    Section SharedMemInit.

      Let L: compatlayer (cdata RData) := clear_shared_mem ↦ gensem clear_shared_mem_spec
             ⊕ pmap_init ↦ gensem pmap_init_spec.

      Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.

      Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

      Local Open Scope Z_scope.

      Section SharedMemInitBody.

        Context `{Hwb: WritableBlockOps}.

        Variable (sc: stencil).

        Variables (ge: genv)
                  (STENCIL_MATCHES: stencil_matches sc ge).

        (** pmap_init *)

        Variable bpmap_init: block.

        Hypothesis hpmap_init1 : Genv.find_symbol ge pmap_init = Some bpmap_init.

        Hypothesis hpmap_init2 : Genv.find_funct_ptr ge bpmap_init = Some (External (EF_external pmap_init (signature_of_type (Tcons tint Tnil) Tvoid cc_default)) (Tcons tint Tnil) Tvoid cc_default).

        (** clear_shared_mem *)

        Variable bclear_shared_mem: block.

        Hypothesis hclear_shared_mem1 : Genv.find_symbol ge clear_shared_mem = Some bclear_shared_mem.

        Hypothesis hclear_shared_mem2 : Genv.find_funct_ptr ge bclear_shared_mem = Some (External (EF_external clear_shared_mem (signature_of_type (Tcons tint (Tcons tint Tnil)) Tvoid cc_default)) (Tcons tint (Tcons tint Tnil)) Tvoid cc_default).

        Definition shared_mem_init_inner_mk_rdata (i j: Z) (adt: RData) :=
          adt {smspool: Calculate_smsp_inner i (Z.to_nat j) (smspool adt)}.

        Section shared_mem_init_inner_loop_proof.

          Variable minit: memb.
          Variable adt: RData.
          Variable i: Z.

          Hypothesis pg : pg adt = true.
          Hypothesis ihost: ihost adt = true.
          Hypothesis ikern: ikern adt = true.
          Hypothesis ipt: ipt adt = true.
          Hypothesis irange: 0 <= i < num_proc.

          Definition shared_mem_init_inner_loop_body_P (le: temp_env) (m: mem): Prop :=
            PTree.get _j le = Some (Vint Int.zero) /\
            PTree.get _i le = Some (Vint (Int.repr i)) /\
            m = (minit, adt).

          Definition shared_mem_init_inner_loop_body_Q (le : temp_env) (m: mem): Prop :=
            m = (minit, shared_mem_init_inner_mk_rdata i (num_proc - 1) adt) /\ PTree.get _i le = Some (Vint (Int.repr i)).

          Lemma shared_mem_init_inner_loop_correct_aux : LoopProofSimpleWhile.t shared_mem_init_inner_while_condition shared_mem_init_inner_while_body ge (PTree.empty _) (shared_mem_init_inner_loop_body_P) (shared_mem_init_inner_loop_body_Q).
          Proof.
            generalize max_unsigned_val; intro muval.
            apply LoopProofSimpleWhile.make with
            (W := Z)
              (lt := fun z1 z2 => (0 <= z2 /\ z1 < z2)%Z)
              (I := fun le m w => exists j,
                                    PTree.get _i le = Some (Vint (Int.repr i)) /\
                                    PTree.get _j le = Some (Vint j) /\
                                    0 <= Int.unsigned j <= num_proc /\
                                    (Int.unsigned j = 0 /\ m = (minit, adt) \/ 0 < Int.unsigned j /\ m = (minit, shared_mem_init_inner_mk_rdata i (Int.unsigned j - 1) adt)) /\
                                    w = num_proc - Int.unsigned j
              )
            .
            apply Zwf_well_founded.
            intros.
            unfold shared_mem_init_inner_loop_body_P in H.
            destruct H as [tjle tmpH].
            destruct tmpH as [tile msubst].
            subst.
            esplit. esplit.
            repeat vcgen.

            intros.
            unfold shared_mem_init_inner_while_condition.
            unfold shared_mem_init_inner_while_body.
            destruct H as [j tmpH].
            destruct tmpH as [tile tmpH].
            destruct tmpH as [tjle tmpH].
            destruct tmpH as [jrange tmpH].
            destruct tmpH as [jcase nval].
            subst.
            destruct jrange as [jlow jhigh].
            apply Zle_lt_or_eq in jhigh.
            destruct m.

            Caseeq jhigh.
            intro jhigh.

            Caseeq jcase.
            (* j = 0 *)
            intro tmpH; destruct tmpH as [jval msubst].
            injection msubst; intros; subst.
            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            unfold clear_shared_mem_spec.
            rewrite pg, ihost, ikern, ipt.
            unfold shared_mem_arg'.
            repeat rewrite zle_lt_true; auto.
            exists (num_proc - Int.unsigned j - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            unfold shared_mem_init_inner_mk_rdata.
            rewrite jval; simpl.
            unfold Calculate_smsp_inner_at_j.
            reflexivity.

            (* j > 0 *)
            intro tmpH.
            destruct tmpH as [jgt0 mval].
            injection mval; intros; subst.
            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            unfold clear_shared_mem_spec; simpl.
            rewrite pg, ihost, ikern, ipt.
            unfold shared_mem_arg'.
            repeat rewrite zle_lt_true; auto.
            exists (num_proc - Int.unsigned j - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            unfold shared_mem_init_inner_mk_rdata.
            replace (Int.unsigned j + 1 - 1) with (Int.unsigned j - 1 + 1) by omega.
            change (Int.unsigned j - 1 + 1) with (Z.succ (Int.unsigned j - 1)).
            rewrite Z2Nat.inj_succ with (n:=(Int.unsigned j - 1)).
            Opaque Z.to_nat Z.of_nat.
            simpl.
            rewrite Nat2Z.inj_succ.
            rewrite Z2Nat.id.
            unfold Z.succ.
            replace (Int.unsigned j - 1 + 1) with (Int.unsigned j) by omega.
            unfold Calculate_smsp_inner_at_j.
            reflexivity.
            omega.
            omega.

            (* j = num_proc *)
            intro jval.
            subst.
            esplit. esplit.
            repeat vcgen.
            unfold shared_mem_init_inner_loop_body_Q.
            Caseeq jcase.
            intro tmpH; destruct tmpH.
            rewrite jval in H0.
            discriminate H0.
            intro tmpH; destruct tmpH.
            rewrite jval in H1.
            injection H1; intros; subst.
            split; eauto.
          Qed.

        End shared_mem_init_inner_loop_proof.

        Lemma shared_mem_init_inner_loop_correct: forall m d d' le i,
                                       pg d = true ->
                                       ihost d = true ->
                                       ikern d = true ->
                                       ipt d = true ->
                                       0 <= i < num_proc ->
                                       PTree.get _j le = Some (Vint Int.zero) ->
                                       PTree.get _i le = Some (Vint (Int.repr i)) ->
                                       d' = shared_mem_init_inner_mk_rdata i (num_proc - 1) d ->
                                       exists le',
                                         (exec_stmt ge (PTree.empty _) le ((m, d): mem) (Swhile shared_mem_init_inner_while_condition shared_mem_init_inner_while_body) E0 le' (m, d') Out_normal /\ PTree.get _i le' = Some (Vint (Int.repr i))).
        Proof.
          intros.
          generalize (shared_mem_init_inner_loop_correct_aux m d i H H0 H1 H2 H3).
          unfold shared_mem_init_inner_loop_body_P.
          unfold shared_mem_init_inner_loop_body_Q.
          intro LP.
          refine (_ (LoopProofSimpleWhile.termination _ _ _ _ _ _ LP le (m, d) _)).
          intro pre.
          destruct pre as [le' tmppre].
          destruct tmppre as [m'' tmppre].
          destruct tmppre as [stmp tmppre].
          destruct tmppre as [m''val tpile'].
          exists le'.
          subst.
          repeat vcgen.
          repeat vcgen.
        Qed.

        Definition shared_mem_init_mk_rdata (i: Z) (adt: RData) := adt {smspool: Calculate_smsp (Z.to_nat i) (smspool adt)}.

        Section shared_mem_init_loop_proof.

          Variable minit: memb.
          Variable adt: RData.

          Hypothesis pg : pg adt = true.
          Hypothesis ihost: ihost adt = true.
          Hypothesis ikern: ikern adt = true.
          Hypothesis ipt: ipt adt = true.

          Definition shared_mem_init_loop_body_P (le: temp_env) (m: mem): Prop :=
            PTree.get _i le = Some (Vint Int.zero) /\
            m = (minit, adt).

          Definition shared_mem_init_loop_body_Q (le : temp_env) (m: mem): Prop :=
            m = (minit, shared_mem_init_mk_rdata (num_proc - 1) adt).

          Lemma shared_mem_init_loop_correct_aux : LoopProofSimpleWhile.t shared_mem_init_outter_while_condition shared_mem_init_outter_while_body ge (PTree.empty _) (shared_mem_init_loop_body_P) (shared_mem_init_loop_body_Q).
          Proof.
            generalize max_unsigned_val; intro muval.
            apply LoopProofSimpleWhile.make with
            (W := Z)
              (lt := fun z1 z2 => (0 <= z2 /\ z1 < z2)%Z)
              (I := fun le m w => exists i,
                                    PTree.get _i le = Some (Vint i) /\
                                    0 <= Int.unsigned i <= num_proc /\
                                    (Int.unsigned i = 0 /\ m = (minit, adt) \/ 0 < Int.unsigned i /\ m = (minit, shared_mem_init_mk_rdata (Int.unsigned i - 1) adt)) /\
                                    w = num_proc - Int.unsigned i
              )
            .
            apply Zwf_well_founded.
            intros.
            unfold shared_mem_init_loop_body_P in H.
            destruct H as [tile msubst].
            subst.
            esplit. esplit.
            repeat vcgen.

            intros.
            unfold shared_mem_init_outter_while_condition.
            unfold shared_mem_init_outter_while_body.
            destruct H as [i tmpH].
            destruct tmpH as [tile tmpH].
            destruct tmpH as [irange tmpH].
            destruct tmpH as [icase nval].
            subst.
            destruct irange as [ilow ihigh].
            apply Zle_lt_or_eq in ihigh.
            destruct m.

            Caseeq ihigh.
            intro ihigh.

            Caseeq icase.
            (* i = 0 *)
            intro tmpH; destruct tmpH as [ival msubst].
            injection msubst; intros; subst.

            exploit (shared_mem_init_inner_loop_correct minit adt (shared_mem_init_inner_mk_rdata 0 (num_proc - 1) adt) (PTree.set _j (Vint (Int.repr 0)) (set_opttemp None Vundef le)) (Int.unsigned i)); repeat vcgen; try rewrite ival; try reflexivity.
            destruct H as [le' stmt].
            destruct stmt as [stmt tmp].

            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            exists (num_proc - Int.unsigned i - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            unfold shared_mem_init_mk_rdata.
            rewrite ival; simpl.
            unfold Calculate_smsp_at_i.
            unfold shared_mem_init_inner_mk_rdata.
            reflexivity.

            (* i > 0 *)
            intro tmpH.
            destruct tmpH as [igt0 mval].
            injection mval; intros; subst.

            exploit (shared_mem_init_inner_loop_correct minit (shared_mem_init_mk_rdata (Int.unsigned i - 1) adt) (shared_mem_init_inner_mk_rdata (Int.unsigned i) (num_proc - 1) (shared_mem_init_mk_rdata (Int.unsigned i - 1) adt)) (PTree.set _j (Vint (Int.repr 0)) (set_opttemp None Vundef le)) (Int.unsigned i)); repeat vcgen.
            destruct H as [le' stmt].
            destruct stmt as [stmt tmp].

            esplit. esplit.
            repeat vcgen.
            esplit. esplit.
            repeat vcgen.
            exists (num_proc - Int.unsigned i - 1).
            repeat vcgen.
            esplit.
            repeat vcgen.
            right.
            split.
            omega.
            unfold shared_mem_init_mk_rdata.
            f_equal.
            replace (Int.unsigned i + 1 - 1) with (Int.unsigned i - 1 + 1) by omega.
            change (Int.unsigned i - 1 + 1) with (Z.succ (Int.unsigned i - 1)).
            rewrite Z2Nat.inj_succ with (n:=(Int.unsigned i - 1)).
            Opaque Z.to_nat Z.of_nat.
            simpl.
            rewrite Nat2Z.inj_succ.
            rewrite Z2Nat.id.
            unfold Z.succ.
            replace (Int.unsigned i - 1 + 1) with (Int.unsigned i) by omega.
            unfold Calculate_smsp_at_i.
            unfold shared_mem_init_inner_mk_rdata.
            symmetry.
            reflexivity.
            omega.
            omega.

            (* i = num_proc *)
            intro ival.
            subst.
            esplit. esplit.
            repeat vcgen.
            unfold shared_mem_init_loop_body_Q.
            Caseeq icase.
            intro tmpH; destruct tmpH.
            rewrite ival in H0.
            discriminate H0.
            intro tmpH; destruct tmpH.
            rewrite ival in H1.
            injection H1; intros; subst.
            split; eauto.
          Qed.

        End shared_mem_init_loop_proof.

        Lemma shared_mem_init_loop_correct: forall m d d' le,
                                       pg d = true ->
                                       ihost d = true ->
                                       ikern d = true ->
                                       ipt d = true ->
                                       PTree.get _i le = Some (Vint Int.zero) ->
                                       d' = shared_mem_init_mk_rdata (num_proc - 1) d ->
                                       exists le',
                                         exec_stmt ge (PTree.empty _) le ((m, d): mem) (Swhile shared_mem_init_outter_while_condition shared_mem_init_outter_while_body) E0 le' (m, d') Out_normal.
        Proof.
          intros.
          generalize (shared_mem_init_loop_correct_aux m d H H0 H1 H2).
          unfold shared_mem_init_loop_body_P.
          unfold shared_mem_init_loop_body_Q.
          intro LP.
          refine (_ (LoopProofSimpleWhile.termination _ _ _ _ _ _ LP le (m, d) _)).
          intro pre.
          destruct pre as [le' tmppre].
          destruct tmppre as [m'' tmppre].
          destruct tmppre as [stmp m''val].
          exists le'.
          subst.
          repeat vcgen.
          repeat vcgen.
        Qed.

        Lemma shared_mem_init_body_correct: forall m d d' env le mbi_adr,
                                      env = PTree.empty _ ->
                                      PTree.get _mbi_adr le = Some (Vint mbi_adr) ->
                                      sharedmem_init_spec (Int.unsigned mbi_adr) d = Some d' ->
                                      high_level_invariant d ->
                                      exists le',
                                        exec_stmt ge env le ((m, d): mem) shared_mem_init_body E0 le' (m, d') Out_normal.
        Proof.
          generalize max_unsigned_val; intro muval.
          intros.
          subst.
          unfold shared_mem_init_body.
          functional inversion H1; subst.

          set (initd := ((((((((d {vmxinfo : real_vmxinfo}) {pg : true}) {LAT
           : real_LAT (LAT d)}) {nps : real_nps} {AC: real_AC}) {init : true}) {PT : 0})
       {ptpool : CalRealPT.real_pt (ptpool d)}) {idpde
      : CalRealIDPDE.real_idpde (idpde d)})).
          exploit (shared_mem_init_loop_correct m initd (shared_mem_init_mk_rdata (num_proc - 1) initd) (PTree.set _i (Vint (Int.repr 0))
        (set_opttemp None Vundef (set_opttemp None Vundef le)))); unfold initd; simpl; try reflexivity; try assumption; repeat ptreesolve.
          unfold real_smspool, CalRealIDPDE.real_idpde.
          unfold shared_mem_init_mk_rdata.
          Opaque Z.to_nat Z.of_nat Calculate_smsp.
          simpl.
          generalize (Calculate_smsp (Z.to_nat 63) (smspool d)).
          generalize (CalRealIDPDE.real_idpde (idpde d)).
          intros real_smspool' real_idpde' stmt.
          destruct stmt as [le' stmt].
          esplit.
          repeat vcgen.
        Qed.

      End SharedMemInitBody.

      Theorem shared_mem_init_code_correct:
        spec_le (shared_mem_init ↦ shared_mem_init_spec_low) (〚shared_mem_init ↦ f_shared_mem_init 〛L).
      Proof.
        set (L' := L) in *. unfold L in *.
        fbigstep_pre L'.
        fbigstep (shared_mem_init_body_correct s (Genv.globalenv p) makeglobalenv b1 Hb1fs Hb1fp b0 Hb0fs Hb0fp m'0 labd labd' (PTree.empty _)
                                        (bind_parameter_temps' (fn_params f_shared_mem_init)
                                                               (Vint mbi_adr::nil)
                                                               (create_undef_temps (fn_temps f_shared_mem_init)))) H0.
      Qed.

    End SharedMemInit.

  End WithPrimitives.

End MSHAREINTROCODESHAREDMEMINIT.


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.

Import ListNotations.

(** Type uniqueness *)

Module UniqueTyp (IdT: ModTyp) <: ModTyp.

Module WeakenL := Weaken IdT.
Export WeakenL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Definition UniETyping_def :=
  fun (ftenv: funTC) (tenv: valTC)
      (e: Exp) (t1: VTyp) (k: ExpTyping ftenv tenv e t1) =>
  forall (t2: VTyp),
    ExpTyping ftenv tenv e t2 ->
        t1 = t2.

Definition UniPTyping_def :=
  fun (ftenv: funTC) (tenv: valTC)
      (ps: Prms) (pt1: PTyp) (k: PrmsTyping ftenv tenv ps pt1) =>
    forall (pt2: PTyp),
      PrmsTyping ftenv tenv ps pt2 ->
        pt1 = pt2.

Definition UniType_ExpTyping_mut :=
                      ExpTyping_mut UniETyping_def UniPTyping_def.

Definition UniType_PrmsTyping_mut :=
                      PrmsTyping_mut UniETyping_def UniPTyping_def.

(****************************************************************************)

Lemma UniVTyping :
  forall (v: Value) (t1 t2: VTyp),
    VTyping v t1 ->
    VTyping v t2 ->
    t1 = t2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  reflexivity.
Defined.

Lemma UniIdTyping :
  forall (tenv: valTC) (x: Id) (t1 t2: VTyp),
    IdTyping tenv x t1 ->
    IdTyping tenv x t2 ->
    t1 = t2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  destruct (findE tenv x).
  inversion H2; subst.
  inversion H3; subst.
  reflexivity.
  inversion H2.
Defined.

Lemma UniIdFTyping :
  forall (ftenv: funTC) (x: Id) (ft1 ft2: FTyp),
    IdFTyping ftenv x ft1 ->
    IdFTyping ftenv x ft2 ->
    ft1 = ft2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  destruct (findE ftenv x).
  inversion H2; subst.
  inversion H3; subst.
  reflexivity.
  inversion H2.
Defined.

Lemma UniEnvTyping :
  forall (env: valEnv) (tenv1 tenv2: valTC),
    EnvTyping env tenv1 ->
    EnvTyping env tenv2 ->
    tenv1 = tenv2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  reflexivity.
Defined.

Lemma UniFEnvTyping :
  forall (fenv: funEnv) (ftenv1 ftenv2: funTC),
    FEnvTyping fenv ftenv1 ->
    FEnvTyping fenv ftenv2 ->
    ftenv1 = ftenv2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  reflexivity.
Defined.

Lemma UniETyping :
  forall (ftenv: funTC) (tenv: valTC)
         (e: Exp) (t1: VTyp),
      ExpTyping ftenv tenv e t1 ->
      forall (t2: VTyp),
         ExpTyping ftenv tenv e t2 ->
         t1 = t2.
Proof.
  intros.
  eapply UniType_ExpTyping_mut.
  - intros.
    unfold UniETyping_def.
    intros.
    inversion X1; subst.
    eapply UniVTyping.
    exact v0.
    assumption.
  - intros.
    unfold UniETyping_def.
    intros.
    inversion X1; subst.
    eapply UniIdTyping.
    exact i.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    eapply H0 in X3.
    exact X3.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    inversion m0; subst.
    + inversion X2; subst.
      eapply H0 in X4.
      exact X4.
    + eapply H in X3.
      rewrite <- X3 in X4.
      eapply H0 in X4.
      exact X4.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    assert (tenv1 = tenv4).
    eapply UniEnvTyping.
    exact e1.
    assumption.
    rewrite <- H0 in X2.
    eapply H in X2.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    eapply H0 in X3.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    assert (FT pt t = FT pt0 t0).
    eapply UniIdFTyping.
    exact i.
    assumption.
    inversion H1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    assert (FT pt t = FT pt0 t0).
    eapply UniIdFTyping.
    exact i.
    assumption.
    inversion H0; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    eapply H in X2.
    eapply H0 in X3.
    inversion X3; subst.
    reflexivity.
  - exact X.
  - exact X0.
Defined.

Lemma UniPTyping :
  forall (ftenv: funTC) (tenv: valTC)
         (ps: Prms) (pt1: PTyp),
      PrmsTyping ftenv tenv ps pt1 ->
      forall (pt2: PTyp),
         PrmsTyping ftenv tenv ps pt2 ->
         pt1 = pt2.
Proof.
  intros.
  eapply UniType_PrmsTyping_mut.
  - intros.
    unfold UniETyping_def.
    intros.
    inversion X1; subst.
    eapply UniVTyping.
    exact v0.
    assumption.
  - intros.
    unfold UniETyping_def.
    intros.
    inversion X1; subst.
    eapply UniIdTyping.
    exact i.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    eapply H0 in X3.
    exact X3.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    inversion m0; subst.
    + inversion X2; subst.
      eapply H0 in X4.
      exact X4.
    + eapply H in X3.
      rewrite <- X3 in X4.
      eapply H0 in X4.
      exact X4.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    assert (tenv1 = tenv4).
    eapply UniEnvTyping.
    exact e0.
    assumption.
    rewrite <- H0 in X2.
    eapply H in X2.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    eapply H0 in X3.
    assumption.
  - intros.
    unfold UniETyping_def in *.
    intros.
    inversion X1; subst.
    assert (FT pt t = FT pt0 t2).
    eapply UniIdFTyping.
    exact i.
    assumption.
    inversion H1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    assert (FT pt t = FT pt0 t2).
    eapply UniIdFTyping.
    exact i.
    assumption.
    inversion H0; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    reflexivity.
  - intros.
    unfold UniETyping_def, UniPTyping_def in *.
    intros.
    inversion X1; subst.
    eapply H in X2.
    eapply H0 in X3.
    inversion X3; subst.
    reflexivity.
  - exact X.
  - exact X0.
Defined.

End UniqueTyp.


(* From StLib. *)
Require Export Programs.

Module Kern (D : DOMAIN) (Pb : PROBLEM D).

  Module P := Prog D Pb.
  Export P.

  (** [code] denotes the type of elementary (computation or communication)
   * steps in a distributed kernel. *)
  Inductive code : Type :=
  | kNop : code
  | kFire : cexpr -> code
  | kIf : bexpr -> code -> code -> code
  | kSeq : code -> code -> code
  | kFor : string -> aexpr -> aexpr -> code -> code.

  (** Notations for elementary steps. *)

  Delimit Scope code_scope with code.

  Notation "'Nop'" :=
    kNop : code_scope.
  Notation "'Fire' c" :=
    (kFire c%aexpr) (at level 80) : code_scope.
  Notation "'If' b 'Then' p1 'Else' p2" :=
    (kIf b%bexpr p1 p2) (at level 80, right associativity) : code_scope.
  Notation "p1 ;; p2" :=
    (kSeq p1 p2) (at level 80, right associativity) : code_scope.
  Notation "'For' i 'From' a 'To' b 'Do' p" :=
    (kFor i a%aexpr b%aexpr p)
      (at level 80, right associativity) : code_scope.

  (** [denote] compiles programs of type [code] into programs of type
   * [prog].  This translation is trivial, except for the compilation of the
   * [Fire] command.  [denote] is parameterized with this compilation step.
   *
   * This allows to give two different denotational semantics to programs of
   * type [code]: One for communication steps, where we check that
   * dependencies are satisfied.  And one for computation steps, where we don't.
   * In particular, we will have to check that the pieces of information we
   * send are part of the current knowledge of the thread, but this is captured
   * later on, when we give the semantics of distributed programs. *)
  Fixpoint denote (p : code) F : prog :=
    match p with
      | Nop%code =>
        Nop%prog
      | (Fire c)%code =>
        F c
      | (If b Then p1 Else p2)%code =>
        (If b Then (denote p1 F) Else (denote p2 F))%prog
      | (p1;; p2)%code =>
        (denote p1 F;; denote p2 F)%prog
      | (For i From a To b Do q)%code =>
        (For i From a To b Do denote q F)%prog
    end.

  Module Comp.
    (** Computation steps.  Here, [Fire c] is compiled as an assertion stating
     * that all the dependencies of [c] are satisfied, followed by a [Flag c]
     * command. *)
    Definition F c := P.Fire c.
    Definition denote (p : code) : prog :=
      denote p F.
  End Comp.

  Module Comm.
    (** Communication steps.  This time, [Fire c] is equivalent to [Flag c]. *)
    Definition F c := Flag c.
    Definition denote (p : code) : prog :=
      denote p F.
  End Comm.

  Definition thread := Z.
  Definition time := Z.

  (** [kern] is the type of distributed programs.  A distributed program
   * is defined by two programs, representing respectively computation steps
   * and communication steps.
   *
   * During computation steps, the program can access two distinguished
   * variables, ["id"] and ["T"].  The former contains the thread's ID while
   * the latter represents the current time step.
   *
   * Similarly, during communication steps, the program can access ["id"] and
   * ["T"], but also ["to"], which contains the ID of the thread to which
   * information will be sent.  E.g., if [T=2], [id=1] and [to=3], this is
   * time step [2], the program is being executed by thread [1] and sending
   * data to thread [3].
   *)
  Record kern :=
    makeKernel
      {
        comp : code;
        comm : code
      }.

  (** We now turn to semantics and correctness of distributed programs. *)
  Record trace :=
    makeTrace
      {
        beforeComp : time -> thread -> array;
        afterComp  : time -> thread -> array;
        sends      : time -> thread -> thread -> array
      }.

  Definition kexec (k : kern) (tr : trace)
             (idMax : thread) (TMax : time) : Prop :=
    (* Initially, nothing is computed. *)
    (forall id, 0 <= id <= idMax -> beforeComp tr 0 id ≡ ∅)
    /\

    (* We go from [beforeComp tr T id] to [afterComp tr T id] through a
     * computation step. *)
    (forall id T,
       0 <= id <= idMax -> 0 <= T <= TMax ->
       exec [("id", id); ("T", T)]
            (beforeComp tr T id)
            (Comp.denote (comp k))
            (afterComp tr T id))
    /\

    (* [sends tr T id to] represents what is sent by thread [id] to thread
     * [to] at step [T]. *)
    (forall id to T,
       0 <= id <= idMax -> 0 <= to <= idMax -> 0 <= T <= TMax ->
       exec [("id", id); ("to", to); ("T", T)]
            ∅
            (Comm.denote (comm k))
            (sends tr T id to))
    /\

    (* A thread cannot send a value it does not know. *)
    (forall id to T,
       0 <= id <= idMax -> 0 <= to <= idMax -> 0 <= T <= TMax ->
       sends tr T id to ⊆ afterComp tr T id)
    /\

    (* Conservation of knowledge: What a thread knows at time [T+1] comes
     * from what it knew after computation step at time [T] and what other
     * threads sent to it. *)
    (forall id T,
       0 <= id <= idMax -> 0 <= T <= TMax ->
       beforeComp tr (T+1) id ⊆
                  afterComp tr T id
                  ∪ ⋃⎨sends tr T from id, from ∈〚0, idMax〛⎬)
    /\

    (* Completeness *)
    (target ⊆ ⋃⎨beforeComp tr (TMax+1) id, id ∈〚0, idMax〛⎬).

  Definition kcorrect (k : kern) (idMax : thread) (TMax : time) :=
    exists tr, kexec k tr idMax TMax.

  (** Trace synthesizer *)

  Definition sends_synth (k : kern) (idMax : thread) :=
    fun T id to =>
      shape [("id", id); ("to", to); ("T", T)]
            (Comm.denote (comm k)).

  Definition computes_synth (k : kern) (idMax : thread) :=
    fun T id =>
      shape [("id", id); ("T", T)]
            (Comp.denote (comp k)).

  Definition bf_synth (k : kern) (idMax : thread) :=
    fun T id =>
      (⋃⎨computes_synth k idMax T' id, T' ∈〚0, T-1〛⎬)
        ∪ (⋃⎨⋃⎨sends_synth k idMax T' from id, from ∈〚0, idMax〛⎬,
             T' ∈〚0, T-1〛⎬).

  Definition af_synth (k : kern) (idMax : thread) :=
    fun T id =>
      (⋃⎨computes_synth k idMax T' id, T' ∈〚0, T〛⎬)
        ∪ (⋃⎨⋃⎨sends_synth k idMax T' from id, from ∈〚0, idMax〛⎬,
             T' ∈〚0, T-1〛⎬).

  Definition trace_synth (k : kern) (idMax : thread) :=
    makeTrace (bf_synth k idMax)
              (af_synth k idMax)
              (sends_synth k idMax).

  (** Main correctness result. *)
  Theorem trace_synth_correct :
    forall k idMax TMax,
      (forall T id,
         0 <= id <= idMax -> 0 <= T <= TMax ->
         vc [("id", id); ("T", T)]
            (⋃⎨computes_synth k idMax T' id, T' ∈〚0, T - 1〛⎬
             ∪ ⋃⎨⋃⎨sends_synth k idMax T' from id, from ∈〚0, idMax〛⎬,
                 T' ∈〚0, T - 1〛⎬)
            (Comp.denote (comp k))) ->
      (forall T id to,
         0 <= id <= idMax -> 0 <= to <= idMax ->
         0 <= T <= TMax ->
         vc [("id", id); ("to", to); ("T", T)] ∅ (Comm.denote (comm k))) ->
      (forall T id to,
         0 <= id <= idMax -> 0 <= to <= idMax ->
         0 <= T <= TMax ->
         sends_synth k idMax T id to ⊆ af_synth k idMax T id) ->
      target ⊆ ⋃⎨bf_synth k idMax (TMax + 1) id, id ∈〚0, idMax〛⎬ ->
      kexec k (trace_synth k idMax) idMax TMax.
  Proof.
    unfold kexec, trace_synth, beforeComp, afterComp; intuition.

    + unfold bf_synth.
      forward; omega.

    + unfold bf_synth, af_synth.
      eapply exec_equiv_r.
      apply vc_sexec_correct. apply H; omega.
      unfold computes_synth.
      setoid_rewrite param_union_bin at 4; [|assumption].
      apply bin_union_snd_third.

    + simpl; unfold sends_synth.
      eapply exec_equiv_r.
      apply vc_sexec_correct. apply H0; omega.
      apply bin_union_empty_l.

    + simpl.
      apply H1; omega.

    + simpl. unfold bf_synth, af_synth.
      replace (T + 1 - 1) with T by ring.
      setoid_rewrite param_union_bin at 2; [|assumption].
      apply equiv_incl.
      setoid_rewrite bin_union_assoc; reflexivity.
  Qed.

  (** Handy tactic applying the main correctness result. *)
  Tactic Notation "synthesize" "trace" :=
    eexists; eapply trace_synth_correct; simpl.

End Kern.


From hahn Require Import Hahn.
From PromisingLib Require Import Basic DenseOrder.
From Promising Require Import Memory View Time Cell TView.

Definition memory_close tview memory :=
  ⟪ CLOSED_CUR :
    Memory.closed_timemap (View.rlx (TView.cur tview)) memory ⟫ /\
  ⟪ CLOSED_ACQ :
    Memory.closed_timemap (View.rlx (TView.acq tview)) memory ⟫ /\
  ⟪ CLOSED_REL :
    forall loc,
      Memory.closed_timemap (View.rlx (TView.rel tview loc)) memory ⟫.

Lemma loc_ts_eq_dec_eq {A} {a b : A} l ts :
  (if loc_ts_eq_dec (l, ts) (l, ts) then a else b) = a.
Proof using. edestruct loc_ts_eq_dec; desf. Qed.

Lemma loc_ts_eq_dec_neq {A} {a b : A} {l ts l' ts'}
      (NEQ: l <> l' \/ ts <> ts'):
  (if loc_ts_eq_dec (l, ts) (l', ts') then a else b) = b.
Proof using. edestruct loc_ts_eq_dec; desf. Qed.

Lemma memory_add_le memory memory' loc from to val released
      (ADD : Memory.add memory loc from to val released memory'):
  Memory.le memory memory'.
Proof using.
  red. ins. erewrite Memory.add_o; eauto.
  destruct (loc_ts_eq_dec (loc0, to0) (loc, to)); [simpls; desf|done].
  exfalso. erewrite Memory.add_get0 in LHS; eauto.
  desf.
Qed.

Lemma memory_remove_le memory memory' loc from to val released
      (ADD : Memory.remove memory loc from to val released memory'):
  Memory.le memory' memory.
Proof using.
  red. ins. erewrite Memory.remove_o in LHS; eauto.
    by destruct (loc_ts_eq_dec (loc0, to0) (loc, to)) in LHS; [desf|].
Qed.

Set Implicit Arguments.
Remove Hints plus_n_O.

Lemma inhabited_init : Memory.inhabited Memory.init.
Proof using. red. ins. Qed.

Lemma inhabited_future memory memory'
      (INHAB : Memory.inhabited memory)
      (FUTURE : Memory.future memory memory') :
  Memory.inhabited memory'.
Proof using.
  destruct FUTURE; auto.
  apply clos_rt1n_rt in FUTURE.
  apply clos_rt_rtn1 in FUTURE.
  induction FUTURE; auto.
  { destruct H.
    eapply Memory.op_future0; eauto. }
  destruct H0.
  eapply Memory.op_future0; eauto.
Qed.

Lemma inhabited_future_init memory (FUTURE : Memory.future Memory.init memory) :
  Memory.inhabited memory.
Proof using. eapply inhabited_future; eauto. apply inhabited_init. Qed.

Definition ts_lt_or_bot memory :=
  forall loc to from msg (GET : Memory.get loc to memory = Some (from, msg)),
    (to = Time.bot /\ from = Time.bot) \/
    ⟪ FTLT : Time.lt from to ⟫.

Lemma memory_init_o loc to from msg
      (GET : Memory.get loc to Memory.init = Some (from, msg)) :
  to = Time.bot /\ from = Time.bot /\ msg = Message.elt.
Proof using.
  unfold Memory.init, Cell.init, Cell.Raw.init in *.
  unfold Memory.get, Cell.get in *; simpls.
  apply IdentMap.singleton_find_inv in GET.
  desf.
Qed.

Lemma ts_lt_or_bot_init : ts_lt_or_bot Memory.init.
Proof using. red. ins. apply memory_init_o in GET. left. desf. Qed.

Definition message_disjoint memory :=
  forall loc to1 from1 msg1 to2 from2 msg2
         (GET1 : Memory.get loc to1 memory = Some (from1, msg1))
         (GET2 : Memory.get loc to2 memory = Some (from2, msg2)),
    to1 = to2 \/ Interval.disjoint (from1, to1) (from2, to2).

Lemma message_disjoint_init : message_disjoint Memory.init.
Proof using.
  red. ins.
  apply memory_init_o in GET1.
  apply memory_init_o in GET2.
  desf. by left.
Qed.

Lemma ts_lt_or_bot_add loc from to val released memory memory_add
      (TLOB : ts_lt_or_bot memory)
      (ADD : Memory.add memory loc from to val released memory_add) :
  ts_lt_or_bot memory_add.
Proof using.
  red. ins.
  erewrite Memory.add_o in GET; eauto.
  desf; simpls; desf.
  { right. inv ADD. inv ADD0. }
  all: by eapply TLOB; eauto.
Qed.

Lemma message_disjoint_add loc from to val released memory memory_add
      (MD : message_disjoint memory)
      (ADD : Memory.add memory loc from to val released memory_add) :
  message_disjoint memory_add.
Proof using.
  red. ins.
  erewrite Memory.add_o in GET1; eauto.
  erewrite Memory.add_o in GET2; eauto.
  desf; simpls; desf.
  { by left. }
  { right. inv ADD. inv ADD0.
    symmetry.
    eapply DISJOINT; eauto. }
  { right. inv ADD. inv ADD0.
    eapply DISJOINT; eauto. }
  all: by eapply MD; eauto.
Qed.

Lemma ts_lt_or_bot_lower loc from to val released released' memory memory_lower
      (TLOB : ts_lt_or_bot memory)
      (LOWER : Memory.lower memory loc from to val released released' memory_lower) :
  ts_lt_or_bot memory_lower.
Proof using.
  red. ins.
  erewrite Memory.lower_o in GET; eauto.
  desf; simpls; desf.
  { right. inv LOWER. inv LOWER0. }
  all: by eapply TLOB; eauto.
Qed.

Lemma message_disjoint_lower loc from to val released released' memory memory_lower
      (MD : message_disjoint memory)
      (LOWER : Memory.lower memory loc from to val released released' memory_lower) :
  message_disjoint memory_lower.
Proof using.
  red. ins.
  erewrite Memory.lower_o in GET1; eauto.
  erewrite Memory.lower_o in GET2; eauto.
  desf; simpls; desf.
  { by left. }
  all: inv LOWER; inv LOWER0; eapply MD; eauto.
Qed.

Lemma ts_lt_or_bot_split loc from to to' val val' released released' memory memory_split
      (TLOB : ts_lt_or_bot memory)
      (SPLIT : Memory.split memory loc from to to' val val' released released' memory_split) :
  ts_lt_or_bot memory_split.
Proof using.
  red. ins.
  erewrite Memory.split_o in GET; eauto.
  desf; simpls; desf.
  1,2: by right; inv SPLIT; inv SPLIT0.
  all: eapply TLOB; eauto.
Qed.

Lemma ts_lt_or_bot_op loc from to val released kind memory memory'
      (TLOB : ts_lt_or_bot memory)
      (OP : Memory.op memory loc from to val released memory' kind) :
  ts_lt_or_bot memory'.
Proof using.
  destruct OP.
  { eapply ts_lt_or_bot_add; eauto. }
  { eapply ts_lt_or_bot_split; eauto. }
  eapply ts_lt_or_bot_lower; eauto.
Qed.

Lemma ts_lt_or_bot_future memory memory'
      (TLOB : ts_lt_or_bot memory)
      (FUTURE : Memory.future memory memory') :
  ts_lt_or_bot memory'.
Proof using.
  apply clos_rt1n_rt in FUTURE.
  apply clos_rt_rtn1 in FUTURE.
  induction FUTURE; auto.
  destruct H.
  eapply ts_lt_or_bot_op; eauto.
Qed.

Lemma ts_lt_or_bot_future_init memory
      (FUTURE : Memory.future Memory.init memory) :
  ts_lt_or_bot memory.
Proof using. eapply ts_lt_or_bot_future; eauto. apply ts_lt_or_bot_init. Qed.

Lemma message_disjoint_split loc from to to' val val' released released' memory memory_split
      (MD : message_disjoint memory)
      (SPLIT : Memory.split memory loc from to to' val val' released released' memory_split) :
  message_disjoint memory_split.
Proof using.
  assert (exists msg, Memory.get loc to' memory = Some (from, msg))
    as [msg GETI].
  { inv SPLIT. inv SPLIT0. eexists. apply GET2. }
  assert (Time.lt from to /\ Time.lt to to') as [LTF LTT].
  { inv SPLIT. inv SPLIT0. }
  assert (Interval.le (from, to) (from, to')) as ILE1.
  { constructor; simpls. reflexivity. apply Time.le_lteq. by left. }
  assert (Interval.le (to, to') (from, to')) as ILE2.
  { constructor; simpls. 2: reflexivity. apply Time.le_lteq. by left. }
  red. ins.
  erewrite Memory.split_o in GET1; eauto.
  erewrite Memory.split_o in GET2; eauto.
  desf; simpls; desf.
  all: try by left.
  all: try by (eapply MD in GET1; eapply GET1 in GET2; desf).
  all: right.
  { symmetry. apply Interval.disjoint_imm. }
  { symmetry.
    eapply Interval.le_disjoint; eauto.
    eapply MD in GET1. eapply GET1 in GETI.
    symmetry.
    desf. }
  { apply Interval.disjoint_imm. }
  { symmetry.
    eapply Interval.le_disjoint; eauto.
    eapply MD in GET1. eapply GET1 in GETI.
    symmetry.
    desf. }
  all: eapply Interval.le_disjoint; eauto.
  all: eapply MD in GET2; eapply GET2 in GETI.
  all: symmetry.
  all: desf.
Qed.

Lemma message_disjoint_op loc from to val released memory memory' kind
      (MD : message_disjoint memory)
      (OP : Memory.op memory loc from to val released memory' kind) :
  message_disjoint memory'.
Proof using.
  destruct OP.
  { eapply message_disjoint_add; eauto. }
  { eapply message_disjoint_split; eauto. }
  eapply message_disjoint_lower; eauto.
Qed.

Lemma message_disjoint_future memory memory'
      (TLOB : message_disjoint memory)
      (FUTURE : Memory.future memory memory') :
  message_disjoint memory'.
Proof using.
  apply clos_rt1n_rt in FUTURE.
  apply clos_rt_rtn1 in FUTURE.
  induction FUTURE; auto.
  destruct H.
  eapply message_disjoint_op; eauto.
Qed.

Lemma message_disjoint_future_init memory
      (FUTURE : Memory.future Memory.init memory) :
  message_disjoint memory.
Proof using. eapply message_disjoint_future; eauto. apply message_disjoint_init. Qed.

Lemma time_le_rect a b c d (AB : Time.le a b) (CD : Time.le c d) :
  Time.le (Time.join a c) (Time.join b d).
Proof using.
  unfold Time.join.
  desf.
  { apply Time.le_lteq. left.
    eapply TimeFacts.le_lt_lt; eauto. }
  etransitivity; eauto.
Qed.

Lemma timemap_le_rect a b c d (AB : TimeMap.le a b) (CD : TimeMap.le c d) :
  TimeMap.le (TimeMap.join a c) (TimeMap.join b d).
Proof using.
  unfold TimeMap.join. intros x.
  all: by apply time_le_rect.
Qed.

Lemma view_le_rect a b c d (AB : View.le a b) (CD : View.le c d) :
  View.le (View.join a c) (View.join b d).
Proof using.
  unfold View.join in *.
  destruct AB. destruct CD.
  constructor; simpls; intros x.
  all: by apply timemap_le_rect.
Qed.

Lemma memory_split_get_old memory memory_split
      loc from to ts val val' released released'
      (SP : Memory.split memory loc from to ts val val' released released' memory_split) :
  Memory.get loc ts memory = Some (from, Message.mk val' released').
Proof using. inv SP. inv SPLIT. Qed.

Lemma interval_le_not_disjoint la ra lb rb
      (LTA : Time.lt la ra)
      (LTB : Time.lt lb rb)
      (NEQ : ra <> rb)
      (ILE : Interval.le (la, ra) (lb, rb)) :
  ~ Interval.disjoint (la, ra) (lb, rb).
Proof using.
  inv ILE. simpls.
  intros HH. eapply HH; constructor; simpls; eauto.
  { reflexivity. }
  eapply TimeFacts.le_lt_lt; eauto.
Qed.

Lemma closed_view_le view memory memory'
      (LE : Memory.le memory memory')
      (CLOS : Memory.closed_view view memory) :
  Memory.closed_view view memory'.
Proof using.
  destruct CLOS.
  constructor; red; [clear RLX; rename PLN into RLX|]; ins.
  all: specialize (RLX loc); desc.
  all: apply LE in RLX; eauto.
Qed.

(*********************************************)
(* TODO: explanation. Maybe a separate file. *)
(*********************************************)
Definition message_view_wf memory :=
  forall loc to from val released
         (GET : Memory.get loc to memory =
                Some (from, Message.mk val released)),
    View.opt_wf released.

Lemma message_view_wf_add
      memory loc from to val released memory'
      (REL_WF : message_view_wf memory)
      (PROM : Memory.add memory loc from to val released memory') :
  message_view_wf memory'.
Proof using.
  red. ins.
  erewrite Memory.add_o in GET; eauto.
  desf.
  2: by eapply REL_WF; eauto.
  simpls; desf.
  inv PROM. inv ADD.
Qed.

Lemma message_view_wf_split
      memory loc from to to' val val' released released' memory'
      (REL_WF : message_view_wf memory)
      (PROM : Memory.split memory loc from to to' val val' released released' memory') :
  message_view_wf memory'.
Proof using.
  red. ins.
  erewrite Memory.split_o in GET; eauto.
  desf.
  3: by eapply REL_WF; eauto.
  all: simpls; desf.
  { inv PROM. inv SPLIT. }
  inv PROM. inv SPLIT.
  eapply REL_WF.
  apply GET2.
Qed.

Lemma message_view_wf_lower
      memory loc from to val released released' memory'
      (REL_WF : message_view_wf memory)
      (PROM : Memory.lower memory loc from to val released released' memory') :
  message_view_wf memory'.
Proof using.
  red. ins.
  erewrite Memory.lower_o in GET; eauto.
  desf.
  2: by eapply REL_WF; eauto.
  simpls; desf.
  inv PROM. inv LOWER.
Qed.

Lemma message_view_wf_op
      memory loc from to val released memory' kind
      (REL_WF : message_view_wf memory)
      (PROM : Memory.op memory loc from to val released memory' kind) :
  message_view_wf memory'.
Proof using.
  destruct PROM.
  { eapply message_view_wf_add; eauto. }
  { eapply message_view_wf_split; eauto. }
  eapply message_view_wf_lower; eauto.
Qed.

Lemma message_view_wf_promise
      promises memory loc from to val released promises' memory' kind
      (REL_WF : message_view_wf memory)
      (PROM : Memory.promise promises memory loc from to
                             val released promises' memory' kind) :
  message_view_wf memory'.
Proof using.
  destruct PROM.
  { eapply message_view_wf_add; eauto. }
  { eapply message_view_wf_split; eauto. }
  eapply message_view_wf_lower; eauto.
Qed.

Lemma message_view_wf_init : message_view_wf Memory.init.
Proof using.
  red. ins. apply memory_init_o in GET. desf.
  unfold Message.elt in *. desf.
  apply View.opt_wf_none.
Qed.

Lemma message_view_wf_future memory memory'
      (MVW    : message_view_wf memory)
      (FUTURE : Memory.future memory memory') :
  message_view_wf memory'.
Proof using.
  induction FUTURE; auto.
  apply IHFUTURE.
  destruct H.
  eapply message_view_wf_op; eauto.
Qed.

Lemma message_view_wf_future_init memory
      (FUTURE : Memory.future Memory.init memory) :
  message_view_wf memory.
Proof using.
  eapply message_view_wf_future; eauto.
  apply message_view_wf_init.
Qed.

Lemma memory_closed_timemap_le view memory memory'
      (MEM_LE : Memory.le memory memory')
      (MEM_CLOS : Memory.closed_timemap view memory) :
  Memory.closed_timemap view memory'.
Proof using.
  red; ins. specialize (MEM_CLOS loc). desf.
  apply MEM_LE in MEM_CLOS.
  eauto.
Qed.

Lemma memory_close_le tview memory memory'
      (MEM_LE : Memory.le memory memory')
      (MEM_CLOS : memory_close tview memory) :
  memory_close tview memory'.
Proof using.
  cdes MEM_CLOS.
  red; splits; ins.
  all: eapply memory_closed_timemap_le; eauto.
Qed.

(*********************************************)
(* TODO: explanation. Maybe a separate file. *)
(*********************************************)
Lemma opt_wf_unwrap (view : option View.t) (H: View.wf (View.unwrap view)) :
  View.opt_wf view.
Proof using. by destruct view; simpls; constructor. Qed.

Lemma view_join_bot_r (lhs : View.t): View.join lhs View.bot = lhs.
Proof using. rewrite View.join_comm. apply View.join_bot_l. Qed.

Lemma view_join_id l : View.join l l = l.
Proof using. rewrite View.le_join_l; reflexivity. Qed.

Lemma time_join_le_r lhs rhs (LE : Time.le lhs rhs): Time.join lhs rhs = rhs.
Proof using.
  unfold Time.join. desf.
  exfalso. eapply DenseOrder.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
Qed.

Lemma time_join_le_l lhs rhs (LE : Time.le rhs lhs): Time.join lhs rhs = lhs.
Proof using. unfold Time.join. desf. by apply TimeFacts.antisym. Qed.

Lemma time_join_bot_r lhs: Time.join lhs Time.bot = lhs.
Proof using. apply time_join_le_l. apply Time.bot_spec. Qed.

Lemma time_join_bot_l rhs: Time.join Time.bot rhs = rhs.
Proof using. apply time_join_le_r. apply Time.bot_spec. Qed.

Lemma time_lt_join_l lhs rlhs rrhs (LT : Time.lt lhs rlhs) :
  Time.lt lhs (Time.join rlhs rrhs).
Proof using. unfold Time.join. desf. eapply TimeFacts.lt_le_lt; eauto. Qed.

Lemma time_lt_join_r lhs rlhs rrhs (LT : Time.lt lhs rrhs) :
  Time.lt lhs (Time.join rlhs rrhs).
Proof using. unfold Time.join. desf. etransitivity; eauto. Qed.


(** * Properties about Context Free Grammars *)
Require Import Coq.Numbers.Natural.Peano.NPeano Coq.Lists.List.
Require Import Fiat.Common Fiat.Common.UIP.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.

Set Implicit Arguments.

Import ListNotations.
Local Open Scope list_scope.

Global Instance item_rect_Proper {Char T}
: Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq)
         (@item_rect Char (fun _ => T)).
Proof.
  lazy.
  intros ?? H ?? H' ? [?|?] ?; subst; eauto with nocore.
Qed.
Global Instance item_rect_Proper_forall {Char T}
: Proper (forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq))
         (@item_rect Char T).
Proof.
  lazy.
  intros ?? H ?? H' [?|?]; subst; eauto with nocore.
Qed.

Global Instance item_rect_Proper_forall_R {C A} {R : relation A}
  : Proper
      ((pointwise_relation _ R)
         ==> (pointwise_relation _ R)
         ==> forall_relation (fun _ : item C => R))
      (item_rect (fun _ : item C => A)).
Proof.
  lazy; intros ?????? [?|?]; trivial.
Qed.

#[global]
Hint Extern 1 (Proper _ (@item_rect _ _)) => exact item_rect_Proper : typeclass_instances.
#[global]
Hint Extern 0 (Proper _ (@item_rect _ _)) => exact item_rect_Proper_forall : typeclass_instances.
#[global]
Hint Extern 0 (Proper (pointwise_relation _ _ ==> pointwise_relation _ _ ==> forall_relation _) (item_rect _))
=> refine item_rect_Proper_forall_R : typeclass_instances.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char).

  Definition parse_of_item_respectful'
             (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
             {str1 str2} (H : str1 =s str2) {it it'} (Hit : item_code it it') (p : parse_of_item G str1 it)
  : parse_of_item G str2 it'
    := match p in (parse_of_item _ _ it), it' return item_code it it' -> parse_of_item G str2 it' with
         | ParseTerminal ch P pf0 pf1, Terminal P' => fun Hit => ParseTerminal G str2 ch P' (transitivity (symmetry (Hit _)) pf0) (transitivity (eq_sym (is_char_Proper H eq_refl)) pf1)
         | ParseTerminal _ _ _ _, NonTerminal _ => fun Hit => match Hit with end
         | ParseNonTerminal nt H' p', NonTerminal nt'
           => fun Hit
              => ParseNonTerminal
                   _
                   (match Hit in (_ = nt') return List.In nt' _ with
                      | eq_refl => H'
                    end)
                   (@parse_of_respectful
                      _ _ H (Lookup G nt) (Lookup G nt')
                      (match Hit in (_ = nt') return productions_code (G nt) (G nt') with
                         | eq_refl => reflexivity _
                       end)
                      p')
         | ParseNonTerminal _ _ _, Terminal _ => fun Hit => match Hit with end
       end Hit.

  Global Arguments parse_of_item_respectful' _ _ _ _ _ !_ _ !_ / .

  Section bodies.
    Context (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
            (parse_of_production_respectful : forall {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat), parse_of_production G str2 pat').

    Definition parse_of_respectful_step {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'.
    Proof.
      refine (match p in (parse_of _ _ pats), pats' return productions_code pats pats' -> parse_of G str2 pats' with
                | ParseHead pat pats p', pat'::pats' => fun Hpats' => ParseHead pats' (@parse_of_production_respectful _ _ H _ _ _ p')
                | ParseTail pat pats p', pat'::pats' => fun Hpats' => ParseTail pat' (@parse_of_respectful _ _ H _ _ _ p')
                | ParseHead _ _ _, nil => fun Hpats' => match _ : False with end
                | ParseTail _ _ _, nil => fun Hpats' => match _ : False with end
              end Hpats);
      try solve [ clear -Hpats'; abstract inversion Hpats'
                | clear -Hpats'; inversion Hpats'; subst; assumption ].
    Defined.

    Definition parse_of_production_respectful_step {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'.
    Proof.
      refine (match p in (parse_of_production _ _ pat), pat' return production_code pat pat' -> parse_of_production G str2 pat' with
                | ParseProductionNil pf, nil => fun Hpat' => ParseProductionNil G str2 (transitivity (eq_sym (length_Proper H)) pf)
                | ParseProductionCons n pat pats p0 p1, pat'::pats' => fun Hpat' => ParseProductionCons _ n (parse_of_item_respectful' (@parse_of_respectful) (take_Proper eq_refl H) _ p0) (@parse_of_production_respectful _ _ (drop_Proper eq_refl H) _ _ _ p1)
                | ParseProductionNil _, _::_ => fun Hpat' => match _ : False with end
                | ParseProductionCons _ _ _ _ _, nil => fun Hpat' => match _ : False with end
              end Hpat);
      try solve [ clear -Hpat'; abstract inversion Hpat'
                | clear -Hpat'; inversion Hpat'; subst; assumption ].
    Defined.

    Global Arguments parse_of_respectful_step _ _ _ _ _ _ !_ / .
    Global Arguments parse_of_production_respectful_step _ _ _ _ _ _ !_ / .
  End bodies.

  Fixpoint parse_of_respectful {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'
    := @parse_of_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpats p
  with parse_of_production_respectful {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'
    := @parse_of_production_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpat p.

  Definition parse_of_item_respectful : forall {str1 str2} H {it it'} Hit p, _
    := @parse_of_item_respectful' (@parse_of_respectful).

  Global Arguments parse_of_item_respectful _ _ _ _ !_ _ !_ / .

  Fixpoint parse_of_respectful_refl {str pf pats Hpats} (p : parse_of G str pats) : parse_of_respectful pf Hpats p = p
    := match p return forall Hpats, parse_of_respectful pf Hpats p = p with
         | ParseHead pat pats p' => fun Hpats => f_equal (ParseHead _) (parse_of_production_respectful_refl p')
         | ParseTail pat pats p' => fun Hpats => f_equal (@ParseTail _ _ _ _ _ _ _) (parse_of_respectful_refl p')
       end Hpats
  with parse_of_production_respectful_refl {str pf pat Hpat} (p : parse_of_production G str pat) : parse_of_production_respectful pf Hpat p = p
       := match p return forall Hpat, parse_of_production_respectful pf Hpat p = p with
            | ParseProductionNil pf => fun Hpat => f_equal (ParseProductionNil _ _) (dec_eq_uip (Nat.eq_dec _) _ _)
            | ParseProductionCons n pat pats p0 p1
              => fun Hpat => f_equal2 (@ParseProductionCons _ _ _ _ _ _ _ _)
                                      (parse_of_item_respectful_refl p0)
                                      (parse_of_production_respectful_refl p1)
          end Hpat
  with parse_of_item_respectful_refl {str pf it Hit} (p : parse_of_item G str it) : parse_of_item_respectful pf Hit p = p
       := match p return forall Hit, parse_of_item_respectful pf Hit p = p with
            | ParseTerminal ch P pf1 pf2 => fun Hit => f_equal2 (ParseTerminal _ _ _ _) (dec_eq_uip (Bool.bool_dec _) _ _) (dec_eq_uip (Bool.bool_dec _) _ _)
            | ParseNonTerminal nt H' p'
              => fun Hit'
                 => f_equal2 (ParseNonTerminal nt)
                             match dec_eq_uip (@Equality.string_eq_dec nt) eq_refl Hit' in (_ = Hit') return match Hit' in (_ = nt') return List.In nt' _ with eq_refl => H' end = H' with
                               | eq_refl => eq_refl
                             end
                             (@parse_of_respectful_refl _ _ _ _ p')
          end Hit.

  (*Global Instance parse_of_Proper : Proper (beq ==> eq ==> iff) (parse_of G).
  Proof.
    split; subst; apply parse_of_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_production_Proper : Proper (beq ==> eq ==> iff) (parse_of_production G).
  Proof.
    split; subst; apply parse_of_production_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_item_Proper : Proper (beq ==> eq ==> iff) (parse_of_item G).
  Proof.
    split; subst; apply parse_of_item_respectful; [ assumption | symmetry; assumption ].
  Qed.*)

  Definition ParseProductionSingleton str it (p : parse_of_item G str it) : parse_of_production G str [ it ].
  Proof.
    econstructor.
    { eapply parse_of_item_respectful; [ | reflexivity | eassumption ].
      rewrite take_long; reflexivity. }
    { constructor.
      rewrite drop_length; auto with arith. }
  Defined.

  Section definitions.
    Context (P : String -> String.string -> Type).

    Definition Forall_parse_of_item'
               (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type)
               {str it} (p : parse_of_item G str it)
      := match p return Type with
           | ParseTerminal ch P pf1 pf2 => unit
           | ParseNonTerminal nt H' p'
             => (P str nt * Forall_parse_of p')%type
         end.

    Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats)
      := match p with
           | ParseHead pat pats p'
             => Forall_parse_of_production p'
           | ParseTail _ _ p'
             => Forall_parse_of p'
         end
    with Forall_parse_of_production {str pat} (p : parse_of_production G str pat)
         := match p return Type with
              | ParseProductionNil pf => unit
              | ParseProductionCons pat strs pats p' p''
                => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type
            end.

    Definition Forall_parse_of_item {str it} (p : parse_of_item G str it)
      := @Forall_parse_of_item' (@Forall_parse_of) str it p.
  End definitions.

  (*Section expand.
    Context {P P' : String -> String.string -> Type}.

    Definition expand_forall_parse_of_item'
               {str str' str''}
               {Forall_parse_of : forall P {str pats} (p : parse_of G str pats), Type}
               (expand : forall {pats pats' pats''} (Hpats : productions_code pats pats') (Hpats' : productions_code pats' pats'') (H : str =s str') (H' : str =s str'') {p}, @Forall_parse_of P str' pats' (parse_of_respectful H Hpats p) -> @Forall_parse_of P' str'' pats'' (parse_of_respectful H' Hpats' p))
               (f : forall n, P str' n -> P' str'' n)
               {it p} (H : str =s str') (H' : str =s str'')
    : @Forall_parse_of_item' P (@Forall_parse_of P) str' it (parse_of_item_respectful H p)
      -> @Forall_parse_of_item' P' (@Forall_parse_of P') str'' it (parse_of_item_respectful H' p).
    Proof.
      destruct p; simpl.
      { exact (fun x => x). }
      { intro ab.
        exact (f _ (fst ab), expand _ H H' _ (snd ab)). }
    Defined.

    Global Arguments expand_forall_parse_of_item' : simpl never.

    Fixpoint expand_forall_parse_of
             str str' str''
             (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
             pats (H : str =s str') (H' : str =s str'') (p : parse_of G str pats)
             {struct p}
    : Forall_parse_of P (parse_of_respectful H p) -> Forall_parse_of P' (parse_of_respectful H' p)
    with expand_forall_parse_of_production
           str str' str''
           (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
           pat (H : str =s str') (H' : str =s str'') (p : parse_of_production G str pat)
           {struct p}
         : Forall_parse_of_production P (parse_of_production_respectful H p) -> Forall_parse_of_production P' (parse_of_production_respectful H' p).
    Proof.
      { destruct p.
        simpl.
        { apply expand_forall_parse_of_production; exact f. }
        { refine (expand_forall_parse_of _ _ _ _ _ _ _ p); exact f. } }
      { destruct p as [ | n pat pats pit pits ]; simpl.
        { exact (fun x => x). }
        { pose proof (fun f' f'' => @expand_forall_parse_of_item' _ (take n str') (take n str'') (@Forall_parse_of) (@expand_forall_parse_of _ _ _ f') f'' _ pit) as expand_forall_parse_of_item.
          specialize (fun f' H H' => expand_forall_parse_of_production _ (drop n str') (drop n str'') f' _ H H' pits).
          clear expand_forall_parse_of.
          change (Forall_parse_of_item P (parse_of_item_respectful (take_Proper eq_refl H) pit) * Forall_parse_of_production P (parse_of_production_respectful (drop_Proper eq_refl H) pits)
                  -> Forall_parse_of_item P' (parse_of_item_respectful (take_Proper eq_refl H') pit) * Forall_parse_of_production P' (parse_of_production_respectful (drop_Proper eq_refl H') pits))%type.
          intro xy.
          split.
          { eapply expand_forall_parse_of_item; [ .. | exact (fst xy) ].
            { intros ? ? H''; apply f.
              rewrite str_le_take in H''; assumption. }
            { intro; apply f.
              { clear -H HSLP.
                rewrite str_le_take, H; reflexivity. }
              { rewrite <- H, <- H'; reflexivity. } } }
          { eapply expand_forall_parse_of_production; [ .. | exact (snd xy) ].
            intros ? ? H''; apply f.
            etransitivity; [ eassumption | apply str_le_drop ]. } } }
    Defined.

    Global Arguments expand_forall_parse_of : simpl never.
    Global Arguments expand_forall_parse_of_production : simpl never.

    Definition expand_forall_parse_of_item {str str' str''} f {it} {p : parse_of_item G str it} (H : str =s str') (H' : str =s str'')
      := @expand_forall_parse_of_item' str str' str'' _ (@expand_forall_parse_of str str' str'' f) (f _ _ ((_ : Proper (beq ==> beq ==> impl) str_le) _ _ H _ _ (reflexivity _) (reflexivity _)) (transitivity (symmetry H) H')) it p.

    Global Arguments expand_forall_parse_of_item : simpl never.
  End expand.*)
End cfg.

Ltac simpl_parse_of_respectful :=
  repeat match goal with
           | [ |- context[@parse_of_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_respectful_step
           | [ |- context[@parse_of_production_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_production_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_production_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_production_respectful_step
           | _ => progress simpl @parse_of_item_respectful
           | _ => progress simpl @parse_of_item_respectful'
         end.

Section parse_of_proper.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char} {str : String}.

  Local Ltac t_parse_of_impl lem :=
    repeat intro;
    match goal with
      | [ H : Proper _ _, H' : _ -> _ |- _ ] => eapply H; [ eassumption.. | apply H'; try clear H H' ]
    end;
    eapply lem; [ .. | eassumption ];
    try first [ assumption
              | reflexivity
              | symmetry; assumption ].

  Section fun0.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> impl) P}.

    Global Instance parse_of_item_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0.
  Section fun0_flip.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> flip impl) P}.

    Global Instance parse_of_item_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0_flip.

  Section fun1.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> impl) P}.

    Global Instance parse_of_item_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1.
  Section fun1_flip.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> flip impl) P}.

    Global Instance parse_of_item_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1_flip.
End parse_of_proper.


(** * Functoriality of composition of natural transformations *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import FunctorCategory.Core Functor.Composition.Core NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Section functorial_composition.
  Context `{Funext}.
  Variables C D E : PreCategory.

  Local Open Scope natural_transformation_scope.

  (** ** whiskering on the left is a functor *)
  Definition whiskerL_functor (F : (D -> E)%category)
  : ((C -> D) -> (C -> E))%category
    := Build_Functor
         (C -> D) (C -> E)
         (fun G => F o G)%functor
         (fun _ _ T => F oL T)
         (fun _ _ _ _ _ => composition_of_whisker_l _ _ _)
         (fun _ => whisker_l_right_identity _ _).

  (** ** whiskering on the right is a functor *)
  Definition whiskerR_functor (G : (C -> D)%category)
  : ((D -> E) -> (C -> E))%category
    := Build_Functor
         (D -> E) (C -> E)
         (fun F => F o G)%functor
         (fun _ _ T => T oR G)
         (fun _ _ _ _ _ => composition_of_whisker_r _ _ _)
         (fun _ => whisker_r_left_identity _ _).
End functorial_composition.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep pred prelude idynamic ordtype pcm finmap unionmap heap coding.
Require Import Hgraphs Logs Wavefronts Apex Partitions.
Require Import WavefrontDimension MutatorCount.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section PolicyDimension.

Variable e0 : LogEntry.
(* Initial graph an heap *)
Variables (h0 : heap) (g0: graph h0).

(* A collector log p will all unique entires *)
Variables  (p : log).

(* Final heap and graph for the log p with the corresponding certificate epf *)
Variables (h : heap) (g: graph h).
Variable (epf : executeLog g0 p = Some (ExRes g)).

Variables (wp polp prp : par2).

(* Wavefront partition *)
Notation FL := (pr1 wp).
Notation OL := (pr2 wp).

(* Policy partition *)
Notation SR := (pr1 polp).
Notation LR := (pr2 polp).

(* Protection partition *)
Notation IS := (pr1 prp).
Notation DS := (pr2 prp).

Notation w_gt := (W_gt g wp).
Notation w_lt := (W_lt g wp).

(* Consider expose_r from Section 5.2.1 of the paper, taking IS =
   True, so it's not mentioned so far. In this shape, expose_r is exactly
   expose_apex, instantiated with W_gt and restricted to the SR part of
   the partition. The LR-part will be processed further. *)

Definition expose_r : seq ptr :=
  [seq let pi := pe.2      in
       let o  := source pi in
       let f  := fld pi    in
       o#f@g | pe <- prefixes e0 p &
               let: (pre, pi)    := pe          in
               let k             := (kind pi)   in
               let o             := (source pi) in
               let f             := (fld pi)    in
               let n             := (new pi)    in
               [&& (kindMA k), ((o, f) \in w_gt pre),
                   SR o & IS n]].

Definition expose_c : seq ptr :=
  [seq new pi | pi <- p &
                let n := new pi    in
                let o := source pi in
                let f := fld pi    in
                [&& (M_plus e0 p o f n > M_minus e0 p o f n), LR o & IS n]].

(* Lemmas: similar to the one, proved for expose_apex *)

Lemma expose_r_fires et l1 l2 :
  let o := source et in
  let f := fld    et in
  let x := o # f @ g in
  IS x -> SR o ->
  p = l1 ++ et :: l2  ->
  kind et == T        ->
  x \in alreadyMarked p ++ expose_r.
Proof.
move=>/=H1 H2 E K.
rewrite mem_cat; apply/orP.
case: (traced_objects epf E K); [left | right].
- by apply/alreadyMarkedP; exists et, l1, l2.
case/hasP: b=>ema D/andP[K2]/andP[/eqP E2]/andP[/eqP E3]/eqP E4; rewrite E2 E3.
case: (prefix_wavefront e0 D E K)=>pre[G1]/(w_gt_approx epf wp) G2.
apply/mapP; exists (pre, ema)=>//=.
rewrite mem_filter K2 -E2 -E3 H2 G1 -!(andbC true)/=.
apply/andP; split; last by rewrite -E4 H1.
by apply: G2; case/prefV: G1=>[i][Y1] Y2 Y3; exists i.
Qed.

Lemma expose_c_fires et l1 l2 :
  let o := source et in
  let f := fld    et in
  let x := o # f @ g in
  IS x -> LR o ->
  p = l1 ++ et :: l2  ->
  kind et == T        ->
  x \in alreadyMarked p ++ expose_c.
Proof.
move=>/=H1 H2 E K.
rewrite mem_cat; apply/orP.
case: (traced_objects' epf E K)=>B.
- by left; apply/alreadyMarkedP; exists et, l1, l2.
case: B=> ema[l3][l4]/andP[M]/andP[/eqP E2]/andP[/eqP E3]N.
case X: (has (matchingTFull ema) p).
- case/hasP: X=>e /in_split[l5][l6]E'/andP[K'/andP[E3']]/andP[E2']E4'.
  by left; apply/alreadyMarkedP; exists e, l5, l6; move/eqP: E4'=>->.
move/negbT: X=>X; subst l2.
right; rewrite /expose_c.
case/mapP: (mut_count_fires e0 epf E K M E2 X N)=>e H3[Z1 Z2 Z3].
case/andP: M=>_/andP[/eqP Y1]/eqP Y2.
apply/mapP; exists e=>//; last by rewrite -Z3.
rewrite !mem_filter -!Z1 -!Z2 in H3 *.
rewrite Y1 in H2; rewrite H2/=.
by case/andP: H3=>->->/=; rewrite andbC -Z3 -E2.
Qed.

Lemma expose_rc_fires et l1 l2 :
  let o := source et in
  let f := fld    et in
  let x := o # f @ g in
  IS x -> p = l1 ++ et :: l2  -> kind et == T ->
  x \in alreadyMarked p ++ expose_r ++ expose_c.
Proof.
move=>o f x H1 E K.
case H2: (SR o).
- move: (expose_r_fires H1 H2 E K); rewrite -/x=>G.
  by rewrite catA mem_cat G.
move: (pr_coh polp o); rewrite H2/==>{H2}H2.
move: (expose_c_fires H1 H2 E K); rewrite -/x=>G.
rewrite !mem_cat in G *.
by case/orP: G=>->//; rewrite -!(orbC true).
Qed.

End PolicyDimension.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Elab.ElabCompilers Tools.Matches.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVSTLC SimpleVCPS SimpleVFix SimpleVFixCPS SimpleVCC SimpleUnit.
Import Core.Notations.
(*TODO: repackage this in compilers*)
Import CompilerDefs.Notations.

Require Coq.derive.Derive.

Definition fix_cc_lang_def : lang :=
  {[l/subst
  [:| "G" : #"env",
      "B" : #"ty",
      "vf" : #"val" "G" (#"neg" (#"prod" (#"neg" "B") "B"))
      -----------------------------------------------
      #"fix" "vf" : #"val" "G" (#"neg" "B")
   ];
  [:= "G" : #"env",
      "B" : #"ty",
      "v" : #"val" "G" (#"neg" (#"prod" (#"neg" "B") "B")),
      "v'" : #"val" "G" "B"
      ----------------------------------------------- ("fix_beta")
      #"jmp" (#"fix" "v") "v'"
      = #"jmp" "v" (#"pair" (#"fix" "v") "v'")
      : #"blk" "G"
  ]]}.

Derive fix_cc_lang
       SuchThat (elab_lang_ext (cc_lang++prod_cc ++ cps_prod_lang ++ block_subst ++value_subst)
                               fix_cc_lang_def
                               fix_cc_lang)
       As fix_cc_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve fix_cc_wf : elab_pfs.

Definition fix_cc_def : compiler :=
  match # from (fix_cps_lang) with
  | {{e #"fix" "G" "A" "e"}} =>
    {{e #"fix" (#"closure" (#"prod" (#"neg" "A") "A")
                 (#"blk_subst" (#"snoc" #"forget"
                                 (#"pair"
                                   (#"pair" (#".1" #"hd")
                                     (#".1" (#".2" #"hd")))
                                   (#".2" (#".2" #"hd"))))
                                 "e") #"hd")}}
  end.

(*
Lemma term_rw_lhs_nth {V} `{Eqb V} (l : Rule.lang V) c t t'' s1 e e1 e2 s1_pre s1_post name
  : wf_lang l ->
    s1 = s1_pre ++ e1::s1_post ->
    eq_term l c t'' e1 e2 ->
    eq_term l c t (con name (s1_pre ++ e2::s1_post)) e ->
    eq_term l c t (con name s1) e.
Proof.
  intros; subst.
  eapply eq_term_trans; eauto.
  (*TODO: conv-stable inversion*)
Admitted.
 *)

Derive fix_cc
       SuchThat (elab_preserving_compiler (cc++prod_cc_compile++subst_cc)
                                          (fix_cc_lang
                                             ++ cc_lang
                                             ++ forget_eq_wkn
                                             ++ unit_eta
                                             ++ unit_lang
                                             ++ prod_cc
                                             ++ cps_prod_lang
                                             ++ block_subst
                                             ++value_subst)
                                          fix_cc_def
                                          fix_cc
                                          fix_cps_lang)
       As fix_cc_preserving.
Proof.
  auto_elab_compiler.
  cleanup_elab_after
    (reduce;
     term_cong; try term_refl;
     unfold Model.eq_term;
     eapply eq_term_trans;
     [eapply eq_term_sym;
      eredex_steps_with cc_lang "clo_eta"|];
     by_reduction).
Qed.
#[export] Hint Resolve fix_cc_preserving : elab_pfs.


From Coq Require Import
     List
     ssreflect
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Environment
     Eval
     Functor
     ProgramAlgebra
     SubFunctor
     Sum1
     Types
     UniversalProperty
.

Local Open Scope SubFunctor.

Inductive Closure
          L
          `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
          E
  : Set :=
| MkClosure (closure : WellFormedValue (L nat)) (environment : Environment E)
.
Arguments MkClosure {L F FL E}.

Global Instance Functor__Closure
       {L} `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
  : Functor (Closure L).
Proof.
  refine {| fmap := fun A B f '(MkClosure c e) => MkClosure c (map f e) |}.
  - move => ? [] c e.
    rewrite map_id //.
  - move => ????? [] c e.
    rewrite map_map //.
Defined.

Definition closure
           {L V} `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
           `{(L V) supports (Closure L)}
           c e
  : WellFormedValue (L V)
  := injectUP' (MkClosure c e).

Definition closureF
           {L V} `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
           `{(L V) supports (Closure L)}
           c e
  : Fix (L V)
  := proj1_sig (closure c e).

Global Instance FoldUP'__closure
       {L V} `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
       `{(L V) supports (Closure L)}
       c e
  : FoldUP' (closureF c e)
  := proj2_sig (closure c e).

Definition isClosure
           {L V} `{F : forall V, Functor (L V)} `{FL : forall V, Functor (L V)}
           `{(L V) supports (Closure L)}
  : Fix (L V) -> option _
  := fun v =>
       match projectUP' (F := Closure L) v with
       | Some (MkClosure f e) => Some (f, e)
       | None                 => None
       end.