Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Require Export proposition__29.
Definition proposition__29B : forall A D G H, (euclidean__defs.Par A G H D) -> ((euclidean__axioms.TS A G H D) -> (euclidean__defs.CongA A G H G H D)).
Proof.
intro A.
intro D.
intro G.
intro H.
intro H0.
intro H1.
assert (* Cut *) (exists a d g h m, (euclidean__axioms.neq A G) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.Col A G a) /\ ((euclidean__axioms.Col A G g) /\ ((euclidean__axioms.neq a g) /\ ((euclidean__axioms.Col H D h) /\ ((euclidean__axioms.Col H D d) /\ ((euclidean__axioms.neq h d) /\ ((~(euclidean__defs.Meet A G H D)) /\ ((euclidean__axioms.BetS a m d) /\ (euclidean__axioms.BetS h m g))))))))))) as H2.
- assert (exists U V u v X, (euclidean__axioms.neq A G) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.Col A G U) /\ ((euclidean__axioms.Col A G V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col H D u) /\ ((euclidean__axioms.Col H D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A G H D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H2 by exact H0.
assert (exists U V u v X, (euclidean__axioms.neq A G) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.Col A G U) /\ ((euclidean__axioms.Col A G V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col H D u) /\ ((euclidean__axioms.Col H D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A G H D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H2.
destruct __TmpHyp as [x H3].
destruct H3 as [x0 H4].
destruct H4 as [x1 H5].
destruct H5 as [x2 H6].
destruct H6 as [x3 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exists x.
exists x2.
exists x0.
exists x1.
exists x3.
split.
-- exact H8.
-- split.
--- exact H10.
--- split.
---- exact H12.
---- split.
----- exact H14.
----- split.
------ exact H16.
------ split.
------- exact H18.
------- split.
-------- exact H20.
-------- split.
--------- exact H22.
--------- split.
---------- exact H24.
---------- split.
----------- exact H26.
----------- exact H27.
- destruct H2 as [a H3].
destruct H3 as [d H4].
destruct H4 as [g H5].
destruct H5 as [h H6].
destruct H6 as [m H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
assert (* Cut *) (euclidean__axioms.neq D H) as H28.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric H D H10).
-- assert (* Cut *) (~(H = G)) as H29.
--- intro H29.
assert (* Cut *) (H = H) as H30.
---- apply (@logic.eq__refl Point H).
---- assert (* Cut *) (euclidean__axioms.Col H D H) as H31.
----- right.
left.
exact H30.
----- assert (* Cut *) (G = G) as H32.
------ apply (@eq__ind__r euclidean__axioms.Point G (fun H32 => (euclidean__defs.Par A G H32 D) -> ((euclidean__axioms.TS A G H32 D) -> ((euclidean__axioms.neq H32 D) -> ((euclidean__axioms.Col H32 D h) -> ((euclidean__axioms.Col H32 D d) -> ((~(euclidean__defs.Meet A G H32 D)) -> ((euclidean__axioms.neq D H32) -> ((H32 = H32) -> ((euclidean__axioms.Col H32 D H32) -> (G = G))))))))))) with (x := H).
-------intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
assert (G = G) as H41 by exact H39.
exact H41.

------- exact H29.
------- exact H0.
------- exact H1.
------- exact H10.
------- exact H18.
------- exact H20.
------- exact H24.
------- exact H28.
------- exact H30.
------- exact H31.
------ assert (* Cut *) (euclidean__axioms.Col A G G) as H33.
------- right.
right.
left.
exact H32.
------- assert (* Cut *) (euclidean__axioms.Col A G H) as H34.
-------- apply (@eq__ind euclidean__axioms.Point H (fun G0 => (euclidean__defs.Par A G0 H D) -> ((euclidean__axioms.TS A G0 H D) -> ((euclidean__axioms.neq A G0) -> ((euclidean__axioms.Col A G0 a) -> ((euclidean__axioms.Col A G0 g) -> ((~(euclidean__defs.Meet A G0 H D)) -> ((G0 = G0) -> ((euclidean__axioms.Col A G0 G0) -> (euclidean__axioms.Col A G0 H)))))))))) with (y := G).
---------intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
assert (H = H) as H42 by exact H40.
exact H41.

--------- exact H29.
--------- exact H0.
--------- exact H1.
--------- exact H8.
--------- exact H12.
--------- exact H14.
--------- exact H24.
--------- exact H32.
--------- exact H33.
-------- assert (* Cut *) (euclidean__defs.Meet A G H D) as H35.
--------- exists H.
split.
---------- exact H8.
---------- split.
----------- exact H10.
----------- split.
------------ exact H34.
------------ exact H31.
--------- apply (@H24 H35).
--- assert (* Cut *) (exists B, (euclidean__axioms.BetS A G B) /\ (euclidean__axioms.Cong G B A G)) as H30.
---- apply (@lemma__extension.lemma__extension A G A G H8 H8).
---- destruct H30 as [B H31].
destruct H31 as [H32 H33].
assert (* Cut *) (exists C, (euclidean__axioms.BetS D H C) /\ (euclidean__axioms.Cong H C D H)) as H34.
----- apply (@lemma__extension.lemma__extension D H D H H28 H28).
----- destruct H34 as [C H35].
destruct H35 as [H36 H37].
assert (* Cut *) (exists E, (euclidean__axioms.BetS H G E) /\ (euclidean__axioms.Cong G E H G)) as H38.
------ apply (@lemma__extension.lemma__extension H G H G H29 H29).
------ destruct H38 as [E H39].
destruct H39 as [H40 H41].
assert (* Cut *) (euclidean__axioms.neq A B) as H42.
------- assert (* Cut *) ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq A G) /\ (euclidean__axioms.neq A B))) as H42.
-------- apply (@lemma__betweennotequal.lemma__betweennotequal A G B H32).
-------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
exact H46.
------- assert (* Cut *) (euclidean__axioms.neq B A) as H43.
-------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H42).
-------- assert (* Cut *) (euclidean__axioms.neq D C) as H44.
--------- assert (* Cut *) ((euclidean__axioms.neq H C) /\ ((euclidean__axioms.neq D H) /\ (euclidean__axioms.neq D C))) as H44.
---------- apply (@lemma__betweennotequal.lemma__betweennotequal D H C H36).
---------- destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
exact H48.
--------- assert (* Cut *) (euclidean__axioms.neq C D) as H45.
---------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric D C H44).
---------- assert (* Cut *) (euclidean__axioms.Col A G B) as H46.
----------- right.
right.
right.
right.
left.
exact H32.
----------- assert (* Cut *) (euclidean__axioms.Col G A B) as H47.
------------ assert (* Cut *) ((euclidean__axioms.Col G A B) /\ ((euclidean__axioms.Col G B A) /\ ((euclidean__axioms.Col B A G) /\ ((euclidean__axioms.Col A B G) /\ (euclidean__axioms.Col B G A))))) as H47.
------------- apply (@lemma__collinearorder.lemma__collinearorder A G B H46).
------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
exact H48.
------------ assert (* Cut *) (euclidean__axioms.Col G A a) as H48.
------------- assert (* Cut *) ((euclidean__axioms.Col G A a) /\ ((euclidean__axioms.Col G a A) /\ ((euclidean__axioms.Col a A G) /\ ((euclidean__axioms.Col A a G) /\ (euclidean__axioms.Col a G A))))) as H48.
-------------- apply (@lemma__collinearorder.lemma__collinearorder A G a H12).
-------------- destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H49.
------------- assert (* Cut *) (euclidean__axioms.neq G A) as H49.
-------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A G H8).
-------------- assert (* Cut *) (euclidean__axioms.Col A B a) as H50.
--------------- apply (@euclidean__tactics.not__nCol__Col A B a).
----------------intro H50.
apply (@euclidean__tactics.Col__nCol__False A B a H50).
-----------------apply (@lemma__collinear4.lemma__collinear4 G A B a H47 H48 H49).

--------------- assert (* Cut *) (euclidean__axioms.Col G A g) as H51.
---------------- assert (* Cut *) ((euclidean__axioms.Col G A g) /\ ((euclidean__axioms.Col G g A) /\ ((euclidean__axioms.Col g A G) /\ ((euclidean__axioms.Col A g G) /\ (euclidean__axioms.Col g G A))))) as H51.
----------------- apply (@lemma__collinearorder.lemma__collinearorder A G g H14).
----------------- destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H52.
---------------- assert (* Cut *) (euclidean__axioms.Col A B g) as H52.
----------------- apply (@euclidean__tactics.not__nCol__Col A B g).
------------------intro H52.
apply (@euclidean__tactics.Col__nCol__False A B g H52).
-------------------apply (@lemma__collinear4.lemma__collinear4 G A B g H47 H51 H49).

----------------- assert (* Cut *) (euclidean__axioms.Col D H C) as H53.
------------------ right.
right.
right.
right.
left.
exact H36.
------------------ assert (* Cut *) (euclidean__axioms.Col H D C) as H54.
------------------- assert (* Cut *) ((euclidean__axioms.Col H D C) /\ ((euclidean__axioms.Col H C D) /\ ((euclidean__axioms.Col C D H) /\ ((euclidean__axioms.Col D C H) /\ (euclidean__axioms.Col C H D))))) as H54.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder D H C H53).
-------------------- destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
exact H55.
------------------- assert (* Cut *) (euclidean__axioms.Col D C h) as H55.
-------------------- apply (@euclidean__tactics.not__nCol__Col D C h).
---------------------intro H55.
apply (@euclidean__tactics.Col__nCol__False D C h H55).
----------------------apply (@lemma__collinear4.lemma__collinear4 H D C h H54 H18 H10).

-------------------- assert (* Cut *) (euclidean__axioms.Col C D h) as H56.
--------------------- assert (* Cut *) ((euclidean__axioms.Col C D h) /\ ((euclidean__axioms.Col C h D) /\ ((euclidean__axioms.Col h D C) /\ ((euclidean__axioms.Col D h C) /\ (euclidean__axioms.Col h C D))))) as H56.
---------------------- apply (@lemma__collinearorder.lemma__collinearorder D C h H55).
---------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H57.
--------------------- assert (* Cut *) (euclidean__axioms.Col D d C) as H57.
---------------------- apply (@euclidean__tactics.not__nCol__Col D d C).
-----------------------intro H57.
apply (@euclidean__tactics.Col__nCol__False D d C H57).
------------------------apply (@lemma__collinear4.lemma__collinear4 H D d C H20 H54 H10).

---------------------- assert (* Cut *) (euclidean__axioms.Col C D d) as H58.
----------------------- assert (* Cut *) ((euclidean__axioms.Col d D C) /\ ((euclidean__axioms.Col d C D) /\ ((euclidean__axioms.Col C D d) /\ ((euclidean__axioms.Col D C d) /\ (euclidean__axioms.Col C d D))))) as H58.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder D d C H57).
------------------------ destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
exact H63.
----------------------- assert (* Cut *) (~(euclidean__defs.Meet A B C D)) as H59.
------------------------ intro H59.
assert (exists M, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B M) /\ (euclidean__axioms.Col C D M)))) as H60 by exact H59.
destruct H60 as [M H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
assert (* Cut *) (euclidean__axioms.Col B A G) as H68.
------------------------- assert (* Cut *) ((euclidean__axioms.Col A G B) /\ ((euclidean__axioms.Col A B G) /\ ((euclidean__axioms.Col B G A) /\ ((euclidean__axioms.Col G B A) /\ (euclidean__axioms.Col B A G))))) as H68.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder G A B H47).
-------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
exact H76.
------------------------- assert (* Cut *) (euclidean__axioms.Col B A M) as H69.
-------------------------- assert (* Cut *) ((euclidean__axioms.Col B A M) /\ ((euclidean__axioms.Col B M A) /\ ((euclidean__axioms.Col M A B) /\ ((euclidean__axioms.Col A M B) /\ (euclidean__axioms.Col M B A))))) as H69.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B M H66).
--------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
exact H70.
-------------------------- assert (* Cut *) (euclidean__axioms.Col A G M) as H70.
--------------------------- apply (@euclidean__tactics.not__nCol__Col A G M).
----------------------------intro H70.
apply (@euclidean__tactics.Col__nCol__False A G M H70).
-----------------------------apply (@lemma__collinear4.lemma__collinear4 B A G M H68 H69 H43).

--------------------------- assert (* Cut *) (euclidean__axioms.Col C D H) as H71.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col D H C) /\ ((euclidean__axioms.Col D C H) /\ ((euclidean__axioms.Col C H D) /\ ((euclidean__axioms.Col H C D) /\ (euclidean__axioms.Col C D H))))) as H71.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder H D C H54).
----------------------------- destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
exact H79.
---------------------------- assert (* Cut *) (euclidean__axioms.Col D H M) as H72.
----------------------------- apply (@euclidean__tactics.not__nCol__Col D H M).
------------------------------intro H72.
apply (@euclidean__tactics.Col__nCol__False D H M H72).
-------------------------------apply (@lemma__collinear4.lemma__collinear4 C D H M H71 H67 H64).

----------------------------- assert (* Cut *) (euclidean__axioms.Col H D M) as H73.
------------------------------ assert (* Cut *) ((euclidean__axioms.Col H D M) /\ ((euclidean__axioms.Col H M D) /\ ((euclidean__axioms.Col M D H) /\ ((euclidean__axioms.Col D M H) /\ (euclidean__axioms.Col M H D))))) as H73.
------------------------------- apply (@lemma__collinearorder.lemma__collinearorder D H M H72).
------------------------------- destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
exact H74.
------------------------------ assert (* Cut *) (euclidean__defs.Meet A G H D) as H74.
------------------------------- exists M.
split.
-------------------------------- exact H8.
-------------------------------- split.
--------------------------------- exact H10.
--------------------------------- split.
---------------------------------- exact H70.
---------------------------------- exact H73.
------------------------------- apply (@H24 H74).
------------------------ assert (* Cut *) (euclidean__defs.Par A B C D) as H60.
------------------------- exists a.
exists g.
exists h.
exists d.
exists m.
split.
-------------------------- exact H42.
-------------------------- split.
--------------------------- exact H45.
--------------------------- split.
---------------------------- exact H50.
---------------------------- split.
----------------------------- exact H52.
----------------------------- split.
------------------------------ exact H16.
------------------------------ split.
------------------------------- exact H56.
------------------------------- split.
-------------------------------- exact H58.
-------------------------------- split.
--------------------------------- exact H22.
--------------------------------- split.
---------------------------------- exact H59.
---------------------------------- split.
----------------------------------- exact H26.
----------------------------------- exact H27.
------------------------- assert (* Cut *) (euclidean__axioms.BetS C H D) as H61.
-------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry D H C H36).
-------------------------- assert (* Cut *) (euclidean__axioms.BetS E G H) as H62.
--------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry H G E H40).
--------------------------- assert (* Cut *) ((euclidean__defs.CongA A G H G H D) /\ ((euclidean__defs.CongA E G B G H D) /\ (euclidean__defs.RT B G H G H D))) as H63.
---------------------------- apply (@proposition__29.proposition__29 A B C D E G H H60 H32 H61 H62 H1).
---------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA A G H G H D)).
-----------------------------intro H64.
destruct H63 as [H65 H66].
destruct H66 as [H67 H68].
assert (* Cut *) (False) as H69.
------------------------------ apply (@H64 H65).
------------------------------ contradiction H69.

Qed.


Set Implicit Arguments.
Unset Strict Implicit.

Axiom vector : Type -> nat -> Type.

Record KleeneStore i j a := kleeneStore
 { dim : nat
 ; peek : vector j dim -> a
 ; pos : vector i dim
 }.

Definition KSmap i j a b (f : a -> b) (s : KleeneStore i j a) : KleeneStore i j b :=
  kleeneStore (fun v => f (peek v)) (pos s).

Record KleeneCoalg (i o : Type -> Type) := kleeneCoalg
  { coalg :> forall a b, (o a) -> KleeneStore (i a) (i b) (o b) }.

Axiom free_b_dim : forall i o (k : KleeneCoalg i o) a b b' (x : o a), dim (coalg k b x) = dim (coalg k b' x).
Axiom t : Type -> Type.
Axiom traverse : KleeneCoalg (fun x => x) t.

Definition size a (x:t a) : nat := dim (traverse a a x).

Lemma iso1_iso2_2 a (y : {x : t unit & vector a (size x)}) : False.
Proof.
destruct y.
pose (X := KSmap (traverse a unit) (traverse unit a x)).
set (e :=(eq_sym (free_b_dim traverse (a:=unit) a unit x))).
clearbody e.
(** The pattern generated by change must have holes where there were implicit
    arguments in the original user-provided term. This particular example fails
    if this is not the case because the inferred argument does not coincide with
    the one in the considered term. *)
progress (change (dim (traverse unit a x)) with (dim X) in e).


Require Import Untyped MLTTTyping LogicalRelation Properties Reduction LRInduction.
Set Universe Polymorphism.

Definition escape0 {Γ A} :
    [Γ ||-< zero | A ] ->
    [Γ |- A].
Proof.
    intros.
    destruct X.
    eapply (LR_rec0 Γ A). exact valid.
    + intros. destruct neA.
      destruct D. assumption.
    + intros. destruct H0. cbn in *.
      destruct (D'_ emptyName).
      assumption.
Defined.

Definition escape1 {Γ A} :
    [Γ ||-< one | A ] ->
    [Γ |- A].
Proof.
    intros.
    destruct X.
    refine (LR_rec1 Γ A _ _ _ valid
      (fun Γ A T T0 T1 H =>
        [Γ ||-< zero | A] ->
        [Γ |- A])
      (fun Γ A T T0 T1 H =>
        [Γ ||-< one | A] ->
        [Γ |- A]) _ _ _ _ _ _ _).
    1, 4 : intros; destruct neA;
      destruct D; exact wfA.
    1, 3 : intros; destruct H0;
      destruct (D'_ emptyName);
      assumption.
    + intros.
      constructor. assumption.
    + intros.
      eapply X.
      exact H.
    + econstructor; eassumption.
Defined.

Definition escapeEqNe {Γ0 A0 B} : forall (neA : [Γ0 ||-ne A0]),
    [Γ0 ||-ne A0 ≅ B | neA] ->
    [Γ0 |- A0 ≅ B].
Proof.
    intros. destruct neA.
    destruct X.
    pose proof (TypeRedWFConv D).
    pose proof (TypeSym (TypeRedWFConv D')).
    eapply TypeTrans. eassumption.
    eapply TypeTrans. eassumption.
    eassumption.
Defined.

Definition escapeEqPi {Γ0 A0} l : forall (H0 : [Γ0 ||-0Π A0])
    (H1 : TyPiRel1 (LR (recl l)) H0),
    (forall (Δ : PCUICAst.PCUICEnvironment.context) (h : [  |- Δ])
       (B : PCUICAst.term), LogicalRelation.relEq (_F H0 h) B -> [Δ |- F H0 ≅ B]) ->
    (forall (Δ : PCUICAst.PCUICEnvironment.context) (a : PCUICAst.term)
       (h1 : [  |- Δ])
       (h2 : [Δ ||-1 a ::: F H0 | {| valid := _F1 H1 h1 |}])
       (B : PCUICAst.term),
     LogicalRelation.relEq (_G H0 h1 h2) B ->
     [Δ |- PCUICAst.subst1 a 0 (G H0) ≅ B]) ->
    forall B, [Γ0 ||-1Π A0 ≅ B | H0] -> [Γ0 |- A0 ≅ B].
Proof.
    intros. destruct H0.
    pose proof (TypeRedWFConv (D'_ emptyName)).
    eapply TypeTrans. eassumption.
    destruct X1.
    pose proof (TypeRedWFConv (D'' emptyName)).
    eapply TypeTrans.
    2 : exact (TypeSym X1).
    exact (AeqB _ _).
Defined.

Definition escapeEq0 {Γ A B H} :
    [ Γ ||-< zero | A ≅ B | H ] ->
    [Γ |- A ≅ B].
Proof.
    intros.
    destruct H.
    revert B X.
    eapply (LR_rec0 Γ A _ _ _ valid
      (fun Γ A T T0 T1 H => forall B : PCUICAst.term,
        [Γ ||-< zero | A ≅ B | LRValidMk _ _ _ H] ->
        [Γ |- A ≅ B])).
    + intros; now eapply escapeEqNe.
    + intros; now eapply (escapeEqPi zero).
    Unshelve.
    all : assumption.
Defined.

Definition escapeEq1 {Γ A B H} :
    [ Γ ||-< one | A ≅ B | H ] ->
    [Γ |- A ≅ B].
Proof.
    intros.
    destruct H.
    revert B X.
    eapply (LR_rec1 Γ A _ _ _ valid
      (fun Γ A T T0 T1 H => forall B : PCUICAst.term,
        [Γ ||-< zero | A ≅ B | LRValidMk _ _ _ H] ->
        [Γ |- A ≅ B])
    (fun Γ A T T0 T1 H => forall B : PCUICAst.term,
        [Γ ||-< one | A ≅ B | LRValidMk _ _ _  H] ->
        [Γ |- A ≅ B])).
    all :cbn in *.
    1, 4 : intros; now eapply escapeEqNe.
    1 : intros; now eapply (escapeEqPi zero).
    2 : intros; now eapply (escapeEqPi one).
    + intros.
      destruct H. rewrite Beq; constructor.
      constructor. assumption.
    + intros.
      eapply X; eassumption.
    Unshelve.
    all : eassumption.
Defined.

Definition escapeTermNe {Γ0 A0 t}: forall
  (neA : [Γ0 ||-ne A0]),
  [Γ0 ||-ne t ::: A0 | neA] ->
  [Γ0 |- t ::: A0].
Proof.
  intros.
  destruct neA.
  destruct X.
  gen_conv.
  destruct X1.
  exact (redFirstCTerm C).
Defined.

Definition escapeTermPi {Γ0 A0} l : forall
  (H0 : [Γ0 ||-0Π A0])
  (H1 : TyPiRel1 (LR (recl l)) H0),
  (forall (Δ : PCUICAst.PCUICEnvironment.context)
     (h : [  |- Δ]) (t : PCUICAst.term),
   LogicalRelation.relTerm (_F H0 h) t -> [Δ |- t ::: F H0]) ->
  (forall (Δ : PCUICAst.PCUICEnvironment.context)
     (a : PCUICAst.term) (h1 : [  |- Δ])
     (h2 : [Δ ||-1 a ::: F H0 | {|  valid := _F1 H1 h1 |}])
     (t : PCUICAst.term),
   LogicalRelation.relTerm (_G H0 h1 h2) t ->
   [Δ |- t ::: PCUICAst.subst1 a 0 (G H0)]) ->
  forall t : PCUICAst.term,
  [Γ0 ||-1Π t ::: A0 | H0] ->
  [Γ0 |- t ::: A0].
Proof.
  intros. destruct H0.
  destruct X1. cbn in *.
  eapply wfTermConv.
  destruct (redf emptyName).
  exact wft.
  exact (TypeSym (TypeRedWFConv (D'_ emptyName))).
Defined.

Definition escapeTerm0 {Γ t A} : forall
    (H : [Γ ||-< zero | A ]),
    [Γ ||-< zero | t ::: A | H ] ->
    [Γ |- t ::: A].
Proof.
    intros.
    destruct H.
    revert t X.
    eapply (LR_rec0 Γ A _ _ _ valid
      (fun Γ A T T0 T1 H => forall t : PCUICAst.term,
        [Γ ||-< zero | t ::: A | LRValidMk _ _ _ H] ->
        [Γ |- t ::: A])).
    + intros. now eapply escapeTermNe.
    + intros. now eapply (escapeTermPi zero).
    Unshelve.
    all : assumption.
Defined.

Definition escapeTerm1 {Γ t A} : forall
    (H : [Γ ||-< one | A ]),
    [Γ ||-< one | t ::: A | H ] ->
    [Γ |- t ::: A].
Proof.
    intros.
    destruct H.
    revert t X.
    eapply (LR_rec1 Γ A _ _ _ valid
      (fun Γ A T T0 T1 H => forall t : PCUICAst.term,
        [Γ ||-< zero | t ::: A | LRValidMk _ _ _  H] ->
        [Γ |- t ::: A])
        (fun Γ A T T0 T1 H => forall t : PCUICAst.term,
        [Γ ||-< one | t ::: A | LRValidMk _ _ _  H] ->
        [Γ |- t ::: A])).
    1, 4 : intros; now eapply escapeTermNe.
    1 : intros; now eapply (escapeTermPi zero).
    2 : intros; now eapply (escapeTermPi one).
    + intros. cbn in *.
      destruct X.
      exact (redFirstCWFTerm dd).
    + intros. cbn in *.
      apply X; eassumption.
    Unshelve.
    all : eassumption.
Defined.

Definition escapeEqTermNe {Γ0 A0 t u}: forall
  (neA : [Γ0 ||-ne A0]),
  [Γ0 ||-ne t ≅ u ::: A0 | neA] ->
  [Γ0 |- t ≅ u ::: A0].
Proof.
  intros.
  destruct X.
  destruct kNFEqm.
  eapply TermTrans.
  exact (RedConvTeWFC d').
  eapply TermTrans. exact kEqm.
  exact (TermSym (RedConvTeWFC d'')).
Defined.

Definition escapeEqTermPi {Γ0 A0} l : forall
  (H0 : [Γ0 ||-0Π A0]) (H1 : TyPiRel1 (LR (recl l)) H0),
  (forall Δ (h : [  |- Δ]) t u,
   LogicalRelation.relEqTerm (_F H0 h) t u -> [Δ |- t ≅ u ::: F H0]) ->
  (forall Δ a
     (h1 : [  |- Δ])
     (h2 : [Δ ||-1 a ::: F H0 | {|valid := _F1 H1 h1 |}])
     t u,
   LogicalRelation.relEqTerm (_G H0 h1 h2) t u ->
   [Δ |- t ≅ u ::: PCUICAst.subst1 a 0 (G H0)]) ->
  forall t u,
  [Γ0 ||-1Π t ≅ u ::: A0 | H0] ->
  [Γ0 |- t ≅ u ::: A0].
Proof.
  intros.
  destruct X1.
  destruct H0. cbn in *.
  eapply TermConv.
  2 : exact (TypeSym (TypeRedWFConv (D'_ emptyName))).
  eapply TermTrans.
  exact (RedConvTeWFC (redf' emptyName)).
  eapply TermTrans.
  exact (fEqg emptyName).
  exact (TermSym (RedConvTeWFC (redg' emptyName))).
Defined.

Definition escapeEqTerm0 {Γ t u A} : forall
    (H : [Γ ||-< zero | A ]),
    [Γ ||-< zero | t ≅ u ::: A | H ] ->
    [Γ |- t ≅ u::: A].
Proof.
  intros.
  destruct H.
  revert t u X.
  eapply (LR_rec0 Γ A _ _ _ valid
  (fun Γ A T T0 T1 H => forall t u,
    [Γ ||-< zero | t ≅ u ::: A | LRValidMk _ _ _ H] ->
    [Γ |- t ≅ u ::: A])).
  cbn in *.
  + intros; now eapply escapeEqTermNe.
  + intros; eapply (escapeEqTermPi zero).
  Unshelve.
  all : eassumption.
Defined.

Definition escapeEqTerm1 {Γ t u A} : forall
    (H : [Γ ||-< one | A ]),
    [Γ ||-< one | t ≅ u ::: A | H ] ->
    [Γ |- t ≅ u::: A].
Proof.
  intros.
  destruct H.
  revert t u X.
  eapply (LR_rec1 Γ A _ _ _ valid
  (fun Γ A T T0 T1 H => forall t u,
    [Γ ||-< zero | t ≅ u ::: A | LRValidMk _ _ _ H] ->
    [Γ |- t ≅ u ::: A])
  (fun Γ A T T0 T1 H => forall t u,
    [Γ ||-< one | t ≅ u ::: A | LRValidMk _ _ _ H] ->
    [Γ |- t ≅ u ::: A])).
  1, 4 : intros; now eapply escapeEqTermNe.
  1 : intros; now eapply (escapeEqTermPi zero).
  2 : intros; now eapply (escapeEqTermPi one).
  + intros.
    destruct X.
    eapply TermTrans.
    exact (RedConvTeWFC d_).
    eapply TermTrans.
    exact AeqBU.
    exact (TermSym (RedConvTeWFC dd')).
  + intros. cbn in *.
    eapply X; try eassumption.
  Unshelve.
  all : eassumption.
Defined.


Require Import ClassicalExtras.
Require Import Setoid.
Require Import Events.
Require Import CommonST.
Require Import TraceModel.
Require Import Robustdef.
Require Import Properties.
Require Import Topology.
Require Import XPrefix.

(** This file proves the alternative, property-free criteria
    for the robust preservation of classes of properties *)

(*********************************************************)
(* PROPERTIES                                            *)
(*********************************************************)

(** *Trace Properties *)
Definition RTC : Prop :=
  forall (P:par src i) C' t, exists C,
      sem tgt  (C' [ P ↓ ] ) t ->
      sem src  (C  [ P  ] ) t.

(*
   assuming there exists a source context and using
   classical logic we can move the existential in RC
   after the implication.
 *)
Axiom some_ctx_src : ctx src i.

Lemma RTC' : RTC <-> (forall (P:par src i) C' t, sem tgt  (C' [ P ↓ ] ) t ->
                         exists C, sem src  (C  [ P  ] ) t).
Proof.
  unfold RTC. split.
  - intros rc P C' t H0. destruct (rc P C' t) as [C H1]. clear rc.
    exists C. apply (H1 H0).
  - intros rc' P C' t.
    assert (K : sem tgt  (C' [ P ↓ ] ) t \/ ~ sem tgt  (C' [ P ↓ ] ) t)
      by now apply classic.
    destruct K as [k | k].
    + destruct (rc' P C' t k) as [C H]. clear rc'.
      exists C. auto.
    + exists some_ctx_src. intros H. exfalso. apply (k H).
Qed.

(* RTC is equivalent to the preservation of robust satisfaction of every property *)
Theorem RTC_RTP : RTC <-> RTP.
Proof.
  rewrite RTC'. split.
  - intros rc P π. rewrite contra_RP.
    intros [C' [t' [H0 H1]]].
    destruct (rc P C' t' H0) as [C H]. clear rc. exists C,t'. auto.
  - intros rp P C' t H. specialize (rp P (fun b => b <> t)).
    rewrite contra_RP in rp. destruct rp as [C [t' [H0 H1]]].
    exists C',t. auto. apply NNPP in H1. subst t'. now exists C.
Qed.

Theorem RTC_RTP_maybe_simpler : RTC <-> (forall P π, RP P π).
Proof.
  unfold RP, rsat, sat. split.
  - unfold RTC.
    intros HRTC P π HsatCP Ct t HsemCtPC. destruct (HRTC P Ct t) as [Cs HTRC']. eauto.
  - rewrite RTC'. intros HRTP P. apply HRTP. eauto.
    (* here's a more detailed forwards proof *)
    (* pose proof (HRTP P (fun t => exists Cs, sem src (Cs[P]) t)) as HRTP'. simpl in HRTP'. *)
    (* assert(G : forall Cs t, sem src (Cs [P]) t -> exists Cs, sem src (Cs [P]) t) by eauto. *)
    (* specialize (HRTP' G). assumption. *)
Qed.

(** *Safety Properties *)

Definition RSC : Prop :=
  forall (P:par src i) C' t, sem tgt (C' [ P ↓ ] ) t ->
    forall m, (prefix m t -> exists C t', sem src (C [ P ] ) t' /\ prefix m t').

(*
   robustly safe compilation criterium is equivalent to the
   preservation of robust satisfaction of all Safety properties
 *)
Theorem RSC_RSP : RSC <-> RSP.
Proof.
 unfold RSC. split.
 - intros rsc P π S. rewrite contra_RP. intros [C' [t [H0 H1]]].
   destruct (S t H1) as [m [pmt S']].
   destruct (rsc P C' t H0 m pmt) as [C [t' [K0 pmt']]].
   exists C, t'. specialize (S' t' pmt'). now auto.
 - intros rsp P C' t H0 m pmt.
   assert (s : Safety (fun b => ~ prefix m b)).
   { unfold Safety. intros b H. apply NNPP in H. exists m. split.
     + assumption.
     + intros b' H' c. apply (c H'). }
   specialize (rsp P (fun b => ~ prefix m b) s).
   rewrite contra_RP in rsp. destruct rsp as [C [t' [K0 K1]]].
   exists C', t. now auto. apply NNPP in K1.
   now exists C,t'.
Qed.

(** ** Stronger variant of Robustly Safe Compilation *)
Lemma stronger_rsc (es : endstate) : (forall (P:par src i) C' t, sem tgt ( C' [ P ↓ ]) t  ->
  forall m, prefix m t -> exists C, sem src ( C [ P ] ) (embedding es m))
  -> RSC.
Proof.
  unfold RSC. intros H P c t Hsem' m Hprefix.
  specialize (H P c t Hsem' m Hprefix). destruct H as [C Hsem].
  exists C. exists (embedding es m). split. assumption. apply embed_pref.
Qed.

(* The reverse direction doesn't hold *)

(** *Dense Properties *)

Definition RDC : Prop :=
  forall (P:par src i) C' t, inf t ->
     (exists C, sem tgt ( C' [ P ↓ ]) t ->
           sem src ( C [ P ]) t).

(* the same as for RC *)
Lemma RDC' : RDC <-> (forall (P:par src i) C' t, inf t -> sem tgt ( C' [ P ↓ ]) t ->
                                  exists C,  sem src ( C [ P ]) t).
Proof.
   unfold RDC. split.
  - intros rc P C' t Hi H0. destruct (rc P C' t) as [C H1]. clear rc.
    assumption. exists C. apply (H1 H0).
  - intros rc' P C' t Hi.
    assert (K :  sem tgt ( C' [ P ↓ ]) t \/ ~  sem tgt ( C' [ P ↓ ]) t)
      by now apply classic.
    destruct K as [k | k].
    + destruct (rc' P C' t Hi k) as [C H]. clear rc'.
      exists C. auto.
    + exists some_ctx_src. intros H. exfalso. apply (k H).
Qed.

Theorem RDC_RDP : RDC <-> RDP.
Proof.
  rewrite RDC'. split.
  - intros rlc P π Hl. rewrite contra_RP. intros [C' [t [H0 H1]]].
    assert(Hi : inf t).
    { unfold inf. intros Hf. apply H1. now apply Hl. }
    destruct (rlc P C' t Hi H0) as [C K0]. clear rlc.
    now exists C,t.
  - intros rlp P C' t Hi H0.
    assert (HD : Dense (fun b => b <> t)).
    { rewrite <- all_fin_in_all_liv. exact (inf_excluded_is_liv t Hi). }
    specialize (rlp P (fun b => b <> t) HD).
    rewrite contra_RP in rlp. destruct rlp as [C [t' [K0 K1]]].
    now exists C', t. apply NNPP in K1. subst t'.
    now exists C.
Qed.

(*********************************************************)
(* Criterium for Observable Properties Preservation

(*

Without the constructor tsilent for traces
(or equivalently when silent divergence is observable)
it is possible to show that the robsust preservation of
all observable properties implies the robust preservation
of all arbitrary properties.
When silent divergence is not observable this is no more true

Theorem RobsP_RPP : (forall P π, Observable π -> RP P π) <->
                    (forall P π, RP P π).
Proof.
  split; try now firstorder.
  intros hr P π. rewrite contra_RP.
  intros [C' [t [hsem ht]]].
  specialize (hr P (fun b => ~ t_eq t b)).
  assert (Observable (fun b => ~ t_eq t b)).
    (* This is False!!
       e.g. when t = tstop
       then the trace tsilent is in the property
       but its only prefix, (ftbd nil) is also a prefix of tstop
    *)

Theorem RobsP_RTC : (forall P π, Observable π -> RP P π) <-> RTC.
Proof. now rewrite RobsP_RPP, RTC_RTP. Qed.

*) *)

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

(*********************************************************)
(* HYPERPROPERTIES                                       *)
(*********************************************************)

Require Import FunctionalExtensionality.
(* Require Import Logic.ClassicalFacts. *)

(** *HyperProperties *)
Definition RHC : Prop :=
  forall (P:par src i) C',
    (exists C, (forall t,  sem tgt ( C' [ P ↓ ]) t  <->  sem src ( C [ P ]) t)).

Lemma Hequiv_lemma : forall (π1 π2 : prop) (H : hprop),
     (forall t, π1 t <-> π2 t) ->
     (H π1 <-> H π2).
Proof.
  intros π1 π2 H H0. assert (π1 = π2).
  { apply functional_extensionality.
    intros t. specialize (H0 t). now apply prop_ext. }
  now subst.
Qed.

Theorem RHC_RHP : RHC <-> RHP.
Proof.
  split.
  - intros H0 P H. rewrite contra_RHP. intros [C' H1].
    specialize (H0 P C'). destruct H0 as [C H0].
    exists C. intros ff. eapply Hequiv_lemma in ff.
    apply (H1 ff). now auto.
  - unfold RHC. intros hrp P C'.
    specialize (hrp P (fun π => π <>  (sem tgt ( C' [ P ↓ ])))).
    rewrite contra_RHP in hrp. destruct hrp as [C H0].
    exists C'. rewrite <- dne. now auto.
    rewrite <- dne in H0. exists C. intros t.
    now  rewrite <- H0.
Qed.

(** *Subset-Closed Hyperproperties*)

Definition RSCHC : Prop :=
  forall (P:par src i) C',
  exists C, forall b,  sem tgt ( C' [ P ↓ ]) b ->  sem src ( C [ P ]) b.

Lemma RSCHC_RSCHP : RSCHC <-> RSCHP.
Proof.
  split.
   - intros ssc P H HH. rewrite contra_RHP. intros [C' H0].
     destruct (ssc P C') as [C h0]. exists C. now firstorder.
   - unfold RSCHC. intros h0 P C'.
     assert  (s : SSC (fun π => ~(forall b,  sem tgt ( C' [ P ↓ ]) b -> π b))).
     { unfold SSC. intros π h1 k Hk ff.
       assert (foo : forall b,  sem tgt ( C' [ P ↓ ]) b -> π b) by now auto.
       now apply (h1 foo). }
     specialize (h0 P (fun π => ~(forall b,  sem tgt ( C' [ P ↓ ]) b -> π b)) s).
     rewrite contra_RHP in h0.
     destruct h0 as [C h1]. exists C'.
     now rewrite <- dne. rewrite <- dne in h1.
     now exists C.
Qed.

(** *2Subset-Closed Hyperproperties*)
Definition R2SCHC :=
  forall (P:par src i) Ct t1 t2,
      (sem tgt (Ct [P ↓]) t1 /\ sem tgt (Ct [P ↓]) t2)
      -> exists Cs, (sem src (Cs [P ]) t1 /\ sem src (Cs [P ]) t2).

Theorem R2SCHC_R2SCHP : R2SCHC <-> R2SCHP.
Proof.
  split.
    - intros ssc P H HH. rewrite contra_RHP. intros [C' H0].
      specialize (ssc P C'). rewrite (HH (beh (C' [P ↓]))) in H0.
      destruct H0 as [t1 [t2 [b_t1 [b_t2 H_t1_t2]]]].
      destruct (ssc t1 t2) as [Cs [bs_t1 bs_t2]]. auto.
      exists Cs. rewrite (HH _). exists t1, t2. split; auto.
  - unfold R2SCHC. intros h0 P C' t1 t2 [H1 H2].
    specialize (h0 P).
    assert (s : twoSC (fun π => (~(sem tgt ( C' [ P ↓ ]) t1 -> π t1)) \/
                              (~(sem tgt ( C' [ P ↓ ]) t2 -> π t2)))).
    { unfold twoSC. intros. split.
      + intros h.
        exists t1, t2. rewrite de_morgan2 in h. destruct h as [h1 h2].
        rewrite <- dne in h1, h2.
        repeat (split; auto).
        intros [k | k]; apply k; [ now left | now right ].
      +  intros [t3 [t4 [b_t3 [b_t4 K]]]].
         rewrite de_morgan2. rewrite <- dne. rewrite <- dne.
         rewrite de_morgan2 in K. destruct K as [k1 k2]. rewrite <- dne in k1,k2.
         specialize (k1 H1). specialize (k2 H2).
         destruct k1, k2; now subst.
    }
    specialize (h0 (fun π => (~(sem tgt ( C' [ P ↓ ]) t1 -> π t1)) \/ (~(sem tgt ( C' [ P ↓ ]) t2 -> π t2)))).
    specialize (h0 s).
    rewrite contra_RHP in h0.
    destruct h0 as [C h1]. exists C'.
    apply de_morgan2; split; now rewrite <- dne.
    apply de_morgan2 in h1; destruct h1 as [h1 h2];
      rewrite <- dne in h1; rewrite <- dne in h2.
    exists C; split; tauto.
Qed.

(** *HyperSafety *)
Definition RHSC : Prop :=
  forall (P:par src i) C' M, Observations M ->
            spref M (sem tgt ( C' [ P ↓ ]))  ->
            exists C, spref M (sem src ( C [ P])).

Theorem RHSC_RHSP : RHSC <-> RHSP.
Proof.
  split.
  - intros hsrc P H hs. rewrite contra_RHP. intros [C' h0].
    destruct (hs (fun b : trace => sem tgt ( C' [ P ↓ ]) b)) as [M [hm0 [hm1 hm2]]].
    assumption. destruct (hsrc P C' M) as [C hh]; auto.
    exists C. now apply hm2.
  - unfold RHSC. intros h P C' M h0 h1.
    assert (hs : HSafe (fun π => ~ spref M π)).
    { unfold HSafe. intros T hm. rewrite <- dne in hm.
      exists M. split; now auto. }
    specialize (h P (fun π => ~ spref M π) hs). rewrite contra_RHP in h.
    destruct h as [C hh]. now exists C'. exists C. now apply NNPP.
Qed.

(** *2HyperSafety *)
Definition R2HSC := forall (P:par src i) Ct, forall m1 m2,
        (spref (fun m => m = m1 \/ m = m2) (sem tgt ( Ct [ P ↓]))
         -> exists Cs, spref (fun m => m = m1 \/ m = m2) (sem src ( Cs [ P]))).

Theorem R2HSC_R2HSP : R2HSC <-> R2HSP.
Proof.
  split.
  - intros hsrc P H hs. rewrite contra_RHP. intros [C' h0].
    destruct (hs (fun b => sem tgt (C' [P ↓]) b)) as [m1 [m2 [H1 H2]]].
    assumption.
    destruct (hsrc P C' m1 m2) as [C hh]; auto.
    exists C. now apply H2.
  - unfold R2HSC.
    intros. specialize (H P).
    assert (hs : H2Safe (fun π => ~ spref (fun m => m = m1 \/ m = m2) π)).
    { clear. unfold H2Safe. intros b hm. rewrite <- dne in hm.
      exists m1, m2. split. assumption. now auto. }
    specialize (H (fun π => ~ spref (fun m => m = m1 \/ m = m2) π) hs).
    rewrite contra_RHP in H. destruct H as [C hh].
    now exists Ct. exists C. now apply NNPP.
Qed.

Lemma R2HSC_RSC : R2HSC -> RSC.
Proof.
  intros H P Ct t Ht m Hpref.
  destruct (H P Ct m m) as [Cs Hspref].
  intros m' [K | K]; subst; now exists t.
  exists Cs. destruct (Hspref m) as [t' H']; simpl; auto.
Qed.

Lemma R2SCHC_R2HSC : R2SCHC -> R2HSC.
Proof.
  rewrite R2SCHC_R2SCHP. rewrite R2HSC_R2HSP.
  intros twosc P S two_safetyS.
  apply twoSC_H2Safe in two_safetyS.
  now apply (twosc P S).
Qed.

(** *HyperLiveness *)

(*********************************************************)
(* Criterium for HyperLiveness Preservation
   is the same as the one for
   all Hyperproperties Preservation                      *)
(*********************************************************)

Lemma bad_HyperLiv : forall C' (P:par src i),
    HLiv (fun π : prop => π <> (sem tgt ( C' [ P ↓ ] ))).
Proof.
  unfold HLiv. intros C' P M obsM.
  assert (sem tgt (C' [P ↓]) = Embedding M \/  sem tgt (C' [P ↓]) <> Embedding M)
    by now apply classic.
  destruct H.
  + rewrite H; clear H. exists (fun t =>
                             (exists m es, M m /\ t = embedding es m) \/
                                       t = tstream (constant_stream an_event)).
    split.
    ++ unfold spref. intros m hm. exists (embedding an_endstate m).
       split.
       +++ left. now exists m, an_endstate.
       +++ now apply embed_pref.
     ++ intros hf. apply (infinite_trace_not_in_embed M).
        rewrite <- hf. now right.
  + exists (Embedding M). split; try now auto.
    unfold spref, Embedding. intros m hm.
    exists (embedding an_endstate m). split.
    ++ now exists m, an_endstate.
    ++ now apply embed_pref.
Qed.

Theorem RHC_RHLP : RHC <-> RHLP.
Proof.
 rewrite RHC_RHP. split; try now firstorder.
 intros rhlp P H. rewrite contra_RHP. intros [C' K].
 specialize (rhlp P (fun π : prop => π <> sem tgt (C' [ P ↓]) ) (bad_HyperLiv C' P)).
 rewrite contra_RHP in rhlp.
 destruct rhlp as [C KK]. exists C'. now rewrite <- dne. apply NNPP in KK.
 exists C. now rewrite KK.
Qed.

Theorem RHLP_RHP :
    RHLP <-> RHP.
Proof. now rewrite <- (RHC_RHP), (RHC_RHLP). Qed.

(*********************************************************)
(* RELATIONS                                             *)
(*********************************************************)

(** *2Relational Trace Properties *)

Definition R2rTC := forall Ct (P1 P2:par src i) t1 t2,
  sem tgt (Ct [P1 ↓]) t1 ->  sem tgt (Ct [P2 ↓]) t2 ->
  exists Cs, sem src (Cs [P1]) t1 /\ sem src (Cs [P2]) t2.

Lemma R2rTC_R2rTP : R2rTC <-> R2rTP.
Proof.
  rewrite R2rTP'. unfold R2rTP, R2rTC. split.
  - intros H P1 P2 r Ct t1 t2 H1 H2 Hr.
    specialize (H Ct P1 P2 t1 t2 H1 H2).
    destruct H as [Cs [G1 G2]]. now exists Cs, t1, t2.
  - intros H Ct P1 P2 t1 t2 H1 H2.
    specialize (H P1 P2 (fun t1' t2' => t1' <> t1 \/ t2' <> t2)).
    assert(Htriv: ~ (t1 <> t1 \/ t2 <> t2)) by tauto.
    simpl in H. specialize (H Ct t1 t2 H1 H2 Htriv).
    destruct H as [Cs [t1' [t2' [H1' [H2' Heq]]]]].
    exists Cs. rewrite de_morgan2 in Heq. destruct Heq as [Heq1 Heq2].
    apply NNPP in Heq1. apply NNPP in Heq2. subst. tauto.
Qed.

(*************************************************************************)
(* If the source language is deterministic than
    R2rTC =>  RTEP (trace equivalence preservation)                      *)
(*************************************************************************)

Section source_determinism.

  Hypothesis src_det : forall P t1 t2, sem src P t1 -> sem src P t2 -> t1 = t2.

  Theorem R2rTP_RTEP : R2rTP -> RTEP.
  Proof.
    rewrite <- R2rTC_R2rTP. unfold R2rTC. rewrite RTEP'. intros H P1 P2 [Ct [t' H']].
    rewrite not_iff in H'. destruct H' as [[H1' nH2'] | [nH1' H2']].
    - destruct (non_empty_sem tgt (Ct [P2 ↓])) as [t2 H2'].
      destruct (H _ _ _ _ _ H1' H2') as [Cs [H1 H2]].
      exists Cs, t2. intros Hf. rewrite <- Hf in H2.
      specialize (src_det (Cs [P1] ) t' t2 H1 H2). now subst.
    - destruct (non_empty_sem tgt (Ct [P1 ↓])) as [t1 H1'].
      destruct (H _ _ _ _ _ H1' H2') as [Cs [H1 H2]].
      exists Cs, t'. intros Hf. rewrite <- Hf in H2.
      specialize (src_det (Cs [P1] ) t1 t' H1 H2). now subst.
   Qed.

End source_determinism.

(** *Arbitrary Relational Trace Properties *)

Definition RrTC :=
  forall (f : par src i -> trace) Ct,
    (forall P, sem tgt (Ct [P↓]) (f P)) ->
    exists Cs, (forall P, sem src (Cs [P]) (f P)).

Lemma RrTC_RrTP : RrTC <-> RrTP'.
Proof.
  split.
  - intros HRrTC R. rewrite contra.
    intros Htgt. rewrite not_forall_ex_not in Htgt.
    destruct Htgt as [Ct Htgt]. rewrite not_forall_ex_not in Htgt.
    destruct Htgt as [f Htgt]. rewrite not_forall_ex_not in Htgt.
    destruct Htgt as [Htgt H]. destruct (HRrTC f Ct Htgt) as [Cs HCs].
    intro Hsrc. apply H. now apply (Hsrc Cs).
  - intros HRrTP f Ct Htgt. specialize (HRrTP (fun g => g <> f)).
    rewrite contra in HRrTP. repeat rewrite not_forall_ex_not in HRrTP.
    destruct HRrTP as [Cs H1].
    { exists Ct. rewrite not_forall_ex_not. exists f.
      rewrite not_forall_ex_not.  exists Htgt. now rewrite <- dne. }
    exists Cs. rewrite not_forall_ex_not in H1. destruct H1 as [f' H1].
    rewrite not_forall_ex_not in H1. destruct H1 as [H1 HH1].
    rewrite <- dne in HH1. now subst.
Qed.

(** *2Relational Safety Properties *)

Definition R2rSC := forall Ct (P1 P2:par src i) m1 m2,
    psem (Ct [P1↓]) m1 -> psem (Ct [P2↓]) m2 ->
    exists Cs, psem (Cs [P1]) m1 /\ psem (Cs [P2]) m2.

Theorem R2rSC_R2rSP : R2rSC <-> R2rSP.
Proof.
  rewrite R2rSP'. unfold R2rSP, R2rSC. split.
  - intros H P1 P2 r Hsafety Ct t1 t2 H1 H2 Hr.
    specialize (H Ct P1 P2).
    unfold safety2 in Hsafety. specialize (Hsafety t1 t2 Hr).
    destruct Hsafety as [m1 [m2 [Hm1 [Hm2 Hs]]]].
    specialize (H m1 m2). unfold psem in H.
    assert (Hex1 : (exists t : trace, prefix m1 t /\ sem _ (plug _ (P1 ↓) Ct) t)).
    { exists t1; auto. }
    assert (Hex2 : (exists t : trace, prefix m2 t /\ sem _ (plug _ (P2 ↓) Ct) t)).
    { exists t2; auto. }
    specialize (H Hex1 Hex2). destruct H as [Cs [HCs1 HCs2]].
    unfold psem in HCs1. unfold psem in HCs2. destruct HCs1 as [t1' [Hpref1' Hsem1']].
    destruct HCs2 as [t2' [Hpref2' Hsem2']].
    exists Cs, t1', t2'. auto.
  - intros H Ct P1 P2 m1 m2 H1 H2.
    specialize (H P1 P2 (fun t1' t2' => ~ (prefix m1 t1') \/ ~(prefix m2 t2'))).
    assert (Hsafety : safety2 (fun t1' t2' => ~ (prefix m1 t1') \/ ~(prefix m2 t2'))).
    { clear. unfold safety2.
      intros t1 t2 Ht. apply not_or_and in Ht. destruct Ht as [Ht1 Ht2].
      apply NNPP in Ht1. apply NNPP in Ht2.
      exists m1. exists m2. firstorder. }
    unfold psem in H1, H2. destruct H1 as [t1 [H1 H1']]. destruct H2 as [t2 [H2 H2']].
    specialize (H Hsafety Ct t1 t2 H1' H2').
    assert (Htriv : ~ (fun t1' t2' : trace => ~ prefix m1 t1' \/ ~ prefix m2 t2') t1 t2).
    { apply and_not_or. split; firstorder. }
    specialize (H Htriv).
    destruct H as [Cs [t1' [t2' [Ht1' [Ht2' H]]]]].
    exists Cs.
    assert (Htriv' : ~ (fun t1' t2' : trace => ~ prefix m1 t1' \/ ~ prefix m2 t2') t1' t2').
    { apply and_not_or. split; firstorder. }
    simpl in Htriv'. apply not_or_and in Htriv'. destruct Htriv' as [Htriv1' Htriv2'].
    apply NNPP in Htriv1'. apply NNPP in Htriv2'.
    split; unfold psem.
    exists t1'; auto. exists t2'; auto.
Qed.

(* the following is another characterization of R2rSC *)
Definition R2rSC' : Prop :=
  forall (P1 P2:par src i) (r : finpref -> finpref -> Prop),
    ((forall Cs m1 m2, psem (Cs [P1]) m1 -> psem (Cs [P2]) m2 -> r m1 m2) ->
     (forall Ct m1 m2, psem (Ct [P1 ↓]) m1 -> psem (Ct [P2 ↓]) m2 -> r m1 m2)).

Theorem R2rSC_R2rSC' : R2rSC <-> R2rSC'.
Proof.
  unfold R2rSC, R2rSC'.
  split.
  - intros H P1 P2 r H' Ct m1 m2 Hsem1 Hsem2.
    specialize (H Ct P1 P2 m1 m2 Hsem1 Hsem2).
    destruct H as [Cs [Hsem1' Hsem2']].
    specialize (H' Cs m1 m2 Hsem1' Hsem2'). now assumption.
  - intros H Ct P1 P2 m1 m2 Hsem1 Hsem2.
    specialize (H P1 P2).
    specialize (H (fun m1 m2 => exists Cs, psem (Cs [P1]) m1 /\ psem (Cs [P2]) m2)); simpl in H.
    assert (H' : forall Cs m1 m2, psem (Cs [P1]) m1 -> psem (Cs [P2]) m2 ->
                             (exists Cs, psem (Cs [P1]) m1 /\ psem (Cs [P2]) m2)).
    { clear. intros Cs m1 m2 Hsem1 Hsem2. exists Cs; now auto. }
    specialize (H H' Ct m1 m2 Hsem1 Hsem2). now assumption.
Qed.

Theorem R2rSP_R2rSC' : R2rSP <-> R2rSC'.
Proof.
  now rewrite <- R2rSC_R2rSP, R2rSC_R2rSC'.
Qed.

(** *Arbitrary Relational Safety Properties *)

Definition RrSC : Prop :=
  forall Ct (f : par src i -> (finpref -> Prop)),
    (forall P, spref (f P) (sem tgt (Ct [P↓]))) ->
    exists Cs,  (forall P, spref (f P) (sem src (Cs [P]))).

Theorem RrSC_RrSP' : RrSC <-> RrSP'.
Proof.
  unfold RrSP', RrSC. split.
  - intros h R h0 Ct f h1. specialize (h Ct f h1).
    destruct h as [Cs h]. now apply (h0 Cs f h).
  - intros h Ct f h0. apply NNPP. intros ff.
    rewrite not_ex_forall_not in ff.
    specialize (h (fun g => exists Cs, forall P, spref (g P) (sem src (Cs [P])))).
    simpl in *.
    assert(hh :  (forall (Cs : ctx src i) (f : par src i -> fprop),
       (forall P : par src i, spref (f P) (sem src (Cs [P]))) ->
       exists Cs0 : ctx src i,
         forall P : par src i, spref (f P) (sem src (Cs0 [P])))).
    { intros Cs f0 hhh. now exists Cs. }
    destruct (h hh Ct f h0) as [Cs hhh]. clear hh h.
    specialize (ff Cs). now auto.
Qed.

(** *2Relational XSafety Properties *)

Definition R2rXC := forall Ct (P1 P2:par src i) x1 x2,
   xsem (Ct [P1↓]) x1 -> xsem (Ct [P2↓]) x2 ->
  exists Cs, xsem (Cs[P1]) x1 /\ xsem (Cs[P2]) x2.

Theorem R2rXC_R2rXP : R2rXC <-> R2rXP.
Proof.
  rewrite R2rXP'. unfold R2rXP, R2rXC. split.
  - intros H P1 P2 r Hsafety Ct t1 t2 H1 H2 Hr.
    specialize (H Ct P1 P2).
    unfold safety2 in Hsafety. specialize (Hsafety t1 t2 Hr).
    destruct Hsafety as [m1 [m2 [Hm1 [Hm2 Hs]]]].
    specialize (H m1 m2). unfold psem in H.
    assert (Hex1 : (exists t : trace, xprefix m1 t /\ sem _ (plug _ (P1 ↓) Ct) t)).
    { exists t1; auto. }
    assert (Hex2 : (exists t : trace, xprefix m2 t /\ sem _ (plug _ (P2 ↓) Ct) t)).
    { exists t2; auto. }
    specialize (H Hex1 Hex2). destruct H as [Cs [HCs1 HCs2]].
    unfold psem in HCs1. unfold psem in HCs2. destruct HCs1 as [t1' [Hpref1' Hsem1']].
    destruct HCs2 as [t2' [Hpref2' Hsem2']].
    exists Cs, t1', t2'. auto.
  - intros H Ct P1 P2 m1 m2 H1 H2.
    specialize (H P1 P2 (fun t1' t2' => ~ (xprefix m1 t1') \/ ~(xprefix m2 t2'))).
    assert (Hsafety : xafety2 (fun t1' t2' => ~ (xprefix m1 t1') \/ ~(xprefix m2 t2'))).
    { clear. unfold xafety2.
      intros t1 t2 Ht. apply not_or_and in Ht. destruct Ht as [Ht1 Ht2].
      apply NNPP in Ht1. apply NNPP in Ht2.
      exists m1. exists m2. firstorder. }
    unfold psem in H1, H2. destruct H1 as [t1 [H1 H1']]. destruct H2 as [t2 [H2 H2']].
    specialize (H Hsafety Ct t1 t2 H1' H2').
    assert (Htriv : ~ (fun t1' t2' : trace => ~ xprefix m1 t1' \/ ~ xprefix m2 t2') t1 t2).
    { apply and_not_or. split; firstorder. }
    specialize (H Htriv).
    destruct H as [Cs [t1' [t2' [Ht1' [Ht2' H]]]]].
    exists Cs.
    assert (Htriv' : ~ (fun t1' t2' : trace => ~ xprefix m1 t1' \/ ~ xprefix m2 t2') t1' t2').
    { apply and_not_or. split; firstorder. }
    simpl in Htriv'. apply not_or_and in Htriv'. destruct Htriv' as [Htriv1' Htriv2'].
    apply NNPP in Htriv1'. apply NNPP in Htriv2'.
    split; unfold psem.
    exists t1'; auto. exists t2'; auto.
Qed.

Definition  R2rXC' : Prop :=
  forall (r : xpref -> xpref -> Prop) (P1 P2:par src i),
    ((forall Cs x1 x2, xsem (Cs [P1]) x1 ->
                  xsem (Cs [P2]) x2 ->
                   r x1 x2) ->
     (forall Ct x1 x2, xsem (Ct [P1 ↓]) x1 ->
                  xsem (Ct [P2 ↓]) x2 ->
                  r x1 x2)).

Lemma R2rXC_R2rXC' : R2rXC <-> R2rXC'.
Proof.
  unfold R2rXC, R2rXC'. split.
   - intros H r P1 P2 H' Ct m1 m2 Hsem1 Hsem2.
    specialize (H Ct P1 P2 m1 m2 Hsem1 Hsem2).
    destruct H as [Cs [Hsem1' Hsem2']].
    specialize (H' Cs m1 m2 Hsem1' Hsem2'). now assumption.
  - intros H Ct P1 P2 m1 m2 Hsem1 Hsem2.
    specialize (H (fun m1 m2 => exists Cs, xsem (Cs [P1]) m1 /\ xsem (Cs [P2]) m2)); simpl in H.
    specialize (H P1 P2).
    assert (H' : forall Cs m1 m2, xsem (Cs [P1]) m1 -> xsem (Cs [P2]) m2 ->
                             (exists Cs, xsem (Cs [P1]) m1 /\ xsem (Cs [P2]) m2)).
    { clear. intros Cs m1 m2 Hsem1 Hsem2. exists Cs; now auto. }
    specialize (H H' Ct m1 m2 Hsem1 Hsem2). now assumption.
Qed.

(* Still R2rXP implies R2rSP, and one can prove it by looking at the
   property-free characterization. *)

Lemma R2rXC_R2rSC : R2rXC -> R2rSC.
Proof.
  unfold R2rXC, R2rSC. intros H Ct P1 P2 m1 m2 [t1 [H1 H1']] [t2 [H2 H2']].
  specialize (H Ct P1 P2 (xembed m1) (xembed m2)).
  apply prefix_xprefix_xembed in H1. apply prefix_xprefix_xembed in H2.
  assert (X1 : xsem (Ct [P1 ↓]) (xembed m1)) by (exists t1; tauto).
  assert (X2 : xsem (Ct [P2 ↓]) (xembed m2)) by (exists t2; tauto).
  specialize (H X1 X2). destruct H as [Cs [[t1' [XX1 Hsem1]] [t2' [XX2 Hsem2]]]].
  exists Cs. apply xprefix_xembed_prefix in XX1.
             apply xprefix_xembed_prefix in XX2. split.
  - exists t1'. tauto.
  - exists t2'. tauto.
Qed.

(** *Arbitrary Relational XSafety Properties *)

Definition RrXC : Prop :=
  forall Ct (f : par src i -> (xpref -> Prop)),
    (forall P, spref_x (f P) (sem tgt (Ct [P↓]))) ->
    exists Cs,  (forall P, spref_x (f P) (sem src (Cs [P]))).

Theorem RrXC_RrXP' : RrXC <-> RrXP'.
Proof.
  unfold RrXP', RrXC. split.
  - intros h R h0 Ct f h1. specialize (h Ct f h1).
    destruct h as [Cs h]. now apply (h0 Cs f h).
  - intros h Ct f h0. apply NNPP. intros ff.
    rewrite not_ex_forall_not in ff.
    specialize (h (fun g => exists Cs, forall P, spref_x (g P) (sem src (Cs [P])))).
    simpl in *.
    assert(hh :  (forall (Cs : ctx src i) (f : par src i -> (xpref -> Prop)),
       (forall P : par src i, spref_x (f P) (sem src (Cs [P]))) ->
       exists Cs0 : ctx src i,
         forall P : par src i, spref_x (f P) (sem src (Cs0 [P])))).
    { intros Cs f0 hhh. now exists Cs. }
    destruct (h hh Ct f h0) as [Cs hhh]. clear hh h.
    specialize (ff Cs). now auto.
Qed.

(** *2Relational HyperProperties *)

Definition R2rHC : Prop :=
  forall (P1 P2:par src i) Ct, exists Cs, (sem src (Cs [P1]) = sem tgt (Ct [P1 ↓]))
                    /\ (sem src (Cs [P2]) = sem tgt (Ct [P2 ↓])).

Theorem R2rHC_R2rHP : R2rHC <-> R2rHP.
Proof.
  unfold R2rHP, R2rHC; split.
  - intros h P1 P2 r hcs Ct. destruct (h P1 P2 Ct) as [Cs [h0 h1]]; clear h.
    specialize (hcs Cs).
    rewrite h0, h1 in hcs. now assumption.
  - intros H2hrp P1 P2 Ct. apply NNPP. intros ff.
    rewrite not_ex_forall_not in ff.
    specialize (H2hrp P1 P2).
    specialize (H2hrp (fun f1 f2 => exists Cs, forall t, f1 t = sem src (Cs [ P1 ]) t
                                                   /\ f2 t = sem src (Cs [ P2 ]) t)).
    simpl in *.
    assert (hh : hrsat2 P1 P2
            (fun f1 f2 : prop =>
             exists Cs : ctx src i,
               forall t : trace, f1 t = sem src (Cs [P1]) t /\ f2 t = sem src (Cs [P2]) t)).
    { clear. unfold hrsat2. intros. exists C. intros. split; now auto. }
    specialize (H2hrp hh Ct); clear hh.
    unfold hrsat2 in H2hrp. destruct H2hrp as [Cs h].
    specialize (ff Cs).
    assert (sem src (Cs [P1]) = sem tgt (Ct [P1 ↓])).
    { apply functional_extensionality. intros t. specialize (h t).
      destruct h as [h1 h2]. auto. }
    assert (sem src (Cs [P2]) = sem tgt (Ct [P2 ↓])).
    { apply functional_extensionality. intros t. specialize (h t).
      destruct h as [h1 h2]. auto. }
    apply ff. split; auto.
Qed.

(** *Arbitrary Relational HyperProperties *)
Definition RrHC : Prop :=
  forall (Ct:ctx tgt (cint i)),
  exists (Cs:ctx src i),
  forall (P:par src i), sem src (Cs [P]) = sem tgt (Ct [P ↓]).

Theorem RrHC_RrHP' : RrHC <-> RrHP'.
Proof.
  unfold RrHP', RrHC. split.
  - intros h R hcs Ct. destruct (h Ct) as [Cs h0]; clear h.
    specialize (hcs Cs).
    assert (hh :  (fun P => sem src (Cs [P])) =
                  (fun P => sem tgt (Ct [P ↓])) ).
    { apply functional_extensionality. now apply h0. }
    now rewrite <- hh.
  - intros hrrhp Ct. apply NNPP. intros ff.
    rewrite not_ex_forall_not in ff.
    specialize (hrrhp (fun f => exists Cs, forall P, f P = sem src (Cs [ P ]) )).
    simpl in *.
    assert (hh : forall (Cs:ctx src i),
                 exists (Cs0:ctx src i),
                 forall (P:par src i), sem src (Cs [P]) = sem src (Cs0 [ P ])).
    { intros Cs. now exists Cs. }
    specialize (hrrhp hh); clear hh.
    destruct (hrrhp Ct) as [Cs h].
    specialize (ff Cs). now apply ff.
Qed.

(** *2Relational SubsetClosed HyperProperties *)
Definition R2rSCHC:=  (forall (P1 P2 : par src i) Ct, exists Cs,
                            (beh (Ct [P1↓])) ⊆  (beh (Cs [P1])) /\
                            (beh (Ct [P2↓])) ⊆  (beh (Cs [P2]))).

Theorem R2rSCHC_R2rSCHP : R2rSCHC <-> R2rSCHP.
  rewrite R2rSCHP'. split.
  + intros scC P1 P2 r r2ssc [Ct nr]. destruct (scC P1 P2 Ct) as [Cs [K1 K2]].
    exists Cs. intros Hf. apply nr. unfold ssc2 in r2ssc. eapply r2ssc; eassumption.
  + intros r2sscP P1 P2 Ct.
    destruct (r2sscP P1 P2
                (fun π1 π2 => ~ subset (beh (Ct [P1 ↓])) π1 \/ ~ subset (beh (Ct [P2 ↓])) π2)) as [Cs Hcs].
    { intros b1 b2 b1' b2' [nsup1 | nsup2] s1 s2.
      + left. unfold "⊆" in *. rewrite not_forall_ex_not in *.
        destruct nsup1 as [t Hn1]. exists t.
        rewrite not_imp in *. split; firstorder.
      + right. unfold "⊆" in *; rewrite not_forall_ex_not in *.
        destruct nsup2 as [t Hn2]. exists t.
        rewrite not_imp in *. split; firstorder. }
    exists Ct. rewrite de_morgan2. split; now rewrite <- dne.
    rewrite de_morgan2 in Hcs. repeat (rewrite <- dne in Hcs).
    now exists Cs.
Qed.

(* This criteria is a variant of RHC and RSP, where the quantification is over
   prefixes like RSP but with the alternation of RHC *)
(* Intuitively it should be close to RSCHC *)
Definition RSCHC_variant : Prop :=
  forall (P: par src i) C', exists C, forall m,
      (exists t', prefix m t' /\ sem tgt (C' [P ↓ ] ) t') ->
      (exists t, prefix m t /\ sem src (C [P] ) t).

Section RSCHC_variant_eq.
  (* In this section, we prove that RSCHC <-> RSCHC_variant under a simple
     assumption *)

  Hypothesis safe_src: forall P t, (forall m, prefix m t -> psem P m) -> sem src P t.

  Lemma RHC_RSCHC_variant: RSCHC -> RSCHC_variant.
  Proof.
    unfold RSCHC, RSCHC_variant.
    intros H P C'.
    specialize (H P C') as [C HC].
    exists C.
    intros m [t' [H1 H2]].
    exists t'; split; auto.
  Qed.

  Lemma RSCHC_variant_RHC: RSCHC_variant -> RSCHC.
  Proof.
    unfold RSCHC, RSCHC_variant.
    intros H P C'.
    specialize (H P C') as [C HC].
    exists C.
    intros t Ht.
    assert (Hallpref: forall m, prefix m t -> psem (C' [P↓]) m).
    { unfold psem. intros m H. eexists; split; eauto. }
    assert (forall m, prefix m t -> psem (C[P]) m).
    { intros m H.
      specialize (HC m (Hallpref m H)). apply HC. }
    apply safe_src.
    eauto.
Qed.

End RSCHC_variant_eq.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import PSCIAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Fixpoint system_off_reboot_loop0 (n: nat) (i: Z) (idx: Z) (g_rd: Pointer) (rec_list: Pointer) (adt: RData) :=
    match n with
    | O => Some (adt, i)
    | S n' =>
      match system_off_reboot_loop0 n' i idx g_rd rec_list adt with
      | Some (adt, i) =>
        rely is_int64 i;
        if i =? idx then
          Some (adt, i + 1)
        else
          when g_target_rec, adt == find_lock_rec_spec g_rd rec_list (VZ64 i) adt;
          when null == is_null_spec g_target_rec adt;
          rely is_int null;
          if null =? 0 then
            when t_rec, adt == granule_map_spec g_target_rec SLOT_REC_TARGET adt;
            when adt == set_rec_runnable_spec t_rec 0 adt;
            when adt == buffer_unmap_spec t_rec adt;
            when adt == granule_unlock_spec g_target_rec adt;
            Some (adt, i + 1)
        else Some (adt, i + 1)
      | _ => None
      end
    end.

  Definition system_off_reboot_spec0 (rec: Pointer) (adt: RData) : option RData :=
    when g_rec == get_rec_g_rec_spec rec adt;
	  when g_rd == get_rec_g_rd_spec rec adt;
	  when' idx == get_rec_rec_idx_spec rec adt;
    when g == get_rec_g_rec_list_spec rec adt;
    when adt == granule_lock_spec g_rec adt;
	  when adt == set_rec_runnable_spec rec 0 adt;
	  when adt == granule_unlock_spec g_rec adt;
    when rec_list, adt == granule_map_spec g SLOT_REC_LIST adt;
    match system_off_reboot_loop0 (Z.to_nat MAX_NUM_RECS) 0 idx g_rd rec_list adt with
    | Some (adt, i) =>
      rely is_int64 i;
      Some adt
    | _ => None
    end.

End SpecLow.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From compcert Require Import Coqlib Integers.
From Coq Require Import Lia ZArith.

Open Scope Z_scope.
(** Integer.max_unsigned *)

Global Transparent Int.repr.
Global Transparent Archi.ptr64.

Lemma Int_max_unsigned_eq64:
  Int.max_unsigned = 4294967295%Z.
Proof.
  unfold Int.max_unsigned, Int.modulus, Int.wordsize, Wordsize_32.wordsize.
  reflexivity.
Qed.

Lemma Ptrofs_max_unsigned_eq32:
  Ptrofs.max_unsigned = 4294967295.
Proof.
  unfold Ptrofs.max_unsigned, Ptrofs.modulus, Ptrofs.wordsize, Wordsize_Ptrofs.wordsize.
  reflexivity.
Qed.

Lemma Int_unsigned_ge_zero :
  forall i,
    Int.unsigned i >= 0.
Proof.
  intro.
  assert (Hrange: 0 <= Int.unsigned i <= Int.max_unsigned). { apply Int.unsigned_range_2. }
  destruct Hrange.
  (**r Search (_ <= _). *)
  apply Z.le_ge in H.
  assumption.
Qed.

Lemma Ptrofs_unsigned_ge_zero :
  forall i,
    Ptrofs.unsigned i >= 0.
Proof.
  intro.
  assert (Hrange: 0 <= Ptrofs.unsigned i <= Ptrofs.max_unsigned). { apply Ptrofs.unsigned_range_2. }
  destruct Hrange.
  (**r Search (_ <= _). *)
  apply Z.le_ge in H.
  assumption.
Qed.

Lemma Ptrofs_unsigned_repr_n:
  forall n,
  0 <= n <= 4294967295 ->
  Ptrofs.unsigned (Ptrofs.repr n) = n.
Proof.
  intros.
  rewrite Ptrofs.unsigned_repr; [reflexivity | rewrite Ptrofs_max_unsigned_eq32; lia].
Qed.

Lemma Int_unsigned_repr_n:
  forall n,
  0 <= n <= 4294967295 ->
  Int.unsigned (Int.repr n) = n.
Proof.
  intros.
  rewrite Int.unsigned_repr; [reflexivity | rewrite Int_max_unsigned_eq64; lia].
Qed.

Lemma Hint_unsigned_int64:
    forall i, (Int64.unsigned (Int64.repr (Int.unsigned i))) = (Int.unsigned i).
Proof.
    intro.
    rewrite Int64.unsigned_repr; [reflexivity |].
    assert (Hrange: 0 <= Int.unsigned i <= Int.max_unsigned). { apply Int.unsigned_range_2. }
    change Int.max_unsigned with 4294967295 in Hrange.
    change Int64.max_unsigned with 18446744073709551615.
    lia.
Qed.

Lemma Hzeq_neq_intro:
    forall (A:Type) a n (b c: A),
      (a <> n)%nat -> (if Coqlib.zeq (Z.of_nat n) (Z.of_nat a) then b else c) = c.
Proof.
  intros.
  apply zeq_false.
  intro.
  apply Nat2Z.inj in H0.
  lia.
Qed.

Lemma Int_repr_eq:
  forall a b
    (Ha_range: 0 <= a <= Int.max_unsigned)
    (Hb_range: 0 <= b <= Int.max_unsigned)
    (Heq: Int.repr a = Int.repr b),
      a = b.
Proof.
  intros.
  unfold Int.repr in Heq.
  inversion Heq.
  do 2 rewrite Int.Z_mod_modulus_eq in H0.
  change Int.modulus with 4294967296 in H0.
  change Int.max_unsigned with 4294967295 in *.
  rewrite Z.mod_small in H0; [ | lia].
  rewrite Z.mod_small in H0; [ | lia].
  assumption.
Qed.

Lemma Clt_Zlt_signed:
  forall ofs hi,
    Int.lt ofs hi = true ->
      Int.signed ofs < Int.signed hi.
Proof.
  intros.
  unfold Int.lt in H.
  destruct (Coqlib.zlt _ _) in H; try inversion H.
  assumption.
Qed.

Lemma Cle_Zle_signed:
  forall lo ofs,
    negb (Int.lt ofs lo) = true ->
      Int.signed lo <= Int.signed ofs.
Proof.
  intros.
  rewrite negb_true_iff in H.
  unfold Int.lt in H.
  destruct (Coqlib.zlt _ _) in H; try inversion H.
  lia.
Qed.

Lemma Clt_Zlt_unsigned:
  forall ofs hi,
    Int.ltu ofs hi = true ->
      Int.unsigned ofs < Int.unsigned hi.
Proof.
  intros.
  unfold Int.ltu in H.
  destruct (Coqlib.zlt _ _) in H; try inversion H.
  assumption.
Qed.

Lemma Cle_Zle_unsigned:
  forall lo ofs,
    negb (Int.ltu ofs lo) = true ->
      Int.unsigned lo <= Int.unsigned ofs.
Proof.
  intros.
  rewrite negb_true_iff in H.
  unfold Int.ltu in H.
  destruct (Coqlib.zlt _ _) in H; try inversion H.
  lia.
Qed.

Close Scope Z_scope.


Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Strings.String.
Require Import Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.EqdepFacts.
Require Import Coq.Logic.ProofIrrelevance.

Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import DetermA.
Require Import AbbrevA.
Require Import InvertA.

Module Hoare (IdT: IdModType) <: IdModType.

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

Module InvertI := Invert IdT.
Export InvertI.

Open Scope string_scope.
Import ListNotations.

Definition HoareTriple_Step
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EStep fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_ExtendedStep
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_Eval
           (P : W -> Prop) (Q : Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)) ->
    P s -> Q v s'.

Definition HoarePrmsTriple_Eval
           (P : W -> Prop) (Q : list Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (es: list Exp) : Prop :=
  forall (s s': W) (vs: list Value),
    PrmsClosure fenv env (Conf Prms s (PS es)) (Conf Prms s'
                                                     (PS (map Val vs))) ->
    P s -> Q vs s'.

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

Lemma write_T_1 {T: Type} (VT: ValTyp T) (f: T -> W)
      (P0: W -> Prop)
      (fenv: funEnv) (env: valEnv) (x: T):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (Write VT f x))
                   (Conf Exp s' e) ->
  P0 (f x) -> P0 s'.
  intros.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  unfold b_exec.
  unfold b_mod.
  unfold xf_write.
  simpl.
  eapply inj_pair2 in H8.
  rewrite H8.
  exact H.
  inversion X0.
Qed.

Definition WriteT1SHT {T: Type} (VT: ValTyp T) (f: T -> W)
           (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: T) :=
  HoareTriple_Step (fun _ => P0 (f x)) (fun _ s => P0 s)
                   fenv env (Write VT f x).

Lemma write_T_1_sht {T: Type} (VT: ValTyp T) (f: T -> W)
      (P0: W -> Prop)
      (fenv: funEnv) (env: valEnv) (x: T):
  forall (s s': W) (e: Exp),
    WriteT1SHT VT f P0 fenv env x.
  unfold WriteT1SHT.
  unfold HoareTriple_Step.
  intros.
  eapply write_T_1.
  eauto.
  auto.
Qed.

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

Lemma bindn_congruence0 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    (forall s, P s -> P1 s) ->
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros E H e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  eapply E.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

Lemma bindn_congruence1 (P: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P) fenv env e ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros H e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

Lemma bindn_congruence2 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    (forall (e1: Exp) (v: Value),
       HoareTriple_Step P (fun _ => P1) fenv env (BindN (Val v) e1)) ->
    forall e1: Exp,
    HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
  unfold HoareTriple_Step, HoareTriple_Eval.
  intros H K e1 s1 s2 e2.
  intros H0 H1.
  inversion H0; subst.
  eapply K.
  eauto.
  auto.
  eapply H in X.
  auto.
  auto.
Qed.

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

Lemma BindN_VHT1 (P0 P1: W -> Prop) (P2: Value -> W -> Prop)
      (fenv: funEnv) (env: valEnv) (e1 e2: Exp)
      (k1: forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))
      (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :
  HoareTriple_Eval P0 (fun _ => P1) fenv env e1 ->
  HoareTriple_Eval P1 P2 fenv env e2 ->
  HoareTriple_Eval P0 P2 fenv env (BindN e1 e2).
  unfold HoareTriple_Eval.
  intros.
  eapply BindN_BStep1 in X.
  destruct X as [s1 X].
  destruct X as [v1 X].
  eapply H0.
  eauto.
  eapply H.
  eauto.
  auto.
  auto.
  auto.
Qed.

Lemma BindS_VHT1 (P0: W -> Prop) (P1 P2: Value -> W -> Prop)

(fenv: funEnv) (env: valEnv) (e1 e2: Exp) (x: Id)

(k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))

      (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :

  HoareTriple_Eval P0 P1 fenv env e1 ->
  (forall v, HoareTriple_Eval (P1 v) P2 fenv ((x,v)::env) e2) ->
  HoareTriple_Eval P0 P2 fenv env (BindS x e1 e2).
Proof.
  unfold HoareTriple_Eval.
  intros.
  eapply BindS_BStep1 in X.
  destruct X as [s1 X].
  destruct X as [v1 X].
  eapply H0.
  eauto.
  eapply H.
  eauto.
  auto.
  auto.
  auto.
Qed.

Lemma Apply_VHT1 (P0: W -> Prop) (P1: list Value -> W -> Prop)
                 (P2: Value -> W -> Prop)
   (fenv: funEnv) (env: valEnv) (f: Fun) (es: list Exp)
     (k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))

     (k2: forall (fenv: funEnv) (env: valEnv) (es:list Exp) (s: W),
      sigT (fun vs: list Value =>
                 sigT (fun s': W =>
      PrmsClosure fenv env (Conf Prms s (PS es))
                           (Conf Prms s' (PS (map Val vs))))))

     (k3: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
          (s1 = s2) /\ (v1 = v2)) :

  HoarePrmsTriple_Eval P0 P1 fenv env es ->
  match f with
  | FC fenv' tenv' e0 e1 x n =>
    length tenv' = length es /\
    match n with
    | 0 => (forall vs: list Value,
          HoareTriple_Eval (P1 vs) P2 fenv' (mkVEnv tenv' vs) e0)
    | S n' => (forall vs: list Value,
          HoareTriple_Eval (P1 vs) P2 ((x,FC fenv' tenv' e0 e1 x n')::fenv')
                           (mkVEnv tenv' vs) e1)
    end
  end ->
  HoareTriple_Eval P0 P2 fenv env (Apply (QF f) (PS es)).
Proof.
  unfold HoareTriple_Eval, HoarePrmsTriple_Eval.
  intros.
  generalize (Apply_BStep1 fenv env f es v s s' k1 k2 k3).
  intro P.
  destruct f.
  destruct H0.
  specialize (P H0 X).
  destruct P as [s1 P].
  destruct P as [vs P].
  specialize (H s s1 vs P H1).
  destruct n.
  specialize (H2 vs s1 s' v y H).
  exact H2.
  specialize (H2 vs s1 s' v y H).
  exact H2.
Qed.

End Hoare.


Require Import SepTypes.Functor SepTypes.OrderedType SepTypes.OFuns
        SepTypes.PChain SepTypes.Tree.

(* Some weird notations. *)
Notation "'ϕ'" := unfoldCompose (at level 65) : mem_scope.
Notation "'ψ'" := foldCompose (at level 65) : mem_scope.
Notation "a '×' b" := (ProductF a b) (at level 65) : mem_scope.
Notation "'|' x '|'" := (ConstantF x) (at level 65) : mem_scope.
Notation "'ϒ' x" := (TreeF x) (at level 65) : mem_scope.

Open Scope mem_scope.

(** The recursive type for memory stores. *)
Section mem.
  Context Z `{OType Z}.

  Definition permF : TypeF := PERF × PreOrderF.

  Definition memF : TypeF := |Z| × ϒ permF.

  Definition MemDiag : nat -> Type := type_n memF.
  Definition Mem := PChain (type_n memF).

  Definition MemPERDiag f `{PDiagram f} := typeSequenceMap f PERF.
  Definition MemPER f `{PDiagram f} := PChain (MemPERDiag f).

  Definition MemPreOrderDiag f `{PDiagram f} := typeSequenceMap f PreOrderF.
  Definition MemPreOrder f `{PDiagram f} := PChain (MemPreOrderDiag f).

  Definition Perm f `{PDiagram f} := (MemPER f * MemPreOrder f)%type.

  (* These are a bit slow to typecheck... *)
  (* But at least they verify that the UnfoldF instance generated by
     typeclass resolution is the type we expect. *)
  (* Definition unfoldSanityCheck *)
  (*   : Mem -o> Z * Tree (Perm (type_n memF)) := ϕ memF. *)
  (* Definition foldSanityCheck *)
  (*   : Z * Tree (Perm (type_n memF)) -o> Mem := ψ memF. *)

  (** To build a Mem, it suffices to build an element of
      [Z * Tree (Perm (type_n memF))] and then apply the fold
      operation. *)

  (* Turn a chain of PERs to a PER on PChains. *)
  Definition memPEREq {f} `{PDiagram f} (per : MemPER f)
    : relation (PChain f) :=
    fun c1 c2 => forall n, proj1_sig (chain per n) (chain c1 n) (chain c2 n).

  (* Turn a chain of preorders to a preorder on PChains. *)
  Definition memPreOrderEq {f} `{PDiagram f} (po : MemPreOrder f)
    : relation (PChain f) :=
    fun c1 c2 => forall n, proj1_sig (chain po n) (chain c1 n) (chain c2 n).

  (* Turn a permission into a PER on PChains. *)
  Definition permEq {f} `{PDiagram f} (p : Perm f) : relation (PChain f) :=
    memPEREq (fst p).

  (* Turn a permission into a preorder on PChains. *)
  Definition permUpd {f} `{PDiagram f} (p : Perm f) : relation (PChain f) :=
    memPreOrderEq (snd p).

  (* A generic contramap operation for relations. *)
  Definition contramap_rel {A B} `{OType A} `{OType B} (f : A -o> B)
             (R : relation B) : relation A :=
    fun x y => R (f @@ x) (f @@ y).

  (* Here we assume that the diagram starts at F unit rather than
     unit. This makes the fixpoint functions much simpler. So, given a
     relation on F unit, we can construct a relation on chains of the
     diagram F unit, F (F unit), ... and then extend it to the full
     diagram by prepending the trivial relation on unit to the
     front. *)

  Program Fixpoint mkPER_f {f} `{PDiagram f}
          (R0 : relation (f 0)) n : relation (f n) :=
    match n with
    | O => R0
    | S n' => contramap_rel (proj n') (mkPER_f R0 n')
    end.

  Program Fixpoint mkPreOrder_f {f} `{PDiagram f}
          (R0 : relation (f 0)) n : relation (f n) :=
    match n with
    | O => R0
    | S n' => contramap_rel (proj n') (mkPreOrder_f R0 n')
    end.

  Lemma exist_inv {A : Type} `{OType A} {P : A -> Prop}
        (a b : {x : A | P x}) :
    a =o= b -> proj1_sig a =o= proj1_sig b.
  Proof. firstorder. Qed.

  Lemma exist_oeq {A : Type} `{OType A} {P : A -> Prop}
        (a b : {x : A | P x}) :
    proj1_sig a =o= proj1_sig b -> a =o= b.
  Proof. firstorder. Qed.

  Instance Proper_mkPER_f {f} `{PDiagram f} R n :
    Proper (oeq ==> oeq ==> oleq) R ->
    Proper (oeq ==> oeq ==> oleq) (mkPER_f R n).
  Proof.
    intros Hprop x y Heq1 z w Heq2.
    induction n; simpl in *.
    - rewrite Heq1, Heq2. reflexivity.
    - unfold contramap_rel. apply IHn.
      rewrite Heq1; reflexivity.
      rewrite Heq2; reflexivity.
  Qed.

  Instance Transitive_mkPER_f {f} `{PDiagram f} R n :
    Transitive  R ->
    Transitive (mkPER_f R n).
  Proof.
    intros HTrans x y z Hxy Hyz.
    induction n; simpl in *.
    - etransitivity; eauto.
    - eapply IHn; eauto.
  Qed.

  (* Build a chain of PER relations from a single one. *)
  Program Definition mkPER {f} `{PDiagram f} (R : relation (f 0))
          {per : Per R} : MemPER f :=
    {| chain := mkPER_f R |}.
  Next Obligation.
    rename x into n.
    constructor.
    - intros x y Heq1 z w Heq2 Hr.
      induction n; auto.
      + destruct per. rewrite <- Heq1, <- Heq2; auto.
      + eapply IHn; eauto. rewrite Heq1; reflexivity.
        rewrite Heq2; reflexivity.
    - intros x y Hr.
      induction n; auto; simpl in *.
      + destruct per; auto.
      + apply IHn. auto.
    - intros x y z Hzy Hyz.
      induction n; auto.
      destruct per; eapply Transitive_Per; eauto.
      eapply IHn; eauto.
  Qed.

  (* Here we need "pseudo-embed" functions to complete the proof. *)
  Next Obligation.
    simpl.
    apply exist_oeq; simpl.
    split.
    - intros x y Hr.
      apply t_step.
      assert (exists x1, proj n @@ x1 =o= x).
      { admit. }
      assert (exists x2, proj n @@ x2 =o= y).
      { admit. }
      destruct H1 as [x1 ?], H2 as [x2 ?].
      exists x1, x2. split; auto. split; auto.
      unfold contramap_rel.
      destruct per.
      rewrite H1, H2; auto.
    - intros x y Hclos.
      induction Hclos.
      + destruct H1 as (x1 & x2 & ? & ? & ?).
        unfold contramap_rel in H3.
        destruct per.
        rewrite <- H1, <- H2; auto.
      + destruct per; etransitivity; eauto.
  Admitted.

  (* Build a chain of preorder relations from a single one. *)
  Program Definition mkPreOrder {f} `{PDiagram f} (R : relation (f 0))
          {po : Preorder R} : MemPreOrder f :=
    {| chain := mkPreOrder_f R |}.
  Next Obligation.
    rename x into n.
    constructor.
    - intros x y Heq1 z w Heq2 Hr.
      induction n; auto.
      + destruct po. rewrite <- Heq1, <- Heq2; auto.
      + eapply IHn; eauto. rewrite Heq1; reflexivity.
        rewrite Heq2; reflexivity.
    - constructor.
      + intros x. induction n; simpl; auto.
        destruct po as [_ []]; auto.
        apply IHn.
      + intros x y z Hxy Hyz. induction n; auto.
        destruct po as [_ []].
        eapply PreOrder_Transitive; eauto.
        eapply IHn; eauto.
  Qed.

  Next Obligation. Admitted.

End mem.


Definition teq_shift_dbselect0 :=
fun (i j : nat) (eqT gtT ltT : Term) => teq_shift_dbselect 0 i j eqT gtT ltT
     : forall (i j : nat) (eqT gtT ltT : Term),
       Shift (dbselect i j eqT gtT ltT) = dbselect i j (Shift eqT) (Shift gtT) (Shift ltT).


 (*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export substc_more.
Require Export sequents_tacs.
Require Export per_props_product.
Require Export per_props_function.
Require Export per_props_squash.
Require Export per_props_equality.
Require Export per_props_nat2.
Require Export lsubstc_vars.

(*

   forall m : nat, squash (exists n : nat, P(m,n))

   implies

   squash (exists f : nat -> nat, forall m : nat, squash (P (m, f m)))

 *)
Lemma axiom_of_choice_00 {o} :
  forall lib f m n (P : @CTerm o),
    n <> m
    -> f <> m
    -> (forall a b,
          member lib a mkc_tnat
          -> member lib b mkc_tnat
          -> type lib (mkc_apply2 P a b))
    -> inhabited_type
         lib
         (mkc_forall
            mkc_tnat
            m
            (mkcv_squash
               [m]
               (mkcv_exists
                  [m]
                  (mkcv_tnat [m])
                  n
                  (mkcv_apply2 [n,m]
                               (mk_cv [n,m] P)
                               (mk_cv_app_l [n] [m] (mkc_var m))
                               (mk_cv_app_r [m] [n] (mkc_var n))))))
    -> inhabited_type
         lib
         (mkc_exists
            nat2nat
            f
            (mkcv_forall
               [f]
               (mk_cv [f] mkc_tnat)
               m
               (mkcv_squash
                  [m,f]
                  (mkcv_apply2 [m,f]
                               (mk_cv [m,f] P)
                               (mk_cv_app_r [f] [m] (mkc_var m))
                               (mkcv_apply [m,f]
                                           (mk_cv_app_l [m] [f] (mkc_var f))
                                           (mk_cv_app_r [f] [m] (mkc_var m))))))).
Proof.
  introv d1 d2 impp inh.

  unfold mkc_forall in inh.
  apply inhabited_function in inh.
  repnd.
  clear inh0 inh1.
  exrepnd.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> inhabited_type
                 lib
                 (mkc_exists
                    mkc_tnat
                    n
                    (mkcv_apply2
                       [n]
                       (mk_cv [n] P)
                       (mk_cv [n] k)
                       (mkc_var n)))) as q.
  { introv mem.
    pose proof (inh0 k k) as h.
    autodimp h hyp.
    allrw @substc_mkcv_squash.
    rw @equality_in_mkc_squash in h.
    repnd.
    rw @mkcv_exists_substc in h; auto.
    allrw @mkcv_tnat_substc.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv_app_l.
    rw @substc2_mk_cv_app_r in h; auto.
    allrw @substc2_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear inh0.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> {j : CTerm
                , member lib j mkc_tnat
                # inhabited_type lib (mkc_apply2 P k j)}) as h.
  { introv mem.
    apply q in mem; clear q.
    apply inhabited_exists in mem; repnd.
    clear mem0 mem1.
    exrepnd.
    exists a; dands; auto.
    allrw @mkcv_apply2_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear q.

  (* First use FunctionalChoice_on to get an existential (a Coq function from terms to terms) *)

  pose proof (FunctionalChoice_on
                {k : CTerm & member lib k mkc_tnat}
                (@CTerm o)
                (fun k j => member lib j mkc_tnat # inhabited_type lib (mkc_apply2 P (projT1 k) j)))
    as fc.
  simphyps.
  autodimp fc hyp; tcsp;[].
  exrepnd.
  clear h.
  rename fc0 into fc.

  assert {c : nat -> nat
          & forall a : CTerm,
              member lib a mkc_tnat
              -> (member lib (mkc_eapply (mkc_nseq c) a) mkc_tnat
                  # inhabited_type lib (mkc_apply2 P a (mkc_eapply (mkc_nseq c) a)))} as fs.
  { exists (fun n =>
              match member_tnat_implies_computes
                      lib
                      (f1 (existT _ (mkc_nat n) (nat_in_nat lib n)))
                      (fst (fc (existT _ (mkc_nat n) (nat_in_nat lib n)))) with
                | existT _ k _ => k
              end).
    introv mem.
    dands.

    - apply member_tnat_iff in mem; exrepnd.
      allrw @computes_to_valc_iff_reduces_toc; repnd.
      eapply member_respects_reduces_toc;[apply reduces_toc_eapply_nseq;exact mem1|].

      remember (member_tnat_implies_computes
                  lib
                  (f1 exI(mkc_nat k, nat_in_nat lib k))
                  (fst (fc exI(mkc_nat k, nat_in_nat lib k)))) as mt.
      exrepnd.

      apply (member_respects_reduces_toc _ _ (mkc_nat k0)).

      + unfold reduces_toc; simpl.
        apply reduces_to_if_step.
        csunf; allsimpl; dcwf h; simpl.
        boolvar; try omega.
        rw @Znat.Nat2Z.id.
        rewrite <- Heqmt; auto.

      + apply member_tnat_iff.
        exists k0.
        apply computes_to_valc_refl; eauto 3 with slow.

    - apply member_tnat_iff in mem; exrepnd.
      pose proof (nat_in_nat lib k) as mk.

      remember (member_tnat_implies_computes
                  lib
                  (f1 exI(mkc_nat k, nat_in_nat lib k))
                  (fst (fc exI(mkc_nat k, nat_in_nat lib k)))) as q.
      exrepnd.
      remember (fc exI(mkc_nat k, nat_in_nat lib k)) as fck.
      exrepnd.
      allsimpl.

      allunfold @inhabited_type; exrepnd.
      exists t.
      allsimpl.

      eapply member_respects_cequivc_type;[|exact fck1].
      apply implies_cequivc_apply2; auto.

      + apply cequivc_sym.
        apply computes_to_valc_implies_cequivc; auto.

      + apply cequivc_sym.
        allrw @computes_to_valc_iff_reduces_toc; repnd.
        eapply cequivc_trans;
          [apply reduces_toc_implies_cequivc;
            apply reduces_toc_eapply_nseq;exact mem1
          |].

        eapply cequivc_trans;
          [|apply cequivc_sym;
             apply computes_to_valc_implies_cequivc;
             exact q0].
        apply reduces_toc_implies_cequivc.
        unfold reduces_toc; simpl.
        apply reduces_to_if_step.
        csunf; simpl; dcwf h; simpl.
        boolvar; try omega.
        allrw @Znat.Nat2Z.id.
        allsimpl.
        rw <- Heqfck; simpl.
        rw <- Heqq; auto.
  }
  clear f1 fc.
  exrepnd.

  (* then "convert" the Coq function into a Nuprl function *)

  apply inhabited_product.

  dands.

  { apply type_nat2nat. }

  { introv eqf.
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    apply tequality_function.
    dands.
    { apply tnat_type. }

    introv eqn.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @substc2_mk_cv.
    allrw @csubst_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.

    apply tequality_mkc_squash.
    apply type_respects_cequivc_left.

    { apply implies_cequivc_apply2; auto.
      { apply equality_int_nat_implies_cequivc; auto.
        apply equality_sym; auto. }
      { eapply equality_nat2nat_apply in eqf;[|exact eqn].
        apply equality_int_nat_implies_cequivc; auto.
        apply equality_sym; auto. }
    }

    { apply impp; eauto 3 with slow.
      { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
      { eapply equality_nat2nat_apply in eqf;[|exact eqn].
        apply equality_sym in eqf; apply equality_refl in eqf; auto. }
    }
  }

  { exists (@mkc_nseq o c).
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkc_var_substc.

    dands.

    { apply member_nseq_nat2nat. }

    { apply inhabited_function; dands; eauto 3 with slow.

      - introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        apply tequality_mkc_squash.
        apply type_respects_cequivc_left.

        { apply implies_cequivc_apply2; auto.
          { apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
          { apply implies_cequivc_apply; auto.
            apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
        }

        { apply impp; eauto 3 with slow.
          { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
          { pose proof (member_nseq_nat2nat lib c) as eqf.
            eapply equality_nat2nat_apply in eqf;[|exact eqn].
            apply equality_sym in eqf; apply equality_refl in eqf; auto. }
        }

      - exists (@mkc_lam o nvarx (mkcv_axiom nvarx)).
        introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        applydup @equality_int_nat_implies_cequivc in eqn.
        apply equality_refl in eqn.
        eapply equality_respects_cequivc_right;
          [apply implies_cequivc_apply;
            [apply cequivc_refl
            |exact eqn0]
          |].
        rw @member_eq.

        eapply member_respects_cequivc;
          [apply cequivc_sym;
            apply cequivc_beta
          |].
        rw @substc_mkcv_axiom.

        apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow).

        pose proof (fs0 a eqn) as q; repnd.

        eapply inhabited_type_cequivc;[|exact q].
        apply implies_cequivc_apply2; auto.
        apply cequivc_sym.
        apply reduces_toc_implies_cequivc.
        destruct_cterms.
        unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl; auto.
    }
  }
Qed.

Definition rule_AC00 {o}
           (P e : @NTerm o)
           (f m n : NVar)
           (H : barehypotheses)
           (i : nat) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_squash (mk_exists (mk_nat2nat) f (mk_forall mk_tnat n (mk_squash (mk_apply2 P (mk_var n) (mk_apply (mk_var f) (mk_var n)))))))))
      [ mk_baresequent H (mk_concl (mk_forall mk_tnat n (mk_squash (mk_exists mk_tnat m (mk_apply2 P (mk_var n) (mk_var m))))) e),
        mk_baresequent H (mk_conclax (mk_member P (mk_fun mk_tnat (mk_fun mk_tnat (mk_uni i))))) ]
      [].

Lemma rule_AC00_true {p} :
  forall lib
         (P e : NTerm)
         (f m n : NVar)
         (H : @barehypotheses p)
         (i : nat)
         (d1 : n <> m)
         (d2 : f <> n)
         (d3 : !LIn f (free_vars P))
         (d4 : !LIn m (free_vars P))
         (d5 : !LIn n (free_vars P)),
    rule_true lib (rule_AC00 P e f m n H i).
Proof.
  unfold rule_AC00, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].
  rename Hyp0 into hyp2.
  destruct hyp2 as [wc2 hyp2].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hh; exrepnd; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as qq; exrepnd; clear hyp2.

  allunfold @mk_forall.
  allunfold @mk_exists.
  allunfold @mk_nat2nat.

  lsubst_tac.
  allapply @member_if_inhabited.
  apply tequality_mkc_member_implies_sp in qq0; auto;[].
  allrw @tequality_mkc_member; repnd.

  lsubst_tac.
  allrw @lsubstc_mkc_tnat.

  pose proof (axiom_of_choice_00 lib f n m (lsubstc P wt s1 ct1)) as ac.
  repeat (autodimp ac hyp).

  - (* from qq1 *)
    introv m1 m2.
    apply equality_in_fun in qq1; repnd.
    pose proof (qq1 a a) as h.
    autodimp h hyp.
    lsubst_tac.
    allrw @lsubstc_mkc_tnat.
    apply equality_in_fun in h; repnd.
    pose proof (h b b) as q.
    autodimp q hyp.
    apply equality_in_uni in q; auto.
    allrw <- @mkc_apply2_eq; auto.

  - (* from hh1 *)
    apply equality_refl in hh1.
    exists (lsubstc e wfce1 s1 pt0).

    repeat lsubstc_vars_as_mkcv.
    auto.

  - repeat lsubstc_vars_as_mkcv.

    dands;
      [|apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow);
        allunfold @mkc_exists; allunfold @mkcv_forall;
        eapply inhabited_type_respects_alphaeqc;[|exact ac];
        apply alphaeqc_mkc_product1;
        apply alphaeqc_sym; apply lsubstc_mk_nat2nat].

    apply tequality_mkc_squash.

    eapply tequality_respects_alphaeqc_left;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        apply lsubstc_mk_nat2nat
      |].
    eapply tequality_respects_alphaeqc_right;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        apply lsubstc_mk_nat2nat
      |].
    apply tequality_product; dands.
    { apply type_nat2nat. }

    introv eqf.
    repeat (rw @substc_mkcv_function; auto;[]).
    allrw @mkcv_tnat_substc.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_apply.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto;[]).
    repeat (rw @substc2_mk_cv_app_l; auto;[]).
    allrw @mkc_var_substc.

    apply tequality_function; dands.
    { apply tnat_type. }

    introv eqn.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @mkcv_apply_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.

    apply tequality_mkc_squash.
    apply equality_in_fun in qq0; repnd.
    applydup qq0 in eqn.
    lsubst_tac.
    apply equality_in_fun in eqn0; repnd.
    pose proof (eqn0 (mkc_apply a a0) (mkc_apply a' a'0)) as q.
    allrw @lsubstc_mkc_tnat.
    autodimp q hyp.
    { apply equality_nat2nat_apply; auto. }
    allrw <- @mkc_apply2_eq.
    apply equality_in_uni in q; auto.
Qed.

(*

   forall f : nat -> nat, squash exists n : nat, P(f,n)

   implies

   squash exists F : (nat -> nat) -> nat, forall f : nat -> nat, P (f, F f)

 *)
Lemma axiom_of_choice_10 {o} :
  forall lib F f n (P : @CTerm o),
    n <> f
    -> inhabited_type
         lib
         (mkc_forall
            nat2nat
            f
            (mkcv_squash
               [f]
               (mkcv_exists
                  [f]
                  (mkcv_tnat [f])
                  n
                  (mkcv_apply2 [n,f]
                               (mk_cv [n,f] P)
                               (mk_cv_app_l [n] [f] (mkc_var f))
                               (mk_cv_app_r [f] [n] (mkc_var n))))))
    -> inhabited_type
         lib
         (mkc_squash
            (mkc_exists
               (mkc_fun nat2nat mkc_tnat)
               F
               (mkcv_forall
                  [F]
                  (mk_cv [F] nat2nat)
                  f
                  (mkcv_apply2 [f,F]
                               (mk_cv [f,F] P)
                               (mk_cv_app_r [F] [f] (mkc_var f))
                               (mkcv_apply [f,F]
                                           (mk_cv_app_l [f] [F] (mkc_var F))
                                           (mk_cv_app_r [F] [f] (mkc_var f))))))).
Proof.
  introv d1 inh.
  apply inhabited_squash.

  unfold mkc_forall in inh.
  apply inhabited_function in inh.
  repnd.
  clear inh0 inh1.
  exrepnd.

  assert (forall f : CTerm,
            member lib f nat2nat
            -> inhabited_type
                 lib
                 (mkc_exists
                    mkc_tnat
                    n
                    (mkcv_apply2
                       [n]
                       (mk_cv [n] P)
                       (mk_cv [n] f)
                       (mkc_var n)))) as q.
  { introv mem.
    pose proof (inh0 f1 f1) as h.
    autodimp h hyp.
    allrw @substc_mkcv_squash.
    rw @equality_in_mkc_squash in h.
    repnd.
    rw @mkcv_exists_substc in h; auto.
    allrw @mkcv_tnat_substc.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv_app_l.
    rw @substc2_mk_cv_app_r in h; auto.
    allrw @substc2_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear inh0.

  assert (forall f : CTerm,
            member lib f nat2nat
            -> {k : CTerm
                , member lib k mkc_tnat
                # inhabited_type lib (mkc_apply2 P f k)}) as h.
  { introv mem.
    apply q in mem; clear q.
    apply inhabited_exists in mem; repnd.
    clear mem0 mem1.
    exrepnd.
    exists a; dands; auto.
    allrw @mkcv_apply2_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear q.

Abort.


(* TLC in Coq
 *
 * Module: tlc.syntax.constructor
 * Purpose: Contains the syntax of constructors.
 *)

Require Import mathcomp.ssreflect.choice.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Constructors for value terms *)
Inductive constructor :=
(* Unit *)
| CUnit
(* Maybe *)
| CNone
| CSome
(* Either *)
| CLeft
| CRight
(* Pair *)
| CPair
(* Boolean *)
| CFalse
| CTrue
(* Natural *)
| CZero
| CSucc
(* List *)
| CNil
| CCons
(* Orientation *)
| CRequest
| CIndication
| CPeriodic
(* PeriodicEvent *)
| CPE
(* FLRequest *)
| CFLSend
(* FLIndication *)
| CFLDeliver
(* SLRequest *)
| CSLSend
(* SLIndication *)
| CSLDeliver
(* PLRequest *)
| CPLSend
(* PLIndication *)
| CPLDeliver.

(* Equality *)
Section eq.

  (* Boolean equality *)
  Definition constructor_eq f1 f2 :=
    match f1, f2 with
    (* Unit *)
    | CUnit, CUnit => true
    (* Maybe *)
    | CNone, CNone => true
    | CSome, CSome => true
    (* Either *)
    | CLeft, CLeft => true
    | CRight, CRight => true
    (* Pair *)
    | CPair, CPair => true
    (* Boolean *)
    | CFalse, CFalse => true
    | CTrue, CTrue => true
    (* Natural *)
    | CZero, CZero => true
    | CSucc, CSucc => true
    (* List *)
    | CNil, CNil => true
    | CCons, CCons => true
    (* Orientation *)
    | CRequest, CRequest => true
    | CIndication, CIndication => true
    | CPeriodic, CPeriodic => true
    (* PeriodicEvent *)
    | CPE, CPE => true
    (* FLRequest *)
    | CFLSend, CFLSend => true
    (* FLIndication *)
    | CFLDeliver, CFLDeliver => true
    (* SLRequest *)
    | CSLSend, CSLSend => true
    (* SLIndication *)
    | CSLDeliver, CSLDeliver => true
    (* PLRequest *)
    | CPLSend, CPLSend => true
    (* PLIndication *)
    | CPLDeliver, CPLDeliver => true
    (* Unequal *)
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma constructor_eqP : Equality.axiom constructor_eq.
  Proof.
    by case; case; constructor.
  Qed.

  (* EqType canonical structures *)
  Definition constructor_eqMixin := EqMixin constructor_eqP.
  Canonical constructor_eqType := EqType constructor constructor_eqMixin.

End eq.