(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2020 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals Lia ssreflect.

Require Import Rbar Rcomplements Continuity Derive Hierarchy RInt PSeries Lim_seq RInt_analysis.

(** This file describes basic properties (such as limits or
differentiability) about basic functions: absolute value, inverse,
square root, power, exponential and so on.*)

(** * Absolute value *)

(** ** in an [AbsRing] *)

Lemma continuous_abs {K : AbsRing} (x : K) :
  continuous abs x.
Proof.
  apply filterlim_locally => /= eps.
  exists eps => /= y Hy.
  eapply Rle_lt_trans, Hy.
  wlog: x y Hy / (abs x <= abs y) => [Hw | Hxy].
    case: (Rle_lt_dec (abs x) (abs y)) => Hxy.
    by apply Hw.
    rewrite abs_minus (abs_minus y).
    apply Hw, Rlt_le, Hxy.
    by apply ball_sym.
  rewrite {1}/abs /=.
  rewrite Rabs_pos_eq.
  apply Rle_minus_l.
  eapply Rle_trans, abs_triangle.
  apply Req_le, f_equal.
  by rewrite /minus -plus_assoc plus_opp_l plus_zero_r.
  by apply -> Rminus_le_0.
Qed.

Lemma filterlim_abs_0 {K : AbsRing} :
  (forall x : K, abs x = 0 -> x = zero) ->
  filterlim (abs (K := K)) (locally' (zero (G := K))) (at_right 0).
Proof.
intros H P [eps HP].
exists eps.
intros x Hx Hx'.
apply HP.
revert Hx.
rewrite /ball /= /AbsRing_ball !minus_zero_r {2}/abs /= Rabs_pos_eq.
by [].
by apply abs_ge_0.
assert (abs x <> 0).
contradict Hx' ; by apply H.
case: (abs_ge_0 x) => // H1.
by rewrite -H1 in H0.
Qed.

(** ** in [R] *)

Lemma continuous_Rabs (x : R) :
  continuous Rabs x.
Proof.
  by apply @continuous_abs.
Qed.

Lemma continuous_Rabs_comp f (x : R) :
  continuous f x -> continuous (fun x0 => Rabs (f x0)) x.
Proof.
move => Hcontfx.
apply: continuous_comp => // .
apply: continuous_Rabs.
Qed.

Lemma filterlim_Rabs (x : Rbar) :
  filterlim Rabs (Rbar_locally' x) (Rbar_locally (Rbar_abs x)).
Proof.
  destruct x as [x| | ] => //=.

  eapply filterlim_filter_le_1, continuous_Rabs.
  intros P [d HP] ; exists d => y Hy _.
  by apply HP.

  eapply filterlim_ext_loc.
  exists 0 => y Hy.
  rewrite Rabs_pos_eq // ; by apply Rlt_le.
  apply is_lim_id.

  eapply filterlim_ext_loc.
  exists 0 => y Hy.
  rewrite -Rabs_Ropp Rabs_pos_eq // -Ropp_0 ;
  by apply Ropp_le_contravar, Rlt_le.
  apply (is_lim_opp id m_infty m_infty), is_lim_id.
Qed.

Lemma is_lim_Rabs (f : R -> R) (x l : Rbar) :
  is_lim f x l -> is_lim (fun x => Rabs (f x)) x (Rbar_abs l).
Proof.
  destruct l as [l| | ] ; simpl ; intros ; first last.
  eapply is_lim_comp.
  2: by apply H.
  by apply filterlim_Rabs.
  destruct x ; by exists (mkposreal _ Rlt_0_1).
  eapply is_lim_comp.
  2: by apply H.
  by apply filterlim_Rabs.
  destruct x ; by exists (mkposreal _ Rlt_0_1).
  apply is_lim_comp_continuous => //.
  by apply continuous_Rabs.
Qed.

Lemma filterlim_Rabs_0 :
  filterlim Rabs (Rbar_locally' 0) (at_right 0).
Proof.
  apply @filterlim_abs_0.
  by apply Rabs_eq_0.
Qed.

Lemma is_lim_Rabs_0 (f : R -> R) (x : Rbar) :
  is_lim f x 0 -> Rbar_locally' x (fun x => f x <> 0)
    -> filterlim (fun x => Rabs (f x)) (Rbar_locally' x) (at_right 0).
Proof.
  intros.
  eapply filterlim_comp, filterlim_Rabs_0.
  intros P HP.
  apply H in HP.
  generalize (filter_and _ _ H0 HP).
  rewrite /filtermap /= ; apply filter_imp.
  intros y Hy.
  apply Hy, Hy.
Qed.

Lemma filterdiff_Rabs (x : R) :
  x <> 0 -> filterdiff Rabs (locally x) (fun y : R => scal y (sign x)).
Proof.
  rewrite -/(is_derive Rabs x (sign x)).
  move => Hx0.
  case: (Rle_lt_dec 0 x) => Hx.
  case: Hx => //= Hx.
  rewrite sign_eq_1 //.
  eapply is_derive_ext_loc.
  apply locally_interval with 0 p_infty.
  by [].
  by [].
  move => /= y Hy _.
  rewrite Rabs_pos_eq //.
  by apply Rlt_le.
  by apply @is_derive_id.
  by apply sym_eq in Hx.
  rewrite sign_eq_m1 //.
  eapply is_derive_ext_loc.
  apply locally_interval with m_infty 0.
  by [].
  by [].
  move => /= y _ Hy.
  rewrite -Rabs_Ropp Rabs_pos_eq //.
  rewrite -Ropp_0 ; by apply Rlt_le, Ropp_lt_contravar.
  apply @is_derive_opp.
  by apply @is_derive_id.
Qed.

Lemma is_derive_Rabs (f : R -> R) (x df : R) :
  is_derive f x df -> f x <> 0
    -> is_derive (fun x => Rabs (f x)) x (sign (f x) * df).
Proof.
  intros Hf Hfx.
  evar_last.
  apply is_derive_comp, Hf.
  by apply filterdiff_Rabs.
  apply Rmult_comm.
Qed.

(** * Inverse function *)

Lemma filterlim_Rinv_0_right :
  filterlim Rinv (at_right 0) (Rbar_locally p_infty).
Proof.
  intros P [M HM].
  have Hd : 0 < / Rmax 1 M.
    apply Rinv_0_lt_compat.
    apply Rlt_le_trans with (2 := Rmax_l _ _).
    by apply Rlt_0_1.
  exists (mkposreal _ Hd) => x /= Hx Hx0.
  apply HM.
  apply Rle_lt_trans with (1 := Rmax_r 1 M).
  replace (Rmax 1 M) with (/ / Rmax 1 M)
  by (field ; apply Rgt_not_eq, Rlt_le_trans with (2 := Rmax_l _ _), Rlt_0_1).
  apply Rinv_lt_contravar.
  apply Rdiv_lt_0_compat with (1 := Hx0).
  apply Rlt_le_trans with (2 := Rmax_l _ _), Rlt_0_1.
  rewrite /ball /= /AbsRing_ball /= /abs /minus /plus /opp /= in Hx.
  rewrite -/(Rminus _ _) Rminus_0_r Rabs_pos_eq // in Hx.
  exact: Rlt_le.
Qed.

Lemma is_lim_Rinv_0_right (f : R -> R) (x : Rbar) :
  is_lim f x 0 -> Rbar_locally' x (fun x => 0 < f x) ->
  is_lim (fun x => / (f x)) x p_infty.
Proof.
  intros.
  eapply filterlim_comp, filterlim_Rinv_0_right.
  intros P HP.
  apply H in HP.
  generalize (filter_and _ _ H0 HP).
  rewrite /filtermap ;
  apply filter_imp => y Hy.
  by apply Hy, Hy.
Qed.

Lemma filterlim_Rinv_0_left :
  filterlim Rinv (at_left 0) (Rbar_locally m_infty).
Proof.
  eapply filterlim_ext_loc.
  exists (mkposreal _ Rlt_0_1) => /= y _ Hy0.
  rewrite -{2}(Ropp_involutive y).
  rewrite -Ropp_inv_permute.
  reflexivity.
  contradict Hy0.
  apply Rle_not_lt, Req_le.
  by rewrite -(Ropp_involutive y) Hy0 Ropp_0.
  eapply filterlim_comp.
  eapply filterlim_comp.
  by apply filterlim_Ropp_left.
  rewrite Ropp_0.
  by apply filterlim_Rinv_0_right.
  apply filterlim_Rbar_opp.
Qed.

Lemma is_lim_Rinv_0_left (f : R -> R) (x : Rbar) :
  is_lim f x 0 -> Rbar_locally' x (fun x => f x < 0) ->
  is_lim (fun x => / (f x)) x m_infty.
Proof.
  intros.
  eapply filterlim_comp, filterlim_Rinv_0_left.
  intros P HP.
  apply H in HP.
  generalize (filter_and _ _ H0 HP).
  rewrite /filtermap ;
  apply filter_imp => y Hy.
  by apply Hy, Hy.
Qed.

Lemma continuous_Rinv x :
  x <> 0 ->
  continuous (fun x => / x) x.
Proof.
move => Hxneq0.
apply continuity_pt_filterlim. (* strange: apply works but not apply: *)
apply: continuity_pt_inv => // .
apply continuity_pt_filterlim.
apply: continuous_id.
Qed.

Lemma continuous_Rinv_comp (f : R -> R) x:
  continuous f x ->
  f x <> 0 ->
  continuous (fun x => / (f x)) x.
Proof.
move => Hcont Hfxneq0.
apply: continuous_comp => //.
by apply: continuous_Rinv.
Qed.

(** * Square root function *)

Lemma filterlim_sqrt_p : filterlim sqrt (Rbar_locally' p_infty) (Rbar_locally p_infty).
Proof.
  apply is_lim_spec.
  move => M.
  exists ((Rmax 0 M)²) => x Hx.
  apply Rle_lt_trans with (1 := Rmax_r 0 M).
  rewrite -(sqrt_Rsqr (Rmax 0 M)).
  apply sqrt_lt_1_alt.
  split.
  apply Rle_0_sqr.
  by apply Hx.
  apply Rmax_l.
Qed.

Lemma is_lim_sqrt_p (f : R -> R) (x : Rbar) :
  is_lim f x p_infty
  -> is_lim (fun x => sqrt (f x)) x p_infty.
Proof.
  intros.
  eapply filterlim_comp, filterlim_sqrt_p.
  by apply H.
Qed.

Lemma filterdiff_sqrt (x : R) :
  0 < x -> filterdiff sqrt (locally x) (fun y => scal y (/ (2 * sqrt x))).
Proof.
  intros Hx.
  apply is_derive_Reals.
  by apply derivable_pt_lim_sqrt.
Qed.

Lemma is_derive_sqrt (f : R -> R) (x df : R) :
  is_derive f x df -> 0 < f x
  -> is_derive (fun x => sqrt (f x)) x (df / (2 * sqrt (f x))).
Proof.
  intros Hf Hfx.
  evar_last.
  eapply is_derive_comp.
  by apply filterdiff_sqrt.
  by apply Hf.
  reflexivity.
Qed.

Lemma continuous_sqrt (x : R) : continuous sqrt x.
Proof.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
apply continuity_pt_filterlim.
by apply: continuity_pt_sqrt.
assert (Hs: forall t, t < 0 -> sqrt t = 0).
  intros t Ht.
  unfold sqrt.
  case Rcase_abs.
  easy.
  intros Ht'.
  now elim Rge_not_lt with (1 := Ht').
intros P H.
rewrite Hs // in H.
unfold filtermap.
eapply locally_open.
apply open_lt. 2: exact Hx.
move => /= t Ht.
rewrite Hs //.
now apply locally_singleton.
Qed.

Lemma continuous_sqrt_comp (f : R -> R) x:
  continuous f x ->
  continuous (fun x => sqrt (f x)) x.
Proof.
move => Hcont.
apply: continuous_comp => // .
by apply: continuous_sqrt.
Qed.

(** * Power function *)

Section nat_to_ring.

Context {K : Ring}.

Definition nat_to_ring (n : nat) : K :=
  sum_n_m (fun _ => one) 1 n.

Lemma nat_to_ring_O :
  nat_to_ring O = zero.
Proof.
  rewrite /nat_to_ring sum_n_m_zero //.
Qed.

Lemma nat_to_ring_Sn (n : nat) :
  nat_to_ring (S n) = plus (nat_to_ring n) one.
Proof.
  case: n => [ | n] ; rewrite /nat_to_ring.
  rewrite sum_n_n sum_n_m_zero //.
  by rewrite plus_zero_l.
  rewrite sum_n_Sm //.
  by apply le_n_S, le_O_n.
Qed.

End nat_to_ring.

Section is_derive_mult.

Context {K : AbsRing}.

Lemma is_derive_mult (f g : K -> K) x (df dg : K) :
  is_derive f x df -> is_derive g x dg
  -> (forall n m : K, mult n m = mult m n)
  -> is_derive (fun x : K => mult (f x) (g x)) x (plus (mult df (g x)) (mult (f x) dg)).
Proof.
  intros Hf Hg Hmult.
  eapply filterdiff_ext_lin.
  eapply filterdiff_comp_2 => /=.
  by apply Hf.
  by apply Hg.
  eapply filterdiff_ext_lin.
  apply (filterdiff_mult (f x,g x)) => /=.
  intros P [d Hd].
  assert (Cf := ex_derive_continuous f x).
  assert (Cg := ex_derive_continuous g x).
  destruct (fun H => proj1 (filterlim_locally _ _) (Cf H) d) as [d1 Hd1].
    eexists ; by apply Hf.
  destruct (fun H => proj1 (filterlim_locally _ _) (Cg H) d) as [d2 Hd2].
    eexists ; by apply Hg.
  exists (mkposreal _ (Rmin_stable_in_posreal d1 d2)) => /= y Hy.
  apply Hd ; split => /=.
  eapply (Hd1 y), ball_le, Hy.
  by apply Rmin_l.
  eapply (Hd2 y), ball_le, Hy.
  by apply Rmin_r.
  by apply Hmult.
  simpl => [[y1 y2]] /=.
  reflexivity.
  simpl => y.
  rewrite /scal /=.
  rewrite mult_assoc (Hmult (f x)) -!mult_assoc.
  by rewrite mult_distr_l.
Qed.

End is_derive_mult.

Lemma filterdiff_pow_n {K : AbsRing} (x : K) (n : nat) :
  (forall a b : K, mult a b = mult b a)
  -> filterdiff (fun y : K => pow_n y n) (locally x)
    (fun y : K => scal y (mult (nat_to_ring n) (pow_n x (pred n)))).
Proof.
  intros Hmult.
  rewrite -/(is_derive (fun y : K => pow_n y n) x (mult (nat_to_ring n) (pow_n x (pred n)))).
  elim: n => [ | n IH] /=.
  evar_last.
  apply is_derive_const.
  by rewrite nat_to_ring_O mult_zero_l.
  evar_last.
  eapply is_derive_mult.
  apply is_derive_id.
  apply IH.
  by apply Hmult.
  simpl.
  rewrite nat_to_ring_Sn mult_one_l mult_assoc (Hmult x) -mult_assoc.
  rewrite mult_distr_r mult_one_l plus_comm.
  apply f_equal2 => //.
  clear ; case: n => [ | n] //=.
  by rewrite nat_to_ring_O !mult_zero_l.
Qed.

Lemma is_derive_n_pow_smalli: forall i p x, (i <= p)%nat ->
  is_derive_n (fun x : R => x ^ p) i x
    (INR (fact p) / INR (fact (p - i)%nat) * x ^ (p - i)%nat).
Proof.
  elim => /= [ | i IH] p x Hip.
  rewrite -minus_n_O ; field.
  by apply INR_fact_neq_0.
  eapply is_derive_ext.
  intros t.
  apply sym_equal, is_derive_n_unique, IH.
  eapply le_trans, Hip ; by apply le_n_Sn.
  evar_last.
  apply is_derive_scal, is_derive_pow, is_derive_id.
  rewrite MyNat.sub_succ_r.
  change one with 1.
  rewrite {1 2} (S_pred (p - i) O) /fact -/fact ?mult_INR.
  field.
  split.
  apply INR_fact_neq_0.
  apply not_0_INR, sym_not_eq, O_S.
  by apply lt_minus_O_lt.
Qed.

Lemma Derive_n_pow_smalli: forall i p x, (i <= p)%nat ->
  Derive_n (fun x : R => x ^ p) i x
    = INR (fact p) / INR (fact (p - i)%nat) * x ^ (p - i)%nat.
Proof.
  intros.
  now apply is_derive_n_unique, is_derive_n_pow_smalli.
Qed.

Lemma is_derive_n_pow_bigi: forall i p x,  (p
                         is_derive_n (fun x : R => x ^ p) i x 0.
Proof.
  elim => /=  [ | i IH] p x Hip.
  by apply lt_n_O in Hip.
  apply lt_n_Sm_le, le_lt_eq_dec in Hip.
  case: Hip => [Hip | ->] ;
  eapply is_derive_ext.
  intros t ; by apply sym_equal, is_derive_n_unique, IH.
  apply @is_derive_const.
  intros t ; rewrite Derive_n_pow_smalli.
  by rewrite minus_diag /=.
  by apply le_refl.
  by apply @is_derive_const.
Qed.

Lemma Derive_n_pow_bigi: forall i p x,  (p
                         Derive_n (fun x : R => x ^ p) i x = 0.
Proof.
  intros.
  now apply is_derive_n_unique, is_derive_n_pow_bigi.
Qed.

Lemma Derive_n_pow i p x:
  Derive_n (fun x : R => x ^ p) i x =
    match (le_dec i p) with
    | left _ => INR (fact p) / INR (fact (p -i)%nat) * x ^ (p - i)%nat
    | right _ => 0
    end.
Proof.
case: le_dec => H.
by apply Derive_n_pow_smalli.
by apply Derive_n_pow_bigi, not_le.
Qed.

Lemma ex_derive_n_pow i p x: ex_derive_n (fun x : R => x ^ p) i x.
Proof.
  case: i => //= i.
  exists (Derive_n (fun x : R => x ^ p) (S i) x).
  rewrite Derive_n_pow.
  case: le_dec => Hip.
  by apply (is_derive_n_pow_smalli (S i)).
  apply (is_derive_n_pow_bigi (S i)) ; lia.
Qed.

Lemma is_RInt_pow :
  forall a b n,
  is_RInt (fun x => pow x n) a b (pow b (S n) / INR (S n) - pow a (S n) / INR (S n)).
Proof.
intros a b n.
set f := fun x => pow x (S n) / INR (S n).
fold (f a) (f b).
assert (H: forall x : R, is_derive f x (pow x n)).
  intros x.
  evar_last.
  rewrite /f /Rdiv -[Rmult]/(scal (V := R_NormedModule)).
  apply is_derive_scal_l.
  apply is_derive_pow, is_derive_id.
  rewrite /pred.
  set k := INR (S n).
  rewrite /scal /= /mult /one /=.
  field.
  rewrite /k S_INR.
  apply Rgt_not_eq, INRp1_pos.
  apply: is_RInt_derive => x Hx //.
apply continuity_pt_filterlim.
apply derivable_continuous_pt.
apply derivable_pt_pow.
Qed.

(** * Exponential function *)

Lemma exp_ge_taylor (x : R) (n : nat) :
  0 <= x -> sum_f_R0 (fun k => x^k / INR (fact k)) n <= exp x.
Proof.
  move => Hx.
  rewrite /exp /exist_exp.
  case: Alembert_C3 => /= y Hy.
  apply Rnot_lt_le => H.
  apply Rminus_lt_0 in H.
  case: (Hy _ H) => N {Hy} Hy.
  move: (Hy _ (le_plus_r n N)) => {Hy}.
  apply Rle_not_lt.
  apply Rle_trans with (2 := Rle_abs _).
  apply Rplus_le_compat_r.
  elim: N => [ | N IH].
  rewrite plus_0_r.
  apply Req_le.
  elim: (n) => {n H} [ | n /= <-].
  apply Rmult_comm.
  apply f_equal.
  apply Rmult_comm.
  apply Rle_trans with (1 := IH).
  rewrite -plus_n_Sm.
  move: (n + N)%nat => {n H N IH} n.
  rewrite /sum_f_R0 -/sum_f_R0.
  apply Rminus_le_0 ; ring_simplify.
  apply Rmult_le_pos.
  apply Rlt_le, Rinv_0_lt_compat, INR_fact_lt_0.
  by apply pow_le.
Qed.

(** Definition *)

Lemma is_exp_Reals (x : R) :
  is_pseries (fun n => / INR (fact n)) x (exp x).
Proof.
  rewrite /exp.
  case: exist_exp => l /= Hl.
  apply Series.is_series_Reals in Hl.
  move: Hl ;
  apply Series.is_series_ext => n.
  by rewrite Rmult_comm pow_n_pow.
Qed.

Lemma exp_Reals (x : R) :
  exp x = PSeries (fun n => / INR (fact n)) x.
Proof.
  apply sym_eq, is_pseries_unique.
  by apply is_exp_Reals.
Qed.

(** Limits *)

Lemma is_lim_exp_p : is_lim (fun y => exp y) p_infty p_infty.
Proof.
  apply is_lim_le_p_loc with (fun y => 1 + y).
  exists 0 => y Hy.
  by apply Rlt_le, exp_ineq1; auto with real.
  pattern p_infty at 2.
  replace p_infty with (Rbar_plus 1 p_infty) by auto.
  eapply is_lim_plus.
  apply is_lim_const.
  apply is_lim_id.
  by [].
Qed.

Lemma is_lim_exp_m : is_lim (fun y => exp y) m_infty 0.
Proof.
  evar_last.
  apply is_lim_ext with (fun y => /(exp (- y))).
  move => y ; rewrite exp_Ropp ; apply Rinv_involutive.
  apply Rgt_not_eq, exp_pos.
  apply is_lim_inv.
  apply is_lim_comp with p_infty.
  apply is_lim_exp_p.
  replace p_infty with (Rbar_opp m_infty) by auto.
  apply is_lim_opp.
  apply is_lim_id.
  by apply filter_forall.
  by [].
  by [].
Qed.

Lemma ex_lim_exp (x : Rbar) : ex_lim (fun y => exp y) x.
Proof.
  case: x => [x | | ].
  apply ex_finite_lim_correct, ex_lim_continuity.
  apply derivable_continuous_pt, derivable_pt_exp.
  exists p_infty ; by apply is_lim_exp_p.
  exists 0 ; by apply is_lim_exp_m.
Qed.

Lemma Lim_exp (x : Rbar) :
  Lim (fun y => exp y) x =
    match x with
      | Finite x => exp x
      | p_infty => p_infty
      | m_infty => 0
    end.
Proof.
  apply is_lim_unique.
  case: x => [x | | ].
  apply is_lim_continuity.
  apply derivable_continuous_pt, derivable_pt_exp.
  by apply is_lim_exp_p.
  by apply is_lim_exp_m.
Qed.

Lemma is_lim_div_exp_p : is_lim (fun y => exp y / y) p_infty p_infty.
Proof.
  apply is_lim_le_p_loc with (fun y => (1 + y + y^2 / 2)/y).
  exists 0 => y Hy.
  apply Rmult_le_compat_r.
  by apply Rlt_le, Rinv_0_lt_compat.
  rewrite /exp.
  rewrite /exist_exp.
  case: Alembert_C3 => /= x Hx.
  rewrite /Pser /infinite_sum in Hx.
  apply Rnot_lt_le => H.
  case: (Hx _ (proj1 (Rminus_lt_0 _ _) H)) => N {Hx} Hx.
  move: (Hx _ (le_plus_r 2 N)) => {Hx}.
  apply Rle_not_lt.
  apply Rle_trans with (2 := Rle_abs _).
  apply Rplus_le_compat_r.
  elim: N => [ | n IH].
  simpl ; apply Req_le ; field.
  apply Rle_trans with (1 := IH).
  rewrite -plus_n_Sm ; move: (2 + n)%nat => {n IH} n.
  rewrite /sum_f_R0 -/sum_f_R0.
  rewrite Rplus_comm ; apply Rle_minus_l ; rewrite Rminus_eq_0.
  apply Rmult_le_pos.
  apply Rlt_le, Rinv_0_lt_compat, INR_fact_lt_0.
  apply pow_le.
  by apply Rlt_le.
  apply is_lim_ext_loc with (fun y => /y + 1 + y / 2).
  exists 0 => y Hy.
  field.
  by apply Rgt_not_eq.
  eapply is_lim_plus.
  eapply is_lim_plus.
  apply is_lim_inv.
  apply is_lim_id.
  by [].
  apply is_lim_const.
  by [].
  apply is_lim_div.
  apply is_lim_id.
  apply is_lim_const.
  apply Rbar_finite_neq, Rgt_not_eq, Rlt_0_2.
  simpl.
  apply Rgt_not_eq, Rinv_0_lt_compat, Rlt_0_2.
  simpl.
  case: Rle_dec (Rlt_le _ _ (Rinv_0_lt_compat 2 (Rlt_0_2))) => //= H _.
  case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ (Rinv_0_lt_compat 2 (Rlt_0_2))) => //= H _.
Qed.

Lemma is_lim_mul_exp_m : is_lim (fun y => y * exp y) m_infty 0.
Proof.
  evar_last.
  apply is_lim_ext_loc with (fun y => - / (exp (-y) / (- y))).
  exists 0 => y Hy.
  rewrite exp_Ropp.
  field.
  split.
  apply Rgt_not_eq, exp_pos.
  by apply Rlt_not_eq.
  apply is_lim_opp.
  apply is_lim_inv.
  apply (is_lim_comp (fun y => exp y / y)) with p_infty.
  by apply is_lim_div_exp_p.
  evar_last.
  apply is_lim_opp.
  apply is_lim_id.
  by [].
  by apply filter_forall.
  by [].
  simpl ; by rewrite Ropp_0.
Qed.

Lemma is_lim_div_expm1_0 : is_lim (fun y => (exp y - 1) / y) 0 1.
Proof.
  apply is_lim_spec.
  move => eps.
  case: (derivable_pt_lim_exp_0 eps (cond_pos eps)) => delta H.
  exists delta => y Hy Hy0.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hy.
  rewrite -/(Rminus _ _) Rminus_0_r in Hy.
  move: (H y Hy0 Hy).
  by rewrite Rplus_0_l exp_0.
Qed.

(** Integral *)

Lemma is_RInt_exp :
  forall a b,
  is_RInt exp a b (exp b - exp a).
Proof.
intros a b.
apply: is_RInt_derive.
  intros x _.
  apply is_derive_Reals, derivable_pt_lim_exp.
intros x _.
apply continuity_pt_filterlim.
apply derivable_continuous_pt.
apply derivable_pt_exp.
Qed.

(** Continuity *)

Lemma continuous_exp x : continuous exp x.
Proof.
apply: ex_derive_continuous.
apply: ex_derive_Reals_1.
exact: derivable_pt_exp.
Qed.

Lemma continuous_exp_comp (f : R -> R) x:
  continuous f x ->
  continuous (fun x => exp (f x)) x.
Proof.
move => Hcont.
apply: continuous_comp => //.
by apply: continuous_exp.
Qed.

(** Derivative *)

Lemma is_derive_exp : forall x, is_derive exp x (exp x).
Proof.
intros x.
apply is_derive_Reals.
apply derivable_pt_lim_exp.
Qed.

Lemma is_derive_n_exp : forall n x, is_derive_n exp n x (exp x).
Proof.
intros [|n]. easy.
simpl.
induction n.
apply is_derive_exp.
intros x.
apply is_derive_ext with exp ; cycle 1.
apply is_derive_exp.
simpl.
intros t.
apply eq_sym.
now apply is_derive_unique.
Qed.

(** * Natural logarithm *)

Lemma is_lim_ln_p : is_lim (fun y => ln y) p_infty p_infty.
Proof.
  apply is_lim_spec.
  move => M.
  exists (exp M) => x Hx.
  rewrite -(ln_exp M).
  apply ln_increasing.
  apply exp_pos.
  by apply Hx.
Qed.

Lemma is_lim_ln_0 :
  filterlim ln (at_right 0) (Rbar_locally m_infty).
Proof.
intros P [M HM].
exists (mkposreal (exp M) (exp_pos _)) => x /= Hx Hx0.
apply HM.
rewrite <- (ln_exp M).
apply ln_increasing.
exact Hx0.
rewrite /ball /= /AbsRing_ball /= /abs /minus /plus /opp /= in Hx.
rewrite -/(Rminus _ _) Rminus_0_r Rabs_pos_eq in Hx.
exact Hx.
now apply Rlt_le.
Qed.

Lemma is_lim_div_ln_p : is_lim (fun y => ln y / y) p_infty 0.
Proof.
  have H : forall x, 0 < x -> ln x < x.
    move => x Hx.
    apply Rminus_lt_0.
    apply Rlt_le_trans with (1 := Rlt_0_1).
    case: (MVT_gen (fun y => y - ln y) 1 x (fun y => (y-1)/y)).
      move => z Hz.
      evar (l : R).
      replace ((z - 1) / z) with l.
      apply is_derive_Reals.
      apply derivable_pt_lim_minus.
      apply derivable_pt_lim_id.
      apply derivable_pt_lim_ln.
      eapply Rlt_trans, Hz.
      apply Rmin_case => //.
      by apply Rlt_0_1.
      rewrite /l ; field.
      apply Rgt_not_eq ; eapply Rlt_trans, Hz.
      apply Rmin_case => //.
      by apply Rlt_0_1.
    move => y Hy.
    apply continuity_pt_minus.
    apply continuity_pt_id.
    apply derivable_continuous_pt ;
    eexists ; apply derivable_pt_lim_ln.
    eapply Rlt_le_trans, Hy.
      apply Rmin_case => //.
      by apply Rlt_0_1.
    move => c [Hc H0].
    replace 1 with (1 - ln 1) by (rewrite ln_1 Rminus_0_r //).
    apply Rminus_le_0.
    rewrite H0.
    move: Hc ; rewrite /Rmin /Rmax ; case: Rle_dec => H1 Hc.
    apply Rmult_le_pos.
    apply Rdiv_le_0_compat.
    apply -> Rminus_le_0 ; apply Hc.
    apply Rlt_le_trans with (1 := Rlt_0_1).
    by apply Hc.
    apply -> Rminus_le_0 ; apply H1.
    apply Rnot_le_lt in H1.
    replace ((c - 1) / c * (x - 1)) with ((1-c) * (1-x) / c).
    apply Rdiv_le_0_compat.
    apply Rmult_le_pos.
    apply -> Rminus_le_0 ; apply Hc.
    apply -> Rminus_le_0 ; apply Rlt_le, H1.
    apply Rlt_le_trans with (1 := Hx).
    by apply Hc.
    field.
    apply Rgt_not_eq.
    apply Rlt_le_trans with (1 := Hx).
    by apply Hc.
  apply (is_lim_le_le_loc (fun _ => 0) (fun y => 2/sqrt y)).
  exists 1 => x Hx.
  split.
  apply Rdiv_le_0_compat.
  rewrite -ln_1.
  apply ln_le.
  apply Rlt_0_1.
  by apply Rlt_le.
  by apply Rlt_trans with (1 := Rlt_0_1).
  replace (ln _) with (2 * ln (sqrt x)).
  rewrite /Rdiv Rmult_assoc.
  apply Rmult_le_compat_l.
  apply Rlt_le, Rlt_0_2.
  apply Rle_div_l.
  by apply Rlt_trans with (1 := Rlt_0_1).
  rewrite -{3}(sqrt_sqrt x).
  field_simplify ; rewrite ?Rdiv_1.
  apply Rlt_le, H.
  apply sqrt_lt_R0.
  by apply Rlt_trans with (1 := Rlt_0_1).
  apply Rgt_not_eq.
  apply sqrt_lt_R0.
  by apply Rlt_trans with (1 := Rlt_0_1).
  apply Rlt_le.
  by apply Rlt_trans with (1 := Rlt_0_1).
  change 2 with (INR 2).
  rewrite -ln_pow.
  rewrite /= Rmult_1_r.
  rewrite sqrt_sqrt.
  by [].
  apply Rlt_le.
  by apply Rlt_trans with (1 := Rlt_0_1).
  apply sqrt_lt_R0.
  by apply Rlt_trans with (1 := Rlt_0_1).
  apply is_lim_const.
  evar_last.
  apply is_lim_div.
  apply is_lim_const.
  apply filterlim_sqrt_p.
  by [].
  by [].
  simpl ; by rewrite Rmult_0_r.
Qed.

Lemma is_lim_div_ln1p_0 : is_lim (fun y => ln (1+y) / y) 0 1.
Proof.
  apply is_lim_spec.
  move => eps.
  case: (derivable_pt_lim_ln 1 (Rlt_0_1) eps (cond_pos eps)) => delta H.
  exists delta => y Hy Hy0.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hy.
  rewrite /= -/(Rminus _ _) Rminus_0_r in Hy.
  move: (H y Hy0 Hy).
  by rewrite ln_1 Rinv_1 Rminus_0_r.
Qed.

Lemma continuous_ln x : (0 < x) -> continuous ln x.
Proof.
move => Hxgt0.
apply: ex_derive_continuous.
exists (/x).
apply is_derive_Reals.
exact: derivable_pt_lim_ln.
Qed.

Lemma is_derive_ln x :
  0 < x -> is_derive ln x (/ x)%R.
Proof.
intros H.
apply is_derive_Reals.
now apply derivable_pt_lim_ln.
Qed.

(** * Unnormalized sinc *)

Lemma is_lim_sinc_0 : is_lim (fun x => sin x / x) 0 1.
Proof.
  apply is_lim_spec.
  move => eps.
  case: (derivable_pt_lim_sin_0 eps (cond_pos eps)) => delta H.
  exists delta => y Hy Hy0.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hy.
  rewrite /= -/(Rminus _ _) Rminus_0_r in Hy.
  move: (H y Hy0 Hy).
  by rewrite Rplus_0_l sin_0 Rminus_0_r.
Qed.

(** * ArcTan *)

Lemma CV_radius_atan : CV_radius (fun n => (-1)^n / (INR (S (n + n)))) = 1.
Proof.
  apply eq_trans with (2 := f_equal Finite Rinv_1).
  apply CV_radius_finite_DAlembert.
  intros n.
  apply Rmult_integral_contrapositive_currified.
  apply pow_nonzero.
  apply Rlt_not_eq, Rminus_lt_0 ; ring_simplify ; apply Rlt_0_1.
  rewrite S_INR ; by apply Rgt_not_eq, RinvN_pos.
  by apply Rlt_0_1.
  apply is_lim_seq_ext with (fun n => 1 - 2 / (2 * INR n + 3)).
  intros n.
  rewrite -plus_n_Sm plus_Sn_m !S_INR plus_INR.
  assert (0 < INR n + INR n + 1).
    rewrite -plus_INR -S_INR.
    by apply (lt_INR O), lt_O_Sn.
  assert (0 < INR n + INR n + 1 + 1 + 1).
    rewrite -plus_INR -!S_INR.
    by apply (lt_INR O), lt_O_Sn.
  rewrite !Rabs_div ; try by apply Rgt_not_eq.
  rewrite -!RPow_abs Rabs_m1 !pow1 !Rabs_pos_eq ; try by left.
  field.
  split ; by apply Rgt_not_eq.
  apply Rmult_integral_contrapositive_currified.
  apply pow_nonzero.
  apply Rlt_not_eq, Rminus_lt_0 ; ring_simplify ; apply Rlt_0_1.
  rewrite -plus_INR ; by apply Rgt_not_eq, RinvN_pos.
  evar_last.
  apply is_lim_seq_minus'.
  apply filterlim_const.
  eapply is_lim_seq_div.
  apply is_lim_seq_const.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  apply is_lim_seq_INR.
  apply is_Rbar_mult_sym, is_Rbar_mult_p_infty_pos.
  by apply Rlt_0_2.
  apply is_lim_seq_const.
  reflexivity ; simpl.
  by [].
  reflexivity.
  simpl ; apply f_equal ; ring.
Qed.

Lemma atan_Reals (x : R) : Rabs x < 1
  -> atan x = x * PSeries (fun n => (-1)^n / (INR (S (n + n)))) (x ^ 2).
Proof.
  wlog: x / (0 <= x) => [Hw | Hx0] Hx.
    case: (Rle_lt_dec 0 x) => Hx0.
    by apply Hw.
    rewrite -{1}(Ropp_involutive x) atan_opp Hw.
    replace ((- x) ^ 2) with (x^2) by ring.
    ring.
    apply Ropp_le_cancel ; rewrite Ropp_involutive Ropp_0 ; by left.
    by rewrite Rabs_Ropp.
  rewrite Rabs_pos_eq // in Hx.
  case: Hx0 => Hx0.
  rewrite atan_eq_ps_atan ; try by split.
  rewrite /ps_atan.
  case: Ratan.in_int => H.
  case: ps_atan_exists_1 => ps Hps.
  apply sym_eq.
  rewrite -Series.Series_scal_l.
  apply Series.is_series_unique.
  apply is_lim_seq_Reals in Hps.
  move: Hps ; apply is_lim_seq_ext => n.
  rewrite -sum_n_Reals.
  apply sum_n_ext => k.
  rewrite /tg_alt /Ratan_seq S_INR !plus_INR.
  rewrite pow_add -pow_mult.
  simpl ; field.
  rewrite -plus_INR -S_INR.
  apply Rgt_not_eq, (lt_INR 0), lt_O_Sn.
  contradict H ; split.
  apply Rle_trans with 0.
  apply Rminus_le_0 ; ring_simplify ; by apply Rle_0_1.
  by left.
  by left.
  by rewrite -Hx0 atan_0 Rmult_0_l.
Qed.

Lemma continuous_atan x : continuous atan x.
Proof.
apply: ex_derive_continuous.
apply: ex_derive_Reals_1.
exact: derivable_pt_atan.
Qed.

Lemma continuous_atan_comp (f : R -> R) x:
  continuous f x ->
  continuous (fun x => atan (f x)) x.
Proof.
move => Hcont.
apply: continuous_comp => //.
by apply: continuous_atan.
Qed.

Lemma is_derive_atan x :
  is_derive atan x (/ (1 + x²)).
Proof.
rewrite Rsqr_pow2.
apply is_derive_Reals, derivable_pt_lim_atan.
Qed.

(** * Cosine *)

Lemma continuous_cos x : continuous cos x.
Proof.
apply continuity_pt_filterlim.
by apply: continuity_cos => // .
Qed.

Lemma continuous_cos_comp (f : R -> R) x:
  continuous f x ->
  continuous (fun x => cos (f x)) x.
Proof.
move => Hcont.
apply: continuous_comp => //.
by apply: continuous_cos.
Qed.

Lemma is_derive_cos x : is_derive cos x (- sin x).
Proof.
apply is_derive_Reals.
apply derivable_pt_lim_cos.
Qed.

(** * Sine *)

Lemma continuous_sin x : continuous sin x.
Proof.
apply continuity_pt_filterlim.
by apply: continuity_sin => // .
Qed.

Lemma continuous_sin_comp (f : R -> R) x:
  continuous f x ->
  continuous (fun x => sin (f x)) x.
Proof.
move => Hcont.
apply: continuous_comp => //.
by apply: continuous_sin.
Qed.

Lemma is_derive_sin x : is_derive sin x (cos x).
Proof.
apply is_derive_Reals.
apply derivable_pt_lim_sin.
Qed.

(** * Tangent *)

Lemma continuous_tan x : cos x <> 0 -> continuous tan x.
Proof.
move => Hcos.
rewrite /tan.
apply: continuous_mult; first by apply: continuous_sin.
by apply: continuous_Rinv_comp; first by apply: continuous_cos.
Qed.

Lemma is_derive_tan x :
  cos x <> 0%R -> is_derive tan x (tan x ^ 2 + 1)%R.
Proof.
intros Hx.
unfold tan.
evar_last.
apply Derive.is_derive_mult.
apply is_derive_sin.
apply is_derive_inv.
apply is_derive_cos.
exact Hx.
simpl.
now field.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e480m2e240m1_15limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Export Estado.
Require Export DefBasicas.
Require Export Semantica.
Require Import Tacticas.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.

Require Import Classical.

Lemma GrantAutoIsInvariant : forall (s s':System) (sValid:validstate s) (p:Perm) (a:idApp) ,pre_grantAuto p a s -> post_grantAuto p a s s' -> validstate s'.
Proof.
  intros.
  unfold validstate.
  unfold pre_grantAuto in H.
  unfold post_grantAuto in H0.
  destruct H0 as [verified H0].
  destruct_conj H.
  destruct_conj H0.
  split.

  unfold allCmpDifferent.
  intros.
  apply (inAppS'InAppS a1 s) in H12;auto.
  apply (inAppS'InAppS a2 s) in H14;auto.
  apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.
  split.

  unfold notRepeatedCmps.
  intros.
  apply (inAppS'InAppS a1 s) in H12;auto.
  apply (inAppS'InAppS a2 s) in H14;auto.
  apply (inAppSameCmp s sValid c a1 a2);auto.
  split.

  unfold notCPrunning.
  rewrite <-H8.
  destructVS sValid.
  auto. split.

  apply (delTmpRunS' s);auto. split.

  apply (cmpRunAppInsS' s);auto. split.

  apply (resContAppInstS' s);auto. split.

  unfold statesConsistency.
  rewrite <- H0.
  rewrite <- H6.
  intros.
  assert (sv2:=sValid).
  destructVS sValid.
  destructSC statesConsistencyVS a0.
  repeat (split;intros; auto).
- destruct H4.
  apply permsSC in H12.
  destruct H12.
  apply H4 in H12.
  destruct H12. destruct H12.
  exists x0;auto.
- destruct H4 as [H4 [H14 H15]].
  destruct H12.
  apply H14 in H12.
  destruct H12 as [lPerm [H12 H16]].
  apply (ifPermsThenInApp s sv2 a0 lPerm);auto.
- rewrite <- H7.
  apply grantedPermGroupsSC in H12; auto.
- rewrite <- H7 in H12.
  destruct H12 as [lGroup H12].
  apply (ifGroupedPermsThenInApp s sv2 a0 lGroup). auto.
- assert (sv2 := sValid). destructVS sValid. split.

  unfold notDupApp.
  rewrite <- H0, <- H6.
  intros. auto. split.

  unfold notDupSysApp.
  rewrite <- H0.
  intros; auto. split.

  unfold notDupPerm.
  apply (notDupPermS' s);auto.
  split.

  unfold allMapsCorrect.
  rewrite <-H0, <-H7, <-H8, <-H9, <- H10, <- H11.
  unfold allMapsCorrect in allMapsCorrectVS.
  destruct_conj allMapsCorrectVS.
  repeat (split;auto; try mapcorrect sValid).
  unfold grantPerm in H4. destruct_conj H4. auto.
  split.

  unfold grantedPermsExist.
  intros. destruct H4 as [H4 [H15 H16]].
  apply H15 in H12.
  destruct H12 as [lPerm [H12 H17]].
  elim (classic (In p0 lPerm));intros.
+ apply (permExistsSpermExistsS' s); auto.
  apply (grantedPermsExistVS a0 p0 lPerm); auto.
+ specialize (H17 p0 H14 H18). destruct H17.
  rewrite <- H19.
  apply (permExistsSpermExistsS' s);auto.
+ unfold noDupSentIntents.
  rewrite <- H13.
  auto.
Qed.


Require Import CertiGraph.CertiGC.gc_spec.

Local Open Scope logic.

Lemma typed_true_tag: forall (to : nat) (g : LGraph) (index : nat),
    typed_true tint
               (force_val
                  (option_map (fun b : bool => Val.of_bool (negb b))
                              (bool_val_i
                                 (Val.of_bool
                                    (negb (Int.lt (Int.repr (raw_tag
                                                               (vlabel g (to, index))))
                                                  (Int.repr 251))))))) ->
    ~ no_scan g (to, index).
Proof.
  intros. remember (Int.lt (Int.repr (raw_tag (vlabel g (to, index)))) (Int.repr 251)).
  unfold typed_true in H. destruct b; simpl in H; [|inversion H].
  symmetry in Heqb. apply lt_repr in Heqb.
  - unfold no_scan. rep_lia.
  - red. pose proof (raw_tag_range (vlabel g (to, index))). rep_lia.
  - red. rep_lia.
Qed.

Lemma typed_false_tag: forall (to : nat) (g : LGraph) (index : nat),
    typed_false tint
               (force_val
                  (option_map (fun b : bool => Val.of_bool (negb b))
                              (bool_val_i
                                 (Val.of_bool
                                    (negb (Int.lt (Int.repr (raw_tag
                                                               (vlabel g (to, index))))
                                                  (Int.repr 251))))))) ->
    no_scan g (to, index).
Proof.
  intros. remember (Int.lt (Int.repr (raw_tag (vlabel g (to, index)))) (Int.repr 251)).
  unfold typed_false in H. destruct b; simpl in H; [inversion H|].
  symmetry in Heqb. apply lt_repr_false in Heqb.
  - unfold no_scan. rep_lia.
  - red. pose proof (raw_tag_range (vlabel g (to, index))). rep_lia.
  - red. rep_lia.
Qed.

Lemma body_do_scan: semax_body Vprog Gprog f_do_scan do_scan_spec.
Proof.
  start_function.
  forward.
  forward_loop (EX n: nat, EX g': LGraph, EX t_info': thread_info,
                PROP (super_compatible (g', t_info', roots) f_info outlier;
                      forward_condition g' t_info' from to;
                      thread_info_relation t_info t_info';
                      closure_has_index g' to (to_index + n);
                      scan_vertex_while_loop from to (nat_seq to_index n) g g')
                LOCAL
                (temp _s (offset_val (- WORD_SIZE)
                                     (vertex_address g' (to, (to_index + n)%nat)));
                 temp _from_start (gen_start g' from);
                 temp _from_limit (limit_address g' t_info' from);
                 temp _next (next_address t_info' to))
                SEP (all_string_constants rsh gv; fun_info_rep rsh f_info fi;
               outlier_rep outlier; graph_rep g'; thread_info_rep sh t_info' ti))
  break: (EX g' : LGraph, EX t_info' : thread_info,
          PROP (super_compatible (g', t_info', roots) f_info outlier;
                forward_condition g' t_info' from to;
                do_scan_relation from to to_index g g';
                thread_info_relation t_info t_info')
          LOCAL ()
          SEP (all_string_constants rsh gv; fun_info_rep rsh f_info fi;
               outlier_rep outlier; graph_rep g'; thread_info_rep sh t_info' ti)).
  - Exists O g t_info. destruct H as [? [? [? ?]]].
    replace (to_index + 0)%nat with to_index by lia. entailer!.
    split; [|split]; [red; auto | apply tir_id | constructor].
  - Intros n g' t_info'. remember (to_index + n)%nat as index.
    unfold next_address, thread_info_rep. Intros.
    unfold heap_struct_rep. destruct H5 as [? [? [? ?]]].
    destruct H6 as [? [? [? [? ?]]]].
    assert (0 <= Z.of_nat to < 12). {
      clear -H5 H14. destruct H5 as [_ [_ ?]]. red in H14.
      pose proof (spaces_size (ti_heap t_info')).
      rewrite Zlength_correct in H0. rep_lia. }
    destruct (gt_gs_compatible _ _ H5 _ H14) as [? [? ?]]. rewrite nth_space_Znth in *.
    remember (Znth (Z.of_nat to) (spaces (ti_heap t_info'))) as sp_to.
    assert (isptr (space_start sp_to)) by (rewrite <- H18; apply start_isptr).
    remember (map space_tri (spaces (ti_heap t_info'))).
    assert (@Znth (val * (val * val)) (Vundef, (Vundef, Vundef))
                  (Z.of_nat to) l = space_tri sp_to). {
      subst l sp_to. now rewrite Znth_map by (rewrite spaces_size; rep_lia). }
    forward; rewrite H22; unfold space_tri. 1: entailer!.
    unfold vertex_address, vertex_offset. rewrite offset_offset_val.
    simpl vgeneration; simpl vindex.
    replace (WORD_SIZE * (previous_vertices_size g' to index + 1) + - WORD_SIZE) with
        (WORD_SIZE * (previous_vertices_size g' to index))%Z by rep_lia.
    unfold gen_start at 1. rewrite if_true by assumption. rewrite H18.
    remember (WORD_SIZE * used_space sp_to)%Z as used_offset.
    remember (WORD_SIZE * previous_vertices_size g' to index)%Z as index_offset.
    freeze [0; 1; 2; 4; 5] FR.
    gather_SEP (graph_rep g') (heap_rest_rep (ti_heap t_info')).
    assert (
        forall b i,
          Vptr b i = space_start sp_to ->
          graph_rep g' * heap_rest_rep (ti_heap t_info') |--
      !! (WORD_SIZE * total_space sp_to + Ptrofs.unsigned i <= Ptrofs.max_unsigned)). {
      intros. sep_apply (graph_and_heap_rest_data_at_ _ _ _ H14 H5).
      assert (space_start sp_to = gen_start g' to) by
          (unfold gen_start; rewrite if_true by assumption;
           rewrite <- H18; reflexivity). rewrite H24 in H23.
      sep_apply (generation_data_at__ptrofs g' t_info' to b i H23).
      unfold gen_size; rewrite nth_space_Znth; entailer!. }
    assert_PROP (force_val
                   (sem_cmp_pp Clt (offset_val index_offset (space_start sp_to))
                               (offset_val used_offset (space_start sp_to))) =
                 Vint (if if zlt index_offset used_offset then true else false
                       then Int.one else Int.zero)). {
      remember (space_start sp_to). destruct v; try contradiction. inv_int i.
      specialize (H23 b (Ptrofs.repr ofs) eq_refl).
      rewrite Ptrofs.unsigned_repr in H23 by rep_lia. sep_apply H23. Intros.
      assert (0 <= ofs + used_offset <= Ptrofs.max_unsigned). {
        subst.
        pose proof (space_order (Znth (Z.of_nat to) (spaces (ti_heap t_info')))).
        unfold WORD_SIZE in *. rep_lia. }
      assert (0 <= ofs + index_offset <= Ptrofs.max_unsigned). {
        subst. red in H8. pose proof (pvs_ge_zero g' to (to_index + n)%nat).
        pose proof (pvs_mono g' to _ _ H8). unfold WORD_SIZE in *. rep_lia. }
      apply prop_right.
      rewrite force_sem_cmp_pp; [|rewrite isptr_offset_val; assumption..].
      simpl. rewrite !ptrofs_add_repr, if_true. 2: reflexivity.
      unfold Ptrofs.ltu. rewrite !Ptrofs.unsigned_repr; auto. f_equal.
      if_tac; if_tac; try reflexivity; lia. }
    forward_if (gen_has_index g' to index).
    + remember (Znth (Z.of_nat to) (spaces (ti_heap t_info'))) as sp_to.
      sep_apply (graph_and_heap_rest_data_at_ _ _ _ H14 H5).
      unfold generation_data_at_.
      assert (gen_start g' to = space_start sp_to) by
          (subst; unfold gen_start; rewrite if_true; assumption). rewrite H31.
      rewrite data_at__memory_block. Intros. rewrite sizeof_tarray_int_or_ptr.
      2: unfold gen_size; apply total_space_range.
      remember (WORD_SIZE * used_space sp_to)%Z as used_offset.
      remember (to_index + n)%nat as index.
      remember (WORD_SIZE * previous_vertices_size g' to index)%Z as index_offset.
      destruct (space_start sp_to); try contradiction. simpl. unfold test_order_ptrs.
      simpl. case (peq b b); intros. 2: contradiction. simpl.
      assert (sepalg.nonidentity (nth_sh g' to)). {
        apply readable_nonidentity, writable_readable_share. unfold nth_sh.
        apply generation_share_writable. }
      assert (forall offset,
                 0 <= offset <= used_offset ->
                 memory_block (nth_sh g' to) (WORD_SIZE * gen_size t_info' to)
                              (Vptr b i) * TT * FRZL FR |--
        weak_valid_pointer (Vptr b (Ptrofs.add i (Ptrofs.repr offset)))). {
        intros. change (Vptr b (Ptrofs.add i (Ptrofs.repr offset))) with
            (offset_val offset (Vptr b i)).
        sep_apply (memory_block_weak_valid_pointer
                     (nth_sh g' to) (WORD_SIZE * gen_size t_info' to)
                     (Vptr b i) offset); auto.
        3: apply extend_weak_valid_pointer.
        - subst. unfold gen_size. split. 1: apply (proj1 H34).
          transitivity (WORD_SIZE * used_space (nth_space t_info' to))%Z.
          + rewrite nth_space_Znth. apply (proj2 H34).
          + apply Zmult_le_compat_l. apply (proj2 (space_order _)).
            unfold WORD_SIZE. lia.
        - clear -H3 H7. destruct H7 as [? [? ?]].
          rewrite <- H0. unfold WORD_SIZE. lia. }
      apply andp_right; apply H34.
      * subst. split.
        1: pose proof (pvs_ge_zero g' to (to_index + n)%nat); unfold WORD_SIZE; lia.
        apply Zmult_le_compat_l. 2: unfold WORD_SIZE; lia. rewrite <- H20.
        apply pvs_mono. assumption.
      * split; [|lia]; subst; apply Z.mul_nonneg_nonneg;
                                  [unfold WORD_SIZE; lia | apply space_order].
    + assert (index_offset < used_offset). {
        destruct (zlt index_offset used_offset); trivial.
        rewrite H24 in H25; unfold typed_true in H25. easy. }
      forward. entailer!. red. rewrite <- H20 in H26.
      rewrite <- Z.mul_lt_mono_pos_l in H26 by (unfold WORD_SIZE; lia).
      apply pvs_lt_rev in H26. assumption.
    + assert (~ index_offset < used_offset). {
        destruct (zlt index_offset used_offset); trivial.
        now rewrite H24 in H25; unfold typed_false in H25. }
      forward. thaw FR. unfold thread_info_rep, heap_struct_rep.
      Exists g' t_info'. unfold forward_condition. entailer!.
      split; [red; auto | exists n; split; trivial].
      unfold gen_has_index. rewrite <- H20 in H26.
      rewrite <- Z.mul_lt_mono_pos_l in H26 by (unfold WORD_SIZE; lia).
      intro; apply H26. now apply pvs_mono_strict.
    + clear H8 H23 H24. Intros. thaw FR. freeze [1;2;3;4;5;6] FR.
      assert (graph_has_v g' (to, index)) by easy.
      (* annotation theta 7 *)
      localize [vertex_rep (nth_sh g' to) g' (to, index)].
      assert (readable_share (nth_sh g' to)) by
          (unfold nth_sh; apply writable_readable_share, generation_share_writable).
      unfold vertex_rep, vertex_at. Intros.
      assert (offset_val (- WORD_SIZE) (vertex_address g' (to, index)) =
              offset_val index_offset (space_start sp_to)). {
        unfold vertex_address. rewrite offset_offset_val. unfold vertex_offset.
        simpl vgeneration. simpl vindex.
        replace (WORD_SIZE * (previous_vertices_size g' to index + 1) + - WORD_SIZE)
          with index_offset by rep_lia.
        f_equal. unfold gen_start.
        rewrite if_true by assumption; now rewrite H18. }
      rewrite H25. forward. rewrite <- H25.
      gather_SEP (data_at _ _ _ _) (data_at _ _ _ _).
      replace_SEP 0 (vertex_rep (nth_sh g' to) g' (to, index)) by
          (unfold vertex_rep, vertex_at; entailer!).
      unlocalize [graph_rep g']. 1: apply graph_vertex_ramif_stable; assumption.
      forward. forward. assert (gen_unmarked g' to). {
        eapply (svwl_gen_unmarked from to _ g); eauto.
        destruct H0 as [_ [_ [? _]]]. assumption. }
      specialize (H26 H14 _ H8).
      rewrite make_header_Wosize, make_header_tag by assumption.
      fold (next_address t_info' to). thaw FR.
      fold (heap_struct_rep sh l (ti_heap_p t_info')).
      gather_SEP
        (data_at _ thread_info_type _ _)
        (heap_struct_rep _ _ _ ) (heap_rest_rep _).
      replace_SEP 0 (thread_info_rep sh t_info' ti) by
          (unfold thread_info_rep; entailer!).
      forward_if
        (EX g'': LGraph, EX t_info'': thread_info,
         PROP (super_compatible (g'', t_info'', roots) f_info outlier;
               forward_condition g'' t_info'' from to;
               thread_info_relation t_info t_info'';
               (no_scan g' (to, index) /\ g'' = g') \/
               (~ no_scan g' (to, index) /\
                scan_vertex_for_loop
                  from to (to, index)
                  (nat_inc_list (length (vlabel g' (to, index)).(raw_fields))) g' g''))
         LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                temp _sz
                     (if Archi.ptr64 then
                        Vlong (Int64.repr
                                 (Zlength (raw_fields (vlabel g' (to, index)))))
                      else vint (Zlength (raw_fields (vlabel g' (to, index)))));
                temp _s (offset_val (- WORD_SIZE) (vertex_address g'' (to, index)));
                temp _from_start (gen_start g'' from);
                temp _from_limit (limit_address g'' t_info'' from);
                temp _next (next_address t_info'' to))
         SEP (thread_info_rep sh t_info'' ti; graph_rep g'';
              fun_info_rep rsh f_info fi;
              all_string_constants rsh gv; outlier_rep outlier)).
      * try (rewrite Int64.unsigned_repr in H27;
             [|pose proof (raw_tag_range (vlabel g' (to, index))); rep_lia]).
        apply typed_true_tag in H27.
        remember (Zlength (raw_fields (vlabel g' (to, index)))).
        assert (1 <= z < (if Archi.ptr64 then Int64.max_signed else Int.max_signed)).
        {
          subst z. pose proof (raw_fields_range (vlabel g' (to, index))).
          split; [lia|]. transitivity (two_p (WORD_SIZE * 8 - 10));
                           [lia | vm_compute; reflexivity]. }
        forward_loop
          (EX i: Z, EX g3: LGraph, EX t_info3: thread_info,
           PROP (scan_vertex_for_loop
                   from to (to, index)
                   (sublist 0 (i - 1)
                            (nat_inc_list
                               (length (vlabel g' (to, index)).(raw_fields)))) g' g3;
                super_compatible (g3, t_info3, roots) f_info outlier;
                forward_condition g3 t_info3 from to;
                thread_info_relation t_info t_info3;
                1 <= i <= z + 1)
           LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                  temp _j (if Archi.ptr64 then (Vlong (Int64.repr i)) else vint i);
                  temp _sz (if Archi.ptr64 then (Vlong (Int64.repr z)) else vint z);
                  temp _s (offset_val (- WORD_SIZE) (vertex_address g3 (to, index)));
                  temp _from_start (gen_start g3 from);
                  temp _from_limit (limit_address g3 t_info3 from);
                  temp _next (next_address t_info3 to))
           SEP (all_string_constants rsh gv;
                outlier_rep outlier;
                fun_info_rep rsh f_info fi;
                graph_rep g3;
                thread_info_rep sh t_info3 ti))
          continue: (EX i: Z, EX g3: LGraph, EX t_info3: thread_info,
           PROP (scan_vertex_for_loop
                   from to (to, index)
                   (sublist 0 i
                            (nat_inc_list
                               (length (vlabel g' (to, index)).(raw_fields)))) g' g3;
                super_compatible (g3, t_info3, roots) f_info outlier;
                forward_condition g3 t_info3 from to;
                thread_info_relation t_info t_info3;
                1 <= i + 1 <= z + 1)
           LOCAL (temp _tag (vint (raw_tag (vlabel g' (to, index))));
                  temp _j (if Archi.ptr64 then (Vlong (Int64.repr i)) else vint i);
                  temp _sz (if Archi.ptr64 then (Vlong (Int64.repr z)) else vint z);
                  temp _s (offset_val (- WORD_SIZE) (vertex_address g3 (to, index)));
                  temp _from_start (gen_start g3 from);
                  temp _from_limit (limit_address g3 t_info3 from);
                  temp _next (next_address t_info3 to))
           SEP (all_string_constants rsh gv;
                fun_info_rep rsh f_info fi;
                outlier_rep outlier;
                graph_rep g3;
                thread_info_rep sh t_info3 ti)).
        -- forward. Exists 1 g' t_info'. replace (1 - 1) with 0 by lia.
           autorewrite with sublist. unfold forward_condition. entailer!.
           try (rewrite Int64.unsigned_repr;
                [| pose proof (raw_tag_range (vlabel g' (to, (to_index + n)%nat)));
                   rep_lia]).
           split; [apply svfl_nil | unfold super_compatible; auto].
        -- Intros i g3 t_info3. forward_if (i <= z).
           ++ forward. entailer!.
              first [rewrite !Int.unsigned_repr in H34 |
                     apply ltu64_repr_false in H34]; try lia.
              ** clear -H28 H33. simpl in H28. split. 1: lia.
                 transitivity
                   (Zlength (raw_fields (vlabel g' (to, (to_index + n)%nat))) + 1);
                   rep_lia.
              ** clear -H28. simpl in H28. rep_lia.
           ++ forward. assert (i = z + 1). {
                try unfold Int64.ltu in H34.
                first [rewrite !Int.unsigned_repr in H34 |
                       rewrite !Int64.unsigned_repr in H34].
                - try (if_tac in H34; [|inversion H34]). lia.
                - simpl in H28. clear -H28 H33. rep_lia.
                - simpl in H28. clear -H28. rep_lia. } subst i. clear H33 H34.
              replace (z + 1 - 1) with z in H29 by lia.
              remember (raw_fields (vlabel g' (to, index))) as r.
              replace (sublist 0 z (nat_inc_list (Datatypes.length r))) with
                  (nat_inc_list (Datatypes.length r)) in H29.
              ** Exists g3 t_info3. entailer!.
              ** rewrite sublist_same; trivial.
                 subst z. rewrite !Zlength_correct, nat_inc_list_length. reflexivity.
           ++ Intros.
              change (Tpointer tvoid {| attr_volatile := false;
                                        attr_alignas := Some 2%N |}) with
                  int_or_ptr_type.
              change (Tpointer tvoid {| attr_volatile := false;
                                        attr_alignas := Some 3%N |}) with
                  int_or_ptr_type.
              assert (isptr (vertex_address g3 (to, index))). {
                erewrite <- svfl_vertex_address; eauto. rewrite <- H18 in H21.
                2: apply graph_has_v_in_closure; assumption. clear -H21 H14.
                unfold vertex_address. unfold gen_start. simpl.
                rewrite if_true by assumption. rewrite isptr_offset_val. assumption. }
              assert (graph_has_gen g3 to) by
                  (eapply svfl_graph_has_gen in H29; [rewrite <- H29|]; assumption).
              assert (graph_has_v g3 (to, index)) by
                  (eapply svfl_graph_has_v in H29; [apply H29| assumption..]).
              forward_call (rsh, sh, gv, fi, ti, g3, t_info3, f_info, roots,
                            outlier, from, to, 0, (@inr Z _ ((to, index), i - 1))).
              ** simpl snd. apply prop_right. simpl.
                 do 4 f_equal.
                 first [rewrite sem_add_pi_ptr_special' |
                        rewrite sem_add_pl_ptr_special]; try easy;
                   [|rewrite isptr_offset_val; assumption].
                 simpl. rewrite offset_offset_val. f_equal. unfold WORD_SIZE; lia.
              ** repeat (split; try assumption). lia.
                 --- eapply svfl_raw_fields in H29;
                       [rewrite <- H29; lia | assumption..].
                 --- rewrite <- H26. symmetry.
                     eapply svfl_raw_mark in H29; [apply H29 | assumption..|].
                     simpl. lia.
                 --- simpl; auto.
              ** Intros vret. destruct vret as [[g4 t_info4] roots']. simpl fst in *.
                 simpl snd in *. simpl in H37. subst roots'. Exists i g4 t_info4.
                 destruct H38 as [? [? [? ?]]].
                 assert (gen_start g3 from = gen_start g4 from) by
                     (eapply fr_gen_start; eauto).
                 assert (limit_address g3 t_info3 from =
                         limit_address g4 t_info4 from). {
                   unfold limit_address. rewrite H45.
                   do 2 f_equal. apply (proj2 H42). }
                 assert (next_address t_info3 to = next_address t_info4 to) by
                     (unfold next_address; f_equal; apply (proj1 H42)). entailer!.
                 split; [|split; [|split]]; try easy.
                 --- remember (nat_inc_list
                                 (Datatypes.length
                                    (raw_fields (vlabel g' (to,
                                                            (to_index + n)%nat))))).
                     assert (i <= Zlength l). {
                       subst l. rewrite Zlength_correct, nat_inc_list_length.
                       rewrite Zlength_correct in H34. lia. }
                     rewrite (sublist_split 0 (i - 1) i) by lia.
                     rewrite (sublist_one (i - 1) i) by lia.
                     apply svfl_add_tail with roots g3; trivial.
                     assert (Z.of_nat (Znth (i - 1) l) = i - 1). {
                       rewrite <- nth_Znth by lia. subst l.
                       rewrite nat_inc_list_nth; [rewrite Z2Nat.id; lia|].
                       rewrite <- ZtoNat_Zlength. rewrite Zlength_correct in H52.
                       rewrite nat_inc_list_length in H52. rewrite Nat2Z.inj_lt.
                       rewrite !Z2Nat.id; lia. } rewrite H53. assumption.
                 --- apply tir_trans with t_info3; assumption.
                 --- f_equal. symmetry. eapply fr_vertex_address; eauto.
                     apply graph_has_v_in_closure; assumption.
        -- Intros i g3 t_info3. cbv [Archi.ptr64]. forward.
           ++ entailer!. clear -H28 H33. simpl in H28.
              first [rewrite !Int.signed_repr | rewrite Int64.signed_repr]; rep_lia.
           ++ Exists (i + 1) g3 t_info3. replace (i + 1 - 1) with i by lia. entailer!.
      * try (rewrite Int64.unsigned_repr in H27;
             [|pose proof (raw_tag_range (vlabel g' (to, index))); rep_lia]).
        apply typed_false_tag in H27. forward. Exists g' t_info'.
        unfold forward_condition. entailer!.
        try (rewrite Int64.unsigned_repr;
             [|pose proof (raw_tag_range (vlabel g' (to, (to_index + n)%nat)));
               rep_lia]). easy.
      * Intros g'' t_info''. assert (isptr (vertex_address g'' (to, index))). {
          assert (isptr (vertex_address g' (to, index))). {
            unfold vertex_address. rewrite isptr_offset_val. unfold gen_start.
            rewrite <- H18 in H21. rewrite if_true; assumption. }
          destruct H30 as [[? ?] | [? ?]]. 1: subst g''; assumption.
          eapply svfl_vertex_address in H32;
            [rewrite <- H32 | | apply graph_has_v_in_closure]; assumption. }
        pose proof (raw_fields_range (vlabel g' (to, index))). forward.
           change (Tpointer tvoid {| attr_volatile := false;
                                     attr_alignas := Some 2%N |}) with int_or_ptr_type.
           change (Tpointer tvoid {| attr_volatile := false;
                                     attr_alignas := Some 3%N |}) with int_or_ptr_type.
           cbv [Archi.ptr64]. simpl sem_binary_operation'.
           first [rewrite add_repr | rewrite add64_repr].
           try (rewrite Int.signed_repr; [|rep_lia]).
           assert (force_val
                     (if Archi.ptr64 then
                        (sem_add_ptr_long
                           int_or_ptr_type
                           (offset_val (-8) (vertex_address g'' (to, index)))
                           (Vlong
                              (Int64.repr
                                 (1 + Zlength (raw_fields (vlabel g' (to, index)))))))
                      else
                        (sem_add_ptr_int
                           int_or_ptr_type Unsigned
                           (offset_val (-4)
                                       (vertex_address g'' (to, index)))
                           (vint (1 + Zlength
                                        (raw_fields (vlabel g' (to, index)))))))
                   = offset_val (- WORD_SIZE)
                                (vertex_address g''
                                                (to, (to_index + (n + 1))%nat))). {
             cbv [Archi.ptr64].
             first [rewrite sem_add_pi_ptr_special' |
                    rewrite sem_add_pl_ptr_special']; try easy.
             - assert (Zlength (raw_fields (vlabel g' (to, index))) =
                       Zlength (raw_fields (vlabel g'' (to, index)))). {
                 destruct H30 as [[? ?] | [? ?]]. 1: subst g''; reflexivity.
                 erewrite svfl_raw_fields; eauto. } rewrite H33.
               simpl. replace (to_index + (n + 1))%nat with (S index) by lia.
               unfold vertex_address. rewrite !offset_offset_val.
               unfold vertex_offset. simpl vgeneration. simpl vindex. f_equal.
               rewrite pvs_S. unfold vertex_size. unfold WORD_SIZE. lia.
             - rewrite isptr_offset_val. assumption. }
           cbv [Archi.ptr64] in H33. rewrite H33. clear H33.
           assert (closure_has_index g'' to (to_index + (n + 1))). {
             replace (to_index + (n + 1))%nat with (index + 1)%nat by lia.
             cut (gen_has_index g'' to index). 1: red; intros; red in H33; lia.
             destruct H30 as [[? ?] | [? ?]].
             - subst g''. destruct H23. assumption.
             - eapply svfl_graph_has_v in H33; eauto. destruct H33. assumption. }
           Exists (n + 1)%nat g'' t_info''. destruct H27 as [? [? [? ?]]]. entailer!.
           clear H37 H38 H39 H40. replace (n + 1)%nat with (S n) by lia.
           rewrite nat_seq_S, Nat.add_comm. destruct H30 as [[? ?] | [? ?]].
           ++ subst g''. split; [| apply svwl_add_tail_no_scan]; easy.
           ++ split; [|apply svwl_add_tail_scan with g']; easy.
  - Intros g' t_info'. Exists g' t_info'. entailer!.
Qed.


(************************************************************************)
(*         *   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 BinPos BinNat.
Local Open Scope N_scope.

(** Obsolete file, see [BinNat] now,
    only compatibility notations remain here. *)

Notation Ndivide := N.divide (only parsing).
Notation Ngcd := N.gcd (only parsing).
Notation Nggcd := N.ggcd (only parsing).
Notation Nggcd_gcd := N.ggcd_gcd (only parsing).
Notation Nggcd_correct_divisors := N.ggcd_correct_divisors (only parsing).
Notation Ngcd_divide_l := N.gcd_divide_l (only parsing).
Notation Ngcd_divide_r := N.gcd_divide_r (only parsing).
Notation Ngcd_greatest := N.gcd_greatest (only parsing).


(******************************************************************************)
(** * Definition of happens-before in the IMM memory model (similar to C11) *)
(******************************************************************************)

Require Import Classical Peano_dec.
From hahn Require Import Hahn.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section IMM_hb.

Variable G : execution.

Notation "'E'" := G.(acts_set).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).

Notation "'fr'" := G.(fr).
Notation "'eco'" := G.(eco).
Notation "'coe'" := G.(coe).
Notation "'coi'" := G.(coi).
Notation "'deps'" := G.(deps).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'detour'" := G.(detour).

Notation "'lab'" := G.(lab).
Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'mod'" := (mod lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Implicit Type WF : Wf G.
Implicit Type COMP : complete G.
Implicit Type SC_PER_LOC : sc_per_loc G.

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

(* release sequence *)
Definition rs := ⦗W⦘ ⨾  ((sb ∩ same_loc) ⨾ ⦗W⦘ ∪ ((sb ∩ same_loc)^? ⨾ rf ⨾ rmw)＊).

Definition release := ⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⨾ rs.

(* synchronizes with *)
Definition sw := release ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾ (sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq⦘.

(* happens-before *)
Definition hb := (sb ∪ sw)⁺.

(* simplified prop *)
Definition sprop :=
  ⦗W⦘ ⨾ rfe^? ⨾ (sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq ∪₁ W⦘ ⨾ hb ⨾ ⦗Rel⦘.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma hb_trans : transitive hb.
Proof using. vauto. Qed.

Lemma sb_in_hb : sb ⊆ hb.
Proof using. vauto. Qed.

Lemma sw_in_hb : sw ⊆ hb.
Proof using. vauto. Qed.

Lemma cr_hb_hb : hb^? ⨾ hb ≡ hb.
Proof using. generalize hb_trans; basic_solver. Qed.

Lemma cr_hb_cr_hb : hb^? ⨾ hb^? ≡ hb^?.
Proof using. generalize hb_trans; basic_solver 20. Qed.

Lemma hb_sb_sw : hb ≡ hb^? ⨾ (sb ∪ sw).
Proof using.
unfold hb; rewrite ct_end at 1; rels.
Qed.

Lemma sprop_trans WF : transitive sprop.
Proof using.
  apply transitiveI.
  unfold sprop at 1 2. rewrite !seqA.
  arewrite (⦗Rel⦘ ⨾ ⦗W⦘ ⨾ rfe^? ⨾ (sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq ∪₁ W⦘ ⊆ hb^?).
  { rewrite crE at 1. rewrite !seq_union_l, !seq_union_r, !seq_id_l.
    unionL.
    { rewrite sb_in_hb. basic_solver. }
    rewrite <- sw_in_hb.
    unfold sw.
    arewrite (⦗Rel⦘ ⨾ ⦗W⦘ ⊆ release).
    { unfold release, rs.
      rewrite rtE. basic_solver 40. }
    rewrite (dom_r WF.(wf_rfeD)) at 1. rewrite !seqA.
    arewrite (⦗R⦘ ⨾ (sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq ∪₁ W⦘ ⊆ (sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq⦘).
    { unfolder. ins. desf; eauto 10.
      all: type_solver. }
    basic_solver 40. }
  arewrite (hb ⨾ hb^? ⨾ hb ⊆ hb).
  2: done.
  rewrite cr_hb_hb.
  apply transitiveI.
  apply hb_trans.
Qed.

(******************************************************************************)
(** ** Same Location relations  *)
(******************************************************************************)

Lemma loceq_rs WF : funeq loc rs.
Proof using. destruct WF; unfold rs; desf; eauto 10 with hahn. Qed.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_rsE WF : rs ≡ ⦗W⦘ ∪ ⦗E⦘ ⨾ rs ⨾ ⦗E⦘.
Proof using.
unfold rs.
split; [|basic_solver].
rewrite rtE; relsf; unionL.
rewrite wf_sbE; basic_solver 21.
basic_solver 21.
unionR right -> right -> right.
rewrite (dom_r (wf_rmwE WF)) at 1.
rewrite <- !seqA.
sin_rewrite inclusion_ct_seq_eqv_r.
rewrite !seqA.
arewrite (⦗E⦘ ⨾ ⦗W⦘ ≡ ⦗W⦘ ⨾ ⦗E⦘) by basic_solver.
hahn_frame.
rewrite ct_begin.
rewrite (dom_l (@wf_sbE G)) at 1.
rewrite (dom_l (wf_rfE WF)) at 1.
basic_solver 21.
Qed.

Lemma wf_releaseE WF : release ≡ ⦗W ∩₁ Rel⦘ ∪ ⦗E⦘ ⨾ release ⨾ ⦗E⦘.
Proof using.
unfold release.
rewrite (wf_rsE WF).
rewrite (@wf_sbE G) at 1.
basic_solver 42.
Qed.

Lemma wf_swE_right WF : sw ≡ sw ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold sw.
rewrite wf_sbE at 1 2.
rewrite (wf_rfiE WF) at 1.
rewrite (wf_rfeE WF) at 1.
basic_solver 42.
Qed.

Lemma wf_swE WF : sw ≡ ⦗E⦘ ⨾ sw ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_swE_right WF) at 1.
hahn_frame.
unfold sw.
rewrite (wf_releaseE WF).
rewrite (dom_l (wf_rfiE WF)).
rewrite (dom_l (@wf_sbE G)).
rewrite (dom_l (wf_rfeE WF)).
basic_solver 40.
Qed.

Lemma wf_hbE WF : hb ≡ ⦗E⦘ ⨾ hb ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold hb.
rewrite <- inclusion_ct_seq_eqv_r, <- inclusion_ct_seq_eqv_l.
apply inclusion_t_t.
rewrite wf_sbE at 1.
rewrite (wf_swE WF) at 1.
basic_solver 42.
Qed.

(******************************************************************************)
(** ** Domains and codomains  *)
(******************************************************************************)

Lemma wf_rsD WF : rs ≡ ⦗W⦘ ⨾ rs ⨾ ⦗W⦘.
Proof using.
split; [|basic_solver].
unfold rs.
relsf; unionL; [basic_solver 12|].
rewrite rtE; relsf; unionL; [basic_solver|].
rewrite (dom_r (wf_rmwD WF)) at 1.
rewrite <- !seqA.
rewrite inclusion_ct_seq_eqv_r.
basic_solver 42.
Qed.

Lemma wf_releaseD WF : release ≡ ⦗FW∩₁Rel⦘ ⨾ release ⨾ ⦗W⦘.
Proof using.
split; [|basic_solver].
unfold release.
rewrite (wf_rsD WF) at 1.
basic_solver 42.
Qed.

Lemma wf_swD WF : sw ≡ ⦗FW∩₁Rel⦘ ⨾ sw ⨾ ⦗FR∩₁Acq⦘.
Proof using.
split; [|basic_solver].
unfold sw.
rewrite (wf_releaseD WF) at 1.
rewrite (wf_rfiD WF) at 1.
rewrite (wf_rfeD WF) at 1.
basic_solver 42.
Qed.

(******************************************************************************)
(** ** init *)
(******************************************************************************)

Lemma no_sw_to_init WF : sw ≡ sw ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_swD WF) at 1.
generalize (read_or_fence_is_not_init WF).
basic_solver 42.
Qed.

Lemma no_hb_to_init WF : hb ≡ hb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
split; [|basic_solver].
unfold hb.
rewrite ct_end.
rewrite (no_sw_to_init WF) at 2.
rewrite no_sb_to_init at 2.
basic_solver 42.
Qed.

(******************************************************************************)
(** more properties **   *)
(******************************************************************************)

Lemma sw_alt WF:
  sw ≡ release ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾  ⦗R ∩₁ Acq⦘
     ∪ release ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾  sb ⨾ ⦗F ∩₁ Acq⦘.
Proof using.
unfold sw.
rewrite (dom_r (wf_rfiD WF)).
rewrite (dom_r (wf_rfeD WF)).
basic_solver 42.
Qed.

Lemma rel_rf_in_sw WF: release ⨾ rf ⨾ ⦗Acq⦘ ⊆ sw.
Proof using.
rewrite (wf_rfD WF), rfi_union_rfe.
unfold sw; basic_solver 42.
Qed.

Lemma sw_in_rel_rf WF:
  sw ⨾ ⦗R⦘ ⊆ release ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾ ⦗Acq⦘.
Proof using.
unfold sw; rewrite !seqA.
arewrite ((sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq⦘ ⨾ ⦗R⦘ ⊆ ⦗Acq⦘) by type_solver 42.
Qed.

Lemma rs_in_co WF SC_PER_LOC : rs ⊆ ⦗W⦘ ⨾ co^?.
Proof using.
unfold rs.

assert (A: ⦗W⦘ ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⊆ ⦗W⦘ ⨾ co^?).
{ arewrite (⦗W⦘ ⊆ ⦗W⦘ ⨾ ⦗W⦘) at 1 by basic_solver.
  rewrite crE; relsf; unionL; [basic_solver|].
  sin_rewrite (w_sb_loc_w_in_coi WF SC_PER_LOC).
  sin_rewrite (dom_l (wf_coiD WF)).
  ie_unfolder; basic_solver. }

relsf; unionL.
arewrite (sb ∩ same_loc ⊆ (sb ∩ same_loc)^?).
by rewrite A.

rewrite rtE; relsf; unionL; [basic_solver|].
sin_rewrite !(rf_rmw_in_co WF SC_PER_LOC).
sin_rewrite (dom_r (wf_coD WF)).

arewrite (⦗W⦘ ⨾ ((sb ∩ same_loc)^? ⨾ co ⨾ ⦗W⦘)⁺ ⊆ (⦗W⦘ ⨾ (sb ∩ same_loc)^? ⨾ co)⁺).
rewrite <- seqA.
rewrite <- ct_seq_swap.
arewrite_id ⦗W⦘ at 2.
by rels.

sin_rewrite (dom_l (wf_coD WF)).
sin_rewrite A.
rewrite !seqA.
rewrite inclusion_ct_seq_eqv_l.
generalize (co_trans WF); ins; relsf.
Qed.

Lemma rs_in_eco WF SC_PER_LOC : rs ⊆ eco^?.
Proof using.
  rewrite rs_in_co, co_in_eco; try done; basic_solver.
Qed.

Lemma rs_sb_loc WF SC_PER_LOC : rs ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⊆ co^?.
Proof using.
  rewrite rs_in_co; auto. rewrite !seqA.
  apply co_sb_loc; auto.
Qed.

Lemma rs_rfi WF SC_PER_LOC :
  rs ⨾ rfi ⊆ sb ∩ same_loc ⨾ ⦗R⦘ ∪ co^? ⨾ rfe ⨾ ⦗R⦘ ⨾ sb.
Proof using.
  generalize (@sb_same_loc_trans G); ins.
  assert (SB: (sb ∩ same_loc)^? ⨾ rfi ⨾ rmw ⊆ sb ∩ same_loc).
  { rewrite (rfi_in_sbloc' WF).
    arewrite (rmw ⊆ rmw ∩ rmw).
    rewrite (rmw_in_sb WF) at 1; rewrite (wf_rmwl WF).
    relsf. }
  unfold rs.
  rewrite rtE; relsf; unionL.
  { rewrite (dom_r (wf_rfiD WF)), (rfi_in_sbloc' WF).
    generalize (@sb_same_loc_trans G). basic_solver 12. }
  { rewrite (dom_r (wf_rfiD WF)); rewrite (rfi_in_sbloc' WF). basic_solver 12. }
  rewrite rfi_union_rfe; relsf.
  rewrite path_ut_last; relsf; unionL.
  { rewrite (dom_r (wf_rfiD WF)) at 2; rewrite (rfi_in_sbloc' WF) at 2.
    sin_rewrite SB. rewrite !seqA. relsf. basic_solver. }
  arewrite (⦗W⦘ ⨾ ((sb ∩ same_loc)^? ⨾ rfi ⨾ rmw ∪ (sb ∩ same_loc)^? ⨾ rfe ⨾ rmw)＊ ⊆ rs).
  { unfold rs. rewrite rfi_union_rfe. relsf. }
  rewrite (dom_l (wf_rfeD WF)) at 1. rewrite !seqA.
  sin_rewrite (rs_sb_loc WF SC_PER_LOC).
  rewrite (dom_l (wf_rmwD WF)).
  arewrite (rfi ⊆ sb); rewrite (rmw_in_sb WF).
  arewrite ((sb ∩ same_loc)^? ⊆ sb^?).
  arewrite_id ⦗R⦘ at 2. rewrite seq_id_l.
  arewrite (sb ⨾ (sb^? ⨾ sb ⨾ sb)＊ ⨾ sb ⊆ sb).
  { generalize (@sb_trans G). ins. relsf. }
  eauto with hahn.
Qed.

Lemma release_in_co WF SC_PER_LOC : ⦗W⦘ ⨾ release ⊆ co^?.
Proof using.
unfold release; rewrite rs_in_co; try done.
type_solver.
Qed.

Lemma sw_in_eco_helper WF SC_PER_LOC  :
 rs ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⊆ eco.
Proof using.
rewrite (dom_l (wf_rsD WF)).
rewrite rs_in_co; try done.
arewrite (rfi ⊆ rf).
arewrite (rfe ⊆ rf).
relsf; unionL.
- rewrite co_in_eco, rf_in_eco; try done.
  generalize (eco_trans WF); type_solver 42.
- rewrite (dom_r (wf_coD WF)), (dom_l (wf_rfD WF)).
  arewrite (⦗W⦘ ⨾ (co ⨾ ⦗W⦘)^? ⊆ co^? ⨾ ⦗W⦘).
  basic_solver.
  arewrite !(⦗W⦘ ⨾ (sb ∩ same_loc)^? ⨾ ⦗W⦘ ⊆ co^?).
  rewrite crE; relsf; unionL; [basic_solver|].
  sin_rewrite (w_sb_loc_w_in_coi WF SC_PER_LOC).
  ie_unfolder; basic_solver.
  rewrite co_in_eco, rf_in_eco; try done.
  generalize (eco_trans WF); type_solver 42.
Qed.

Lemma sw_in_eco WF SC_PER_LOC : ⦗W⦘ ⨾ sw ⨾ ⦗R⦘ ⊆ eco.
Proof using.
unfold sw; rewrite !seqA.
unfold release; rewrite !seqA.
arewrite_id (⦗W⦘ ⨾ ⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^?).
by type_solver.
rels.
sin_rewrite (sw_in_eco_helper WF SC_PER_LOC).
generalize (eco_trans WF); type_solver 42.
Qed.

Lemma sw_in_eco_sb WF SC_PER_LOC : ⦗W⦘ ⨾ sw ⨾ ⦗F⦘ ⊆ eco ⨾ sb ⨾ ⦗F⦘.
Proof using.
unfold sw; rewrite !seqA.
unfold release; rewrite !seqA.
arewrite_id (⦗W⦘ ⨾ ⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^?).
by type_solver.
rels.
sin_rewrite (sw_in_eco_helper WF SC_PER_LOC).
rewrite (wf_ecoD WF) at 1.
generalize (eco_trans WF); type_solver 42.
Qed.

Lemma sw_in_sb_eco_sb WF SC_PER_LOC :
    sw ⊆ (⦗F ∩₁ Rel⦘ ⨾ sb)^? ⨾ eco ⨾ (sb ⨾ ⦗F ∩₁ Acq⦘)^?.
Proof using.
unfold sw.
unfold release; rewrite !seqA.
sin_rewrite sw_in_eco_helper; try done.
basic_solver 42.
Qed.

Lemma eco_sw_helper WF SC_PER_LOC
  x y z (ECO: eco x y) (SW: sw y z) (NECO: ~ eco y z) :
  exists k, eco x k /\ sb k z /\ ~ rmw k z.
Proof using.
assert (Wy: W y).
  apply (wf_ecoD WF) in ECO; try edone.
  apply (wf_swD WF) in SW; try edone.
  by unfolder in *; type_solver.
assert (SW1 := SW).
apply (wf_swD WF) in SW1; try edone.
unfolder in SW1; desc.
destruct SW2.
- exploit sw_in_eco_sb; eauto.
  unfolder; splits; eauto.
  by desf.
  unfold eqv_rel, seq; ins; desc.
  exists z0; splits; eauto using (eco_trans WF); subst.
  done.
  intro A; eapply (wf_rmwD WF) in A; unfolder in *; type_solver.
- exfalso; apply NECO.
  apply sw_in_eco; try done.
  unfolder; ins; desf.
Qed.

Lemma eco_sw WF SC_PER_LOC :
eco ⨾ (sw \ eco) ⊆ eco ⨾ (sb \ rmw).
Proof using.
unfold seq, minus_rel, inclusion; ins; desc.
eapply eco_sw_helper; eauto.
Qed.

Lemma eco_sw_1 WF SC_PER_LOC :
eco ⨾ sw ⊆ eco ∪ eco ⨾ (sb \ rmw).
Proof using.
unfolder; ins; desf.
destruct (classic (eco z y)).
by generalize (eco_trans WF); basic_solver.
right; eapply eco_sw_helper; eauto.
Qed.

Lemma eco_seq_hb WF SC_PER_LOC COMP :
  eco ⨾ hb ⊆ eco ∪ eco ⨾ (sb \ rmw) ⨾ hb^?.
Proof using.
unfold hb; rewrite seq_ct_absorb_lt, cr_of_ct; eauto using eco_trans.
rewrite minus_union_l.
relsf; unionL; eauto with hahn.
rewrite rmw_in_fr, fr_in_eco; auto with hahn.
sin_rewrite eco_sw; auto.
rewrite !seqA; auto with hahn.
Qed.

Lemma release_in_hb_co WF SC_PER_LOC: release ⊆ (hb^? ⨾ co^?).
Proof using.
unfold release; rewrite rs_in_co; try done.
rewrite sb_in_hb; basic_solver 10.
Qed.

Lemma hb_alt WF:
  hb ⊆ ⦗W⦘ ⨾ sw ∪ (⦗W⦘ ⨾ sw)^? ⨾ ((sb \ rmw) ∪ rmw ∪ ⦗F⦘ ⨾ sw ∪ (sb \ rmw) ⨾ sw ∪ rmw ⨾ sw)⁺.
Proof using.
unfold hb.
rewrite (dom_l (wf_swD WF)) at 1.
arewrite (⦗FW ∩₁ Rel⦘ ⊆ ⦗F⦘ ∪ ⦗W⦘) by type_solver 12.
relsf; rewrite <- !unionA.
arewrite (sb ⊆ (sb \ rmw) ∪ rmw) at 1 by unfolder; ins; tauto.
rewrite path_union1.
assert (TRANS: transitive (⦗W⦘ ⨾ sw)).
by apply transitiveI; rewrite (dom_r (wf_swD WF)) at 1; type_solver.
relsf.
unionL; [by vauto|].
rewrite !seqA.
arewrite_false (sw ⨾ ⦗W⦘).
by rewrite (dom_r (wf_swD WF)) at 1; type_solver.
unionR right.
hahn_frame.
apply inclusion_t_t.
basic_solver 42.
Qed.

Lemma rs_rf_rmw WF:
  rs ⨾ (rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾ rmw ⊆ rs.
Proof using.
unfold rs; rewrite !seqA.
arewrite ((rfi ∪ (sb ∩ same_loc)^? ⨾ rfe) ⨾ rmw ⊆ (sb ∩ same_loc)^? ⨾ rf ⨾ rmw).
rewrite rfi_union_rfe; basic_solver 12.
relsf; unionL.
rewrite !seqA.
arewrite ( sb ∩ same_loc ⨾ ⦗W⦘ ⨾ (sb ∩ same_loc)^? ⊆ sb ∩ same_loc).
by arewrite_id ⦗W⦘; generalize (@sb_same_loc_trans G); ins; relsf.
rewrite (dom_l (wf_rfD WF)).
rewrite rtE.
rewrite <- ct_step.
basic_solver 21.
unionR right.
hahn_frame.
rewrite <- ct_end.
basic_solver.
Qed.

Lemma sw_rmw_sw WF: sw ⨾ rmw ⨾ sw ⊆ sw ⨾ sb^?.
Proof using.
unfold sw at 2.
unfold release; rewrite !seqA.
arewrite (rmw ⨾ ⦗Rel⦘ ⨾ (⦗F⦘ ⨾ sb)^? ⊆ rmw).
by rewrite (dom_r (wf_rmwD WF)); type_solver.
unfold rs.
relsf.
rewrite !unionA.
apply inclusion_union_l.
- arewrite (rfi ⊆ sb).
  rewrite (rmw_in_sb WF).
  generalize (@sb_trans G); basic_solver 21.
- unfold sw, release.
  rewrite !seqA.
  arewrite !((sb ⨾ ⦗F⦘)^? ⨾ ⦗Acq⦘ ⨾ rmw ⊆ rmw).
  by rewrite (dom_l (wf_rmwD WF)); type_solver.
  sin_rewrite !(rs_rf_rmw WF).
  arewrite !((⦗W⦘ ⨾ (sb ∩ same_loc ⨾ ⦗W⦘ ∪ ((sb ∩ same_loc)^? ⨾ rf ⨾ rmw)＊))
    ⨾ ⦗W⦘ ⨾ ((sb ∩ same_loc)^? ⨾ rf ⨾ rmw)＊ ⊆⦗W⦘ ⨾ (sb ∩ same_loc ⨾ ⦗W⦘ ∪ ((sb ∩ same_loc)^? ⨾ rf ⨾ rmw)＊)).
  relsf; unionL; [|by arewrite_id ⦗W⦘ at 2; relsf].
  rewrite rtE at 1; relsf; unionL; [basic_solver 12|unionR right].
  rewrite ct_begin, !seqA; rels.
  arewrite (sb ∩ same_loc ⨾ ⦗W⦘ ⨾ (sb ∩ same_loc)^? ⊆ (sb ∩ same_loc)^?).
  generalize (@sb_same_loc_trans G); basic_solver 21.
  hahn_frame_l; rewrite <- !seqA; rewrite <- ct_begin; rels.
  unionL.
  * generalize (@sb_same_loc_trans G).
    basic_solver 42.
  * unfold rs.
    hahn_frame.
    basic_solver 21.
  * unfold rs.
    hahn_frame.
    basic_solver 21.
Qed.

(******************************************************************************)
(** IMM-coherence and its consequences **   *)
(******************************************************************************)

Definition coherence := irreflexive (hb ⨾ eco).
Implicit Type COH : coherence.

Lemma coherence_sc_per_loc COH : sc_per_loc G.
Proof using.
red; rewrite sb_in_hb.
red in COH; unfolder in *; basic_solver 12.
Qed.

Definition coherent_expanded :=
  ⟪ Crf   : irreflexive (rf ⨾ hb) ⟫ /\
  ⟪ Crw   : irreflexive (co ⨾ rf ⨾ hb) ⟫ /\
  ⟪ Cww   : irreflexive (co ⨾ hb) ⟫ /\
  ⟪ Cwr   : irreflexive (co ⨾ hb ⨾ rf⁻¹) ⟫ /\
  ⟪ Crr   : irreflexive (co ⨾ rf ⨾ hb ⨾ rf⁻¹) ⟫.

Lemma hb_eco_r_alt :
  hb ⨾ eco ≡
    hb ⨾ rf ∪ hb ⨾ co ∪ hb ⨾ co ⨾ rf ∪ hb ⨾ fr ∪ hb ⨾ fr ⨾ rf.
Proof using. unfold Execution_eco.eco, Execution.fr; basic_solver 42. Qed.

Proposition coherence_expanded_eq :
  coherence <-> coherent_expanded.
Proof using.
  unfold coherence; rewrite hb_eco_r_alt; unfold Execution.fr.
  unfold coherent_expanded; unnw.
  split; ins.
  - rewrite !seqA in *.
    repeat (apply irreflexive_union in H; desf); splits.
    all: try by rotate 1.
    all: try by rotate 2.
  - desf.
    relsf; repeat (splits; try apply irreflexive_union).
    all: try by rotate 1.
    all: try by rotate 2.
Qed.

Proposition coherence_alt :
  irreflexive (hb ∪ hb ⨾ rfe ∪ hb ⨾ co ⨾ rfe^? ∪ hb ⨾ fr ⨾ rfe^?) -> coherence.
Proof using.
  unfold coherence; unfold Execution_eco.eco; relsf.
rewrite rfi_union_rfe; relsf.
arewrite (rfi ⊆ sb); rewrite sb_in_hb; rewrite !crE; relsf.
ins; unionL.
all: try rotate 1.
all: generalize hb_trans; ins; relsf.
all: try (unfolder in *; basic_solver 12).
Qed.

Lemma hb_eco_irr COH : irreflexive (hb ⨾ eco).
Proof using.
apply COH.
Qed.

Lemma hb_irr WF COH : irreflexive hb.
Proof using.
unfold hb.
rewrite path_ut_first.
relsf; repeat (splits; try apply irreflexive_union).
by rewrite (ct_of_trans (@sb_trans G)); apply sb_irr.
rewrite (sw_in_sb_eco_sb WF (coherence_sc_per_loc COH)) at 1.
rotate 2.
arewrite ((sb ⨾ ⦗F ∩₁ Acq⦘)^? ⊆ (sb ∪ sw)＊).
arewrite (sb＊ ⊆ (sb ∪ sw)＊).
arewrite ((⦗F ∩₁ Rel⦘ ⨾ sb)^? ⊆ (sb ∪ sw)＊).
relsf.
generalize (eco_irr WF).
red in COH; revert COH.
basic_solver.
Qed.

Lemma hb_acyc WF COH : acyclic hb.
Proof using.
  eapply trans_irr_acyclic.
  2: by apply hb_trans.
  apply hb_irr; auto.
Qed.

Lemma w_hb_loc_w_in_co WF COH :
  ⦗W⦘ ⨾ hb ∩ same_loc ⨾ ⦗W⦘ ⊆ co.
Proof using.
apply (w_r_loc_w_in_co WF (wf_hbE WF) (hb_irr WF COH) (hb_eco_irr COH)).
Qed.

Lemma w_hb_loc_r_in_co_rf WF COH COMP:
  ⦗W⦘ ⨾ hb ∩ same_loc ⨾ ⦗R⦘ ⊆ co^? ⨾ rf.
Proof using.
apply (w_r_loc_r_in_co_rf WF (wf_hbE WF) (hb_eco_irr COH) COMP).
Qed.

Lemma r_hb_loc_w_in_fr WF COH COMP:
  ⦗R⦘ ⨾ hb ∩ same_loc ⨾ ⦗W⦘ ⊆ fr.
Proof using.
apply (r_r_loc_w_in_fr WF (wf_hbE WF) (hb_eco_irr COH) COMP).
Qed.

Lemma r_hb_loc_r_in_fr_rf WF COH COMP:
  ⦗R⦘ ⨾ hb ∩ same_loc ⨾ ⦗R⦘ ⊆ fr ⨾ rf ∪ rf^{-1} ⨾ rf.
Proof using.
apply (r_r_loc_r_in_fr_rf WF (wf_hbE WF) (hb_eco_irr COH) COMP).
Qed.

Lemma hb_loc_in_eco WF COH COMP:
  ⦗RW⦘ ⨾ hb ∩ same_loc ⨾ ⦗RW⦘ ⊆ eco ∪ (sb \ rmw) ∪ (sb \ rmw) ⨾ hb ⨾ (sb \ rmw).
Proof using.
unfold restr_eq_rel, Events.same_loc.

unfolder; ins; desc.
rename H0 into HB, H2 into SAME_LOC, H into RWx, H1 into RWy.
hahn_rewrite (wf_hbE WF) in HB; unfolder in *; desc.
forward (apply eco_almost_total with (x:=x) (y:=y)); eauto.
  by intro; subst; eapply hb_irr; edone.

desf.
- ins; desf; [basic_solver | |].
  by exfalso; eapply COH; basic_solver.
  apply ct_begin in HB0.
  unfold seq in HB0; desc.
  destruct HB0 as [HB0|X]; cycle 1.
by hahn_rewrite (wf_swD WF) in X; hahn_rewrite (wf_rfD WF) in H;
 exfalso; type_unfolder; unfolder in *; desf.
  apply rtE in HB2.
  unfold eqv_rel, union in HB2; desf.
  -- destruct (classic (rmw x y)).
    by left; left; apply fr_in_eco, rmw_in_fr; auto using coherence_sc_per_loc.
    by left; right; splits; eauto.
  -- apply ct_end in HB2.
    unfold seq in HB2; desc.
    destruct HB3 as [HB3|X]; cycle 1.
    * exfalso.
      apply sw_in_sb_eco_sb in X; auto using coherence_sc_per_loc.
      unfold seq, eqv_rel, clos_refl in X; desf.
      + apply COH with (x:=x).
        exists z2; splits.

        apply ct_begin; basic_solver.
        apply eco_transp_rf_rf_in_eco; auto; basic_solver 8.
      + apply COH with (x:=x).
        exists z2; splits.
        apply ct_begin; eexists; splits; try apply rt_end; basic_solver 6.
        by apply eco_transp_rf_rf_in_eco; auto; basic_solver 8.
      + type_solver.
      + type_solver.
    * assert (~rmw x z0).
      { intro RMW_x_z0.
        apply COH with (x:=z0).
        exists y; splits.
        apply ct_end; basic_solver 6.
        apply rmw_in_fr, fr_in_eco in RMW_x_z0; auto using coherence_sc_per_loc.
        apply transp_rf_rf_eco_in_eco; auto; basic_solver 8.
      }
      assert (~rmw z1 y).
      { intro RMW_z1_y.
        apply COH with (x:=x).
        exists z1; splits.
        apply ct_begin; basic_solver 6.
        apply rmw_in_fr, fr_in_eco in RMW_z1_y; auto using coherence_sc_per_loc.
        apply eco_transp_rf_rf_in_eco; auto; basic_solver 8.
      }
      apply rtE in HB2; unfold union, eqv_rel in HB2; desf.
      + left; right; splits.
        eby eapply sb_trans.
        intro RMW_x_y.
by hahn_rewrite (wf_rmwD WF) in RMW_x_y; hahn_rewrite (wf_rfD WF) in H0;
 unfolder in *; type_solver.
      + basic_solver 8.

- ins; desf; [basic_solver | |].
  by exfalso; eapply COH; basic_solver.
 hahn_rewrite (wf_rfD WF) in H;
 exfalso; type_unfolder; unfolder in *; desf.
- ins; desf; [basic_solver | |].
  by exfalso; eapply COH; basic_solver.
 hahn_rewrite (wf_rfD WF) in H0;
 exfalso; type_unfolder; unfolder in *; desf.
- ins; desf; [basic_solver | |].
  by exfalso; eapply COH; basic_solver.
 hahn_rewrite (wf_rfD WF) in H;
 exfalso; type_unfolder; unfolder in *; desf.
Qed.

Lemma hb_in_sb_swe : hb ⊆ (sb ∪ (sw \ sb))⁺.
Proof using.
  unfold hb.
  rewrite (ri_union_re G sw) at 1.
  apply inclusion_t_t.
  basic_solver.
Qed.

Lemma sprop_irr WF COH : irreflexive sprop.
Proof using.
  unfold sprop.
  rewrite sb_in_hb.
  arewrite ((hb ⨾ ⦗F⦘)^? ⨾ ⦗Acq ∪₁ W⦘ ⨾ hb ⨾ ⦗Rel⦘ ⊆ hb^? ⨾ hb).
  { basic_solver. }
  rewrite cr_hb_hb.
  arewrite_id ⦗W⦘. rewrite seq_id_l.
  apply irreflexive_seqC.
  rewrite crE, seq_union_r, seq_id_r.
  apply irreflexive_union. split.
  { by apply hb_irr. }
  arewrite (rfe ⊆ rf). rewrite rf_in_eco.
  apply COH.
Qed.

End IMM_hb.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ B Eprime /\ (wd_ B C /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime O /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime))))))))))))))))) -> col_ C B O)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O X A B C M1 M2 P1 P2 : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ M2 A /\ (wd_ M2 C /\ (wd_ M1 A /\ (wd_ M1 B /\ (wd_ P2 M2 /\ (wd_ P1 M1 /\ (wd_ A P2 /\ (wd_ C P2 /\ (wd_ A P1 /\ (wd_ B P1 /\ (wd_ M1 M2 /\ (col_ M1 P1 X /\ (col_ M1 P1 O /\ (col_ M2 P2 X /\ (col_ M2 P2 O /\ (col_ M1 P1 M2 /\ (col_ M2 P2 M1 /\ (col_ M2 A C /\ col_ M1 A B))))))))))))))))))))) -> col_ P2 M2 P1)).
Proof.
  time tac.
Qed.

End FOFProblem.