Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 3
*)

(** 1 Mutual Coinduction *)

Section Arg3_1.

Definition monotone3 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r r' (IN: gf r x0 x1 x2) (LE: r <3= r'), gf r' x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf : rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Implicit Arguments gf [].

Theorem paco3_acc: forall
  l r (OBG: forall rr (INC: r <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3 gf rr),
  l <3= paco3 gf r.
Proof.
  intros; assert (SIM: paco3 gf (r \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_mon: monotone3 (paco3 gf).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_mult_strong: forall r,
  paco3 gf (upaco3 gf r) <3= paco3 gf r.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_mult: forall r,
  paco3 gf (paco3 gf r) <3= paco3 gf r.
Proof. intros; eapply paco3_mult_strong, paco3_mon; eauto. Qed.

Theorem paco3_fold: forall r,
  gf (upaco3 gf r) <3= paco3 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco3_unfold: forall (MON: monotone3 gf) r,
  paco3 gf r <3= gf (upaco3 gf r).
Proof. unfold monotone3; intros; destruct PR; eauto. Qed.

End Arg3_1.

Hint Unfold monotone3.
Hint Resolve paco3_fold.

Implicit Arguments paco3_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_unfold         [ T0 T1 T2 ].

Instance paco3_inst  T0 T1 T2 (gf : rel3 T0 T1 T2->_) r x0 x1 x2 : paco_class (paco3 gf r x0 x1 x2) :=
{ pacoacc    := paco3_acc gf;
  pacomult   := paco3_mult gf;
  pacofold   := paco3_fold gf;
  pacounfold := paco3_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg3_2.

Definition monotone3_2 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2) (LE_0: r_0 <3= r'_0)(LE_1: r_1 <3= r'_1), gf r'_0 r'_1 x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf_0 gf_1 : rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco3_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_2_0 gf_0 gf_1 rr r_1),
  l <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco3_2_0 gf_0 gf_1 (r_0 \3/ l) r_1 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_2_1 gf_0 gf_1 r_0 rr),
  l <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco3_2_1 gf_0 gf_1 r_0 (r_1 \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_2_0_mon: monotone3_2 (paco3_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_1_mon: monotone3_2 (paco3_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_0_mult_strong: forall r_0 r_1,
  paco3_2_0 gf_0 gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_2_1_mult_strong: forall r_0 r_1,
  paco3_2_1 gf_0 gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_2_0_mult: forall r_0 r_1,
  paco3_2_0 gf_0 gf_1 (paco3_2_0 gf_0 gf_1 r_0 r_1) (paco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco3_2_0_mult_strong, paco3_2_0_mon; eauto. Qed.

Corollary paco3_2_1_mult: forall r_0 r_1,
  paco3_2_1 gf_0 gf_1 (paco3_2_0 gf_0 gf_1 r_0 r_1) (paco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco3_2_1_mult_strong, paco3_2_1_mon; eauto. Qed.

Theorem paco3_2_0_fold: forall r_0 r_1,
  gf_0 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco3_2_1_fold: forall r_0 r_1,
  gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1) <3= paco3_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco3_2_0_unfold: forall (MON: monotone3_2 gf_0) (MON: monotone3_2 gf_1) r_0 r_1,
  paco3_2_0 gf_0 gf_1 r_0 r_1 <3= gf_0 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone3_2; intros; destruct PR; eauto. Qed.

Theorem paco3_2_1_unfold: forall (MON: monotone3_2 gf_0) (MON: monotone3_2 gf_1) r_0 r_1,
  paco3_2_1 gf_0 gf_1 r_0 r_1 <3= gf_1 (upaco3_2_0 gf_0 gf_1 r_0 r_1) (upaco3_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone3_2; intros; destruct PR; eauto. Qed.

End Arg3_2.

Hint Unfold monotone3_2.
Hint Resolve paco3_2_0_fold.
Hint Resolve paco3_2_1_fold.

Implicit Arguments paco3_2_0_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_2_0_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_2_0_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_2_0_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_2_0_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_2_0_unfold         [ T0 T1 T2 ].
Implicit Arguments paco3_2_1_unfold         [ T0 T1 T2 ].

Instance paco3_2_0_inst  T0 T1 T2 (gf_0 gf_1 : rel3 T0 T1 T2->_) r_0 r_1 x0 x1 x2 : paco_class (paco3_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2) :=
{ pacoacc    := paco3_2_0_acc gf_0 gf_1;
  pacomult   := paco3_2_0_mult gf_0 gf_1;
  pacofold   := paco3_2_0_fold gf_0 gf_1;
  pacounfold := paco3_2_0_unfold gf_0 gf_1 }.

Instance paco3_2_1_inst  T0 T1 T2 (gf_0 gf_1 : rel3 T0 T1 T2->_) r_0 r_1 x0 x1 x2 : paco_class (paco3_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2) :=
{ pacoacc    := paco3_2_1_acc gf_0 gf_1;
  pacomult   := paco3_2_1_mult gf_0 gf_1;
  pacofold   := paco3_2_1_fold gf_0 gf_1;
  pacounfold := paco3_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg3_3.

Definition monotone3_3 T0 T1 T2 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2) (LE_0: r_0 <3= r'_0)(LE_1: r_1 <3= r'_1)(LE_2: r_2 <3= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable gf_0 gf_1 gf_2 : rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco3_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_0 gf_0 gf_1 gf_2 (r_0 \3/ l) r_1 r_2 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \3/ l) r_2 x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <3= rr) (CIH: l <_paco_3= rr), l <_paco_3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \3/ l) x0 x1 x2) by eauto.
  clear PR; repeat (try left; do 4 paco_revert; paco_cofix_auto).
Qed.

Theorem paco3_3_0_mon: monotone3_3 (paco3_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_1_mon: monotone3_3 (paco3_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_2_mon: monotone3_3 (paco3_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_0_mult_strong: forall r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_1_mult_strong: forall r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Theorem paco3_3_2_mult_strong: forall r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 4 paco_revert; paco_cofix_auto). Qed.

Corollary paco3_3_0_mult: forall r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_0_mult_strong, paco3_3_0_mon; eauto. Qed.

Corollary paco3_3_1_mult: forall r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_1_mult_strong, paco3_3_1_mon; eauto. Qed.

Corollary paco3_3_2_mult: forall r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco3_3_2_mult_strong, paco3_3_2_mon; eauto. Qed.

Theorem paco3_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <3= paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco3_3_0_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_0 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

Theorem paco3_3_1_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_1 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

Theorem paco3_3_2_unfold: forall (MON: monotone3_3 gf_0) (MON: monotone3_3 gf_1) (MON: monotone3_3 gf_2) r_0 r_1 r_2,
  paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <3= gf_2 (upaco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone3_3; intros; destruct PR; eauto. Qed.

End Arg3_3.

Hint Unfold monotone3_3.
Hint Resolve paco3_3_0_fold.
Hint Resolve paco3_3_1_fold.
Hint Resolve paco3_3_2_fold.

Implicit Arguments paco3_3_0_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_acc            [ T0 T1 T2 ].
Implicit Arguments paco3_3_0_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_mon            [ T0 T1 T2 ].
Implicit Arguments paco3_3_0_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_mult_strong    [ T0 T1 T2 ].
Implicit Arguments paco3_3_0_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_mult           [ T0 T1 T2 ].
Implicit Arguments paco3_3_0_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_fold           [ T0 T1 T2 ].
Implicit Arguments paco3_3_0_unfold         [ T0 T1 T2 ].
Implicit Arguments paco3_3_1_unfold         [ T0 T1 T2 ].
Implicit Arguments paco3_3_2_unfold         [ T0 T1 T2 ].

Instance paco3_3_0_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco3_3_1_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco3_3_2_inst  T0 T1 T2 (gf_0 gf_1 gf_2 : rel3 T0 T1 T2->_) r_0 r_1 r_2 x0 x1 x2 : paco_class (paco3_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2) :=
{ pacoacc    := paco3_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco3_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco3_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco3_3_2_unfold gf_0 gf_1 gf_2 }.


(* An attempt at a value type for generalized environments. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Keys for environment signature.
**************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibTactics TLC.LibList TLC.LibLogic TLC.LibNat TLC.LibEpsilon TLC.LibReflect TLC.LibFset.

(** * Abstract Definition of value for an environment. *)
Module Type ValueType.
Parameter value : Set.
Parameter value_inhab : Inhab value.
Parameter value_comp : Comparable value.
Instance  value_comparable : Comparable value := value_comp.
Definition values := fset value.

(* How do I get var without too much ?
Function fv (v : value) := VariablesType.vars.
*)

End ValueType.


From iris.program_logic Require Export weakestpre.
From fae_gtlc_mu.cast_calculus Require Export lang lang_lemmas.
From fae_gtlc_mu.cast_calculus Require Import types_notations.

(* Iris resources for invariants *)
Class implG Σ := ImplG {
  implG_invG : invG Σ;
}.

(* Iris resources gradual side for weakest preconditions... *)
Instance implG_irisG `{implG Σ} : irisG lang Σ := {
  iris_invG := implG_invG;
  state_interp σ κs _ := True%I;
  fork_post _ := True%I;
}.
Global Opaque iris_invG.

From iris.program_logic Require Export ectx_lifting.
From iris.proofmode Require Export tactics.
From fae_gtlc_mu.cast_calculus Require Export lang_lemmas.

(* some WP lemmas *)
Section wps.
  Context `{implG Σ}.

  Lemma wp_CastError' E Φ :
    ⊢ WP CastError @ MaybeStuck; E {{Φ}}.
  Proof. simpl. iApply wp_lift_pure_stuck. intro σ. destruct σ. exact CastError_stuck. done. Qed.

  Lemma wp_CastError (K : ectx) E Φ :
    ⊢ WP fill K CastError @ MaybeStuck; E {{Φ}}.
  Proof.
    destruct K.
    - by iApply wp_CastError'.
    - iApply (wp_pure_step_later MaybeStuck _ _ CastError True 1 _).
      intros _. apply nsteps_once. by apply cast_error_step. done.
      iApply wp_lift_pure_stuck. intro σ. destruct σ. exact CastError_stuck. done.
  Qed.

  (* a bind lemma for WP *)
  Lemma wp_bind (K : ectx) E e Φ :
    WP e @ MaybeStuck; E {{ v, WP fill K (of_val v) @ MaybeStuck; E {{ Φ }} }} ⊢ WP fill K e @ MaybeStuck; E {{ Φ }}.
  Proof.
    destruct (decide (e = CastError)) as [-> | eNeqCE].
    { iIntros "_". iApply wp_CastError. }
    iIntros "H". iLöb as "IH" forall (E e eNeqCE Φ). rewrite wp_unfold /wp_pre.
    assert (language.to_val e = to_val e) as ->; first done.
    destruct (to_val e) as [v|] eqn:He.
    { apply of_to_val in He as <-. by iApply fupd_wp. }
    rewrite wp_unfold /wp_pre.
    assert (language.to_val (fill K  e) = to_val (fill K e)) as ->; first done.
    rewrite fill_not_val //.
    iIntros (σ1 κ κs n) "Hσ". iMod ("H" $! tt [] [] 0 with "[$]") as "[% H]". iModIntro; iSplit.
    { eauto using reducible_fill. }
    iIntros (e2 σ2 efs Hstep).
    destruct (decide (e2 = CastError)).
    - rewrite e0.
      iMod ("H" $! CastError σ2 efs with "[]") as "H".
      simpl. iPureIntro. cut (prim_step e [] CastError []). inversion Hstep; done.
      { assert (prim_step (fill K e) [] e2 []). inversion Hstep; simplify_eq; by econstructor. eapply fill_step_CastError_inv; eauto. by simplify_eq. }
      iIntros "!>!>".
      iMod "H" as "(Hσ' & H & Hefs)".
      iModIntro. iFrame "Hσ Hefs". assert (CastError = fill [] CastError) as ->. done. iApply wp_CastError.
    - destruct (fill_step_inv K e κ e2 efs) as (e2'&->&?); auto.
      iMod ("H" $! e2' σ2 efs with "[]") as "H".
      simpl. inversion H1; by simplify_eq.
      iIntros "!>!>".
      iMod "H" as "(Hσ' & H & Hefs)".
      iModIntro. iFrame "Hσ Hefs".
      destruct K as [|Ki K]. simpl. iApply wp_fupd. iApply (wp_wand with "H"). iIntros (v) "Hwpv". iMod (wp_value_inv with "Hwpv"). by iModIntro.
      destruct (decide (e2' = CastError)) as [-> | neq]. iApply wp_CastError.
      by iApply "IH".
  Qed.

End wps.

Ltac wp_head := iApply wp_pure_step_later; auto; iNext.
Ltac wp_value := iApply wp_value.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.msl_ext.iter_sepcon.
Require Import RamifyCoq.msl_ext.ramification_lemmas.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.dag.
Require Import RamifyCoq.graph.weak_mark_lemmas.
Require Import RamifyCoq.msl_application.Graph.
Require Import Coq.Logic.Classical.

Local Open Scope logic.

Section PointwiseGraph_Mark.

Context {V E: Type}.
Context {GV GE Pred: Type}.
Context {SGBA: PointwiseGraphBasicAssum V E}.
Context {SGC: PointwiseGraphConstructor V E bool unit unit GV GE}.
Context {L_SGC: Local_PointwiseGraphConstructor V E bool unit unit GV GE}.
Context {SGP: PointwiseGraphPred V E GV GE Pred}.
Context {SGA: PointwiseGraphAssum SGP}.

Instance MGS: WeakMarkGraph.MarkGraphSetting bool.
Proof.
  apply (WeakMarkGraph.Build_MarkGraphSetting _ (eq true)).
  intros; destruct x; [left | right]; congruence.
Defined.

Global Existing Instance MGS.

Notation Graph := (LabeledGraph V E bool unit unit).
Notation SGraph := (PointwiseGraph V E GV GE).

Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Definition mark1 x (G1: Graph) (G2: Graph) := WeakMarkGraph.mark1 x G1 G2.
Definition mark x (G1: Graph) (G2: Graph) := WeakMarkGraph.mark x G1 G2 /\ G1 ~=~ G2.

Definition mark_list xs g1 g2 := relation_list (map mark xs) g1 g2.

Lemma mark_invalid_refl: forall (g: Graph) root, ~ vvalid g root -> mark root g g.
Proof.
  intros.
  split.
  + apply WeakMarkGraph.mark_invalid_refl; auto.
  + reflexivity.
Qed.

Lemma mark_marked_root_refl: forall (g: Graph) root, WeakMarkGraph.marked g root -> mark root g g.
Proof.
  intros.
  split.
  + apply WeakMarkGraph.mark_marked_root_refl; auto.
  + reflexivity.
Qed.

Lemma mark_list_eq: forall root xs g1 g2,
  mark_list xs g1 g2 ->
  WeakMarkGraph.componded_mark_list root xs g1 g2 /\ g1 ~=~ g2.
Proof.
  intros.
  change (mark_list xs g1 g2) with
    (relation_list (map (fun x => relation_conjunction (WeakMarkGraph.mark x) (respectful_relation pg_lg structurally_identical)) xs) g1 g2) in H.
  eapply relation_list_conjunction in H.
  rewrite relation_conjunction_iff in H.
  split.
  + destruct H as [? _].
    eapply relation_list_inclusion; [| exact H].
    intros ? _.
    clear.
    intros g1 g2 ?.
    exists g2; [| apply WeakMarkGraph.eq_do_nothing; auto].
    exists g1; [apply WeakMarkGraph.eq_do_nothing; auto |].
    auto.
  + eapply si_list.
    exact (proj2 H).
Qed.

Lemma mark1_mark_list_mark: forall root l (g g': Graph),
  vvalid g root ->
  (WeakMarkGraph.unmarked g) root ->
  step_list g root l ->
  relation_list (mark1 root :: mark_list l :: nil) g g' ->
  mark root g g'.
Proof.
  intros.
  destruct_relation_list g0 in H2.
  eapply (mark_list_eq root) in H2.
  destruct H2; simpl in H2.
  split.
  + eapply WeakMarkGraph.mark1_componded_mark_list_mark; eauto.
    split_relation_list (g :: g0 :: g0 :: g' :: nil); auto;
    apply WeakMarkGraph.eq_do_nothing; auto.
  + destruct H3 as [? _].
    rewrite H3; auto.
Qed.

Lemma mark_partial_labeled_graph_equiv: forall x (g g': Graph),
  mark x g g' ->
  ((predicate_partial_labeledgraph g (Complement _ (reachable g x))) ~=~
  (predicate_partial_labeledgraph g' (Complement _ (reachable g x))))%LabeledGraph.
Proof.
  intros.
  split; [| split].
  + destruct H.
    simpl;
    rewrite <- H0.
    reflexivity.
  + destruct H as [[? ?] _].
    simpl in *; intros.
    specialize (H0 v).
    assert (~ g |= x ~o~> v satisfying (WeakMarkGraph.unmarked g)).
    1: {
      destruct H1.
      intro; apply H3.
      apply reachable_by_is_reachable in H4; auto.
    }
    clear - H0 H3.
    destruct (vlabel g v), (vlabel g' v).
    - auto.
    - rewrite H0; auto.
    - symmetry; tauto.
    - auto.
  + intros; simpl.
    destruct (elabel g e), (elabel g' e); auto.
Qed.

Lemma root_stable_ramify: forall (g: Graph) (x: V) (gx: GV),
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vvalid g x ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx * (vertex_at x gx -* reachable_vertices_at x g)).
Proof. apply va_reachable_root_stable_ramify. Qed.

Lemma root_update_ramify: forall (g: Graph) (x: V) (lx: bool) (gx gx': GV),
  vvalid g x ->
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vgamma (Graph_PointwiseGraph (labeledgraph_vgen g x lx)) x = gx' ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard g) ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard (labeledgraph_vgen g x lx)) ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -* reachable_vertices_at x (labeledgraph_vgen g x lx))).
Proof. apply va_reachable_root_update_ramify. Qed.

(* TODO: remove this lemma? *)
Lemma exp_mark1: forall (g: Graph) (x: V) (lx: bool),
  WeakMarkGraph.label_marked lx ->
  @derives Pred _ (reachable_vertices_at x (labeledgraph_vgen g x lx)) (EX g': Graph, !! (mark1 x g g') && reachable_vertices_at x g').
Proof.
  intros.
  apply (exp_right (labeledgraph_vgen g x lx)).
  apply andp_right; [apply prop_right | auto].
  apply WeakMarkGraph.vertex_update_mark1; auto.
Qed.

Lemma mark_neighbor_ramify: forall {A} (g1: Graph) (g2: A -> Graph) x y,
  (forall (g: Graph) x y, reachable g x y \/ ~ reachable g x y) ->
  vvalid g1 x ->
  step g1 x y ->
  Included (Intersection V (reachable g1 x) (Complement V (reachable g1 y)))
     (vguard g1) ->
  (forall a, mark y g1 (g2 a) -> Included (Intersection V (reachable g1 x) (Complement V (reachable g1 y))) (vguard (g2 a))) ->
  @derives Pred _
    (reachable_vertices_at x g1)
    (reachable_vertices_at y g1 *
      (ALL a: A, !! mark y g1 (g2 a) -->
        (reachable_vertices_at y (g2 a) -*
         reachable_vertices_at x (g2 a)))).
Proof.
  intros.
  assert (Included (reachable g1 y) (reachable g1 x)).
  1: {
    hnf; unfold Ensembles.In; intros.
    apply step_reachable with y; auto.
  }
  apply vertices_at_ramif_xQ. eexists. split; [|split].
  + apply Ensemble_join_Intersection_Complement; auto.
  + intros. destruct H5 as [_ ?].
    rewrite <- H5; clear H5.
    apply Ensemble_join_Intersection_Complement; auto.
  + intros.
    apply GSG_PartialGraphPreserve; auto.
    - unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6; destruct H6 as [? _].
      apply reachable_foot_valid in H6; auto.
    - destruct H5.
      rewrite H6; clear H6.
      unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6; destruct H6 as [? _].
      apply reachable_foot_valid in H6; auto.
    - apply mark_partial_labeled_graph_equiv in H5.
      eapply si_stronger_partial_labeledgraph_simple; [| eassumption].
      unfold Included, Ensembles.In; intros.
      rewrite Intersection_spec in H6.
      tauto.
Qed.

Lemma mark_list_mark_ramify: forall {A} (g1 g2: Graph) (g3: A -> Graph) x l y l',
  (forall (g: Graph) x y, reachable g x y \/ ~ reachable g x y) ->
  vvalid g1 x ->
  step_list g1 x (l ++ y :: l') ->
  relation_list (mark1 x :: mark_list l :: nil) g1 g2 ->
  Included (Intersection V (reachable g2 x) (Complement V (reachable g2 y)))
     (vguard g2) ->
  (forall a, mark y g2 (g3 a) -> Included (Intersection V (reachable g2 x) (Complement V (reachable g2 y))) (vguard (g3 a))) ->
  @derives Pred _
    (reachable_vertices_at x g2)
    (reachable_vertices_at y g2 *
      (ALL a: A, !! mark y g2 (g3 a) -->
        (reachable_vertices_at y (g3 a) -*
         reachable_vertices_at x (g3 a)))).
Proof.
  intros.
  destruct_relation_list g1' in H2.
  destruct H5 as [? _].
  apply (mark_list_eq x) in H2.
  destruct H2 as [_ ?].
  rewrite <- H5 in H2; clear g1' H5.
  apply mark_neighbor_ramify; auto.
  + destruct H2. rewrite <- (H2 x). auto.
  + rewrite <- (step_si g1); auto. hnf in H1. rewrite <- H1.
    rewrite in_app_iff. right. apply in_eq.
Qed.

End PointwiseGraph_Mark.


From fae_gtlc_mu.refinements.static_gradual Require Export logical_relation compat_easy.
From fae_gtlc_mu.embedding Require Import expressions types types_lemmas.
From fae_gtlc_mu.stlc_mu Require Export typing.
From fae_gtlc_mu.cast_calculus Require Export types consistency_lemmas.
From fae_gtlc_mu.refinements.static_gradual Require Import compat_cast.all.
From fae_gtlc_mu.backtranslation Require Import expressions well_typedness.
From fae_gtlc_mu.stlc_mu Require Export contexts.
From fae_gtlc_mu.cast_calculus Require Export contexts.
From fae_gtlc_mu.backtranslation Require Import contexts.
From fae_gtlc_mu Require Export embedding.contexts.

Section relation_for_specification_lemma.
  Context `{!implG Σ, !specG Σ}.

  (** Static terms are related to their embeddings *)
  (** Proof by induction on the type derivation of expression and application of boring compatibility lemmas. *)
  Theorem embedding_relates (Γ : list stlc_mu.types.type) (e : stlc_mu.lang.expr) (τ : stlc_mu.types.type) :
    Γ ⊢ₛ e : τ → map embed_type Γ ⊨ e ≤log≤ [[e]] : [| τ |].
  Proof.
    induction 1; simpl.
    - apply bin_log_related_var. by rewrite list_lookup_fmap H.
    - by apply bin_log_related_unit.
    - by apply bin_log_related_pair.
    - by eapply bin_log_related_fst.
    - by eapply bin_log_related_snd.
    - by apply bin_log_related_injl.
    - by apply bin_log_related_injr.
    - by eapply bin_log_related_case.
    - by apply bin_log_related_lam.
    - by eapply bin_log_related_app.
    - apply bin_log_related_fold. by rewrite -embd_unfold_comm.
    - rewrite embd_unfold_comm. apply bin_log_related_unfold. by simpl in IHtyped.
  Qed.

  (** Gradual terms are related to their backtranslation *)
  (** Proof by induction on the type derivation of expression and application of all compatibility lemmas (including compatibility lemma for casts now). *)
  Theorem back_relates (Γ : list cast_calculus.types.type) (e : cast_calculus.lang.expr) (τ : cast_calculus.types.type) :
    Γ ⊢ₜ e : τ → Γ ⊨ <<<e>>> ≤log≤ e : τ.
  Proof.
    induction 1; simpl.
    - by apply bin_log_related_var.
    - by apply bin_log_related_unit.
    - by apply bin_log_related_pair.
    - by eapply bin_log_related_fst.
    - by eapply bin_log_related_snd.
    - by apply bin_log_related_injl.
    - by apply bin_log_related_injr.
    - by eapply bin_log_related_case.
    - by apply bin_log_related_lam.
    - by eapply bin_log_related_app.
    - by apply bin_log_related_fold.
    - by apply bin_log_related_unfold.
    - assert (pτi : Closed τi). apply (cast_calculus.typing.typed_closed H).
      destruct (consistency_open_dec τi τf);
                destruct (decide (Closed τi));
                destruct (decide (Closed τf)); try by contradiction.
      by apply bin_log_related_back_cast.
    - apply bin_log_related_omega.
  Qed.

  (** Gradual contexts (of depth 1) are related to their backtranslations *)
  Lemma back_ctx_item_relates (Γ : list cast_calculus.types.type) (e : stlc_mu.lang.expr) (e' : cast_calculus.lang.expr) (τ : cast_calculus.types.type) (pτ : Closed τ)
        (Γ' : list cast_calculus.types.type) (τ' : cast_calculus.types.type) (C : cast_calculus.contexts.ctx_item) :
      cast_calculus.contexts.typed_ctx_item C Γ τ Γ' τ' →
      Γ ⊨ e ≤log≤ e' : τ →
      Γ' ⊨ stlc_mu.contexts.fill_ctx_item (backtranslate_ctx_item C) e ≤log≤ cast_calculus.contexts.fill_ctx_item C e' : τ'.
  Proof.
    destruct C; intros; inversion H; simplify_eq; simpl.
    - by apply bin_log_related_lam.
    - eapply bin_log_related_app; eauto using back_relates.
    - eapply bin_log_related_app; eauto using back_relates.
    - eapply bin_log_related_pair; eauto using back_relates.
    - eapply bin_log_related_pair; eauto using back_relates.
    - by eapply bin_log_related_fst.
    - by eapply bin_log_related_snd.
    - by apply bin_log_related_injl.
    - by apply bin_log_related_injr.
    - eapply bin_log_related_case; try apply back_relates; try done.
    - eapply bin_log_related_case; try apply back_relates; try done.
    - eapply bin_log_related_case; try apply back_relates; try done.
    - by apply bin_log_related_fold.
    - by apply bin_log_related_unfold.
    - destruct (consistency_open_dec τ τ');
                destruct (decide (Closed τ));
                destruct (decide (Closed τ')); try by contradiction.
      by apply bin_log_related_back_cast.
  Qed.

  (** Gradual contexts are related to their backtranslation *)
  Lemma back_ctx_relates (Γ : list cast_calculus.types.type) (e : stlc_mu.lang.expr) (e' : cast_calculus.lang.expr) (τ : cast_calculus.types.type) (pτ : Closed τ)
        (Γ' : list cast_calculus.types.type) (τ' : cast_calculus.types.type) (C : cast_calculus.contexts.ctx) :
      cast_calculus.contexts.typed_ctx C Γ τ Γ' τ' →
      Γ ⊨ e ≤log≤ e' : τ →
      Γ' ⊨ stlc_mu.contexts.fill_ctx (backtranslate_ctx C) e ≤log≤ cast_calculus.contexts.fill_ctx C e' : τ'.
  Proof.
    revert Γ τ pτ Γ' τ' e e'.
    induction C; intros Γ τ pτ Γ' τ' e e' H.
    - by inversion H.
    - inversion_clear H. intro Hee'. simpl.
      apply back_ctx_item_relates with (Γ := Γ2) (τ := τ2). by eapply typed_ctx_closedness. auto. by eapply IHC.
  Qed.

  (** Static contexts (of depth 1) are related to their embeddings *)
  Lemma embed_ctx_item_relates (Γ : list stlc_mu.types.type) (e : stlc_mu.lang.expr) (e' : cast_calculus.lang.expr) (τ : stlc_mu.types.type) (pτ : Closed τ)
        (Γ' : list stlc_mu.types.type) (τ' : stlc_mu.types.type) (C : stlc_mu.contexts.ctx_item) :
      stlc_mu.contexts.typed_ctx_item C Γ τ Γ' τ' →
      (map embed_type Γ) ⊨ e ≤log≤ e' : (embed_type τ) →
      (map embed_type Γ') ⊨ stlc_mu.contexts.fill_ctx_item C e ≤log≤ cast_calculus.contexts.fill_ctx_item (embed_ctx_item C) e' : (embed_type τ').
  Proof.
    destruct C; intros; inversion H; simplify_eq; simpl.
    - by apply bin_log_related_lam.
    - eapply bin_log_related_app; eauto using embedding_relates.
    - eapply bin_log_related_app; eauto.
      assert (TArrow [|τ|] [|τ'|] = embed_type (stlc_mu.types.TArrow τ τ')) as ->; try done.
      eauto using embedding_relates.
    - eapply bin_log_related_pair; eauto using embedding_relates.
    - eapply bin_log_related_pair; eauto using embedding_relates.
    - by eapply bin_log_related_fst.
    - by eapply bin_log_related_snd.
    - by apply bin_log_related_injl.
    - by apply bin_log_related_injr.
    - eapply bin_log_related_case; try apply embedding_relates; try done.
      fold (embed_type τ1). assert ([|τ1|] :: map embed_type Γ' = map embed_type (τ1 :: Γ')) as ->; try done.
      eauto using embedding_relates.
      fold (embed_type τ2). assert ([|τ2|] :: map embed_type Γ' = map embed_type (τ2 :: Γ')) as ->; try done.
      eauto using embedding_relates.
    - eapply (bin_log_related_case _ _ _ _ _ _ _ _ (embed_type τ2)); try apply embedding_relates; try done.
      assert (TSum [|τ1|] [|τ2|] = embed_type (stlc_mu.types.TSum τ1 τ2)) as ->; try done.
      eauto using embedding_relates.
      assert ([|τ2|] :: map embed_type Γ' = map embed_type (τ2 :: Γ')) as ->; try done.
      eauto using embedding_relates.
    - eapply (bin_log_related_case _ _ _ _ _ _ _ (embed_type τ1)); try apply embedding_relates; try done.
      assert (TSum [|τ1|] [|τ2|] = embed_type (stlc_mu.types.TSum τ1 τ2)) as ->; try done.
      eauto using embedding_relates.
      assert ([|τ1|] :: map embed_type Γ' = map embed_type (τ1 :: Γ')) as ->; try done.
      eauto using embedding_relates.
    - apply bin_log_related_fold. by rewrite -embd_unfold_comm.
    - rewrite embd_unfold_comm. by apply bin_log_related_unfold.
  Qed.

  (** Static contexts are related to their embeddings *)
  Lemma embed_ctx_relates (Γ : list stlc_mu.types.type) (e : stlc_mu.lang.expr) (e' : cast_calculus.lang.expr) (τ : stlc_mu.types.type) (pτ : Closed τ)
        (Γ' : list stlc_mu.types.type) (τ' : stlc_mu.types.type) (C : stlc_mu.contexts.ctx) :
      stlc_mu.contexts.typed_ctx C Γ τ Γ' τ' →
      (map embed_type Γ) ⊨ e ≤log≤ e' : (embed_type τ) →
      (map embed_type Γ') ⊨ stlc_mu.contexts.fill_ctx C e ≤log≤ cast_calculus.contexts.fill_ctx (embed_ctx C) e' : (embed_type τ').
  Proof.
    revert Γ τ pτ Γ' τ' e e'.
    induction C; intros Γ τ pτ Γ' τ' e e' H.
    - by inversion H.
    - inversion_clear H. intro Hee'. simpl.
      apply embed_ctx_item_relates with (Γ := Γ2) (τ := τ2). by eapply stlc_mu.contexts.typed_ctx_closedness. auto. by eapply IHC.
  Qed.

End relation_for_specification_lemma.


Require Import RelationClasses.
Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive sim_localF (none_for:SimPromises.t) (lc_src lc_tgt:Local.t): Prop :=
| sim_localF_intro
    (TVIEW_CUR: View.le lc_src.(Local.tview).(TView.cur) lc_tgt.(Local.tview).(TView.cur))
    (TVIEW_ACQ: View.le lc_src.(Local.tview).(TView.acq) lc_tgt.(Local.tview).(TView.acq))
    (PROMISES: SimPromises.sem none_for SimPromises.bot lc_src.(Local.promises) lc_tgt.(Local.promises))
.

Lemma sim_localF_nonsynch_loc
      none_for loc lc_src lc_tgt
      (SIM: sim_localF none_for lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch_loc loc lc_tgt.(Local.promises)):
  Memory.nonsynch_loc loc lc_src.(Local.promises).
Proof.
  inv SIM. inv PROMISES. ii. destruct msg.
  destruct (Memory.get loc t lc_tgt.(Local.promises)) as [[? []]|] eqn:X.
  - exploit NONSYNCH; eauto. s. i. subst.
    exploit LE; eauto. rewrite GET. i. inv x.
    unfold SimPromises.none_if. condtac; ss.
  - exploit COMPLETE; eauto. rewrite SimPromises.bot_spec. congr.
Qed.

Lemma sim_localF_nonsynch
      none_for lc_src lc_tgt
      (SIM: sim_localF none_for lc_src lc_tgt)
      (NONSYNCH: Memory.nonsynch lc_tgt.(Local.promises)):
  Memory.nonsynch lc_src.(Local.promises).
Proof.
  ii. eapply sim_localF_nonsynch_loc; eauto.
Qed.

Lemma sim_localF_memory_bot
      none_for lc_src lc_tgt
      (SIM: sim_localF none_for lc_src lc_tgt)
      (BOT: lc_tgt.(Local.promises) = Memory.bot):
  lc_src.(Local.promises) = Memory.bot.
Proof.
  apply Memory.ext. i. rewrite Memory.bot_get.
  destruct (Memory.get loc ts lc_src.(Local.promises)) as [[? []]|] eqn:X; ss.
  inv SIM.  inv PROMISES. exploit COMPLETE; eauto.
  { rewrite BOT, Memory.bot_get. ss. }
  rewrite SimPromises.bot_spec. ss.
Qed.

Lemma sim_localF_promise
      none_for
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to val released kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to val released lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to val (SimPromises.none_if loc to none_for released) lc2_src mem2_src (SimPromises.kind_transf loc to none_for kind)>> /\
    <<LOCAL2: sim_localF none_for lc2_src lc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit sim_memory_closed_opt_view; eauto. i.
  exploit Memory.promise_future; try apply PROMISE_SRC; eauto.
  { apply WF1_SRC. }
  { apply WF1_SRC. }
  { unfold SimPromises.none_if. condtac; viewtac. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    unfold SimPromises.none_if. condtac; viewtac.
  - econs; eauto.
Qed.

Lemma read_tview_mon'
      tview1 tview2 loc ts released1 released2 ord1 ord2
      (TVIEW_CUR: View.le tview1.(TView.cur) tview2.(TView.cur))
      (TVIEW_ACQ: View.le tview1.(TView.acq) tview2.(TView.acq))
      (REL: View.opt_le released1 released2)
      (WF2: TView.wf tview2)
      (WF_REL2: View.opt_wf released2)
      (ORD: Ordering.le ord1 ord2):
  <<CUR: View.le
           (TView.read_tview tview1 loc ts released1 ord1).(TView.cur)
           (TView.read_tview tview2 loc ts released2 ord2).(TView.cur)>> /\
  <<ACQ: View.le
           (TView.read_tview tview1 loc ts released1 ord1).(TView.acq)
           (TView.read_tview tview2 loc ts released2 ord2).(TView.acq)>>.
Proof.
  splits.
  - unfold TView.read_tview, View.singleton_ur_if.
    repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
  - unfold TView.read_tview, View.singleton_ur_if.
    repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
Qed.

Lemma sim_localF_read
      none_for
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt
      loc ts val released_tgt ord_src ord_tgt
      (STEP_TGT: Local.read_step lc1_tgt mem1_tgt loc ts val released_tgt ord_tgt lc2_tgt)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt):
  exists released_src lc2_src,
    <<REL: View.opt_le released_src released_tgt>> /\
    <<STEP_SRC: Local.read_step lc1_src mem1_src loc ts val released_src ord_src lc2_src>> /\
    <<LOCAL2: sim_localF none_for lc2_src lc2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit sim_memory_get; try apply MEM1; eauto. i. des.
  esplits; eauto.
  - econs; eauto. eapply TViewFacts.readable_mon; eauto.
  - exploit read_tview_mon'; eauto.
    { apply WF1_TGT. }
    { eapply MEM1_TGT. eauto. }
    i. des. econs; eauto.
Qed.

Lemma write_tview_mon'
      tview1 tview2 sc1 sc2 loc ts ord1 ord2
      (TVIEW_CUR: View.le tview1.(TView.cur) tview2.(TView.cur))
      (TVIEW_ACQ: View.le tview1.(TView.acq) tview2.(TView.acq))
      (SC: TimeMap.le sc1 sc2)
      (WF2: TView.wf tview2)
      (ORD: Ordering.le ord1 ord2):
  <<CUR: View.le
           (TView.write_tview tview1 sc1 loc ts ord1).(TView.cur)
           (TView.write_tview tview2 sc2 loc ts ord2).(TView.cur)>> /\
  <<ACQ: View.le
           (TView.write_tview tview1 sc1 loc ts ord1).(TView.acq)
           (TView.write_tview tview2 sc2 loc ts ord2).(TView.acq)>>.
Proof.
  splits.
  - unfold TView.write_tview.
    repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
  - unfold TView.write_tview.
    repeat (condtac; aggrtac);
      (try by etrans; [apply TVIEW|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF2).
Qed.

Lemma sim_localF_fulfill
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (NONEFOR: (Ordering.le Ordering.acqrel ord_tgt /\ SimPromises.mem loc to none_for = false) \/
                Ordering.le ord_tgt Ordering.plain)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src (SimPromises.none_if loc to none_for released) ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_localF (SimPromises.unset loc to none_for) lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  guardH NONEFOR.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)
     (TView.write_released lc1_tgt.(Local.tview) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { unguardH NONEFOR. des.
    - unfold TView.write_released.
      condtac; [|by econs].
      condtac; cycle 1.
      { by destruct ord_tgt; inv NONEFOR; inv COND0. }
      econs. unfold TView.write_tview. s.
      repeat (condtac; aggrtac); try by apply WF1_TGT.
      + rewrite <- View.join_r. rewrite <- ? View.join_l. apply LOCAL1.
      + rewrite <- View.join_r. rewrite <- ? View.join_l.
        etrans; [|apply LOCAL1]. apply WF1_SRC.
    - unfold TView.write_released. repeat (condtac; viewtac). refl.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    + unfold SimPromises.none_if. destruct (SimPromises.mem loc to none_for) eqn:X.
      * unguardH NONEFOR. des; [congr|]. unfold TView.write_released. condtac; [|refl].
        destruct ord_src, ord_tgt; inv ORD; inv NONEFOR; inv COND.
      * etrans; eauto.
    + unfold SimPromises.none_if. condtac; viewtac.
    + eapply TViewFacts.writable_mon; try exact WRITABLE; eauto. apply LOCAL1.
  - exploit write_tview_mon'; eauto.
    { apply LOCAL1. }
    { apply LOCAL1. }
    { apply WF1_TGT. }
    i. des. econs; eauto.
  - ss.
Qed.

Lemma sim_localF_write
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.plain \/ Ordering.le Ordering.acqrel ord_tgt)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src (SimPromises.kind_transf loc to none_for kind)>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_localF (SimPromises.unset loc to none_for) lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  guardH ORD_TGT.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_localF_promise; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  assert (NONEFOR: __guard__ ((Ordering.le Ordering.acqrel ord_tgt /\ SimPromises.mem loc to none_for = false) \/
                              Ordering.le ord_tgt Ordering.plain)).
  { destruct (Ordering.le ord_tgt Ordering.strong_relaxed) eqn:X.
    - right. unguardH ORD_TGT. destruct ord_tgt; des; ss.
    - left. splits.
      { by destruct ord_tgt; inv X. }
      exploit ORD0.
      { by destruct ord_tgt; inv X. }
      i. des. subst.
      destruct (SimPromises.mem loc to none_for) eqn:Y; ss.
      inv LOCAL1. inv PROMISES. exploit NONEFOR; eauto. i. des.
      inv STEP1. inv PROMISE. exploit Memory.add_get0; try exact PROMISES; eauto. congr.
  }
  exploit sim_localF_fulfill; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  i. des.
  exploit promise_fulfill_write; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. exploit ORD0; eauto.
    - etrans; eauto.
    - i. des. subst. splits; auto. eapply sim_localF_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto.
  - unguardH NONEFOR. des.
    + unfold SimPromises.none_if in *. rewrite NONEFOR0 in *. ss.
    + subst. unfold TView.write_released at 1. condtac; [|by econs].
      destruct ord_src, ord_tgt; inv ORD; inv NONEFOR; inv COND.
  - etrans; eauto.
Qed.

Lemma sim_localF_update
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt
      lc3_tgt sc3_tgt mem3_tgt
      loc ts1 val1 released1_tgt ord1_src ord1_tgt
      from2 to2 val2 released2_tgt ord2_src ord2_tgt kind
      (STEP1_TGT: Local.read_step lc1_tgt mem1_tgt loc ts1 val1 released1_tgt ord1_tgt lc2_tgt)
      (STEP2_TGT: Local.write_step lc2_tgt sc1_tgt mem1_tgt loc from2 to2 val2 released1_tgt released2_tgt ord2_tgt lc3_tgt sc3_tgt mem3_tgt kind)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (ORD1: Ordering.le ord1_src ord1_tgt)
      (ORD2: Ordering.le ord2_src ord2_tgt)
      (ORD2_TGT: Ordering.le ord2_tgt Ordering.plain \/ Ordering.le Ordering.acqrel ord2_tgt):
  exists released1_src released2_src lc2_src lc3_src sc3_src mem3_src,
    <<REL1: View.opt_le released1_src released1_tgt>> /\
    <<REL2: View.opt_le released2_src released2_tgt>> /\
    <<STEP1_SRC: Local.read_step lc1_src mem1_src loc ts1 val1 released1_src ord1_src lc2_src>> /\
    <<STEP2_SRC: Local.write_step lc2_src sc1_src mem1_src loc from2 to2 val2 released1_src released2_src ord2_src lc3_src sc3_src mem3_src (SimPromises.kind_transf loc to2 none_for kind)>> /\
    <<LOCAL3: sim_localF (SimPromises.unset loc to2 none_for) lc3_src lc3_tgt>> /\
    <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEM3: sim_memory mem3_src mem3_tgt>>.
Proof.
  guardH ORD2_TGT.
  exploit Local.read_step_future; eauto. i. des.
  exploit sim_localF_read; eauto. i. des.
  exploit Local.read_step_future; eauto. i. des.
  hexploit sim_localF_write; eauto. i. des.
  esplits; eauto.
Qed.

Lemma sim_localF_fence
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      ordr_src ordw_src
      ordr_tgt ordw_tgt
      (STEP_TGT: Local.fence_step lc1_tgt sc1_tgt ordr_tgt ordw_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt)
      (ORDR_TGT: Ordering.le ordr_tgt Ordering.acqrel)
      (ORDW_TGT: Ordering.le ordw_tgt Ordering.relaxed):
  exists lc2_src sc2_src,
    <<STEP_SRC: Local.fence_step lc1_src sc1_src ordr_src ordw_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_localF none_for lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT. esplits; eauto.
  - econs; eauto. i. eapply sim_localF_nonsynch; eauto.
    apply RELEASE. etrans; eauto.
  - econs; try apply LOCAL1.
    + s. repeat (condtac; aggrtac).
      * apply LOCAL1.
      * etrans; [|apply LOCAL1]. apply WF1_SRC.
      * apply LOCAL1.
    + s. repeat (condtac; aggrtac).
      rewrite View.join_comm, View.join_bot_l. apply LOCAL1.
  - unfold TView.write_fence_sc.
    repeat (condtac; viewtac).
Qed.

Lemma sim_localF_introduction
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt):
  <<LOCAL2: sim_localF SimPromises.bot lc1_src lc1_tgt>>.
Proof.
  esplits. econs; apply LOCAL1.
Qed.

Lemma sim_localF_lower_src
      none_for1
      lc1_src sc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_src mem2_src
      loc from to val released
      (LOCAL1: sim_localF none_for1 lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (MEM1_SRC: Memory.closed mem1_src)
      (STEP_SRC: Local.promise_step lc1_src mem1_src loc from to val None lc2_src mem2_src (Memory.op_kind_lower released)):
  <<LOCAL2: exists none_for2, sim_localF none_for2 lc2_src lc1_tgt>> /\
  <<MEM2: sim_memory mem2_src mem1_tgt>> /\
  <<WF2_SRC: Local.wf lc2_src mem2_src>>.
Proof.
  splits.
  - inv STEP_SRC. inv PROMISE.
    exists (match Memory.get loc to lc1_tgt.(Local.promises) with
       | Some _ => SimPromises.set loc to none_for1
       | None => none_for1
       end).
    inv LOCAL1. econs; ss. inv PROMISES0. econs; ss.
    + ii.
      exploit LE; eauto. i.
      exploit Memory.lower_get0; try exact PROMISES; eauto. i.
      erewrite Memory.lower_o; eauto.
      unfold SimPromises.none_if.
      destruct (Memory.get loc to (Local.promises lc1_tgt)) eqn:TGT.
      * rewrite SimPromises.set_o. condtac; ss.
        { des. subst. condtac; ss; cycle 1.
          { revert COND0. condtac; ss. des; congr. }
          rewrite x in x1. inv x1. ss.
        }
        { guardH o. condtac.
          { revert COND0. condtac; ss.
            { des. subst. unguardH o. des; congr. }
            guardH o0. i.
            rewrite x. repeat f_equal. unfold SimPromises.none_if. condtac; ss.
          }
          rewrite x. repeat f_equal. unfold SimPromises.none_if. condtac; ss.
          revert COND0. condtac; ss.
        }
      * condtac; ss. des. subst. congr.
    + i. revert MEM0. condtac; ss; cycle 1.
      { eapply NONEFOR. }
      rewrite SimPromises.set_o. condtac; ss; cycle 1.
      { eapply NONEFOR. }
      i. des. subst. destruct p. eauto.
    + i. revert SRC. erewrite Memory.lower_o; eauto. condtac; ss.
      * i. des. inv SRC. eapply COMPLETE; eauto. eapply Memory.lower_get0. eauto.
      * i. eapply COMPLETE; eauto.
  - etrans; [|eauto]. inv STEP_SRC. inv PROMISE. eapply lower_sim_memory. eauto.
  - eapply Local.promise_step_future; eauto.
Qed.

Lemma sim_localF_nonsynch_src
      none_for
      lang st sc
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (LOCAL1_SRC: Local.wf lc1_src mem1_src)
      (LOCAL2_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists none_for2 lc2_src mem2_src,
    <<STEP_SRC: rtc (@Thread.tau_step lang)
                    (Thread.mk lang st lc1_src sc mem1_src)
                    (Thread.mk lang st lc2_src sc mem2_src)>> /\
    <<NONSYNCH2: Memory.nonsynch lc2_src.(Local.promises)>> /\
    <<LOCAL2: sim_localF none_for2 lc2_src lc1_tgt>> /\
    <<MEM2: sim_memory mem2_src mem1_tgt>>.
Proof.
  inversion LOCAL1_SRC. unfold Memory.finite in *. des.
  assert (FINITE' : forall (loc : Loc.t) (from to : Time.t) (msg : Message.t),
             Memory.get loc to (Local.promises lc1_src) =
             Some (from, msg) -> msg.(Message.released) <> None -> In (loc, to) dom).
  { ii. eapply FINITE. eauto. }
  clear FINITE. move dom after lc1_src. revert_until dom. revert none_for.
  induction dom.
  { esplits; eauto. ii. destruct (Message.released msg) eqn:X; ss.
    exfalso. eapply FINITE'; eauto. congr.
  }
  destruct a as [loc to]. i.
  destruct (Memory.get loc to lc1_src.(Local.promises)) as [[? []]|] eqn:X; cycle 1.
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. i. inv x; ss.
    inv H1. congr.
  }
  destruct released; cycle 1.
  { eapply IHdom; eauto. i. exploit FINITE'; eauto. i. inv x; ss.
    inv H1. rewrite H in X. inv X. ss.
  }
  exploit MemoryFacts.promise_exists_None; eauto.
  { eapply MemoryFacts.some_released_time_lt; [by apply MEM1_SRC|]. apply LOCAL1_SRC. eauto. }
  i. des.
  exploit Memory.promise_future; try apply LOCAL1_SRC; eauto; try by econs. i. des.
  exploit sim_localF_lower_src; eauto.
  { econs; eauto. econs. }
  i. des.
  exploit IHdom; eauto.
  { eapply Memory.future_closed_timemap; eauto. }
  { eapply TView.future_closed; eauto. }
  { s. i. inv x0. revert H.
    erewrite Memory.lower_o; eauto. condtac; ss.
    - i. des. inv H. ss.
    - guardH o. i. exploit FINITE'; eauto. i. des; ss.  inv x.
      unguardH o. des; congr.
  }
  i. des. esplits; try exact NONSYNCH2; eauto.
  econs 2; eauto. econs.
  - econs. econs 1. econs; eauto. econs; eauto. econs.
  - ss.
Qed.

Lemma sim_localF_fence_src
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      (NONSYNCH: Memory.nonsynch lc1_src.(Local.promises))
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: Local.fence_step lc1_src sc1_src Ordering.plain Ordering.acqrel lc2_src sc2_src>> /\
    <<LOCAL2: sim_localF none_for lc2_src lc1_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc1_tgt>>.
Proof.
  esplits; ss. econs; s.
  - repeat (condtac; aggrtac). apply LOCAL1.
  - repeat (condtac; aggrtac). apply LOCAL1.
  - apply LOCAL1.
Qed.

Lemma sim_localF_elimination
      none_for
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      (STEP_TGT: Local.fence_step lc1_tgt sc1_tgt Ordering.plain Ordering.acqrel lc2_tgt sc2_tgt)
      (LOCAL1: sim_localF none_for lc1_src lc1_tgt)
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt):
  <<LOCAL2: sim_local lc1_src lc2_tgt>> /\
  <<SC2: TimeMap.le sc1_src sc2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT. esplits; ss.
  econs; s.
  - unfold TView.read_fence_tview. condtac; ss.
    unfold TView.write_fence_tview. econs; repeat (condtac; aggrtac).
    etrans; [|apply TVIEW_CUR]. apply WF1_SRC.
  - econs; try by apply PROMISES.
    + inv PROMISES. ii. exploit LE; eauto.
      unfold SimPromises.none_if. condtac; ss.
      exploit RELEASE; eauto. s. i. subst. ss.
    + i. rewrite SimPromises.bot_spec in *. congr.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Classes.EquivDec.
Require Import Leapfrog.FinType.
Require Leapfrog.Syntax.
Require Leapfrog.Reachability.
Module P4A := Leapfrog.Syntax.
Require Import Leapfrog.ConfRel.
Import ListNotations.

Section WP.
  Set Implicit Arguments.

  (* State identifiers. *)
  Variable (St1: Type).
  Context `{St1_eq_dec: EquivDec.EqDec St1 eq}.
  Context `{St1_finite: @Finite St1 _ St1_eq_dec}.

  Variable (St2: Type).
  Context `{St2_eq_dec: EquivDec.EqDec St2 eq}.
  Context `{St2_finite: @Finite St2 _ St2_eq_dec}.

  Notation St := (St1 + St2)%type.

  (* Header identifiers. *)
  Variable (Hdr: Type).
  Context `{Hdr_eq_dec: EquivDec.EqDec Hdr eq}.
  Context `{Hdr_finite: @Finite Hdr _ Hdr_eq_dec}.
  Variable (Hdr_sz: Hdr -> nat).

  Variable (a: P4A.t St Hdr_sz).
  Variable (reachable_states: list (state_template a * state_template a)).

  Fixpoint be_subst {c} (be: bit_expr Hdr c) (e: bit_expr Hdr c) (x: bit_expr Hdr c) : bit_expr Hdr c :=
    match be with
    | BELit _ _ l => BELit _ _ l
    | BEBuf _ _ _
    | BEHdr _ _ _
    | BEVar _ _ =>
      if bit_expr_eq_dec be x then e else be
    | BESlice be hi lo => beslice (be_subst be e x) hi lo
    | BEConcat e1 e2 => beconcat (be_subst e1 e x) (be_subst e2 e x)
    end.

  Fixpoint sr_subst {c} (sr: store_rel Hdr c) (e: bit_expr Hdr c) (x: bit_expr Hdr c) : store_rel Hdr c :=
  match sr with
  | BRTrue _ _
  | BRFalse _ _ => sr
  | BREq e1 e2 => BREq (be_subst e1 e x) (be_subst e2 e x)
  | BRAnd r1 r2 => brand (sr_subst r1 e x) (sr_subst r2 e x)
  | BROr r1 r2 => bror (sr_subst r1 e x) (sr_subst r2 e x)
  | BRImpl r1 r2 => brimpl (sr_subst r1 e x) (sr_subst r2 e x)
  end.

  Inductive lkind :=
  | Jump
  | Read.

  Definition leap_kind (pred cur: state_template a) : lkind :=
    match cur.(st_buf_len) with
    | 0 => Jump
    | _ => Read
    end.

  Fixpoint expr_to_bit_expr {c n} (s: side) (e: P4A.expr Hdr_sz n) : bit_expr Hdr c :=
    match e with
    | P4A.EHdr h => BEHdr c s (P4A.HRVar h)
    | P4A.ELit _ bs => BELit _ c (Ntuple.t2l bs)
    | P4A.ESlice _ e hi lo => BESlice (expr_to_bit_expr s e) hi lo
    | P4A.EConcat l r => BEConcat (expr_to_bit_expr s l) (expr_to_bit_expr s r)
    end.

  Definition val_to_bit_expr {c n} (value: P4A.v n) : bit_expr Hdr c :=
    match value with
    | P4A.VBits _ bs => BELit _ c (Ntuple.t2l bs)
    end.

  Fixpoint wp_op' {c} (s: side) (o: P4A.op Hdr_sz) : nat * store_rel Hdr c -> nat * store_rel Hdr c :=
    fun '(buf_hi_idx, phi) =>
      match o with
      | P4A.OpNil _ => (buf_hi_idx, phi)
      | P4A.OpSeq o1 o2 =>
        wp_op' s o1 (wp_op' s o2 (buf_hi_idx, phi))
      | P4A.OpExtract _ hdr =>
        let new_idx := buf_hi_idx - Hdr_sz hdr in
        let slice := beslice (BEBuf _ _ s) (buf_hi_idx - 1) new_idx in
        (new_idx, sr_subst phi slice (BEHdr _ s (P4A.HRVar hdr)))
      | P4A.OpAsgn lhs rhs =>
        (buf_hi_idx, sr_subst phi (expr_to_bit_expr s rhs) (BEHdr _ s (P4A.HRVar lhs)))
      end.

  Definition wp_op {c} (s: side) (o: P4A.op Hdr_sz) (phi: store_rel Hdr c) : store_rel Hdr c :=
    snd (wp_op' s o (P4A.op_size o, phi)).

  Equations pat_cond {ctx: bctx} {ty: P4A.typ} (si: side) (p: P4A.pat ty) (c: P4A.cond Hdr_sz ty) : store_rel Hdr ctx :=
    { pat_cond si (P4A.PExact val) (P4A.CExpr e) :=
        BREq (expr_to_bit_expr si e) (val_to_bit_expr val);
      pat_cond _ (P4A.PAny _) _ :=
        BRTrue _ _;
      pat_cond si (P4A.PPair p1 p2) (P4A.CPair e1 e2) :=
        BRAnd (pat_cond si p1 e1) (pat_cond si p2 e2) }.

  Fixpoint cases_cond
    {ctx: bctx}
    {ty: Syntax.typ}
    (si: side)
    (cond: Syntax.cond Hdr_sz ty)
    (target: P4A.state_ref St)
    (cases: list (P4A.sel_case St ty))
    (default: P4A.state_ref St)
    : store_rel Hdr ctx
  :=
    match cases with
    | nil =>
      if target == default then (BRTrue _ _) else (BRFalse _ _)
    | case :: cases =>
      if target == P4A.sc_st case
      then bror (pat_cond si case.(P4A.sc_pat) cond)
                (cases_cond si cond target cases default)
      else brand (brimpl (pat_cond si case.(P4A.sc_pat) cond) (BRFalse _ _))
                 (cases_cond si cond target cases default)
    end.

  Definition trans_cond
             {c: bctx}
             (s: side)
             (t: P4A.transition St Hdr_sz)
             (st': P4A.state_ref St)
    : store_rel Hdr c :=
    match t with
    | P4A.TGoto _ r =>
      if r == st'
      then BRTrue _ _
      else BRFalse _ _
    | P4A.TSel cond cases default =>
      cases_cond s cond st' cases default
    end.

  Definition jump_cond
             {c}
             (si: side)
             (prev cur: state_template a)
    : store_rel Hdr c :=
    match prev.(st_state) with
    | inl cand =>
      let st := a.(P4A.t_states) cand in
      trans_cond si (P4A.st_trans st) cur.(st_state)
    | inr cand =>
      match cur.(st_state) with
      | inr false => BRTrue _ _
      | _ => BRFalse _ _
      end
    end.

  (* Left- and right weakest precondition operators. *)
  Definition wp_lpred {c: bctx}
             (si: side)
             (b: bvar c)
             (prev cur: state_template a)
             (k: lkind)
             (phi: store_rel Hdr c)
    : store_rel Hdr c :=
    let phi' :=
    match k with
    | Read =>
      phi
    | Jump =>
      match prev.(st_state) with
      | inl s =>
        let cond := jump_cond si prev cur in
        let phi'' := sr_subst phi (BELit _ _ []) (BEBuf _ _ si) in
        wp_op si (a.(P4A.t_states) s).(P4A.st_op) (brimpl cond phi'')
      | inr s =>
        sr_subst phi (BELit _ _ []) (BEBuf _ _ si)
      end
    end in
    sr_subst phi' (beconcat (BEBuf _ _ si) (BEVar _ b)) (BEBuf _ _ si).

  Definition wp_pred_pair
             (phi: conf_rel a)
             (preds: nat * (state_template a * state_template a))
    : conf_rel a :=
    let '(size, (prev_l, prev_r)) := preds in
    let phi_rel := phi.(cr_rel) in
    let cur_l := phi.(cr_st).(cs_st1) in
    let cur_r := phi.(cr_st).(cs_st2) in
    let leap_l := leap_kind prev_l cur_l in
    let leap_r := leap_kind prev_r cur_r in
    let b := BVarTop phi.(cr_ctx) size in
    let phi_rel := weaken_store_rel size phi_rel in
    {| cr_st := {| cs_st1 := prev_l;
                   cs_st2 := prev_r |};
       cr_rel := wp_lpred Left b prev_l cur_l leap_l
                          (wp_lpred Right b prev_r cur_r leap_r phi_rel) |}.

  (* Weakest precondition operator. *)
  Definition wp (phi: conf_rel a) : list (conf_rel a) :=
    let cur_st_left  := phi.(cr_st).(cs_st1) in
    let cur_st_right := phi.(cr_st).(cs_st2) in
    let pred_pairs := List.flat_map (Reachability.reaches (cur_st_left, cur_st_right)) reachable_states in
    List.map (wp_pred_pair phi) pred_pairs.

End WP.

Global Hint Unfold wp_lpred: wp.
Global Hint Unfold wp_pred_pair: wp.


(** * Reflective notations for context free grammars *)
Require Import Coq.Strings.Ascii.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Common.Equality.

Global Arguments N_of_ascii !_ / .
Global Arguments Compare_dec.leb !_ !_ / .
Global Arguments BinNat.N.leb !_ !_ / .
Global Arguments BinNat.N.compare !_ !_ / .
Global Arguments BinPos.Pos.to_nat !_ / .

Module opt.
  Local Arguments N_of_ascii / _ .
  Local Arguments N_of_digits / _ .
  Local Arguments BinNat.N.add !_ !_ / .
  Local Arguments BinNat.N.mul !_ !_ / .
  Definition N_of_ascii ch
    := Eval simpl in N_of_ascii ch.
End opt.

Global Arguments opt.N_of_ascii !_ / .

Delimit Scope rchar_scope with rchar.

Section syntax.
  Context {Char : Type}.

  Inductive RCharExpr :=
  | rbeq (ch : Char)
  | ror (_ _ : RCharExpr)
  | rand (_ _ : RCharExpr)
  | rneg (_ : RCharExpr)
  | rcode_le_than (code : BinNums.N)
  | rcode_ge_than (code : BinNums.N).

  Bind Scope rchar_scope with RCharExpr.

  Inductive ritem :=
  | RTerminal (_ : RCharExpr)
  | RNonTerminal (_ : String.string).

  Definition rproduction := list ritem.
  Definition rproductions := list rproduction.
End syntax.

Scheme Minimality for ritem Sort Type.
Scheme Minimality for ritem Sort Set.
Scheme Minimality for ritem Sort Prop.

Scheme Equality for RCharExpr.
Scheme Equality for ritem.
Global Instance RCharExpr_BoolDecR {Char} {Char_beq : BoolDecR Char} : BoolDecR (@RCharExpr Char)
  := RCharExpr_beq Char_beq.
Global Instance RCharExpr_BoolDec_bl {Char} {Char_beq : BoolDecR Char} {Char_bl : BoolDec_bl eq} : BoolDec_bl (@eq (@RCharExpr Char))
  := internal_RCharExpr_dec_bl Char_beq Char_bl.
Global Instance RCharExpr_BoolDec_lb {Char} {Char_beq : BoolDecR Char} {Char_lb : BoolDec_lb eq} : BoolDec_lb (@eq (@RCharExpr Char))
  := internal_RCharExpr_dec_lb Char_beq Char_lb.
Global Instance ritem_BoolDecR {Char} {Char_beq : BoolDecR Char} : BoolDecR (@ritem Char)
  := ritem_beq Char_beq.
Global Instance ritem_BoolDec_bl {Char} {Char_beq : BoolDecR Char} {Char_bl : BoolDec_bl eq} : BoolDec_bl (@eq (@ritem Char))
  := internal_ritem_dec_bl Char_beq Char_bl.
Global Instance ritem_BoolDec_lb {Char} {Char_beq : BoolDecR Char} {Char_lb : BoolDec_lb eq} : BoolDec_lb (@eq (@ritem Char))
  := internal_ritem_dec_lb Char_beq Char_lb.

Global Arguments RCharExpr : clear implicits.
Global Arguments ritem : clear implicits.
Global Arguments rproduction : clear implicits.
Global Arguments rproductions : clear implicits.
Global Arguments rbeq {Char%type_scope} _.
Global Arguments ror {Char%type_scope} (_ _)%rchar_scope.
Global Arguments rand {Char%type_scope} (_ _)%rchar_scope.
Global Arguments rneg {Char%type_scope} (_)%rchar_scope.
Global Arguments rcode_le_than {Char%type_scope} (_)%N_scope.
Global Arguments rcode_ge_than {Char%type_scope} (_)%N_scope.

Infix "||" := ror : rchar_scope.
Infix "&&" := rand : rchar_scope.
Notation "~ x" := (rneg x) : rchar_scope.

Section semantics.
  Context {Char : Type}.

  Class interp_RCharExpr_data :=
    { irbeq : Char -> Char -> bool;
      irN_of : Char -> BinNums.N }.

  Context {idata : interp_RCharExpr_data}.

  Fixpoint interp_RCharExpr (expr : RCharExpr Char) : Char -> bool
    := match expr with
       | rbeq ch => irbeq ch
       | ror a b => fun ch => interp_RCharExpr a ch || interp_RCharExpr b ch
       | rand a b => fun ch => interp_RCharExpr a ch && interp_RCharExpr b ch
       | rneg x => fun ch => negb (interp_RCharExpr x ch)
       | rcode_le_than code => fun ch => BinNat.N.leb (irN_of ch) code
       | rcode_ge_than code => fun ch => BinNat.N.leb code (irN_of ch)
       end%bool.

  (*Global Coercion interp_RCharExpr : RCharExpr >-> Funclass.*)

  Definition interp_ritem (expr : ritem Char) : item Char
    := match expr with
       | RTerminal x => Terminal (interp_RCharExpr x)
       | RNonTerminal x => NonTerminal x
       end.

  Definition interp_rproduction (expr : rproduction Char) : production Char
    := List.map interp_ritem expr.

  Definition interp_rproductions (expr : rproductions Char) : productions Char
    := List.map interp_rproduction expr.
End semantics.

Global Arguments interp_RCharExpr_data : clear implicits.

Global Instance ascii_interp_RCharExpr_data : interp_RCharExpr_data Ascii.ascii
  := { irbeq := Equality.ascii_beq;
       irN_of := opt.N_of_ascii }.

(** Alternative that isn't higher order *)
Definition char_at_matches_interp {Char} {HSLM : StringLikeMin Char}
           {_ : interp_RCharExpr_data Char} n str P
  := char_at_matches n str (interp_RCharExpr P).