(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XRseries.
Require Import XSeqProp.
Require Import XPartSum.
Require Import Max.
Local Open Scope XR_scope.

(**********)
(** * Formalization of alternated series *)
Definition tg_alt (Un:nat -> R) (i:nat) : R := (-R1) ^ i * Un i.
Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, R0 <= Un n.

Lemma CV_ALT_step0 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold Un_growing; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0.
  do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
  pattern (tg_alt Un (S (2 * n))) at 1; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * S n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -R1 * Un (S (2 * S n)))) with
      (Un ( 2 * S n)%nat).
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite Rplus_comm.
rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
  apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

Lemma CV_ALT_step1 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
Proof.
  intros; unfold Un_decreasing; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * n)) + (-R1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
      (Un (2 * S n)%nat).
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
}
  rewrite H0; apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

(**********)
Lemma CV_ALT_step2 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un ->
    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= R0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
  replace (-R1 * -R1 * Un 2%nat) with (Un 2%nat).
  2:{
rewrite <- Ropp_mult_distr_l.
rewrite <- Ropp_mult_distr_r.
rewrite Ropp_involutive.
rewrite Rmult_1_l.
rewrite Rmult_1_l.
reflexivity.
  }
  apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
  replace (Un 1%nat + (-R1 * Un 1%nat + Un 2%nat)) with (Un 2%nat).
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
}
    apply H.
  cut (S (2 * S N) = S (S (S (2 * N)))).
  intro; rewrite H1; do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2;
    rewrite <- Rplus_0_r.
  rewrite Rplus_assoc; apply Rplus_le_compat_l.
  unfold tg_alt; rewrite <- H1.
  rewrite pow_1_odd.
  cut (S (S (2 * S N)) = (2 * S (S N))%nat).
  intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
  apply Rplus_le_reg_l with (Un (S (2 * S N))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S N)) + (-R1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
      with (Un (S (S (2 * S N)))).
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite <- Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_l.
reflexivity.
}

  apply H.
  ring.
  apply HrecN.
  ring.
Qed.

(** A more general inequality *)
Lemma CV_ALT_step3 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= R0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
  apply Rplus_le_reg_l with (Un 1%nat).
  rewrite Rplus_0_r; replace (Un 1%nat + -R1 * Un 1%nat) with R0.
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite Rplus_opp_r.
reflexivity.
}
    apply H0.
  assert (H1 := even_odd_cor N).
  elim H1; intros.
  elim H2; intro.
  rewrite H3; apply CV_ALT_step2; assumption.
  rewrite H3; rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2;
    rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt; simpl.
  replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
  rewrite pow_1_even.
  replace (-R1 * (-R1 * (-R1 * R1)) * Un (S (S (S (2 * x))))) with
    (- Un (S (S (S (2 * x))))).
2:{
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_r.
rewrite Rmult_1_l.
rewrite <- Ropp_mult_distr_l.
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
rewrite Ropp_involutive.
rewrite Rmult_1_l.
reflexivity.
}
  apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
  rewrite Rplus_0_r; rewrite Rplus_opp_r.
  apply H0.
  apply CV_ALT_step2; assumption.
Qed.

  (**********)
Lemma CV_ALT_step4 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold has_ub; unfold bound.
  exists (Un 0%nat).
  unfold is_upper_bound; intros; elim H1; intros.
  rewrite H2; rewrite decomp_sum.
  replace (tg_alt Un 0) with (Un 0%nat).
  pattern (Un 0%nat) at 2; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  apply CV_ALT_step3; assumption.
  unfold tg_alt; simpl.
rewrite Rmult_1_l.
reflexivity.
  apply lt_O_Sn.
Qed.

(** This lemma gives an interesting result about alternated series *)
Lemma CV_ALT :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    Un_cv Un R0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros.
  assert (H2 := CV_ALT_step0 _ H).
  assert (H3 := CV_ALT_step4 _ H H0).
  destruct (growing_cv _ H2 H3) as (x,p).
  exists x.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
  intros; cut (R0 < eps / (IZR 2)).
    intro.
    2:{
unfold Rdiv. apply Rmult_lt_0_compat.
	assumption.
apply Rinv_0_lt_compat.
apply Rlt_0_2.
}
  elim (H1 (eps / (IZR 2)) H5); intros N2 H6.
  elim (p (eps / (IZR 2)) H5); intros N1 H7.
  set (N := max (S (2 * N1)) N2).
  exists N; intros.
  assert (H9 := even_odd_cor n).
  elim H9; intros P H10.
  cut (N1 <= P)%nat.
  intro; elim H10; intro.
  replace (sum_f_R0 (tg_alt Un) n - x) with
    (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
  apply Rle_lt_trans with
    (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
  apply Rabs_triang.
  rewrite (double_var eps); apply Rplus_lt_compat.
  rewrite H12; apply H7; assumption.
  rewrite Rabs_Ropp; unfold tg_alt; rewrite Rabs_mult;
    rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
	apply H6.
  unfold ge; apply le_trans with n.
  apply le_trans with N; [ unfold N; apply le_max_r | assumption ].
  apply le_n_Sn.
  rewrite tech5.
unfold Rminus.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
  rewrite H12; apply Rlt_trans with (eps / (IZR 2)).
  apply H7; assumption.
  unfold Rdiv; apply Rmult_lt_reg_l with (IZR 2).
exact Rlt_0_2.
  rewrite (Rmult_comm (IZR 2)); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
    [ rewrite Rmult_1_r | discrR ].
  rewrite double.
  pattern eps at 1; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
    assumption.
exact Neq_2_0.
  elim H10; intro; apply le_double.
  rewrite <- H11; apply le_trans with N.
  unfold N; apply le_trans with (S (2 * N1));
    [ apply le_n_Sn | apply le_max_l ].
  assumption.
  apply lt_n_Sm_le.
  rewrite <- H11.
  apply lt_le_trans with N.
  unfold N; apply lt_le_trans with (S (2 * N1)).
  apply lt_n_Sn.
  apply le_max_l.
  assumption.
Qed.

(*************************************************)
(** *       Convergence of alternated series     *)
Theorem alternated_series :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_cv Un R0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros; apply CV_ALT.
  assumption.
  unfold positivity_seq; apply decreasing_ineq; assumption.
  assumption.
Qed.

Theorem alternated_series_ineq :
  forall (Un:nat -> R) (l:R) (N:nat),
    Un_decreasing Un ->
    Un_cv Un R0 ->
    Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
    sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
Proof.
  intros.
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
  intros; split.
  apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
  apply CV_ALT_step0; assumption.
  assumption.
  apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
  apply CV_ALT_step1; assumption.
  assumption.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge; apply le_trans with (2 * n)%nat.
  apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry ; assumption | discriminate ].
  assumption.
  apply le_n_Sn.
  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge; apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry ; assumption | discriminate ].
  assumption.
Qed.

(***************************************)
(** * Application : construction of PI *)
(***************************************)

Definition PI_tg (n:nat) := / INR (2 * n + 1).

Lemma PI_tg_pos : forall n:nat, R0 <= PI_tg n.
Proof.
  intro; unfold PI_tg; left; apply Rinv_0_lt_compat; apply lt_INR_0;
    replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
Qed.

Lemma PI_tg_decreasing : Un_decreasing PI_tg.
Proof.
  unfold PI_tg, Un_decreasing; intro.
  apply Rmult_le_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (2 * S n + 1)).
  apply lt_INR_0.
  replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply le_INR.
  replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
  apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
  ring.
  apply not_O_INR; discriminate.
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
Qed.

Lemma PI_tg_cv : Un_cv PI_tg R0.
Proof.
  unfold Un_cv; unfold R_dist; intros.
  cut (R0 < (IZR 2) * eps).
    intro.
2:{
apply Rmult_lt_0_compat.
apply Rlt_0_2.
assumption.
}
  assert (H1 := archimed (/ ((IZR 2) * eps))).
  cut (0 <= up (/ ((IZR 2) * eps)))%Z.
  intro; assert (H3 := IZN (up (/ ((IZR 2) * eps))) H2).
  elim H3; intros N H4.
  cut (0 < N)%nat.
  intro; exists N; intros.
  cut (0 < n)%nat.
  intro; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite Rabs_right.
  unfold PI_tg; apply Rlt_trans with (/ INR (2 * n)).
  apply Rmult_lt_reg_l with (INR (2 * n)).
  apply lt_INR_0.
  replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
  apply lt_le_trans with n.
  assumption.
  apply le_plus_l.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * n + 1))).
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply lt_INR.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
  replace n with (S (pred n)).
  apply not_O_INR; discriminate.
  symmetry ; apply S_pred with 0%nat.
  assumption.
  apply Rle_lt_trans with (/ INR (2 * N)).
  apply Rinv_le_contravar.
  rewrite mult_INR; apply Rmult_lt_0_compat.
    simpl.
pattern R0 ; rewrite <- Rplus_0_l.
apply Rplus_lt_compat;exact Rlt_0_1.
 apply lt_INR_0. assumption.
  apply le_INR.
  now apply mult_le_compat_l.
  rewrite mult_INR.
  apply Rmult_lt_reg_l with (INR N / eps).
  apply Rdiv_lt_0_compat with (2 := H).
  now apply (lt_INR 0).
  replace (_ */ _) with (/((IZR 2) * eps)).
  replace (_ / _ * _) with (INR N).
  rewrite INR_IZR_INZ.
  now rewrite <- H4.
  unfold Rdiv.
rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
reflexivity.
apply Rlt_not_eq'.
assumption.
  simpl (INR 2).
change R1 with (IZR 1).
rewrite <- plus_IZR.
simpl.
unfold Rdiv.
rewrite Rinv_mult_distr.
rewrite Rinv_mult_distr.
repeat rewrite Rmult_assoc.
rewrite (Rmult_comm (INR N)).
repeat rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
rewrite Rmult_comm.
reflexivity.
apply Rlt_not_eq'.
change R0 with (INR 0).
apply lt_INR.
assumption.
exact Neq_2_0.
apply Rlt_not_eq'.
change R0 with (INR 0).
apply lt_INR.
assumption.
exact Neq_2_0.
apply Rlt_not_eq'.
assumption.
  apply PI_tg_pos.
  apply lt_le_trans with N; assumption.
  elim H1; intros H5 _.
  destruct (lt_eq_lt_dec 0 N) as [[| <- ]|H6].
  assumption.
  rewrite H4 in H5.
  simpl in H5.
  cut (R0 < / ((IZR 2) * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)).
  elim (lt_n_O _ H6).
  apply le_IZR.
  left; apply Rlt_trans with (/ ((IZR 2) * eps)).
  apply Rinv_0_lt_compat; assumption.
  elim H1; intros; assumption.
Qed.

Lemma exist_PI :
  { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }.
Proof.
  apply alternated_series.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
Qed.

(** Now, PI is defined *)
Definition Alt_PI : R := (IZR 4) * (let (a,_) := exist_PI in a).

(** We can get an approximation of PI with the following inequality *)
Lemma Alt_PI_ineq :
  forall N:nat,
    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= Alt_PI / (IZR 4) <=
    sum_f_R0 (tg_alt PI_tg) (2 * N).
Proof.
  intro; apply alternated_series_ineq.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
  unfold Alt_PI; case exist_PI; intro.
  replace ((IZR 4) * x / (IZR 4)) with x.
  trivial.
  unfold Rdiv; rewrite (Rmult_comm (IZR 4)); rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
change R0 with (IZR 0).
apply IZR_neq.
intro eq. inversion eq.
Qed.

Lemma Alt_PI_RGT_0 : R0 < Alt_PI.
Proof.
  assert (H := Alt_PI_ineq 0).
  apply Rmult_lt_reg_l with (/ (IZR 4)).
  apply Rinv_0_lt_compat.
change 4%Z with (2+2)%Z.
rewrite plus_IZR.
pattern R0;rewrite <- Rplus_0_l.
apply Rplus_lt_compat;exact Rlt_0_2.
  rewrite Rmult_0_r; rewrite Rmult_comm.
  elim H; clear H; intros H _.
  unfold Rdiv in H;
    apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
  simpl; unfold tg_alt; simpl; rewrite Rmult_1_l;
    rewrite Rmult_1_r; apply Rplus_lt_reg_l with (PI_tg 1).
  rewrite Rplus_0_r;
    replace (PI_tg 1 + (PI_tg 0 + -R1 * PI_tg 1)) with (PI_tg 0);
      unfold PI_tg.
2:{
simpl.
rewrite Rinv_1.
rewrite <- Ropp_mult_distr_l.
rewrite Rmult_1_l.
symmetry.
rewrite Rplus_comm.
rewrite Rplus_assoc.
rewrite Rplus_opp_l.
rewrite Rplus_0_r.
reflexivity.
}
  simpl; apply Rinv_lt_contravar.
  rewrite Rmult_1_l; replace (IZR 2 + R1) with (IZR 3).
pattern R0;rewrite <- Rplus_0_l.
apply Rplus_lt_compat.
pattern R0;rewrite <- Rplus_0_l.
apply Rplus_lt_compat.
exact Rlt_0_1.
exact Rlt_0_1.
exact Rlt_0_1.
change R1 with (IZR 1).
rewrite <- plus_IZR.
simpl.
reflexivity.
  rewrite Rplus_comm; pattern R1 at 1; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l.
pattern R0;rewrite <- Rplus_0_l.
apply Rplus_lt_compat.
exact Rlt_0_1.
exact Rlt_0_1.
  assumption.
Qed.


Require Import core core_axioms fintype.
Import ScopedNotations.

Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [x|]; reflexivity.  Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)).
Proof. fext. intros [x|]; reflexivity. Qed.

Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = (tau s) .: (sigma >> tau) .
Proof.
  fext. intros [x|]. reflexivity. simpl. reflexivity.
Qed.

Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) :
  (zero_p m >> scons_p m f g) = f.
Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed.

Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) :
  shift_p m  >> scons_p m f g = g.
Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed.

Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} :
  (scons_p m f g) >> h = scons_p m (f >> h) (g >> h).
Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl_fext :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         (* | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *) *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head

         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s.:?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g
         | [|- context[?x2 .: shift >> ?f]] => change x2 with (f var_zero); rewrite (@scons_eta _ _ f)
         | [|- context[?f var_zero .: ?g]] => change g with (shift >> f); rewrite scons_eta

         |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)

         | _ => first [progress (rewrite scons_comp) |  progress (rewrite scons_eta_id) | progress (autorewrite with FunctorInstances)]
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc_fext :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         (* | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *) *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[?x2 .: shift >> ?f]|- _] =>
           change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[?f var_zero .: ?g]|- _] =>
           change g with (shift >> f) in H; rewrite scons_eta in H
         | _ => first [progress (rewrite scons_comp in *) | progress (rewrite scons_eta_id in *) | progress (autorewrite with FunctorInstances in *)]
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl_fext" "in" "*" :=
  fsimpl_fext; fsimplc_fext.

Hint Rewrite @scons_p_comp scons_p_head scons_p_tail : FunctorInstances.


From discprob.basic Require Import base nify.
From mathcomp Require Import ssreflect seq ssrbool eqtype.
Import Omega.

Lemma undup_map {A B: eqType} (l: seq A) (f: A → B):
  undup [seq f x | x <- l] = undup [seq f x | x <- undup l].
Proof.
  induction l as [| a l] => //=.
  symmetry. case: ifP.
  * intros Hin. apply (map_f f) in Hin.
    rewrite Hin. done.
  * intros Hnin. rewrite //=.
    case: ifP.
    ** intros Hin'.
       move /mapP in Hin'. destruct Hin' as [a' ? ?]; subst.
       case: ifP; auto.
       intros Hfalse. exfalso. move /mapP in Hfalse. apply Hfalse.
       exists a'.
       *** rewrite -mem_undup; done.
       *** auto.
    ** intros Hnin'.
       case: ifP; last by (intros; f_equal; eauto).
       intros Hfalse. move /mapP in Hnin'. exfalso. apply Hnin'.
       move /mapP in Hfalse. destruct Hfalse as [a' ? ?].
       exists a'.
       *** rewrite mem_undup; done.
       *** auto.
Qed.

Lemma nth_legacy {A: Type} (d: A) l x:
  nth d l x = List.nth x l d.
Proof.
  revert x; induction l => //=; destruct x => /= //.
Qed.

Lemma nth_error_nth1 {A: Type} (d: A) l x:
  x < length l →
  List.nth_error l x = Some (nth d l x).
Proof.
  revert l.
  induction x.
  - rewrite //=. destruct l; auto. rewrite //=. omega.
  - intros l Hlt0; destruct l.
      ** rewrite //= in Hlt0. omega.
      ** rewrite //=. eapply IHx. rewrite //= in Hlt0. omega.
Qed.

Lemma nth_error_nth2 {A: Type} (d: A) l x v:
  List.nth_error l x = Some v →
  nth d l x = v.
Proof.
  revert x.
  induction l => //=.
  - destruct x; rewrite //=.
  - destruct x; rewrite //=; first by inversion 1.
    eauto.
Qed.

Lemma size_legacy {A: Type} (l: list A):
  size l = length l.
Proof. induction l => //=. Qed.

Lemma map_legacy {A B: Type} (f: A → B) l:
  map f l = List.map f l.
Proof.
  induction l => //=.
Qed.

Lemma mem_seq_legacy {A: eqType} (x: A) (l: seq A):
  x \in l ↔ In x l.
Proof.
  split.
  - induction l.
    * inversion 1.
    * move /orP => [Heq|Htail].
      ** move /eqP in Heq. by left.
      ** right. auto.
  - induction l; inversion 1.
    * apply /orP; left; subst; auto.
    * apply /orP; right; subst; auto.
Qed.

Require Import Reals Psatz.

Local Open Scope R.
From discprob.basic Require Import base nify order.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
Import List.

Lemma fold_left_Rmin_init l x:
  fold_left Rmin l x <= x.
Proof.
  revert x. induction l => //=; first reflexivity.
  intros x. etransitivity; first eapply IHl.
  apply Rmin_l.
Qed.

Lemma fold_left_Rmin_mono_init l x x':
  x <= x' →
  fold_left Rmin l x <= fold_left Rmin l x'.
Proof.
  revert x x'. induction l => //=.
  intros. eapply IHl.
  apply Rle_min_compat_r; auto.
Qed.

Lemma fold_left_Rmin_cons a l x:
  fold_left Rmin (a :: l) x <= fold_left Rmin l x.
Proof.
  revert a x. destruct l.
  - intros; apply Rmin_l.
  - intros => //=. apply fold_left_Rmin_mono_init.
    apply Rle_min_compat_r. apply Rmin_l.
Qed.

Lemma fold_left_ext {A B} (f f': A → B → A) l l' x x':
  (forall a b, f a b = f' a b) → l = l' → x = x' → fold_left f l x = fold_left f' l' x'.
Proof.
  revert x x' l'. induction l => //=.
  - intros.  subst => //=.
  - intros x x' [| a' l']; first by auto.
    intros => //=. eapply IHl; eauto; by congruence.
Qed.

Lemma fold_left_Rmin_glb l r x:
  (∀ r', In r' l → r <= r') → r <= x → r <= fold_left Rmin l x.
Proof.
  revert r x. induction l as [| a l] => //=.
  intros r x Hglb Hinit. eapply IHl.
  - intros. apply Hglb; eauto.
  - apply Rmin_glb; eauto.
Qed.

Lemma fold_left_Rmin_witness1 l x:
  (∃ r, In r l ∧ r = fold_left Rmin l x) ∨ ((∀ r, In r l → x < r) ∧ fold_left Rmin l x = x).
Proof.
  revert x. induction l as [| a l] => //=.
  - right. split; auto; intros ? [].
  - intros x. edestruct (IHl (Rmin x a)) as [(r&Hin&Heq)|Hlt].
    * left. exists r. split; auto.
    * destruct (Rlt_dec x a).
      ** right; split.
         *** intros ? [|]; eauto.
             **** subst. nra.
             **** eapply Rle_lt_trans; last eapply Hlt; eauto.
                  rewrite Rmin_left; nra.
         *** destruct Hlt as (?&->). rewrite Rmin_left; nra.
      ** left. move: Hlt. rewrite Rmin_right; last by nra => Hlt.
         intros. exists a; split; first by left.
         apply Rle_antisym.
         ***  apply fold_left_Rmin_glb; try nra. intros. left. apply Hlt; eauto.
         *** apply fold_left_Rmin_init.
Qed.

Lemma fold_left_Rmax_init l x:
  x <= fold_left Rmax l x.
Proof.
  revert x. induction l => //=; first reflexivity.
  intros x. etransitivity; last eapply IHl.
  apply Rmax_l.
Qed.

Lemma fold_left_Rmax_mono_init l x x':
  x <= x' →
  fold_left Rmax l x <= fold_left Rmax l x'.
Proof.
  revert x x'. induction l => //=.
  intros. eapply IHl.
  apply Rle_max_compat_r; auto.
Qed.

Lemma fold_left_Rmax_cons a l x:
   fold_left Rmax l x <= fold_left Rmax (a :: l) x.
Proof.
  revert a x. destruct l.
  - intros; apply Rmax_l.
  - intros => //=. apply fold_left_Rmax_mono_init.
    apply Rle_max_compat_r. apply Rmax_l.
Qed.

Lemma fold_left_Rmax_lub l r x:
  (∀ r', In r' l → r' <= r) → x <= r → fold_left Rmax l x <= r.
Proof.
  revert r x. induction l as [| a l] => //=.
  intros r x Hglb Hinit. eapply IHl.
  - intros. apply Hglb; eauto.
  - apply Rmax_lub; eauto.
Qed.

Lemma fold_left_Rmax_witness1 l x:
  (∃ r, In r l ∧ r = fold_left Rmax l x) ∨ ((∀ r, In r l → r < x) ∧ fold_left Rmax l x = x).
Proof.
  revert x. induction l as [| a l] => //=.
  - right. split; auto; intros ? [].
  - intros x. edestruct (IHl (Rmax x a)) as [(r&Hin&Heq)|Hlt].
    * left. exists r. split; auto.
    * destruct (Rgt_dec x a).
      ** right; split.
         *** intros ? [|]; eauto.
             **** subst. nra.
             **** eapply Rge_gt_trans; last eapply Hlt; eauto.
                  rewrite Rmax_left; nra.
         *** destruct Hlt as (?&->). rewrite Rmax_left; nra.
      ** left. move: Hlt. rewrite Rmax_right; last by nra => Hlt.
         intros. exists a; split; first by left.
         apply Rle_antisym.
         *** apply fold_left_Rmax_init.
         *** apply fold_left_Rmax_lub; try nra. intros. left. apply Hlt; eauto.
Qed.

Lemma fold_left_Rmax_Rmin_map {A} (l: list A) (x: R) f:
   fold_left Rmax (map f l) x = - fold_left Rmin (map (λ x, - f x) l) (- x).
Proof.
  revert x.
  induction l => x //=.
  - nra.
  - assert (- Rmax x (f a) = Rmin (- x) (-f a)) as <-; last auto.
    apply Ropp_Rmax.
Qed.

Lemma allpairs_comp {A A' B B'} (f1: A → A') (f2: B → B') l1 l2:
  [seq (f1 x1, f2 x2) | x1 <- l1, x2 <- l2] =
  [seq (x1, x2) | x1 <- [seq f1 i | i <- l1], x2 <- [seq f2 i | i <- l2]].
Proof.
  revert f1 f2 l2; induction l1 => //= f1 f2 l2.
  rewrite ?IHl1.
  rewrite -map_comp //=.
Qed.

Lemma foldl_Rmin l:
  ∀ x, foldl Rmin x l <= x.
Proof.
  induction l; rewrite //=; intros; try nra.
  eapply Rle_trans; first eapply IHl.
  apply Rmin_l.
Qed.


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

 From ExtLib Require Import
     Structures.Monad.

From ITree Require Import
     ITree
     ITreeFacts
     Events.MapDefault
     Events.StateFacts.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.
(* end hide *)

(** * A trace-based axiomatic memory model?
  This is currently a very naive experiment, nothing well thought out.
*)

Module Simple.

  Section WithDom.

    Variable (var value : Type).
    Variable (eqb : var -> var -> bool).
    Infix "=?" := eqb (at level 50).

    (* We assume computations interacting through simple read and writes with a memory *)
    Variant StateE : Type -> Type :=
    | GetVar (x : var) : StateE value
    | SetVar (x : var) (v : value) : StateE unit.

    (* [action]s are read and writes to the memory, they map one to one to events *)
    Variant action : Type := Wr (x: var) (v : value) | Rd (x : var) (v : value).
    (* A history is a finite list of actions that has occurred. We add to the left, never remove *)
    Definition history : Type := list action.

    (* The semantics of a read is deterministic if at least one write to the same cell has taken place before *)
    Fixpoint read (t : history) (x : var) : option value :=
      match t with
      | nil => None
      | Wr y v :: t => if x =? y then Some v else read t x
      | Rd _ _ :: t => read t x
      end.

    (* Our model of computation is gonna be essentially a non-deterministic
   stateful computation using historys as states *)
    Definition myMonad (X : Type) : Type :=
      history -> itree void1 (history * X) -> Prop.
    Definition myOtherMonad (X : Type) : Type :=
      (history -> itree void1 (history * X)) -> Prop.

    (* We can now define our handler.
   - we simply record writes in the history
   - Reads are deterministic if we find a write.
   - Reads are unspecified if we haven't written yet to it, i.e. can return any value
   We can remark that we don't use the reads from the history, we could ditch them
     *)
    Variant handler_prop: StateE ~> myMonad :=
    | SetVarH : forall x v h,
        handler_prop _ (SetVar x v) h (ret (Wr x v :: h, tt))
    | GetVarSetH : forall x v h,
        read h x = Some v ->
        handler_prop _ (GetVar x) h (ret (Rd x v :: h, v))
    | GetVarUnsetH : forall x v h,
        read h x = None ->
        handler_prop _ (GetVar x) h (ret (Rd x v :: h, v))
    .

    (* We can also define the model where one cannot read to a variable before it's written to *)
    Variant handler_prop': StateE ~> myMonad :=
    | SetVarH' : forall x v h,
        handler_prop' _ (SetVar x v) h (ret (Wr x v :: h, tt))
    | GetVarSetH' : forall x v h,
        read h x = Some v ->
        handler_prop' _ (GetVar x) h (ret (Rd x v :: h, v))
    .

    (* We can also define the executable model where a default value is used *)
    Definition handler_exec (def : value) : StateE ~> stateT history (itree void1) :=
      fun _ e h =>
        match e with
        | SetVar x v => ret (Wr x v :: h, tt)
        | GetVar x   =>
          match read h x with
          | Some v => ret (Rd x v :: h, v)
          | None   => ret (Rd x def :: h, def)
          end
        end
    .

    (* Clearly, there is some kind of refinement going on between the models *)
    Lemma handler_prop_refine :
      forall X (e : StateE X) h t,
        handler_prop' _ e h t ->
        handler_prop _ e h t.
    Proof.
      intros * HP.
      dependent destruction HP.
      constructor; auto.
      constructor; auto.
    Qed.

    (* Clearly, the implementation is somehow valid *)
    Lemma handler_exec_refine :
      forall X (e : StateE X) def h t,
        handler_exec def _ e h = t ->
        handler_prop _ e h t.
    Proof.
      intros * HP.
      destruct e; cbn in *.
      destruct (read h x) eqn:EQ.
      subst t; constructor; auto.
      subst t; constructor 3; auto.
      subst t; constructor; auto.
    Qed.

    (* MGZ'15 takes a different take: it defines axioms that constraint the legal actions
     given an history that a memory model can allow *)
    Definition site (a : action) : var :=
      match a with
      | Rd x _ | Wr x _ => x
      end.

    Definition is_write (a : action) : bool :=
      match a with
      | Wr _ _ => true
      | _ => false
      end.

    Definition modifies (a : action) (x : var) : bool :=
      match a with
      | Wr y _ => y =? x
      | _ => false
      end.

    Record valid (can_do : history -> action -> Prop) : Prop :=
      {
      (* Different sites are separated: actions at different sites commute *)
      Site_comm : forall h a a',
          site a =? site a' ->
          can_do (a :: h) a' <-> can_do (a' :: h) a;

      (* Different sites are separated: an action at a site cannot regulate actions at other sites *)
      Site_drop : forall h a a',
          site a =? site a' ->
          can_do (a :: h) a' <-> can_do h a';

      (* Reads don't regulate possible actions *)
      Read_noop : forall h x v a,
          can_do h (Rd x v) ->
          can_do (Rd x v :: h) a <-> can_do h a;

      (* Writes regulate reads *)
      Read_written : forall h x v v',
          can_do h (Wr x v) ->
          can_do (Wr x v :: h) (Rd x v') <-> v = v';

      (* Writes can only regulate reads *)
      Write_not_read : forall h x v a,
          can_do h (Wr x v) ->
          ~ is_write a ->
          can_do (Wr x v :: h) a <-> can_do h a;

      (* Writes can only be regulated by actions modifying their location *)
      Not_mod_write : forall h l v a,
          can_do h a ->
          ~ modifies a l ->
          can_do (a :: h) (Wr l v) <-> can_do h (Wr l v);

      (* The value intended to be written does not mandate the legality of a write *)

      Write_any_value : forall h x v v',
          can_do h (Wr x v) <-> can_do h (Wr x v');

      (* At the dawn of time, nothing can be read *)
      Base_read : forall l v,
          ~ can_do nil (Rd l v)

      }.

    (* Question : can we easily link both approaches? *)
    Definition event_of_action (a : action) : {X : Type & StateE X & X} :=
      match a with
      | Rd x v => existT2 _ _ _ (GetVar x) v
      | Wr x v => existT2 _ _ _ (SetVar x v) tt
      end.
    (* We could define a notion of "can_do", but at least this attempt lacks something:
       we also need to constraint the "h" to be reachable
     *)
    Definition can_do_step : history -> action -> Prop :=
      fun h a =>
        let '(existT2 _ _ X e v) := event_of_action a in
        handler_prop _ e h (ret (a :: h, v)).
    Inductive can_extend : history -> history -> Prop :=
    | Extend_refl : forall h, can_extend h h
    | Extend_step : forall h h' a,
        can_extend h h' ->
        can_do_step h' a ->
        can_extend h (a :: h').

    Definition valid_history : history -> Prop :=
      can_extend nil.

    Definition can_do := fun h a => valid_history h /\ can_do_step h a.

    Lemma handler_prop_valid : valid can_do.
    Proof.
      constructor.
      (* - intros * SITE; split; intros CAN. *)
      (*   + destruct a, a'; try now constructor.  *)
      (*     * cbn in CAN. *)
      (*       inv CAN. *)
      (*       constructor. *)
      (*       dependent destruction CAN. *)
      (*       cbn in x. *)
    Admitted.

  End WithDom.

End Simple.

Module MGZ.

  Section WithDom.

    Variable (loc value : Type).
    Variable (eqb : loc -> loc -> bool).
    Infix "=?" := eqb (at level 50).

    (* We assume computations interacting through simple read and writes with a memory *)
    Variant MemE : Type -> Type :=
    | RdE (l : loc)             : MemE value
    | WrE (l : loc) (v : value) : MemE unit
    | AllocE                    : MemE loc
    | FreeE (l : loc)           : MemE unit.

    (* [action]s map one to one to events, but carry the answer as well *)
    Variant action : Type :=
      Wr (l : loc) (v : value)
    | Rd (l : loc) (v : value)
    | Al (l : loc)
    | Fr (l : loc).

    (* A history is a finite list of actions that has occurred. We add to the left, never remove *)
    Definition history : Type := list action.

    (* The semantics of a read is deterministic if at least one write to the same cell has taken place before *)
    Variant can_read : Type := | SuccessR (v : value) | UninitR | FreedR.
    Fixpoint read (h : history) (l : loc) : can_read :=
      match h with
      | nil                     => UninitR
      | Wr l' v :: h            => if l =? l' then SuccessR v else read h l
      | Fr l' :: h              => if l =? l' then FreedR else read h l
      | Rd _ _ :: h | Al _ :: h => read h l
      end.

    Variant can_write : Type := | SuccessW | UninitW | FreedW.
    Fixpoint write (h : history) (l : loc) : can_write :=
      match h with
      | nil                       => UninitW
      | Fr l' :: h                => if l =? l' then FreedW else write h l
      | Al l' :: h                => if l =? l' then SuccessW else write h l
      | Rd _ _ :: h | Wr _ _ :: h => write h l
      end.

    Variant can_alloc : Type := | SuccessA | BoundA.
    Fixpoint alloc (h : history) (l : loc) : can_alloc :=
      match h with
      | nil                       => SuccessA
      | Fr l' :: h                => if l =? l' then SuccessA else alloc h l
      | Al l' :: h                => if l =? l' then BoundA else alloc h l
      | Rd _ _ :: h | Wr _ _ :: h => alloc h l
      end.

    Variant can_free : Type := | SuccessF | AlreadyFreedF | UninitF.
    Fixpoint free (h : history) (l : loc) : can_free :=
      match h with
      | nil                       => UninitF
      | Fr l' :: h                => if l =? l' then AlreadyFreedF else free h l
      | Al l' :: h                => if l =? l' then SuccessF else free h l
      | Rd _ _ :: h | Wr _ _ :: h => free h l
      end.

    (* Our model of computation is gonna be essentially a non-deterministic
   stateful computation using historys as states *)
    Definition myMonad (X : Type) : Type :=
      history -> itree void1 (history * X) -> Prop.

    (* We can now define our handler.
     Here is only the "well defined, successful, deterministic" bit.
     What should be the semantics of the other cases?
     *)
    Variant handler_prop: MemE ~> myMonad :=
    | RdH : forall l v h,
        read h l = SuccessR v ->
        handler_prop _ (RdE l) h (ret (Rd l v :: h, v))

    | WrH : forall l v h,
        write h l = SuccessW ->
        handler_prop _ (WrE l v) h (ret (Wr l v :: h, tt))

    | AlH : forall l h,
        alloc h l = SuccessA ->
        handler_prop _ AllocE h (ret (Al l :: h, l))

    | FrH : forall l h,
        free h l = SuccessF ->
        handler_prop _ (FreeE l) h (ret (Fr l :: h, tt))
    .

    (* MGZ'15 takes a different take: it defines rules to describes legal actions given an history *)
    Definition site (a : action) : loc :=
      match a with
      | Rd l _ | Wr l _ | Al l | Fr l => l
      end.

    Definition is_write (a : action) : bool :=
      match a with
      | Wr _ _ => true
      | _ => false
      end.

    Definition modifies (a : action) (l : loc) : bool :=
      match a with
      | Wr l' _ | Al l' | Fr l' => l' =? l
      | _ => false
      end.

    Record valid (can_do : history -> action -> Prop) : Prop :=
      {
      (* Different sites are separated: actions at different sites commute *)
      Site_comm : forall h a a',
          site a =? site a' ->
          can_do (a :: h) a' <-> can_do (a' :: h) a;

      (* Different sites are separated: an action at a site cannot regulate actions at other sites *)
      Site_drop : forall h a a',
          site a =? site a' ->
          can_do (a :: h) a' <-> can_do h a';

      (* Reads don't regulate possible actions *)
      Read_noop : forall h l v a,
          can_do h (Rd l v) ->
          can_do (Rd l v :: h) a <-> can_do h a;

      (* Writes regulate reads *)
      Read_written : forall h l v v',
          can_do h (Wr l v) ->
          can_do (Wr l v :: h) (Rd l v') <-> v = v';

      (* Writes can only regulate reads *)
      Write_not_read : forall h l v a,
          can_do h (Wr l v) ->
          ~ is_write a ->
          can_do (Wr l v :: h) a <-> can_do h a;

      (* Writes can only be regulated by actions modifying their location *)
      Not_mod_write : forall h l v a,
          can_do h a ->
          ~ modifies a l ->
          can_do (a :: h) (Wr l v) <-> can_do h (Wr l v);

      (* The value intended to be written does not mandate the legality of a write *)
      Write_any_value : forall h l v v',
          can_do h (Wr l v) <-> can_do h (Wr l v');

      (* Allocation enable writes *)
      Alloc_allows_write : forall h l v,
          can_do h (Al l) ->
          can_do (Al l :: h) (Wr l v);
      (* A location cannot be allocated twice *)
      Alloc_forbids_alloc : forall h l,
          can_do h (Al l) ->
          ~ can_do (Al l :: h) (Al l);
      (* Allocation enables free *)
      Alloc_allows_free : forall h l,
          can_do h (Al l) ->
          can_do (Al l :: h) (Fr l);

      (* Free forbids reads (but it can still write???) *)
      Free_forbids_read : forall h l v,
          can_do h (Fr l) ->
          ~ can_do (Fr l :: h) (Rd l v);
      (* A location cannot be freed twice *)
      Free_forbids_free : forall h l,
          can_do h (Fr l) ->
          ~ can_do (Fr l :: h) (Fr l);
      (* A freed location can be reallocated *)
      Free_allows_alloc : forall h l,
          can_do h (Fr l) ->
          ~ can_do (Fr l :: h) (Al l);

      (* At the dawn of time, nothing can be read *)
      Base_read : forall l v,
          ~ can_do nil (Rd l v);
      (* At the dawn of time, everything can be allocated *)
      Base_alloc : forall l,
          can_do nil (Al l);
      (* At the dawn of time, nothing can be freed *)
      Base_free : forall l,
          ~  can_do nil (Fr l)

      }.

  End WithDom.
End MGZ.


Require Import fae_gtlc_mu.cast_calculus.consistency.
From fae_gtlc_mu Require Import prelude.

Lemma consistency_open_sym {τ τ'} : consistency_open τ τ' → consistency_open τ' τ.
Proof. induction 1; try by constructor. Qed.

Lemma consistency_open_unfold_help τ τ' α (pα : Closed α) α' (pα' : Closed α') k :
  consistency_open (TRec τ) (TRec τ') → consistency_open α α' → consistency_open τ.[upn k (α .: ids)] τ'.[upn k (α' .: ids)].
Proof.
  intro pC. inversion_clear pC.
  generalize dependent τ'.
  generalize dependent k.
  induction τ.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + asimpl; constructor.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + asimpl; constructor. by apply IHτ1. by apply IHτ2.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + asimpl; constructor. by apply IHτ1. by apply IHτ2.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + asimpl; constructor. by apply IHτ1. by apply IHτ2.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + intro. apply GenSymRec.
      assert (triv : up (upn k (α .: ids)) = upn (S k) (α .: ids)); first by asimpl. rewrite triv.
      by apply IHτ.
  - intros k τ' pC. inversion_clear pC.
    + asimpl; constructor.
    + intro.
      destruct (subst_fv_upn_cases x k (α .: ids)) as [[-> plt] | [j [eq ->]] ];
      destruct (subst_fv_upn_cases x k (α' .: ids)) as [[-> plt'] | [j' [eq' ->]]]; try by (exfalso; lia).
      * apply GenSymVar.
      * assert (triv : j' = j). lia. rewrite triv. clear triv.
        destruct j; asimpl. by rewrite pα pα'. apply GenSymVar.
  - intros k τ' pC.
    asimpl; constructor.
Qed.

Lemma consistency_open_unfold τ (pτ : Closed (TRec τ)) τ' (pτ' : Closed (TRec τ')) : consistency_open (TRec τ) (TRec τ') → consistency_open τ.[TRec τ/] τ'.[TRec τ'/].
Proof.
  intro pC.
  assert (triv : τ.[TRec τ/] = τ.[upn 0 (TRec τ .: ids)]). by asimpl. rewrite triv. clear triv.
  assert (triv : τ'.[TRec τ'/] = τ'.[upn 0 (TRec τ' .: ids)]). by asimpl. rewrite triv. clear triv.
  by apply consistency_open_unfold_help; auto.
Qed.

Definition consistency_open_dec τ τ' : sumor (consistency_open τ τ') (notT (consistency_open τ τ')).
Proof.
  generalize dependent τ'.
  induction τ; intro τ'; destruct τ'; ((by (apply inleft; by constructor)) || (try by apply inright; intro abs; inversion abs)); try specialize (IHτ1 τ'1); try specialize (IHτ2 τ'2); try specialize (IHτ τ0).
  - destruct IHτ1.
    destruct IHτ2.
    apply inleft; by constructor.
    apply inright. intro abs. inversion abs. contradiction.
    apply inright. intro abs. inversion abs. contradiction.
  - destruct IHτ1.
    destruct IHτ2.
    apply inleft; by constructor.
    apply inright. intro abs. inversion abs. contradiction.
    apply inright. intro abs. inversion abs. contradiction.
  - destruct IHτ1.
    destruct IHτ2.
    apply inleft; by constructor.
    apply inright. intro abs. inversion abs. contradiction.
    apply inright. intro abs. inversion abs. contradiction.
  - destruct IHτ.
    apply inleft; by constructor.
    apply inright. intro abs. inversion abs. contradiction.
  - destruct (decide (x = x0)).
    apply inleft. rewrite e. eapply GenSymVar.
    apply inright. intro abs. inversion abs. contradiction.
Qed.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import Coq.Logic.Eqdep_dec.
Require Import VST.msl.functors.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Local Open Scope nat_scope.

Module Type TY_FUNCTOR.
  Parameter F : functor.

  Parameter T : Type.
  Parameter T_bot : T.

  Parameter other : Type.
End TY_FUNCTOR.

Module Type KNOT.
  Declare Module TF:TY_FUNCTOR.
  Import TF.

  Parameter knot : Type.

  Parameter ag_knot : ageable knot.
  #[global] Existing Instance ag_knot.
  #[global] Existing Instance ag_prod.

  Definition predicate := (knot * other) -> T.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if Compare_dec.le_gt_dec n (level w) then T_bot else p w.

  Axiom squash_unsquash : forall x, squash (unsquash x) = x.
  Axiom unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').

  Axiom knot_level : forall k:knot,
    level k = fst (unsquash k).

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

End KNOT.

Module Knot (TF':TY_FUNCTOR) : KNOT with Module TF:=TF'.
  Module TF := TF'.
  Import TF.

  (* Put the discrete pointed order on rhs *)
  Inductive leT : T -> T -> Prop :=
   | leT_refl : forall t, leT t t
   | leT_bot: forall t, leT T_bot t.

  Lemma leT_asym: forall t t',
    leT t t' -> leT t' t -> t = t'.
  Proof.
    intros.
    inversion H; subst; auto.
    inversion H0; subst; auto.
  Qed.

  Fixpoint sinv (n: nat) : Type :=
    match n with
      | O => unit
      | S n => prodT (sinv n) ((F (sinv n) * other) -> T)
    end.

  Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
    match m as m' return forall (p : sinv (m'+n)), sinv n with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst p)
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition predicate := knot * other -> T.

  Fixpoint stratify (n:nat) (Q:predicate) {struct n} : sinv n :=
    match n as n' return sinv n' with
    | O => tt
    | S n' => ( stratify n' Q, fun v => Q (existT (F oo sinv) n' (fst v),snd v) )
    end.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); lia.
    destruct (Peano_dec.eq_nat_dec x y).
    left; exists O; lia.
    right; lia.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : predicate := fun w =>
    match w with (existT _ nw w',e) =>
      match decompose_nat nw n with
        | inleft (existT _ m Hm) => snd (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm)) (w', e)
        | inright H => T_bot
      end
    end.

  Definition proof_irr_nat := eq_proofs_unicity Peano_dec.dec_eq_nat.
  Arguments proof_irr_nat [x] [y] _ _.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (floor m1 (S n) p1).
  Proof.
    intros.
    remember (fst (floor m1 (S n) p1)) as p.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    assert (m1 + S n = S m1 + n) by lia.
    destruct p1 as [p1 f'].
    generalize (IHm1 n p1 H p Heqp).
    simpl.
    clear.
    revert H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr_nat).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr_nat).
    simpl in H2.
    trivial.
  Qed.

  Lemma stratify_unstratify_more : forall n m1 m2 p1 p2,
    floor m1 n p1 = floor m2 n p2 ->

    (stratify n oo unstratify (m1+n)) p1 =
    (stratify n oo unstratify (m2+n)) p2.
  Proof.
    unfold compose; induction n; simpl; intros; auto.
    apply injective_projections; simpl; trivial.

    assert ((m1 + S n) =  (S m1 + n)) by lia.
    assert ((m2 + S n) =  (S m2 + n)) by lia.
    assert (floor (S m1) n (eq_rect (m1 + S n) _ p1 _ H0) = floor (S m2) n (eq_rect (m2 + S n) _ p2 _ H1)).
    do 2 rewrite floor_shuffle.
    congruence.
    generalize (IHn (S m1) (S m2) _ _ H2).
    clear.
    generalize H0 H1.
    revert p1 p2.
    rewrite H0; clear H0.
    rewrite H1; clear H1.
    intros p1 p2 H1 H2.
    replace H1 with (refl_equal (S m1 + n)) by (apply proof_irr_nat).
    replace H2 with (refl_equal (S m2 + n)) by (apply proof_irr_nat).
    simpl; auto.

    apply extensionality; intro v.
    unfold unstratify.
    destruct (decompose_nat n (m2 + S n)) as [[r Hr]|Hr].
    2: exfalso; lia.
    destruct (decompose_nat n (m1 + S n)) as [[s Hs]|Hs].
    2: exfalso; lia.
    assert (m2 = r) by lia; subst r.
    assert (m1 = s) by lia; subst s.
    simpl.
    replace Hr with (refl_equal (m2 + S n)) by (apply proof_irr_nat).
    replace Hs with (refl_equal (m1 + S n)) by (apply proof_irr_nat).
    simpl.
    rewrite H; auto.
  Qed.

  Lemma stratify_unstratify : forall n,
         stratify n oo unstratify n = id (sinv n).
  Proof.
    unfold id, compose; intro n; extensionality p; revert n p.
    induction n.

    intros; destruct p; auto.

    simpl; intros [p f].
    apply injective_projections; simpl; trivial.

    replace (stratify n (unstratify (S n) (p,f))) with
            (stratify n (unstratify n p)); auto.
    replace (stratify n (unstratify n p)) with
      ((stratify n oo unstratify (0+n)) p) by trivial.
    rewrite (stratify_unstratify_more _ 0 1 p (p,f)); trivial.

    extensionality v.

    destruct (decompose_nat n (S n)) as [[r Hr]|?]; auto.
    assert (r = O) by lia; subst r.
    simpl in *.
    replace Hr with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    destruct v; auto.

    exfalso.
    lia.
  Qed.

  Lemma unstratify_stratify1 : forall n (p:predicate) w,
    leT ((unstratify n oo stratify n) p w) (p w).
  Proof.
    unfold compose; induction n; simpl; intros; unfold unstratify.

    (* 0 case *)
    destruct w as [nw rm]; simpl.
    destruct nw as [nw e].
    destruct (decompose_nat nw O) as [[r Hr]|?].
    exfalso; lia.
    apply leT_bot.

    (* S n case *)
    case_eq w; intros nw rm Hrm.
    destruct nw as [nw e].
    destruct (decompose_nat nw (S n)) as [[r Hr]|?]; try (apply lt_rhs_top).
    destruct r; simpl.

    assert (n = nw) by lia.
    subst nw.
    simpl in Hr.
    replace Hr with (refl_equal (S n)) by apply proof_irr_nat; simpl.
    unfold compose.
    destruct w.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S nw) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S nw))) by apply proof_irr_nat; simpl.
    clear Hr.

    generalize (IHn p w).
    unfold unstratify.
    rewrite Hrm.
    destruct (decompose_nat nw (r + S nw)) as [[x Hx]|?].
    assert (x = r) by lia; subst x.
    replace Hx with (refl_equal (r + S nw)) by apply proof_irr_nat.
    simpl; auto.
    exfalso; lia.
    apply leT_bot.
  Qed.

  Lemma unstratify_stratify2 : forall n p w,
     projT1 (fst w) < n ->
        leT (p w) ((unstratify n oo stratify n) p w).
  Proof.
    unfold compose.
    induction n; simpl; intros.

    (* 0 case *)
    inversion H.

    (* S n case *)
    unfold unstratify.
    case_eq w; intros [m rm] e Hw.
    assert (projT1 (fst w) = m).
    rewrite Hw; auto.

    destruct (decompose_nat m (S n)) as [[r Hr]|?].
    destruct r; simpl.

    assert (n = m) by lia.
    move H0 after H1.
    subst m. fold sinv. simpl in Hr. rewrite (proof_irr_nat Hr (refl_equal _)). clear Hr.
    simpl.
    unfold compose.
    rewrite <- Hw.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S m) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S m))) by apply proof_irr_nat; simpl.
    clear Hr.
    rewrite H0 in H.
    assert (m < (r +  S m)) by lia.
    specialize ( IHn p w).
    rewrite H0 in IHn.
    specialize ( IHn H1).
    revert IHn.
    unfold unstratify.
    rewrite Hw.
    destruct (decompose_nat m (r + S m)) as [[x Hx]|?].
    assert (x = r) by lia; subst x.
    replace Hx with (refl_equal (r + S m)) by apply proof_irr_nat.
    simpl; auto.
    exfalso; lia.
    exfalso; lia.
  Qed.

  Lemma unstratify_stratify3 : forall n (p:predicate) w,
    projT1 (fst w) >= n -> leT ((unstratify n oo stratify n) p w) T_bot.
  Proof.
    unfold compose, unstratify; intros n p w H.
    case_eq w; intros [wn rm] e.
    intro Hrm.
    rewrite Hrm in H; simpl in H.
    destruct (decompose_nat wn n) as [[r Hr]|?].
    exfalso; lia.
    apply leT_bot.
  Qed.

  Definition squash (x:nat * F predicate) : knot :=
    match x with (n,y) => existT (F oo sinv) n (fmap F (stratify n) y) end.

  Definition unsquash (x:knot) : (nat * F predicate) :=
    match x with existT _ n y => (n, fmap F (unstratify n) y) end.

  Definition def_knot_level (k:knot) := fst (unsquash k).

  Definition def_knot_age1 (k:knot) : option knot :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition def_knot_unage (k:knot) : knot :=
    match unsquash k with
    | (n,x) => squash (S n,x)
    end.

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if Compare_dec.le_gt_dec n (def_knot_level (fst w)) then T_bot else p w.

  Lemma squash_unsquash : forall x, squash (unsquash x) = x.
  Proof.
    intros; destruct x as [x f]; simpl.
    unfold compose.
    replace (fmap F (stratify x) (fmap F (unstratify x) f)) with
      ((fmap F (stratify x) oo fmap F (unstratify x)) f) by trivial.
    rewrite fmap_comp.
    replace (stratify x oo unstratify x) with (id (sinv x)).
    rewrite fmap_id; simpl; auto.
    unfold compose.
    extensionality z.
    replace (stratify x (unstratify x z)) with ((stratify x oo unstratify x) z) by trivial.
    rewrite stratify_unstratify; auto.
  Qed.

  Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').
  Proof.
    intros.
    simpl.
    replace (fmap F  (unstratify n) (fmap F (stratify n) x')) with
      ((fmap F (unstratify n) oo fmap F (stratify n)) x') by trivial.
    rewrite fmap_comp.
    apply injective_projections; simpl; trivial.
    replace (unstratify n oo stratify n) with (approx n); auto.
    extensionality p z.
    apply leT_asym.

    intuition.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    replace (approx n p (a, b)) with T_bot.
    apply leT_bot.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    trivial.
    exfalso.
    lia.
    replace (approx n p (a,b)) with (p (a,b)).
    apply unstratify_stratify2.
    simpl.
    destruct a.
    unfold level in g.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    exfalso.
    lia.
    trivial.

    intuition.
    destruct (Compare_dec.le_lt_dec n (def_knot_level a)).
    replace (approx n p (a, b)) with T_bot.
    apply unstratify_stratify3; auto.
    simpl.
    destruct a.
    unfold level in l.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); auto.
    intro.
    exfalso.
    lia.
    replace (approx n p (a, b)) with (p (a, b)).
    apply unstratify_stratify1; auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); auto.
    intro.
    exfalso.
    lia.
  Qed.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
    intros.
    rewrite <- (squash_unsquash k1).
    rewrite <- (squash_unsquash k2).
    rewrite H.
    trivial.
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma ag_knot_facts : ageable_facts knot def_knot_level def_knot_age1.
  Proof.
    constructor.

   unfold def_knot_age1; unfold def_knot_level; simpl; intros x'.
    case_eq (unsquash x'); intros.
    destruct x' as [n' xx']. simpl in *. inv H.
    exists (squash (S n, fmap F (unstratify n) xx')).
    rewrite unsquash_squash.
    f_equal.
    f_equal.
    transitivity ((fmap F (stratify n) oo fmap F (approx (S n)) oo fmap F (unstratify n)) xx'); auto.
    do 2 rewrite fmap_comp.
    replace (stratify n oo approx (S n) oo unstratify n) with (@id (sinv n)).
    rewrite fmap_id. auto.
   clear.
    rewrite <- (stratify_unstratify n).
    f_equal. extensionality  a w.
    unfold approx, compose. destruct w.
    simpl fst.
    destruct (Compare_dec.le_gt_dec (S n) (def_knot_level k)); auto.
    destruct k. simpl in *.
    unfold def_knot_level in l.
    simpl in *.
    destruct (decompose_nat x n); auto.
    destruct s. exfalso.
    lia.

    intros.
    unfold def_knot_age1, def_knot_level.
    destruct (unsquash x); simpl.
    destruct n; intuition; try discriminate.

    unfold def_knot_age1, def_knot_level; intros.
    destruct (unsquash x).
    destruct n; inv H; simpl; auto.
  Qed.

  Definition ag_knot : ageable knot :=
    mkAgeable knot def_knot_level def_knot_age1 ag_knot_facts .
  #[global] Existing Instance ag_knot.
  #[global] Existing Instance ag_prod.

  Lemma knot_level : forall k:knot,
    level k = fst (unsquash k).
  Proof (fun k => refl_equal (def_knot_level k)).

  Lemma knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof (fun k => refl_equal (def_knot_age1 k)).

End Knot.


Load properties.

Lemma polDef Pi A: forall (F G H:@formula Pi) p, forall hf hg, subst H F p = Some hf -> subst H G p = Some hg ->
    (pol H p = Some TT -> eval A F <= eval A G -> eval A hf <= eval A hg) /\
    (pol H p = Some FF -> eval A F >= eval A G -> eval A hf <= eval A hg).
Proof.
  intros F G H p.
  induction p in F, G, H |- *.
  - intros. rewrite polEmpty. split;intros.
    + rewrite substEmpty in H0, H1.
      injection H0 as <-;injection H1 as <-.
      exact H3.
    + congruence.
  - intros hf hg Ef Eg.
    destruct H as [ | | |H'|H1 H2|H1 H2|H1 H2|H1 H2] eqn:H0;
      destruct a as [|[|[|]]];cbn in *;try congruence.
    all: rewrite appInv in Ef,Eg;
      destruct Ef as (af&Ef0&->);
      destruct Eg as (ag&Eg0&->).

    (* ~ *)
    + destruct pol as [[]|] eqn:Hp;cbn;split;intros;try congruence.
      all: destruct (IHp G F H' ag af Eg0 Ef0).
      1: specialize (H3 Hp H2).
      2: specialize (H4 Hp H2).
      all: destruct (eval A af), (eval A ag);repeat constructor;
        now apply PeanoNat.Nat.nle_succ_0 in H3.

    (* /\ *)
    (* second case is like first case but with H2 in IH *)
    + destruct (IHp F G H1 af ag Ef0 Eg0).
      destruct pol as [[]|];split;intros;try congruence;cbn.
      * specialize (H3 H5 H6).
        now apply PeanoNat.Nat.min_le_compat.
      * specialize (H4 H5 H6).
        now apply PeanoNat.Nat.min_le_compat.
    + destruct (IHp F G H2 af ag Ef0 Eg0).
      destruct pol as [[]|];split;intros;try congruence;cbn.
      * specialize (H3 H5 H6).
        now apply PeanoNat.Nat.min_le_compat.
      * specialize (H4 H5 H6).
        now apply PeanoNat.Nat.min_le_compat.

    (* \/ *)
    (* /\ but with max instead of min *)
    + destruct (IHp F G H1 af ag Ef0 Eg0).
      destruct pol as [[]|];split;intros;try congruence;cbn.
      * specialize (H3 H5 H6).
        now apply PeanoNat.Nat.max_le_compat.
      * specialize (H4 H5 H6).
        now apply PeanoNat.Nat.max_le_compat.
    + destruct (IHp F G H2 af ag Ef0 Eg0).
      destruct pol as [[]|];split;intros;try congruence;cbn.
      * specialize (H3 H5 H6).
        now apply PeanoNat.Nat.max_le_compat.
      * specialize (H4 H5 H6).
        now apply PeanoNat.Nat.max_le_compat.

    (* -> *)
    (* first case is ~ \/ *)
    (* first case is \/ *)
    + destruct (IHp G F H1 ag af Eg0 Ef0).
      destruct pol as [[]|];split;intros [=] ?.
      1: apply H3 in H6;trivial.
      2: apply H4 in H6;trivial.
      all: cbn;
      apply PeanoNat.Nat.max_le_compat;
      destruct (eval A af), (eval A ag);lia.
    + destruct (IHp F G H2 af ag Ef0 Eg0).
      destruct pol as [[]|];split;intros [=] ?.
      1: apply H3 in H6;trivial.
      2: apply H4 in H6;trivial.
      all: now cbn;apply PeanoNat.Nat.max_le_compat.

    (* <-> no case applicable *)
    + split;intros [=].
    + split;intros [=].
Qed.


(* this is a naive interface for a memory model. It is not used it the
   code, just in my (Alexandre Pilkiewicz) dissertation *)
Require Import Libs.
Require Import AST.
Require Import Setoid.
Require Import ArithClasses.

(*Require Import Floats.*)

Record Array_Id := mk_Array_Id {
  open_Array_Id : ident}.

Global Instance singletonInd_Array_Id : singletonInd Array_Id ident :=
{ open := open_Array_Id;
  mk := mk_Array_Id}.
Proof.
  destruct i; auto.
  auto.
Qed.

Record Cell_Id `(Numerical Num) := mkCellIdent
  { array : Array_Id;
    cell : list Num}.

Implicit Arguments Cell_Id [[H]].
Implicit Arguments array [[Num] [H]].
Implicit Arguments cell [[Num] [H]].

Module Type NAIVEMEM(N:NUMERICAL).
  Import N.
  Existing Instance Numerical_Num.

  (** values of the language *)
  Parameter Value: Type.

  (** memories *)
  Parameter Memory: Type.

  Parameter read: Memory -> Cell_Id Num -> option Value.
  Parameter write: Memory -> Cell_Id Num -> Value -> option Memory.
  Parameter rws: forall mem1 mem2 ci v,
    write mem1 ci v = Some mem2 ->
    read mem2 ci = Some v.

  Parameter rwo: forall mem1 mem2 ci1 ci2 v,
    write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
End NAIVEMEM.


From iris.algebra Require Import excl auth agree frac list cmra csum.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode notation.
From iris_examples.logatom.conditional_increment Require Import spec.
From iris.prelude Require Import options.

(** Using prophecy variables with helping: implementing conditional counter from
    "Logical Relations for Fine-Grained Concurrency" by Turon et al. (POPL 2013) *)

(** * Implementation of the functions. *)

(*
  new_counter() :=
    let c = ref (injL 0) in
    ref c
 *)
Definition new_counter : val :=
  λ: <>,
    ref (ref (InjL #0)).

(*
  complete(c, f, x, n, p) :=
    Resolve CmpXchg(c, x, ref (injL (if !f then n+1 else n))) p (ref ()) ;; ()
 *)
Definition complete : val :=
  λ: "c" "f" "x" "n" "p",
    let: "l_ghost" := ref #() in
    (* Compare with #true to make this a total operation that never
       gets stuck, no matter the value stored in [f]. *)
    let: "new_n" := if: !"f" = #true then "n" + #1 else "n" in
    Resolve (CmpXchg "c" "x" (ref (InjL "new_n"))) "p" "l_ghost" ;; #().

(*
  get c :=
    let x = !c in
    match !x with
    | injL n      => n
    | injR (f, n, p) => complete c f x n p; get(c, f)
 *)
Definition get : val :=
  rec: "get" "c" :=
    let: "x" := !"c" in
    match: !"x" with
      InjL "n"    => "n"
    | InjR "args" =>
        let: "f" := Fst (Fst "args") in
        let: "n" := Snd (Fst "args") in
        let: "p" := Snd "args" in
        complete "c" "f" "x" "n" "p" ;;
        "get" "c"
    end.

(*
  cinc c f :=
    let x = !c in
    match !x with
    | injL n =>
        let p := new proph in
        let y := ref (injR (n, f, p)) in
        if CAS(c, x, y) then complete(c, f, y, n, p)
        else cinc c f
    | injR (f', n', p') =>
        complete(c, f', x, n', p');
        cinc c f
 *)
Definition cinc : val :=
  rec: "cinc" "c" "f" :=
    let: "x" := !"c" in
    match: !"x" with
      InjL "n" =>
        let: "p" := NewProph in
        let: "y" := ref (InjR ("f", "n", "p")) in
        if: CAS "c" "x" "y" then complete "c" "f" "y" "n" "p" ;; Skip
        else "cinc" "c" "f"
    | InjR "args'" =>
        let: "f'" := Fst (Fst "args'") in
        let: "n'" := Snd (Fst "args'") in
        let: "p'" := Snd "args'" in
        complete "c" "f'" "x" "n'" "p'" ;;
        "cinc" "c" "f"
    end.

(** ** Proof setup *)

Definition numUR      := authR $ optionUR $ exclR ZO.
Definition tokenUR    := exclR unitO.
Definition one_shotUR := csumR (exclR unitO) (agreeR unitO).

Class cincG Σ := ConditionalIncrementG {
                     cinc_numG      :> inG Σ numUR;
                     cinc_tokenG    :> inG Σ tokenUR;
                     cinc_one_shotG :> inG Σ one_shotUR;
                   }.

Definition cincΣ : gFunctors :=
  #[GFunctor numUR; GFunctor tokenUR; GFunctor one_shotUR].

Global Instance subG_cincΣ {Σ} : subG cincΣ Σ → cincG Σ.
Proof. solve_inG. Qed.

Section conditional_counter.
  Context {Σ} `{!heapGS Σ, !cincG Σ}.
  Context (N : namespace).

  Local Definition stateN   := N .@ "state".
  Local Definition counterN := N .@ "counter".

  (** Updating and synchronizing the counter and flag RAs *)

  Lemma sync_counter_values γ_n (n m : Z) :
    own γ_n (● Excl' n) -∗ own γ_n (◯ Excl' m) -∗ ⌜n = m⌝.
  Proof.
    iIntros "H● H◯". iCombine "H●" "H◯" as "H". iDestruct (own_valid with "H") as "H".
      by iDestruct "H" as %[H%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  Qed.

  Lemma update_counter_value γ_n (n1 n2 m : Z) :
    own γ_n (● Excl' n1) -∗ own γ_n (◯ Excl' n2) ==∗ own γ_n (● Excl' m) ∗ own γ_n (◯ Excl' m).
  Proof.
    iIntros "H● H◯". iCombine "H●" "H◯" as "H". rewrite -own_op. iApply (own_update with "H").
    by apply auth_update, option_local_update, exclusive_local_update.
  Qed.

  Definition counter_content (γs : gname) (n : Z) :=
    (own γs (◯ Excl' n))%I.

  (** Definition of the invariant *)

  Fixpoint val_to_some_loc (vs : list (val * val)) : option loc :=
    match vs with
    | ((_, #true)%V, LitV (LitLoc l)) :: _  => Some l
    | _                         :: vs => val_to_some_loc vs
    | _                               => None
    end.

  Inductive abstract_state : Set :=
  | Quiescent : Z → abstract_state
  | Updating : loc → Z → proph_id → abstract_state.

  Definition state_to_val (s : abstract_state) : val :=
    match s with
    | Quiescent n => InjLV #n
    | Updating f n p => InjRV (#f,#n,#p)
    end.

  Global Instance state_to_val_inj : Inj (=) (=) state_to_val.
  Proof.
    intros [|] [|]; simpl; intros Hv; inversion_clear Hv; done.
  Qed.

  Definition own_token γ := (own γ (Excl ()))%I.

  Definition pending_state P (n : Z) (proph_winner : option loc) l_ghost_winner (γ_n : gname) :=
    (P ∗ ⌜match proph_winner with None => True | Some l => l = l_ghost_winner end⌝ ∗ own γ_n (● Excl' n))%I.

  (* After the prophecy said we are going to win the race, we commit and run the AU,
     switching from [pending] to [accepted]. *)
  Definition accepted_state Q (proph_winner : option loc) (l_ghost_winner : loc) :=
    ((∃ v, l_ghost_winner ↦{#1/2} v) ∗ match proph_winner with None => True | Some l => ⌜l = l_ghost_winner⌝ ∗ Q end)%I.

  (* The same thread then wins the CmpXchg and moves from [accepted] to [done].
     Then, the [γ_t] token guards the transition to take out [Q].
     Remember that the thread winning the CmpXchg might be just helping.  The token
     is owned by the thread whose request this is.
     In this state, [l_ghost_winner] serves as a token to make sure that
     only the CmpXchg winner can transition to here, and owning half of[l] serves as a
     "location" token to ensure there is no ABA going on. Notice how [counter_inv]
     owns *more than* half of its [l], which means we know that the [l] there
     and here cannot be the same. *)
  Definition done_state Q (l l_ghost_winner : loc) (γ_t : gname) :=
    ((Q ∨ own_token γ_t) ∗ (∃ v, l_ghost_winner ↦ v) ∗ (∃ v, l ↦{#1/2} v))%I.

  (* We always need the [proph] in here so that failing threads coming late can
     always resolve their stuff.
     Moreover, we need a way for anyone who has observed the [done] state to
     prove that we will always remain [done]; that's what the one-shot token [γ_s] is for. *)
  Definition state_inv P Q (p : proph_id) n (c_l l l_ghost_winner : loc) γ_n γ_t γ_s : iProp Σ :=
    (∃ vs, proph p vs ∗
      (own γ_s (Cinl $ Excl ()) ∗
       (c_l ↦{#1/2} #l ∗ ( pending_state P n (val_to_some_loc vs) l_ghost_winner γ_n
        ∨ accepted_state Q (val_to_some_loc vs) l_ghost_winner ))
       ∨ own γ_s (Cinr $ to_agree ()) ∗ done_state Q l l_ghost_winner γ_t))%I.

  Definition pau P Q γs f :=
    (▷ P -∗ ◇ AU << ∀ (b : bool) (n : Z), counter_content γs n ∗ f ↦_(λ _, True) #b >>
                 @ ⊤∖(↑N ∪ ↑inv_heapN), ∅
                 << counter_content γs (if b then n + 1 else n)%Z ∗ f ↦_(λ _, True) #b, COMM Q >>)%I.

  Definition counter_inv γ_n c :=
    (∃ (l : loc) (q : Qp) (s : abstract_state),
       (* We own *more than* half of [l], which shows that this cannot
          be the [l] of any [state] protocol in the [done] state. *)
       c ↦{#1/2} #l ∗ l ↦{#1/2 + q} (state_to_val s) ∗
       match s with
        | Quiescent n => c ↦{#1/2} #l ∗ own γ_n (● Excl' n)
        | Updating f n p =>
           ∃ P Q l_ghost_winner γ_t γ_s,
             (* There are two pieces of per-[state]-protocol ghost state:
             - [γ_t] is a token owned by whoever created this protocol and used
               to get out the [Q] in the end.
             - [γ_s] reflects whether the protocol is [done] yet or not. *)
             inv stateN (state_inv P Q p n c l l_ghost_winner γ_n γ_t γ_s) ∗
             □ pau P Q γ_n f ∗ f ↦_(λ _, True) □
       end)%I.

  Local Hint Extern 0 (environments.envs_entails _ (counter_inv _ _)) => unfold counter_inv : core.

  Definition is_counter (γ_n : gname) (ctr : val) :=
    (∃ (c : loc), ⌜ctr = #c ∧ N ## inv_heapN⌝ ∗ inv_heap_inv ∗ inv counterN (counter_inv γ_n c))%I.

  Global Instance is_counter_persistent γs ctr : Persistent (is_counter γs ctr) := _.

  Global Instance counter_content_timeless γs n : Timeless (counter_content γs n) := _.

  Global Instance abstract_state_inhabited: Inhabited abstract_state := populate (Quiescent 0).

  Lemma counter_content_exclusive γs c1 c2 :
    counter_content γs c1 -∗ counter_content γs c2 -∗ False.
  Proof.
    iIntros "Hb1 Hb2".
    iDestruct (own_valid_2 with "Hb1 Hb2") as %?%auth_frag_op_valid_1.
    done.
  Qed.

  (** A few more helper lemmas that will come up later *)

  Lemma mapsto_valid_3 l v1 v2 q :
    l ↦ v1 -∗ l ↦{q} v2 -∗ ⌜False⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (mapsto_ne with "Hl1 Hl2") as %?; done.
  Qed.

  (** Once a [state] protocol is [done] (as reflected by the [γ_s] token here),
      we can at any later point in time extract the [Q]. *)
  Lemma state_done_extract_Q P Q p m c_l l l_ghost γ_n γ_t γ_s :
    inv stateN (state_inv P Q p m c_l l l_ghost γ_n γ_t γ_s) -∗
    own γ_s (Cinr (to_agree ())) -∗
    □(own_token γ_t ={⊤}=∗ ▷ Q).
  Proof.
    iIntros "#Hinv #Hs !# Ht".
    iInv stateN as (vs) "(Hp & [NotDone | Done])".
    * (* Moved back to NotDone: contradiction. *)
      iDestruct "NotDone" as "(>Hs' & _ & _)".
      iDestruct (own_valid_2 with "Hs Hs'") as %?. contradiction.
    * iDestruct "Done" as "(_ & QT & Hghost)".
      iDestruct "QT" as "[Q | >T]"; last first.
      { iDestruct (own_valid_2 with "Ht T") as %Contra.
          by inversion Contra. }
      iSplitR "Q"; last done. iIntros "!> !>". unfold state_inv.
      iExists _. iFrame "Hp". iRight.
      unfold done_state. iFrame "#∗".
  Qed.

  (** ** Proof of [complete] *)

  (** The part of [complete] for the succeeding thread that moves from [accepted] to [done] state *)
  Lemma complete_succeeding_thread_pending (γ_n γ_t γ_s : gname) c_l P Q p
        (m n : Z) (l l_ghost l_new : loc) Φ :
    inv counterN (counter_inv γ_n c_l) -∗
    inv stateN (state_inv P Q p m c_l l l_ghost γ_n γ_t γ_s) -∗
    l_ghost ↦{# 1 / 2} #() -∗
    (□(own_token γ_t ={⊤}=∗ ▷ Q) -∗ Φ #()) -∗
    own γ_n (● Excl' n) -∗
    l_new ↦ InjLV #n -∗
    WP Resolve (CmpXchg #c_l #l #l_new) #p #l_ghost ;; #() {{ v, Φ v }}.
  Proof.
    iIntros "#InvC #InvS Hl_ghost HQ Hn● [Hl_new Hl_new']". wp_bind (Resolve _ _ _)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl Hl'] & Hrest)".
    iInv stateN as (vs) "(>Hp & [NotDone | Done])"; last first.
    { (* We cannot be [done] yet, as we own the "ghost location" that serves
         as token for that transition. *)
      iDestruct "Done" as "(_ & _ & Hlghost & _)".
      iDestruct "Hlghost" as (v') ">Hlghost".
        by iDestruct (mapsto_valid_2 with "Hl_ghost Hlghost") as %[??].
    }
    iDestruct "NotDone" as "(>Hs & >Hc' & [Pending | Accepted])".
    { (* We also cannot be [Pending] any more we have [own γ_n] showing that this
       transition has happened   *)
       iDestruct "Pending" as "[_ >[_ Hn●']]".
       iCombine "Hn●" "Hn●'" as "Contra".
       iDestruct (own_valid with "Contra") as %Contra. by inversion Contra.
    }
    (* So, we are [Accepted]. Now we can show that l = l', because
       while a [state] protocol is not [done], it owns enough of
       the [counter] protocol to ensure that does not move anywhere else. *)
    iDestruct (mapsto_agree with "Hc Hc'") as %[= ->].
    (* We perform the CmpXchg. *)
    iCombine "Hc Hc'" as "Hc".
    wp_apply (wp_resolve with "Hp"); first done; wp_cmpxchg_suc.
    iIntros "!>" (vs' ->) "Hp'". simpl.
    (* Update to Done. *)
    iDestruct "Accepted" as "[Hl_ghost_inv [HEq Q]]".
    iMod (own_update with "Hs") as "Hs".
    { apply (cmra_update_exclusive (Cinr (to_agree ()))). done. }
    iDestruct "Hs" as "#Hs'". iModIntro.
    iSplitL "Hl_ghost_inv Hl_ghost Q Hp' Hl".
    (* Update state to Done. *)
    { iNext. iExists _. iFrame "Hp'". iRight. unfold done_state.
      iFrame "#∗". iDestruct "Hl_ghost_inv" as (v) "Hl_ghost_inv".
      iDestruct (mapsto_agree with "Hl_ghost Hl_ghost_inv") as %<-.
      iSplitR "Hl"; iExists _; iFrame. }
    iModIntro. iSplitR "HQ".
    { iNext. iDestruct "Hc" as "[Hc1 Hc2]".
      iExists l_new, _, (Quiescent n). iFrame. }
    wp_seq. iApply "HQ".
    iApply state_done_extract_Q; done.
  Qed.

  (** The part of [complete] for the failing thread *)
  Lemma complete_failing_thread γ_n γ_t γ_s c_l l P Q p m n l_ghost_inv l_ghost l_new Φ :
    l_ghost_inv ≠ l_ghost →
    inv counterN (counter_inv γ_n c_l) -∗
    inv stateN (state_inv P Q p m c_l l l_ghost_inv γ_n γ_t γ_s) -∗
    (□(own_token γ_t ={⊤}=∗ ▷ Q) -∗ Φ #()) -∗
    l_new ↦ InjLV #n -∗
    WP Resolve (CmpXchg #c_l #l #l_new) #p #l_ghost ;; #() {{ v, Φ v }}.
  Proof.
    iIntros (Hnl) "#InvC #InvS HQ Hl_new". wp_bind (Resolve _ _ _)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl Hl'] & Hrest)".
    iInv stateN as (vs) "(>Hp & [NotDone | [#Hs Done]])".
    { (* If the [state] protocol is not done yet, we can show that it
         is the active protocol still (l = l').  But then the CmpXchg would
         succeed, and our prophecy would have told us that.
         So here we can prove that the prophecy was wrong. *)
        iDestruct "NotDone" as "(_ & >Hc' & State)".
        iDestruct (mapsto_agree with "Hc Hc'") as %[=->].
        iCombine "Hc Hc'" as "Hc".
        wp_apply (wp_resolve with "Hp"); first done; wp_cmpxchg_suc.
        iIntros "!>" (vs' ->). iDestruct "State" as "[Pending | Accepted]".
        + iDestruct "Pending" as "[_ [Hvs _]]". iDestruct "Hvs" as %Hvs. by inversion Hvs.
        + iDestruct "Accepted" as "[_ [Hvs _]]". iDestruct "Hvs" as %Hvs. by inversion Hvs. }
    (* So, we know our protocol is [Done]. *)
    (* It must be that l' ≠ l because we are in the failing thread. *)
    destruct (decide (l' = l)) as [->|Hn]. {
      (* The [state] protocol is [done] while still being the active protocol
         of the [counter]?  Impossible, now we will own more than the whole location! *)
      iDestruct "Done" as "(_ & _ & >Hl'')".
      iDestruct "Hl''" as (v') "Hl''".
      iDestruct (mapsto_combine with "Hl Hl''") as "[Hl _]".
      rewrite dfrac_op_own Qp_half_half.
      iDestruct (mapsto_valid_3 with "Hl Hl'") as "[]".
    }
    (* The CmpXchg fails. *)
    wp_apply (wp_resolve with "Hp"); first done. wp_cmpxchg_fail.
    iIntros "!>" (vs' ->) "Hp". iModIntro.
    iSplitL "Done Hp". { iNext. iExists _. iFrame "#∗". } iModIntro.
    iSplitL "Hc Hrest Hl Hl'". { eauto 10 with iFrame. }
    wp_seq. iApply "HQ".
    iApply state_done_extract_Q; done.
  Qed.

  (** ** Proof of [complete] *)
  (* The postcondition basically says that *if* you were the thread to own
     this request, then you get [Q].  But we also try to complete other
     thread's requests, which is why we cannot ask for the token
     as a precondition. *)
  Lemma complete_spec (c f l : loc) (n : Z) (p : proph_id) γ_n γ_t γ_s l_ghost_inv P Q :
    N ## inv_heapN →
    inv_heap_inv -∗
    inv counterN (counter_inv γ_n c) -∗
    inv stateN (state_inv P Q p n c l l_ghost_inv γ_n γ_t γ_s) -∗
    □ pau P Q γ_n f -∗
    f ↦_(λ _, True) □ -∗
    {{{ True }}}
       complete #c #f #l #n #p
    {{{ RET #(); □ (own_token γ_t ={⊤}=∗ ▷Q) }}}.
  Proof.
    iIntros (?) "#GC #InvC #InvS #PAU #isGC".
    iModIntro. iIntros (Φ) "_ HQ". wp_lam. wp_pures.
    wp_alloc l_ghost as "[Hl_ghost' Hl_ghost'2]". wp_pures.
    wp_bind (! _)%E. simpl.
    (* open outer invariant *)
    iInv counterN as (l' q s) "(>Hc & >Hl' & Hrest)".
    (* two different proofs depending on whether we are succeeding thread *)
    destruct (decide (l_ghost_inv = l_ghost)) as [-> | Hnl].
    - (* we are the succeeding thread *)
      (* we need to move from [pending] to [accepted]. *)
      iInv stateN as (vs) "(>Hp & [(>Hs & >Hc' & [Pending | Accepted]) | [#Hs Done]])".
      + (* Pending: update to accepted *)
        iDestruct "Pending" as "[P >[Hvs Hn●]]".
        iDestruct ("PAU" with "P") as ">AU".
        iMod (inv_mapsto_own_acc_strong with "GC") as "Hgc"; first solve_ndisj.
        (* open and *COMMIT* AU, sync flag and counter *)
        iMod "AU" as (b n2) "[[Hn◯ Hf] [_ Hclose]]".
        iDestruct ("Hgc" with "Hf") as "(_ & Hf & Hfclose)".
        wp_load.
        iMod ("Hfclose" with "[//] Hf") as "[Hf Hfclose]".
        iDestruct (sync_counter_values with "Hn● Hn◯") as %->.
        iMod (update_counter_value _ _ _ (if b then n2 + 1 else n2)%Z with "Hn● Hn◯")
          as "[Hn● Hn◯]".
        iMod ("Hclose" with "[Hn◯ Hf]") as "Q"; first by iFrame.
        iModIntro. iMod "Hfclose" as "_".
        (* close state inv *)
        iIntros "!> !>". iSplitL "Q Hl_ghost' Hp Hvs Hs Hc'".
        { iNext. iExists _. iFrame "Hp". iLeft. iFrame.
          iRight. iSplitL "Hl_ghost'"; first by iExists _.
          destruct (val_to_some_loc vs) eqn:Hvts; iFrame. }
        (* close outer inv *)
        iModIntro. iSplitR "Hl_ghost'2 HQ Hn●".
        { eauto 12 with iFrame. }
        destruct b;
        wp_alloc l_new as "Hl_new"; wp_pures;
          iApply (complete_succeeding_thread_pending
                    with "InvC InvS Hl_ghost'2 HQ Hn● Hl_new").
      + (* Accepted: contradiction *)
        iDestruct "Accepted" as "[>Hl_ghost_inv _]".
        iDestruct "Hl_ghost_inv" as (v) "Hlghost".
        iCombine "Hl_ghost'" "Hl_ghost'2" as "Hl_ghost'".
        by iDestruct (mapsto_valid_2 with "Hlghost Hl_ghost'") as %[??].
      + (* Done: contradiction *)
        iDestruct "Done" as "[QT >[Hlghost _]]".
        iDestruct "Hlghost" as (v) "Hlghost".
        iCombine "Hl_ghost'" "Hl_ghost'2" as "Hl_ghost'".
        by iDestruct (mapsto_valid_2 with "Hlghost Hl_ghost'") as %[??].
    - (* we are the failing thread. exploit that [f] is a GC location. *)
      iMod (inv_mapsto_acc with "GC isGC") as (b) "(_ & H↦ & Hclose)"; first solve_ndisj.
      wp_load.
      iMod ("Hclose" with "H↦") as "_". iModIntro.
      (* close invariant *)
      iModIntro. iSplitL "Hc Hrest Hl'". { eauto 10 with iFrame. }
      (* two equal proofs depending on value of b1 *)
      wp_pures.
      destruct (bool_decide (b = #true));
      wp_alloc Hl_new as "Hl_new"; wp_pures;
        iApply (complete_failing_thread
                  with "InvC InvS HQ Hl_new"); done.
  Qed.

  (** ** Proof of [cinc] *)

  Lemma cinc_spec γs v (f: loc) :
    is_counter γs v -∗
    <<< ∀ (b : bool) (n : Z), counter_content γs n ∗ f ↦_(λ _, True) #b >>>
        cinc v #f @ (↑N ∪ ↑inv_heapN)
    <<< counter_content γs (if b then n + 1 else n)%Z ∗ f ↦_(λ _, True) #b, RET #() >>>.
  Proof.
    iIntros "#InvC". iDestruct "InvC" as (c_l [-> ?]) "[#GC #InvC]".
    iIntros (Φ) "AU". iLöb as "IH".
    wp_lam. wp_pures. wp_bind (!_)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl [Hl' Hl'']] & Hrest)".
    wp_load. destruct s as [n|f' n' p'].
    - iDestruct "Hrest" as "(Hc' & Hv)".
      iModIntro. iSplitR "AU Hl'".
      { iModIntro. iExists _, (q/2)%Qp, (Quiescent n). iFrame. }
      wp_let. wp_load. wp_match. wp_apply wp_new_proph; first done.
      iIntros (l_ghost p') "Hp'".
      wp_let. wp_alloc ly as "Hly".
      wp_let. wp_bind (CmpXchg _ _ _)%E.
      (* open outer invariant again to CAS c_l *)
      iInv counterN as (l'' q2 s) "(>Hc & >Hl & Hrest)".
      destruct (decide (l' = l'')) as [<- | Hn].
      + (* CAS succeeds *)
        iDestruct (mapsto_agree with "Hl' Hl") as %<-%state_to_val_inj.
        iDestruct "Hrest" as ">[Hc' Hn●]". iCombine "Hc Hc'" as "Hc".
        wp_cmpxchg_suc.
        (* Take a "peek" at [AU] and abort immediately to get [gc_is_gc f]. *)
        iMod "AU" as (b' n') "[[CC Hf] [Hclose _]]".
        iDestruct (inv_mapsto_own_inv with "Hf") as "#Hgc".
        iMod ("Hclose" with "[CC Hf]") as "AU"; first by iFrame.
        (* Initialize new [state] protocol .*)
        iDestruct (laterable with "AU") as (AU_later) "[AU #AU_back]".
        iMod (own_alloc (Excl ())) as (γ_t) "Token"; first done.
        iMod (own_alloc (Cinl $ Excl ())) as (γ_s) "Hs"; first done.
        iDestruct "Hc" as "[Hc Hc']".
        set (winner := default ly (val_to_some_loc l_ghost)).
        iMod (inv_alloc stateN _ (state_inv AU_later _ _ _ _ _ winner _ _ _)
               with "[AU Hs Hp' Hc' Hn●]") as "#Hinv".
        { iNext. iExists _. iFrame "Hp'". iLeft. iFrame. iLeft.
          iFrame. destruct (val_to_some_loc l_ghost); simpl; done. }
        iModIntro. iDestruct "Hly" as "[Hly1 Hly2]". iSplitR "Hl' Token". {
          (* close invariant *)
          iNext. iExists _, _, (Updating f n p'). eauto 10 with iFrame.
        }
        wp_pures. wp_apply complete_spec; [done..|].
        iIntros "Ht". iMod ("Ht" with "Token") as "Φ". wp_seq. by wp_lam.
      + (* CAS fails: closing invariant and invoking IH *)
        wp_cmpxchg_fail.
        iModIntro. iSplitR "AU".
        { iModIntro. iExists _, _, s. iFrame. }
        wp_pures. by iApply "IH".
    - (* l' ↦ injR *)
      iModIntro.
      (* extract state invariant *)
      iDestruct "Hrest" as (P Q l_ghost γ_t γ_s) "(#InvS & #P_AU & #Hgc)".
      iSplitR "Hl' AU".
      (* close invariant *)
      { iModIntro. iExists _, _, (Updating f' n' p'). iFrame. eauto 10 with iFrame. }
      wp_let. wp_load. wp_match. wp_pures.
      wp_apply complete_spec; [done..|].
      iIntros "_". wp_seq. by iApply "IH".
  Qed.

  Lemma new_counter_spec :
    N ## inv_heapN →
    inv_heap_inv -∗
    {{{ True }}}
        new_counter #()
    {{{ ctr γs, RET ctr ; is_counter γs ctr ∗ counter_content γs 0 }}}.
  Proof.
    iIntros (?) "#GC". iIntros (Φ) "!# _ HΦ". wp_lam.
    wp_alloc l_n as "Hl_n".
    wp_alloc l_c as "Hl_c".
    iMod (own_alloc (● Excl' 0%Z  ⋅ ◯ Excl' 0%Z)) as (γ_n) "[Hn● Hn◯]".
    { by apply auth_both_valid_discrete. }
    iMod (inv_alloc counterN _ (counter_inv γ_n l_c)
      with "[Hl_c Hl_n Hn●]") as "#InvC".
    { iNext. iDestruct "Hl_c" as "[Hl_c1 Hl_c2]".
      iDestruct "Hl_n" as "[??]".
      iExists l_n, (1/2)%Qp, (Quiescent 0). iFrame. }
    iModIntro.
    iApply ("HΦ" $! #l_c γ_n).
    iSplitR; last by iFrame. iExists _. eauto with iFrame.
  Qed.

  Lemma get_spec γs v :
    is_counter γs v -∗
    <<< ∀ (n : Z), counter_content γs n >>>
        get v @ (↑N ∪ ↑inv_heapN)
    <<< counter_content γs n, RET #n >>>.
  Proof.
    iIntros "#InvC" (Φ) "AU". iDestruct "InvC" as (c_l [-> ?]) "[GC InvC]".
    iLöb as "IH". wp_lam. wp_bind (! _)%E.
    iInv counterN as (c q s) "(>Hc & >[Hl [Hl' Hl'']] & Hrest)".
    wp_load.
    destruct s as [n|f n p].
    - iMod "AU" as (au_n) "[Hn◯ [_ Hclose]]"; simpl.
      iDestruct "Hrest" as "[Hc' Hn●]".
      iDestruct (sync_counter_values with "Hn● Hn◯") as %->.
      iMod ("Hclose" with "Hn◯") as "HΦ".
      iModIntro. iSplitR "HΦ Hl'". {
        iNext. iExists c, (q/2)%Qp, (Quiescent au_n). iFrame.
      }
      wp_let. wp_load. wp_match. iApply "HΦ".
    - iDestruct "Hrest" as (P Q l_ghost γ_t γ_s) "(#InvS & #PAU & #Hgc)".
      iModIntro. iSplitR "AU Hl'". {
        iNext. iExists c, (q/2)%Qp, (Updating _ _ p). eauto 10 with iFrame.
      }
      wp_let. wp_load. wp_pures. wp_bind (complete _ _ _ _ _)%E.
      wp_apply complete_spec; [done..|].
      iIntros "Ht". wp_seq. iApply "IH". iApply "AU".
  Qed.

End conditional_counter.

Definition atomic_cinc `{!heapGS Σ, !cincG Σ} :
  spec.atomic_cinc Σ :=
  {| spec.new_counter_spec := new_counter_spec;
     spec.cinc_spec := cinc_spec;
     spec.get_spec := get_spec;
     spec.counter_content_exclusive := counter_content_exclusive |}.

Typeclasses Opaque counter_content is_counter.