(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2013-2018 Sylvie Boldo
#<br />#
Copyright (C) 2013-2018 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.
*)

(** * Rounding to odd and its properties, including the equivalence
      between rnd_NE and double rounding with rnd_odd and then rnd_NE *)

Require Import Reals Psatz.
Require Import Core Operations.

Definition Zrnd_odd x :=  match Req_EM_T x (IZR (Zfloor x))  with
  | left _   => Zfloor x
  | right _  => match (Z.even (Zfloor x)) with
      | true => Zceil x
      | false => Zfloor x
     end
  end.

Global Instance valid_rnd_odd : Valid_rnd Zrnd_odd.
Proof.
split.
(* . *)
intros x y Hxy.
assert (Zfloor x <= Zrnd_odd y)%Z.
(* .. *)
apply Z.le_trans with (Zfloor y).
now apply Zfloor_le.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))).
now apply Z.le_refl.
case (Z.even (Zfloor y)).
apply le_IZR.
apply Rle_trans with y.
apply Zfloor_lb.
apply Zceil_ub.
now apply Z.le_refl.
unfold Zrnd_odd at 1.
(* . *)
destruct (Req_EM_T  x (IZR (Zfloor x))) as [Hx|Hx].
(* .. *)
apply H.
(* .. *)
case_eq (Z.even (Zfloor x)); intros Hx2.
2: apply H.
unfold Zrnd_odd; destruct (Req_EM_T  y (IZR (Zfloor y))) as [Hy|Hy].
apply Zceil_glb.
now rewrite <- Hy.
case_eq (Z.even (Zfloor y)); intros Hy2.
now apply Zceil_le.
apply Zceil_glb.
assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le.
case (Zle_lt_or_eq _ _  H0); intros H1.
apply Rle_trans with (1:=Zceil_ub _).
rewrite Zceil_floor_neq.
apply IZR_le; lia.
now apply sym_not_eq.
contradict Hy2.
rewrite <- H1, Hx2; discriminate.
(* . *)
intros n; unfold Zrnd_odd.
rewrite Zfloor_IZR, Zceil_IZR.
destruct (Req_EM_T  (IZR n) (IZR n)); trivial.
case (Z.even n); trivial.
Qed.

Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) ->
  (Z.even (Zrnd_odd x)) = false.
Proof.
intros x Hx; unfold Zrnd_odd.
destruct (Req_EM_T  x (IZR (Zfloor x))) as [H|H].
now contradict H.
case_eq (Z.even (Zfloor x)).
(* difficult case *)
intros H'.
rewrite Zceil_floor_neq.
rewrite Z.even_add, H'.
reflexivity.
now apply sym_not_eq.
trivial.
Qed.

Lemma Zfloor_plus: forall (n:Z) y,
  (Zfloor (IZR n+y) = n + Zfloor y)%Z.
Proof.
intros n y; unfold Zfloor.
unfold Zminus; rewrite Zplus_assoc; f_equal.
apply sym_eq, tech_up.
rewrite plus_IZR.
apply Rplus_lt_compat_l.
apply archimed.
rewrite plus_IZR, Rplus_assoc.
apply Rplus_le_compat_l.
apply Rplus_le_reg_r with (-y)%R.
ring_simplify (y+1+-y)%R.
apply archimed.
Qed.

Lemma Zceil_plus: forall (n:Z) y,
  (Zceil (IZR n+y) = n + Zceil y)%Z.
Proof.
intros n y; unfold Zceil.
rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR.
rewrite Zfloor_plus.
ring.
Qed.

Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z.
Proof.
intros z; case (Zle_or_lt z 0); intros H1.
rewrite Z.abs_neq; try assumption.
apply Z.even_opp.
rewrite Z.abs_eq; auto with zarith.
Qed.

Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) ->
    Z.even (Zfloor x) = true ->
   (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof.
intros x y Hx H.
unfold Zrnd_odd; rewrite Hx, Zfloor_plus.
case (Req_EM_T y (IZR (Zfloor y))); intros Hy.
rewrite Hy; repeat rewrite <- plus_IZR.
repeat rewrite Zfloor_IZR.
case (Req_EM_T _ _); intros K; easy.
case (Req_EM_T _ _); intros K.
contradict Hy.
apply Rplus_eq_reg_l with (IZR (Zfloor x)).
now rewrite K, plus_IZR.
rewrite Z.even_add, H; simpl.
case (Z.even (Zfloor y)).
now rewrite Zceil_plus, plus_IZR.
now rewrite plus_IZR.
Qed.

Section Fcore_rnd_odd.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).
Notation cexp := (cexp beta fexp).

Definition Rnd_odd_pt (x f : R) :=
  format f /\ ((f = x)%R \/
    ((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\
    exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)).

Definition Rnd_odd (rnd : R -> R) :=
  forall x : R, Rnd_odd_pt x (rnd x).

Theorem Rnd_odd_pt_opp_inv :   forall x f : R,
  Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f.
Proof with auto with typeclass_instances.
intros x f (H1,H2).
split.
replace f with (-(-f))%R by ring.
now apply generic_format_opp.
destruct H2.
left.
replace f with (-(-f))%R by ring.
rewrite H; ring.
right.
destruct H as (H2,(g,(Hg1,(Hg2,Hg3)))).
split.
destruct H2.
right.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_UP_pt_opp...
apply generic_format_opp.
left.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_DN_pt_opp...
apply generic_format_opp.
exists (Float beta (-Fnum g) (Fexp g)).
split.
rewrite F2R_Zopp.
replace f with (-(-f))%R by ring.
rewrite Hg1; reflexivity.
split.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
Qed.

Theorem round_odd_opp :
  forall x,
  round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R.
Proof.
intros x; unfold round.
rewrite <- F2R_Zopp.
unfold F2R; simpl.
apply f_equal2; apply f_equal.
rewrite scaled_mantissa_opp.
generalize (scaled_mantissa beta fexp x); intros r.
unfold Zrnd_odd.
case (Req_EM_T (- r) (IZR (Zfloor (- r)))).
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
apply eq_IZR.
now rewrite opp_IZR, <- Y1, <-Y2.
intros Y1 Y2.
absurd (r=IZR (Zfloor r)); trivial.
pattern r at 2; replace r with (-(-r))%R by ring.
rewrite Y2, <- opp_IZR.
rewrite Zfloor_IZR.
rewrite opp_IZR, <- Y2.
ring.
case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
absurd (-r=IZR (Zfloor (-r)))%R; trivial.
pattern r at 2; rewrite Y1.
rewrite <- opp_IZR, Zfloor_IZR.
now rewrite opp_IZR, <- Y1.
intros Y1 Y2.
unfold Zceil; rewrite Ropp_involutive.
replace  (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))).
case (Z.even (Zfloor r));  simpl; ring.
apply trans_eq with (Z.even (Zceil r)).
rewrite Zceil_floor_neq.
rewrite Z.even_add.
destruct (Z.even (Zfloor r)); reflexivity.
now apply sym_not_eq.
rewrite <- (Z.even_opp (Zfloor (- r))).
reflexivity.
apply cexp_opp.
Qed.

Theorem round_odd_pt :
  forall x,
  Rnd_odd_pt x (round beta fexp Zrnd_odd x).
Proof with auto with typeclass_instances.
cut (forall x : R, (0 < x)%R -> Rnd_odd_pt x (round beta fexp Zrnd_odd x)).
intros H x; case (Rle_or_lt 0 x).
intros H1; destruct H1.
now apply H.
rewrite <- H0.
rewrite round_0...
split.
apply generic_format_0.
now left.
intros Hx; apply Rnd_odd_pt_opp_inv.
rewrite <- round_odd_opp.
apply H.
auto with real.
(* *)
intros x Hxp.
generalize (generic_format_round beta fexp Zrnd_odd x).
set (o:=round beta fexp Zrnd_odd x).
intros Ho.
split.
assumption.
(* *)
case (Req_dec o x); intros Hx.
now left.
right.
assert (o=round beta fexp Zfloor x \/ o=round beta fexp Zceil x).
unfold o, round, F2R;simpl.
case (Zrnd_DN_or_UP Zrnd_odd  (scaled_mantissa beta fexp x))...
intros H; rewrite H; now left.
intros H; rewrite H; now right.
split.
destruct H; rewrite H.
left; apply round_DN_pt...
right; apply round_UP_pt...
(* *)
unfold o, Zrnd_odd, round.
case (Req_EM_T (scaled_mantissa beta fexp x)
     (IZR (Zfloor (scaled_mantissa beta fexp x)))).
intros T.
absurd (o=x); trivial.
apply round_generic...
unfold generic_format, F2R; simpl.
rewrite <- (scaled_mantissa_mult_bpow beta fexp) at 1.
apply f_equal2; trivial; rewrite T at 1.
apply f_equal, sym_eq, Ztrunc_floor.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
intros L.
case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))).
(* . *)
generalize (generic_format_round beta fexp Zceil x).
unfold generic_format.
set (f:=round beta fexp Zceil x).
set (ef := cexp f).
set (mf := Ztrunc (scaled_mantissa beta fexp f)).
exists (Float beta mf ef).
unfold canonical.
rewrite <- H0.
repeat split; try assumption.
apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))).
2: rewrite H1; reflexivity.
apply trans_eq with (negb (Z.even (Fnum
  (Float beta  (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))).
2: reflexivity.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Y.
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
unfold canonical.
simpl.
apply sym_eq, cexp_DN...
unfold canonical.
rewrite <- H0; reflexivity.
reflexivity.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
intros Y.
replace  (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |})
   with (Fnum (Float beta 0 (fexp (mag beta 0)))).
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
unfold generic_format.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1.
unfold F2R; simpl.
apply Rmult_neq_compat_r.
apply Rgt_not_eq, bpow_gt_0.
rewrite Ztrunc_floor.
assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
apply canonical_0.
unfold canonical.
rewrite <- H0; reflexivity.
rewrite <- Y; unfold F2R; simpl; ring.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
simpl.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Y; simpl in Y; rewrite <- Y.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
(* . *)
intros Y.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Hrx.
set (ef := cexp x).
set (mf := Zfloor (scaled_mantissa beta fexp x)).
exists (Float beta mf ef).
unfold canonical.
repeat split; try assumption.
simpl.
apply trans_eq with (cexp (round beta fexp Zfloor x )).
apply sym_eq, cexp_DN...
reflexivity.
intros Hrx; contradict Y.
replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z.
simpl; discriminate.
apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.

Theorem Rnd_odd_pt_unique :
  forall x f1 f2 : R,
  Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 ->
  f1 = f2.
Proof.
intros x f1 f2 (Ff1,H1) (Ff2,H2).
(* *)
case (generic_format_EM beta fexp x); intros L.
apply trans_eq with x.
case H1; try easy.
intros (J,_); case J; intros J'.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.
case H2; try easy.
intros (J,_); case J; intros J'; apply sym_eq.
apply Rnd_DN_pt_idempotent with format; assumption.
apply Rnd_UP_pt_idempotent with format; assumption.
(* *)
destruct H1 as [H1|(H1,H1')].
contradict L; now rewrite <- H1.
destruct H2 as [H2|(H2,H2')].
contradict L; now rewrite <- H2.
destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
apply Rnd_DN_pt_unique with format x; assumption.
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- L3.
apply trans_eq with (negb (Z.even (Fnum ff))).
rewrite K3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
(* *)
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- K3.
apply trans_eq with (negb (Z.even (Fnum gg))).
rewrite L3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
apply Rnd_UP_pt_unique with format x; assumption.
Qed.

Theorem Rnd_odd_pt_monotone :
  round_pred_monotone (Rnd_odd_pt).
Proof with auto with typeclass_instances.
intros x y f g H1 H2 Hxy.
apply Rle_trans with (round beta fexp Zrnd_odd x).
right; apply Rnd_odd_pt_unique with x; try assumption.
apply round_odd_pt.
apply Rle_trans with (round beta fexp Zrnd_odd y).
apply round_le...
right; apply Rnd_odd_pt_unique with y; try assumption.
apply round_odd_pt.
Qed.

End Fcore_rnd_odd.

Section Odd_prop_aux.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *)
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd *)

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Lemma generic_format_fexpe_fexp: forall x,
 generic_format beta fexp x ->  generic_format beta fexpe x.
Proof.
intros x Hx.
apply generic_inclusion_mag with fexp; trivial; intros Hx2.
generalize (fexpe_fexp (mag beta x)).
lia.
Qed.

Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R),
      (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) ->
      exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true.
Proof with auto with typeclass_instances.
intros c x (g,(Hg1,Hg2)).
exists (Float beta
     (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
     (c (mag beta x))).
assert (F2R (Float beta
     (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
     (c (mag beta x))) = x).
unfold F2R; simpl.
rewrite mult_IZR, IZR_Zpower.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Hg1; unfold F2R.
apply f_equal, f_equal.
ring.
lia.
split; trivial.
split.
unfold canonical, cexp.
now rewrite H.
simpl.
rewrite Z.even_mul.
rewrite Z.even_pow.
rewrite Even_beta.
apply Bool.orb_true_intro.
now right.
lia.
Qed.

Variable choice:Z->bool.
Variable x:R.

Variable d u: float beta.
Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d).
Hypothesis Cd: canonical beta fexp d.
Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u).
Hypothesis Cu: canonical beta fexp u.

Hypothesis xPos: (0 < x)%R.

Let m:= ((F2R d+F2R u)/2)%R.

Lemma d_eq: F2R d= round beta fexp Zfloor x.
Proof with auto with typeclass_instances.
apply Rnd_DN_pt_unique with (generic_format beta fexp) x...
apply round_DN_pt...
Qed.

Lemma u_eq: F2R u= round beta fexp Zceil x.
Proof with auto with typeclass_instances.
apply Rnd_UP_pt_unique with (generic_format beta fexp) x...
apply round_UP_pt...
Qed.

Lemma d_ge_0: (0 <= F2R d)%R.
Proof with auto with typeclass_instances.
rewrite d_eq; apply round_ge_generic...
apply generic_format_0.
now left.
Qed.

Lemma mag_d:  (0< F2R d)%R ->
    (mag beta (F2R d) = mag beta x :>Z).
Proof with auto with typeclass_instances.
intros Y.
rewrite d_eq; apply mag_DN...
now rewrite <- d_eq.
Qed.

Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x).
Proof with auto with typeclass_instances.
intros Y.
now rewrite Cd, <- mag_d.
Qed.

Lemma format_bpow_x: (0 < F2R d)%R
    -> generic_format beta fexp  (bpow (mag beta x)).
Proof with auto with typeclass_instances.
intros Y.
apply generic_format_bpow.
apply valid_exp.
rewrite <- Fexp_d; trivial.
apply Z.lt_le_trans with  (mag beta (F2R d))%Z.
rewrite Cd; apply mag_generic_gt...
now apply Rgt_not_eq.
apply Hd.
apply mag_le; trivial.
apply Hd.
Qed.

Lemma format_bpow_d: (0 < F2R d)%R ->
  generic_format beta fexp (bpow (mag beta (F2R d))).
Proof with auto with typeclass_instances.
intros Y; apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
Qed.

Lemma d_le_m: (F2R d <= m)%R.
Proof.
assert (F2R d <= F2R u)%R.
  apply Rle_trans with x.
  apply Hd.
  apply Hu.
unfold m.
lra.
Qed.

Lemma m_le_u: (m <= F2R u)%R.
Proof.
assert (F2R d <= F2R u)%R.
  apply Rle_trans with x.
  apply Hd.
  apply Hu.
unfold m.
lra.
Qed.

Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z).
Proof with auto with typeclass_instances.
intros dPos; apply mag_unique_pos.
split.
apply Rle_trans with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl.
rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply d_le_m.
case m_le_u; intros H.
apply Rlt_le_trans with (1:=H).
rewrite u_eq.
apply round_le_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z.
absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R.
apply Rlt_not_le.
destruct  (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
apply Rle_trans with (round beta fexp Zfloor x).
2: right; apply sym_eq, d_eq.
apply round_ge_generic...
apply generic_format_bpow.
apply valid_exp.
apply mag_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonical.
now left.
replace m with (F2R d).
destruct (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
apply Rle_ge; now left.
unfold m in H |- *.
lra.
Qed.

Lemma mag_m_0: (0 = F2R d)%R
    -> (mag beta m =mag beta (F2R u)-1:>Z)%Z.
Proof with auto with typeclass_instances.
intros Y.
apply mag_unique_pos.
unfold m; rewrite <- Y, Rplus_0_l.
rewrite u_eq.
destruct (mag beta x) as (e,He).
rewrite Rabs_pos_eq in He by now apply Rlt_le.
rewrite round_UP_small_pos with (ex:=e).
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
split.
unfold Zminus; rewrite bpow_plus.
unfold Rdiv; apply Rmult_le_compat_l.
apply bpow_ge_0.
simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le.
exact Rlt_0_2.
apply IZR_le.
specialize (radix_gt_1 beta).
lia.
apply Rlt_le_trans with (bpow (fexp e)*1)%R.
2: right; ring.
unfold Rdiv; apply Rmult_lt_compat_l.
apply bpow_gt_0.
lra.
now apply He, Rgt_not_eq.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
Qed.

Lemma u'_eq:  (0 < F2R d)%R -> exists f:float beta, F2R f = F2R u /\ (Fexp f = Fexp d)%Z.
Proof with auto with typeclass_instances.
intros Y.
rewrite u_eq; unfold round.
eexists; repeat split.
simpl; now rewrite Fexp_d.
Qed.

Lemma m_eq :
  (0 < F2R d)%R ->
  exists f:float beta,
  F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
destruct u'_eq as (u', (Hu'1,Hu'2)); trivial.
exists (Fmult (Float beta b (-1)) (Fplus d u'))%R.
split.
rewrite F2R_mult, F2R_plus, Hu'1.
unfold m; rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp (Fplus d u'))%Z.
unfold Fmult.
destruct  (Fplus d u'); reflexivity.
rewrite Zplus_comm; unfold Zminus; apply f_equal2.
2: reflexivity.
rewrite Fexp_Fplus.
rewrite Z.min_l.
now rewrite Fexp_d.
rewrite Hu'2; lia.
Qed.

Lemma m_eq_0: (0 = F2R d)%R ->  exists f:float beta,
   F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
exists (Fmult (Float beta b (-1)) u)%R.
split.
rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l.
rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp u)%Z.
unfold Fmult.
destruct u; reflexivity.
rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2.
Qed.

Lemma fexp_m_eq_0:  (0 = F2R d)%R ->
  (fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z.
Proof with auto with typeclass_instances.
intros Y.
assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z.
2: lia.
destruct (mag beta x) as (e,He).
rewrite Rabs_right in He.
2: now left.
assert (e <= fexp e)%Z.
apply exp_small_round_0_pos with beta (Zfloor) x...
now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
rewrite u_eq, round_UP_small_pos with (ex:=e); trivial.
2: now apply He, Rgt_not_eq.
rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
replace (fexp (fexp e)) with (fexp e).
case exists_NE_; intros V.
contradict V; rewrite Even_beta; discriminate.
rewrite (proj2 (V e)); lia.
apply sym_eq, valid_exp; lia.
Qed.

Lemma Fm:  generic_format beta fexpe m.
Proof.
case (d_ge_0); intros Y.
(* *)
destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
now apply sym_eq.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp (mag beta (F2R d))).
lia.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
assumption.
intros H; unfold cexp; rewrite Hg2.
rewrite mag_m_0; try assumption.
apply Z.le_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
lia.
Qed.

Lemma Zm:
   exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true.
Proof with auto with typeclass_instances.
case (d_ge_0); intros Y.
(* *)
destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold cexp.
generalize (fexpe_fexp  (mag beta (F2R d))).
lia.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite mag_m_0; trivial.
apply Z.le_lt_trans with (1:=fexpe_fexp _).
generalize (fexp_m_eq_0 Y).
lia.
Qed.

Lemma DN_odd_d_aux :
  forall z, (F2R d <= z < F2R u)%R ->
  Rnd_DN_pt (generic_format beta fexp) z (F2R d).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R d) with (round beta fexp Zfloor z).
apply round_DN_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zfloor z)).
apply generic_format_round...
intros Y; apply Rle_antisym; trivial.
apply round_DN_pt...
apply Hd.
apply Hz1.
intros Y ; elim (Rlt_irrefl z).
apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y).
apply round_DN_pt...
Qed.

Lemma UP_odd_d_aux :
  forall z, (F2R d < z <= F2R u)%R ->
  Rnd_UP_pt (generic_format beta fexp) z (F2R u).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R u) with (round beta fexp Zceil z).
apply round_UP_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)).
apply generic_format_round...
intros Y ; elim (Rlt_irrefl z).
apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y).
apply round_UP_pt...
intros Y; apply Rle_antisym; trivial.
apply round_UP_pt...
apply Hu.
apply Hz1.
Qed.

Lemma round_N_odd_pos :
  round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
               round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
set (o:=round beta fexpe Zrnd_odd x).
case (generic_format_EM beta fexp x); intros Hx.
replace o with x; trivial.
unfold o; apply sym_eq, round_generic...
now apply generic_format_fexpe_fexp.
assert (K1:(F2R d <= o)%R).
apply round_ge_generic...
apply generic_format_fexpe_fexp, Hd.
apply Hd.
assert (K2:(o <= F2R u)%R).
apply round_le_generic...
apply generic_format_fexpe_fexp, Hu.
apply Hu.
assert (P:(x <> m -> o=m -> (forall P:Prop, P))).
intros Y1 Y2.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (x=m)%R; try trivial.
now rewrite <- Y2, H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct Zm as (k',(Hk'1,(Hk'2,Hk'3))).
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Y2.
assert (generic_format beta fexp o -> (forall P:Prop, P)).
intros Y.
assert (H:(Rnd_odd_pt beta fexpe x o)).
apply round_odd_pt...
destruct H as (_,H); destruct H.
absurd (generic_format beta fexp x); trivial.
now rewrite <- H.
destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))).
eexists; split.
apply sym_eq, Y.
simpl; unfold cexp.
apply Z.le_lt_trans with (1:=fexpe_fexp _).
lia.
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonical_unique with fexpe...
now rewrite Hk'1, <- Hk1.
case K1; clear K1; intros K1.
2: apply H; rewrite <- K1; apply Hd.
case K2; clear K2; intros K2.
2: apply H; rewrite K2; apply Hu.
case (Rle_or_lt  x m); intros Y;[destruct Y|idtac].
(* . *)
apply trans_eq with (F2R d).
apply round_N_eq_DN_pt with (F2R u)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert (o <= (F2R d + F2R u) / 2)%R.
apply round_le_generic...
apply Fm.
now left.
destruct H1; trivial.
apply P.
now apply Rlt_not_eq.
trivial.
apply sym_eq, round_N_eq_DN_pt with (F2R u)...
(* . *)
replace o with x.
reflexivity.
apply sym_eq, round_generic...
rewrite H0; apply Fm.
(* . *)
apply trans_eq with (F2R u).
apply round_N_eq_UP_pt with (F2R d)...
apply DN_odd_d_aux; split; try left; assumption.
apply UP_odd_d_aux; split; try left; assumption.
assert ((F2R d + F2R u) / 2 <= o)%R.
apply round_ge_generic...
apply Fm.
now left.
destruct H0; trivial.
apply P.
now apply Rgt_not_eq.
rewrite <- H0; trivial.
apply sym_eq, round_N_eq_UP_pt with (F2R d)...
Qed.

End Odd_prop_aux.

Section Odd_prop.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.
Variable choice:Z->bool.

Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *)
Context { valid_expe : Valid_exp fexpe }.
Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd *)

Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.

Theorem round_N_odd :
  forall x,
  round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
               round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
intros x.
case (total_order_T x 0); intros H; [case H; clear H; intros H | idtac].
rewrite <- (Ropp_involutive x).
rewrite round_odd_opp.
rewrite 2!round_N_opp.
apply f_equal.
destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
auto with real.
(* . *)
rewrite H; repeat rewrite round_0...
(* . *)
destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
Qed.

End Odd_prop.

Section Odd_propbis.

Variable beta : radix.
Hypothesis Even_beta: Z.even (radix_val beta)=true.

Variable emin prec:Z.
Variable choice:Z->bool.

Hypothesis prec_gt_1: (1 < prec)%Z.

Notation format := (generic_format beta (FLT_exp emin prec)).
Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)).
Notation cexp_flt := (cexp beta (FLT_exp emin prec)).
Notation fexpe k := (FLT_exp (emin-k) (prec+k)).

Lemma Zrnd_odd_plus': forall x y,
  (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) ->
   (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
Proof.
intros x y (n,(e,(H1,H2))).
apply Zrnd_odd_plus.
rewrite H1.
rewrite <- IZR_Zpower.
2: auto with zarith.
now rewrite <- mult_IZR, Zfloor_IZR.
rewrite H1, <- IZR_Zpower.
2: auto with zarith.
rewrite <- mult_IZR, Zfloor_IZR.
rewrite Z.even_mul.
rewrite Z.even_pow.
2: auto with zarith.
rewrite Even_beta.
apply Bool.orb_true_iff; now right.
Qed.

Theorem mag_round_odd: forall (x:R),
 (emin < mag beta x)%Z ->
  (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x))
      = mag_val beta x (mag beta x))%Z.
Proof with auto with typeclass_instances.
intros x.
assert (T:Prec_gt_0 prec).
unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
intros _; rewrite Zx, round_0...
destruct (mag beta x) as (e,He); simpl; intros H.
apply mag_unique; split.
apply abs_round_ge_generic...
apply generic_format_FLT_bpow...
now apply Z.lt_le_pred.
now apply He.
assert (V:
  (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R).
apply abs_round_le_generic...
apply generic_format_FLT_bpow...
now apply Zlt_le_weak.
left; now apply He.
case V; try easy; intros K.
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))].
absurd (Rabs x < bpow beta e)%R.
apply Rle_not_lt; right.
now rewrite <- H0,K.
now apply He.
pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))).
assert (Y1: F2R gg = bpow beta e).
unfold F2R; simpl.
rewrite IZR_Zpower.
rewrite <- bpow_plus.
f_equal; ring.
assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
assert (Y2: canonical beta (FLT_exp emin prec) gg).
unfold canonical; rewrite Y1; unfold gg; simpl.
unfold cexp; now rewrite mag_bpow.
assert (Y3: Fnum gg = Z.abs (Fnum g)).
apply trans_eq with (Fnum (Fabs g)).
2: destruct g; unfold Fabs; now simpl.
f_equal.
apply canonical_unique with (FLT_exp emin prec); try assumption.
destruct g; unfold Fabs; apply canonical_abs; easy.
now rewrite Y1, F2R_abs, <- Hg1,K.
assert (Y4: Z.even (Fnum gg) = true).
unfold gg; simpl.
rewrite Z.even_pow; try assumption.
assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith].
unfold FLT_exp.
apply Z.max_case_strong; auto with zarith.
absurd (true = false).
discriminate.
rewrite <- Hg3.
rewrite <- Zeven_abs.
now rewrite <- Y3.
Qed.

Theorem fexp_round_odd: forall (x:R),
  (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x)
      = cexp_flt x)%Z.
Proof with auto with typeclass_instances.
intros x.
assert (G0:Valid_exp (FLT_exp emin prec)).
apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith.
case (Req_dec x 0); intros Zx.
rewrite Zx, round_0...
case (Zle_or_lt (mag beta x) emin).
unfold cexp; destruct (mag beta x) as (e,He); simpl.
intros H; unfold FLT_exp at 4.
rewrite Z.max_r.
2: auto with zarith.
apply Z.max_r.
assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin).
assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R).
apply abs_round_le_generic...
apply generic_format_bpow'...
unfold FLT_exp; rewrite Z.max_r; auto with zarith.
left; apply Rlt_le_trans with (bpow beta e).
now apply He.
now apply bpow_le.
assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R).
apply Rabs_pos.
assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R).
assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x
    (round beta (FLT_exp emin prec) Zrnd_odd x)).
apply round_odd_pt...
destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))].
apply Rgt_not_eq; rewrite H0.
apply Rlt_le_trans with (bpow beta (e-1)).
apply bpow_gt_0.
now apply He.
rewrite Hg1; intros K.
contradict Hg3.
replace (Fnum g) with 0%Z.
easy.
case (Z.eq_dec (Fnum g) Z0); intros W; try easy.
contradict K.
apply Rabs_no_R0.
now apply F2R_neq_0.
apply Rle_antisym; try assumption.
apply Rle_trans with (succ beta (FLT_exp emin prec) 0).
right; rewrite succ_0.
rewrite ulp_FLT_small; try easy.
unfold Prec_gt_0; auto with zarith.
rewrite Rabs_R0; apply bpow_gt_0.
apply succ_le_lt...
apply generic_format_0.
apply generic_format_abs; apply generic_format_round...
case G2; [easy|intros; now contradict G3].
rewrite <- mag_abs.
rewrite G, mag_bpow; auto with zarith.
intros H; unfold cexp.
now rewrite mag_round_odd.
Qed.

End Odd_propbis.


From ITree Require Import
     ITree
     Events.State.

Set Implicit Arguments.

(* View XY Z X generalizes the Subevent relation.
   Should be thought as `X` is a subdomain of `XY`, and `Z` a view of the complement.
   Note that one could always chose to take Z = unit, but it is important to express operations.
 *)
Class View {XY Z X : Type -> Type} : Type :=
  { preview : XY ~> X +' Z
    ; review : X ~> XY
    ; preview_review : forall {t} (x : X t), preview (review x) = inl1 x
    ; review_preview : forall {t} (xy : XY t) x, preview xy = inl1 x -> review x = xy
  }.
Arguments View : clear implicits.
Arguments preview {_ _ _} _ [_].
Arguments review {_ _ _} _ [_].

(* Partial injection of the bigger domain of events back into the smaller one *)
Definition isa {X Z y} {V : View X Z y} : forall t, X t -> option (y t) :=
  fun t mx =>
    match V.(preview) mx with
    | inl1 x => Some x
    | inr1 _ => None
    end.

(* Embedding of the subdomain into the bigger one *)
Definition subevent {X Z y} {V : View X Z y} : y ~> X := V.(review).

(* Generic lifting of an type-indexed function from the subdomain of effects `a`
   into the ambient one `A`.
   This is where we crucially need the `Z` argument to
   ̀View` for `preview` to also tell us how to embed the complement `A\a` into
   `B`. *)
Definition over {A B a} {z : View A B a} (f : a ~> B) : A ~> B :=
  fun t a => match z.(preview) a with
          | inl1 a => f _ a
          | inr1 b => b
          end.
Arguments over {_ _ _ _} _ [_] _.

(* The less informative previous Subevent relation is recovered by dismissing the `Z` parameter *)
Definition Subevent A B := forall x, View A x B.

(* Should be enough to express generic lemmas as needed for swap *)
(* The instance from atomic domains of events to bigger ones is expressed through `over` *)

(*
  forall f, translate f (trigger x) = trigger (f x)
  over {V} swap (subevent {V} x) = subevent {V} (swap {V} x)
  -----------------
  translate swap (trigger (subevent {f} x)) ~ trigger (subevent {f} (swap x))

  forall V, translate (over {z:=V} (swap a b)) X

  translate (over f) (Vis e k) = Vis (over f e) (fun x => translate (over f) k)
  translate (over f) (translate (over g) X) =
*)

(* Things are also interested with respect to simplifying the construction of interpreters.
 Consider the case from GlobalE for example *)
From ITree Require Import
     Events.State.
From Vellvm Require Import
     LLVMEvents.
From ExtLib Require Import
     Programming.Show
     Structures.Monads
     Structures.Maps.

Section Globals.
  Variable (k v:Type).
  Context {map : Type}.
  Context {M: Map k v map}.
  Context {SK : Show k}.

  Import ITree.Basics.Basics.Monads.

  (* Lift an interpreter g handling only GlobalE to one over a generic overset of effects.
     Note that we use the Z parameter here with another structure than a domain of events.
     Makes a lot of sense, but raises the question of instances to be inferred.
     Relates to our concern for generic triggers?
   *)
  Definition foo {e f s}
             {vv :View f (stateT s (itree e)) (GlobalE k v)}
             (g : GlobalE k v ~> stateT s (itree e))
    : itree f ~> stateT s (itree e).
  Proof.
    eapply interp_state.
    intros.
    generalize (@over _ _ _ vv). intros.
    eapply X0. eapply g. eapply X.
  Defined.

End Globals.

(* We should still be able to build our instances with a bit more work *)
Instance View_id {A} : View A void1 A.
refine
  {| preview := inl1
     ; review := fun _ x => x
  |}.
auto.
intros ? ? ? H; inversion H; auto.
Defined.

Instance View_none {A}: View A A void1.
refine
  {| preview := inr1
     ; review := fun t (x: void1 t) => match x with end
  |}.
intros ? x; inversion x.
intros ? ? x; inversion x.
Defined.

(* Z +' B ? *)
Instance View_L {A B Z a} {_ : View A Z a} : View (A +' B) Z a.
Admitted.
Definition View_R {A B Z b} (_ : View B Z b) : View (A +' B) Z b.
Admitted.

(* **** JUNK TO SORT **** *)

(* We can define join if need be *)
 CoFixpoint join {E} : itree (itree E) ~> itree E.
  intros. econstructor.
  destruct (X.(observe)).
  { eapply RetF. exact r. }
  { eapply TauF. exact (join _ _ t). }
  { eapply TauF. eapply ITree.bind'. 2: exact e.
    exact (fun x => join _ _ (k x)). }
  Defined.

(*
  E -< itree E  :: trigger
  MonadTrans (stateT s)
  trigger :: stateT s (itree E)

  View A Z x -> B -< Z -> View (A +' B) Z x
  View A void1 x
*)

(*
  e1 ~> stateT s1 (itree f1)
  e2 ~> stateT s2 (itree f2)

  itree (stateT s1 (itree f1) +' stateT s2 (itree f2))
  stateT s1 (itree (itree f1 +' stateT s2 (itree f2)))
 *)
(* Old version toying with a four places version of View *)
(*
  Record View {XY Z X Y : Type -> Type} : Type :=
  { preview : XY ~> X +' Z
  ; review : Y ~> Z
  }.
  Arguments View : clear implicits.
  Arguments preview {_ _ _ _} _ [_].
  Arguments review {_ _ _ _} _ [_].

  Definition isa {X y} {V : View X X y y} : forall t, X t -> option (y t).
  intros. eapply V.(preview) in X0.  destruct X0. exact (Some y0). exact None.
  Defined.

  Definition inject {X y} {V : View X X y y} : y ~> X := V.(review).

  Definition over {A B a Z} {z : View A B a Z} (f : a ~> B) : A ~> B.
    refine (fun t a => match z.(preview) a with
                    | inl1 a => f _ a
                    | inr1 b => b
                    end).
  Defined.

  Definition View_id {A} : View A A void1.
  Admitted.
  Definition View_none {A} : View A void1.
  Admitted.
  Definition View_L {A B a} (_ : View A a) : View (A +' B) a.
  Admitted.
  Definition View_R {A B b} (_ : View B b) : View (A +' B) b.
  Admitted.
*)

(* Trying to figure out what we need exactly
    Record we_want {X Y x : Type -> Type} : Type :=
    { other : Type -> Type
    ; otherp : other ~> Y
    ; go : (x ~> Y) -> (X ~> Y)
    ; iso : Iso X (other + x)
    ; _ : forall h a, go h = match iso a with
                        | inl b => otherp b
                        | inr b => h b
                        end

    }.
    Arguments we_want : clear implicits.

    Definition ww_map {A} : we_want A A A.
      refine {| other := void1
             |}.
      destruct 1.
      exact (fun x => x).
    Defined.

    Definition ww_ignore {A x} : we_want A  A x.
    refine {| other := A
              ; otherp := fun _ x => x
              ;go := fun _ _ x => x
           |}.
    Defined.

    Definition ww_x {A B C x} (wwA : we_want A C x) (wwB : we_want B C x)
    : we_want (A +' B) C x.
    refine {| other := wwA.(other) +' wwB.(other)
            |}.
    { destruct 1.
      eapply wwA.(otherp). assumption.
      eapply wwB.(otherp). assumption. }
    destruct 2.
    eapply wwA.(go); eauto.
    eapply wwB.(go); eauto.
    Defined.

    (X ~> x + other) -> (other ~> Y) -> (x ~> Y) -> itree X ~> T (itree Y)

*)

(* First version, Gregory trying to stick mor precisely to Haskell's prisms
  Section with_mapping.
    Record Prism {B A : Type -> Type} : Type :=
    { p_ask : forall t, A t -> option (B t)
    ; p_put : forall t, B t -> A t
    ; ask_put : forall t (x : A t) y, p_ask x = Some y -> p_put y = x
    ; put_ask : forall t (x : B t), p_ask (p_put x) = Some x
    ; ask_only : forall t (x : A t), p_ask x = None -> forall y, p_put y <> x
    }.
    Arguments Prism _ _ : clear implicits.
    Arguments ask_put {_ _} _ _ _.
    Arguments put_ask {_ _} _ _.
    Arguments ask_only {_ _} _ _ _.

    Definition Prism_id {A} : Prism A A.
    refine
    {| p_ask _ x := Some x
     ; p_put _ x := x
     |}.
    { inversion 1. auto. }
    { reflexivity. }
    { inversion 1. }
    Defined.

    Definition Prism_L {A B C} (P : Prism B A) : Prism (B +' C) (A +' C).
    econstructor.
    Unshelve.
    4:{ intros. destruct X.
      eapply P.(p_ask) in a.
      destruct a.
      { eapply Some. constructor. eapply b. }
      { eapply None. }
      eapply Some. right. assumption. }
    4: { destruct 1.
         { constructor. eapply P.(p_put). assumption. }
         right. assumption. }
    { simpl. destruct x; simpl; intros.
      { generalize (P.(ask_put) _ a).
        destruct (p_ask P t a).
        { inversion H.
          intro. specialize (H0 _ eq_refl).
          congruence. }
        { congruence. } }
      { inversion H. congruence. } }
    { simpl.
      destruct x.
      erewrite put_ask. reflexivity. reflexivity. }
    { simpl. destruct x; try congruence.
      generalize (P.(ask_only) _ a).
      destruct (p_ask P t a); try congruence.
      intros. destruct y.
      intro. inversion H1. eapply H; eauto.
      congruence. }
    Defined.

    Record Prism' {A B C D : Type -> Type} : Type :=
    { pleft : Prism C A
    ; pright : Prism D B
    }.
    Arguments Prism' : clear implicits.
    Arguments pleft {_ _ _ _} _.
    Arguments pright {_ _ _ _} _.

    Definition pover {A B C D} (p : Prism' A B C D) : (C ~> D) -> (A ~> B).
      intros.
      eapply (p.(pleft).(p_ask)) in X0.
      destruct X0.
      { eapply X in c.
        eapply (p.(pright).(p_put) _ c). }
      {

    view   : A -> a + o
    insert : a + o -> A

    Record Prism' {A B C D : Type -> Type} : Type :=
    { get : forall t, A t -> option (C t)
    ; put :

  End with_mapping.

*)


Require Import Utf8 Classical.

Example hansya U R:=
forall a:U,R a a:Prop.

Example hihansya U R:=
forall a:U,~R a a:Prop.

Example taisyo U R:=
forall a b:U,R a b->R b a.

Example hantaisyo U R:=
forall a b:U,R a b->R b a->a=b:Prop.

Example sui U(R:U->U->Prop):=
forall a b c,R a b->R b c->R a c.

Example hikakukano U R:=
forall a b:U,R a b\/R b a:Prop.

Example hitaisyo U(R:U->U->Prop):=
forall a b,R a b->~R b a.

Goal forall U(R1 R2:U->U->Prop),
hantaisyo U R1->
(forall a b,R2 a b->R1 a b/\a<>b)->
hitaisyo U R2.
Proof.
intros.
unfold hitaisyo.
intros.
intro.
assert(H3:=H0 a b).
specialize(H0 b a).
specialize(H0 H2).
clear H2.
specialize(H3 H1).
clear H1 R2.
destruct H0,H3.
apply H3.
clear H1 H3.
unfold hantaisyo in H.
specialize(H a b).
specialize(H H2 H0).
clear R1 H0 H2.
case H.
clear b H.
reflexivity.
Qed.

Goal forall U(R1 R2:U->U->Prop),
sui U R1->
hantaisyo U R1->
(forall a b,R2 a b<->R1 a b/\a<>b)->
sui U R2.
Proof.
intros.
unfold sui.
intros.
assert(H4:=H1 a b).
assert(H5:=H1 b c).
specialize(H1 a c).
destruct H1,H4,H5.
clear H1 H7 H8.
apply H6.
clear H6.
specialize(H4 H2).
clear H2.
specialize(H5 H3).
clear H3 R2.
destruct H4,H5.
clear H2.
unfold sui in H.
specialize(H a b c).
specialize(H H1 H3).
unfold hantaisyo in H0.
specialize(H0 a b).
split.
clear b H0 H1 H3 H4.
assumption.
clear H.
intro.
apply H4.
clear H4.
subst.
specialize(H0 H1 H3).
clear R1 H1 H3.
case H0.
clear b H0.
reflexivity.
Qed.

Goal forall U(R1 R2:U->U->Prop),
(forall a b,R2 a b->R1 a b/\a<>b)->
hihansya U R2.
Proof.
intros.
unfold hihansya.
intros.
intro.
specialize(H a a).
specialize(H H0).
clear H0 R2.
destruct H.
clear R1 H.
apply H0.
clear H0.
reflexivity.
Qed.

Goal forall U(R1 R2:U->U->Prop),
(forall a b,R1 a b\/a=b->R2 a b)->
hansya U R2.
Proof.
intros.
unfold hansya.
intro.
specialize(H a a).
apply H.
clear R2 H.
right.
clear R1.
reflexivity.
Qed.

Goal forall U(R1 R2:U->U->Prop),
hitaisyo U R1->
(forall a b,R2 a b->R1 a b\/a=b)->
hantaisyo U R2.
Proof.
intros.
unfold hantaisyo.
intros.
assert(H3:=H0 a b).
specialize(H0 b a).
specialize(H0 H2).
clear H2.
specialize(H3 H1).
clear H1 R2.
destruct H0.
destruct H3.
unfold hitaisyo in H.
specialize(H a b).
apply H in H1.
all:clear H.
specialize(H1 H0).
clear H0 R1.
exfalso.
clear U a b.
assumption.
clear R1 H0.
case H1.
clear b H1.
reflexivity.
clear R1 H3.
case H0.
clear a H0.
reflexivity.
Qed.

Goal forall U(R1 R2:U->U->Prop),
sui U R1->
(forall a b,R2 a b<->R1 a b\/a=b)->
sui U R2.
Proof.
intros.
unfold sui.
intros.
assert(H3:=H0 a b).
assert(H4:=H0 b c).
specialize(H0 a c).
destruct H0,H3,H4.
clear H0 H6 H7.
specialize(H3 H1).
clear H1.
specialize(H4 H2).
clear H2.
apply H5.
clear H5 R2.
unfold sui in H.
specialize(H a b c).
destruct H3.
destruct H4.
specialize(H H0 H1).
clear H0 H1 b.
left.
assumption.
all:clear H.
subst.
left.
assumption.
destruct H4.
subst.
left.
assumption.
right.
clear R1.
subst.
reflexivity.
Qed.

Goal forall U R,
sui U R->
hihansya U R->
hitaisyo U R.
Proof.
intros.
unfold hitaisyo.
intros.
intro.
unfold sui in H.
specialize(H a b a).
specialize(H H1 H2).
clear H1 H2 b.
unfold hihansya in H0.
specialize(H0 a).
specialize(H0 H).
clear U R a H.
assumption.
Qed.

Goal forall U R,
hitaisyo U R->
hihansya U R.
Proof.
intros.
unfold hihansya.
intro.
intro.
unfold hitaisyo in H.
specialize(H a a).
specialize(H H0).
specialize(H H0).
clear U R a H0.
assumption.
Qed.

Goal forall U R,
sui U R->
taisyo U R->
(forall a,exists b,R a b)->
hansya U R.
Proof.
intros.
unfold hansya.
intro.
specialize(H0 a).
destruct H0.
unfold sui in H.
unfold taisyo in X.
specialize(X a x).
specialize(X H0).
specialize(H a x a).
specialize(H H0 X).
clear x X H0.
assumption.
Qed.

Goal forall U(R1 R2:U->U->Prop),
(forall a b,R1 a b->R2 a b\/a=b)<->
forall a b,R1 a b/\a<>b->R2 a b.
Proof.
intros.
split.
intros.
destruct H0.
specialize(H a b).
specialize(H H0).
clear H0 R1.
destruct H.
clear H1.
assumption.
exfalso.
specialize(H1 H).
clear H a b R2 U.
assumption.
intros.
specialize(H a b).
assert(a=b\/a<>b).
apply classic.
destruct H1.
right.
clear H0 H R1 R2.
case H1.
clear H1 b.
reflexivity.
left.
apply H.
clear H R2.
split.
clear H1.
assumption.
intro.
specialize(H1 H).
clear H H0 a b R1 U.
assumption.
Qed.

Goal forall U R,
hikakukano U R->
hansya U R.
Proof.
intros.
unfold hansya.
intro.
unfold hikakukano in H.
specialize(H a a).
destruct H.
assumption.
assumption.
Qed.

Example saidaigen U(R:U->U->Prop)a:=
forall x,R x a.

Goal forall U(R:U->U->Prop)a b,
hantaisyo U R->
saidaigen U R a->
saidaigen U R b->
a=b.
Proof.
intros.
unfold hantaisyo in H.
specialize(H a b).
unfold saidaigen in H0.
unfold saidaigen in H1.
specialize(H0 b).
specialize(H1 a).
specialize(H H1 H0).
clear H0 H1 R.
case H.
clear b H.
reflexivity.
Qed.

Example saisyogen U(R:U->U->Prop)a:=
forall x,R a x.

Goal forall U(R:U->U->Prop)a b,
hantaisyo U R->
saisyogen U R a->
saisyogen U R b->
a=b.
Proof.
intros.
unfold hantaisyo in H.
specialize(H a b).
unfold saisyogen in H0.
unfold saisyogen in H1.
specialize(H0 b).
specialize(H1 a).
specialize(H H0 H1).
clear H0 H1 R.
case H.
clear b H.
reflexivity.
Qed.

Example kyokudaigen U(R:U->U->Prop)a:=
forall x,R a x->a=x.

Goal forall U(R:U->U->Prop)a,
hantaisyo U R->
saidaigen U R a->
kyokudaigen U R a.
Proof.
intros.
unfold kyokudaigen.
intros.
unfold saidaigen in H0.
specialize(H0 x).
unfold hantaisyo in H.
specialize(H a x).
specialize(H H1 H0).
case H.
clear R x H0 H1 H.
reflexivity.
Qed.

Example kyokusyogen U(R:U->U->Prop)a:=
forall x,R x a->x=a.

Goal forall U(R:U->U->Prop)a,
hantaisyo U R->
saisyogen U R a->
kyokusyogen U R a.
Proof.
intros.
unfold kyokusyogen.
intros.
unfold saisyogen in H0.
specialize(H0 x).
unfold hantaisyo in H.
specialize(H x a).
specialize(H H1 H0).
case H.
clear R a H0 H1 H.
reflexivity.
Qed.

Goal forall U(R:U->U->Prop)a b,
saidaigen U R a->
kyokudaigen U R b->
a=b.
Proof.
intros.
unfold saidaigen in H.
specialize(H b).
unfold kyokudaigen in H0.
specialize(H0 a).
specialize(H0 H).
case H0.
clear a H H0 R.
reflexivity.
Qed.

Goal forall U(R:U->U->Prop)a b,
saisyogen U R a->
kyokusyogen U R b->
a=b.
Proof.
intros.
unfold saisyogen in H.
specialize(H b).
unfold kyokusyogen in H0.
specialize(H0 a).
specialize(H0 H).
case H0.
clear b H H0 R.
reflexivity.
Qed.

Goal forall U(R:U->U->Prop),
hikakukano U R->
forall a,
kyokudaigen U R a->
saidaigen U R a.
Proof.
intros.
unfold saidaigen.
intro.
unfold kyokudaigen in H0.
specialize(H0 x).
unfold hikakukano in H.
specialize(H a x).
destruct H.
specialize(H0 H).
subst.
assumption.
clear H0.
assumption.
Qed.

Goal forall U(R:U->U->Prop),
hikakukano U R->
forall a,
kyokusyogen U R a->
saisyogen U R a.
Proof.
intros.
unfold saisyogen.
intro.
unfold kyokusyogen in H0.
specialize(H0 x).
unfold hikakukano in H.
specialize(H a x).
destruct H.
clear H0.
assumption.
specialize(H0 H).
subst.
assumption.
Qed.


From RecordUpdate Require Import RecordSet.
From Perennial.Helpers Require Import Map gset.

From Perennial.goose_lang Require Import crash_modality crash_borrow.
From Perennial.base_logic Require Import lib.ghost_map.

From Goose.github_com.mit_pdos.perennial_examples Require Import alloc.
From Perennial.program_logic Require Export ncinv.
From Perennial.program_proof.examples Require Import alloc_addrset.

Inductive block_status :=
| block_free
| block_reserved
| block_used.

#[global]
Instance block_status_eq_dec : EqDecision block_status.
Proof.
  intros e1 e2.
  destruct e1, e2;
  try (abstract (left; congruence));
  try (abstract (right; congruence)).
Qed.

Class allocG Σ :=
  { alloc_used_preG :> ghost_mapG Σ u64 block_status;
    alloc_freeset :> ghost_varG Σ (gset u64);
 }.

(* state representation types (defined here since modules can't be in sections) *)
Module alloc.
  Definition t := gmap u64 block_status.

  Definition domain (σ: t) : gset u64 := dom σ.
  Definition free (σ: t) : gset u64 := dom (filter (λ x, x.2 = block_free) σ).
  Definition used (σ: t) : gset u64 := dom (filter (λ x, x.2 = block_used) σ).
  Definition unused (σ: t) : gset u64 := dom (filter (λ x, x.2 ≠ block_used) σ).

  Global Instance _witness : Inhabited t.
  Proof. econstructor. apply (∅: gmap u64 block_status). Defined.

  Lemma unused_used_disjoint σ :
    unused σ ## used σ.
  Proof.
    rewrite /unused /used.
    apply elem_of_disjoint => a H1 H2.
    apply elem_of_dom in H1 as [s1 [H1 Hs1]%map_filter_lookup_Some].
    apply elem_of_dom in H2 as [s2 [H2 Hs2]%map_filter_lookup_Some].
    congruence.
  Qed.

  Lemma unused_used_domain σ :
    unused σ ∪ used σ = domain σ.
  Proof.
    rewrite /unused /used /domain.
    apply set_eq => a.
    rewrite elem_of_union.
    rewrite !elem_of_dom.
    split.
    - destruct 1.
      + destruct H as [s [H _]%map_filter_lookup_Some]; eauto.
      + destruct H as [s [H _]%map_filter_lookup_Some]; eauto.
    - intros.
      destruct H as [s H].
      destruct (decide (s = block_used)); [right | left]; exists s.
      + rewrite map_filter_lookup_Some; eauto.
      + rewrite map_filter_lookup_Some; eauto.
  Qed.
End alloc.

Definition alloc_post_crash (σ: alloc.t) : Prop :=
  alloc.free σ = alloc.unused σ.

Lemma alloc_post_crash_lookup_unused σ k:
  alloc_post_crash σ →
  k ∈ alloc.unused σ →
  σ !! k = Some block_free.
Proof.
  intros <-. rewrite elem_of_dom. intros (kv&Hlook).
  edestruct (map_filter_lookup_Some (λ x, x.2 = block_free) σ k kv) as (Hlook'&_).
  simpl in *; intuition; subst; auto.
Qed.

Lemma alloc_post_crash_lookup_not_reserved σ k:
  alloc_post_crash σ →
  ¬ (σ !! k = Some block_reserved).
Proof.
  intros Hcrash Hlook.
  assert (σ !! k = Some block_free); last by congruence.
  apply alloc_post_crash_lookup_unused; auto.
  rewrite /alloc.unused. rewrite elem_of_dom. eexists.
  rewrite map_filter_lookup_Some; split; eauto.
Qed.

Lemma alloc_used_reserve s u :
  u ∈ alloc.free s →
  alloc.used (<[u:=block_reserved]> s) =
  alloc.used s.
Proof.
  rewrite /alloc.free /alloc.used.
  intros Hufree.
  apply elem_of_dom in Hufree as [status Hufree].
  apply map_filter_lookup_Some in Hufree as [Hufree ?];
    simpl in *; subst.
  rewrite map_filter_insert_not' //= => status.
  rewrite Hufree=>[= <-] //.
Qed.

Lemma alloc_free_reserved s a :
  s !! a = Some block_reserved →
  alloc.used (<[a := block_free]> s) =
  alloc.used s.
Proof.
  rewrite /alloc.used.
  intros Hareserved.
  rewrite map_filter_insert_not' //= => status.
  rewrite Hareserved=>[= <-] //.
Qed.

Lemma alloc_used_insert s a :
  alloc.used (<[a := block_used]> s) = {[a]} ∪ alloc.used s.
Proof.
  rewrite /alloc.used.
  rewrite map_filter_insert_True //.
  set_solver.
Qed.

Section goose.
Context `{ffi_sem: ffi_semantics}.
Context `{!ffi_interp ffi}.
Context {ext_tys: ext_types ext}.
Context `{!heapGS Σ}.
Context `{!allocG Σ}.
Context `{!stagedG Σ}.

Record alloc_names :=
  { alloc_status_name: gname;
    alloc_free_name : gname;
  }.

Instance alloc_names_eta : Settable _ := settable! Build_alloc_names <alloc_status_name; alloc_free_name>.

Implicit Types (a: u64) (m: gmap u64 ()) (free: gset u64).

Context (P: alloc.t → iProp Σ).
Context (Ψ: u64 → iProp Σ).
Context (N: namespace).
Implicit Types (l:loc) (γ:alloc_names) (σ: alloc.t).

Definition Nlock := N.@"allocator".
Definition Ninv := N.@"inv".

Definition allocator_inv γ (d: gset u64) : iProp Σ :=
  ∃ σ,
    "%Hdom" ∷ ⌜ dom σ = d ⌝ ∗
    "Hstatus" ∷ ghost_map_auth γ.(alloc_status_name) 1 σ ∗
    "Hfreeset_auth" ∷ ghost_var (γ.(alloc_free_name)) (1/2) (alloc.free σ) ∗
    "HP" ∷ P σ
.

Definition block_cinv γ addr : iProp Σ :=
  Ψ addr ∨ addr ↪[alloc_status_name γ] block_used.

Definition free_block γ k : iProp Σ :=
  "Hcrashinv" ∷ (crash_borrow (Ψ k) (block_cinv γ k)) ∗
  "Hmapsto" ∷ (k ↪[alloc_status_name γ] block_free).

Definition free_block_pending γ k : iProp Σ :=
  (|C={⊤}=> block_cinv γ k).

Definition reserved_block γ k P : iProp Σ :=
  "Hcrashinv" ∷ (crash_borrow P (block_cinv γ k)) ∗
  "Hmapsto" ∷ (k ↪[alloc_status_name γ] block_reserved) ∗
  "Halloc_inv" ∷ ∃ d, ncinv Ninv (allocator_inv γ d).

Definition reserved_block_in_prep γ k : iProp Σ :=
  "Hmapsto" ∷ (k ↪[alloc_status_name γ] block_reserved) ∗
  "Halloc_inv" ∷ ∃ d, ncinv Ninv (allocator_inv γ d).

Definition used_block γ k : iProp Σ :=
  "Hmapsto" ∷ (k ↪[alloc_status_name γ] block_used).

Definition allocator_linv γ (mref: loc) : iProp Σ :=
 ∃ (freeset: gset u64),
  "Hfreemap" ∷ is_addrset mref (freeset) ∗
  "Hblocks" ∷ ([∗ set] k ∈ freeset, k ↪[alloc_status_name γ] block_free) ∗
  "Hborrows" ∷ crash_borrow ([∗ set] k ∈ freeset, Ψ k) ([∗ set] k ∈ freeset, block_cinv γ k) ∗
  "Hfreeset_frag" ∷ ghost_var (γ.(alloc_free_name)) (1/2) (freeset)
.

Definition is_allocator (l: loc) (d: gset u64) γ : iProp Σ :=
  ∃ (lref mref: loc),
    "#m" ∷ readonly (l ↦[Allocator :: "m"] #lref) ∗
    "#free" ∷ readonly (l ↦[Allocator :: "free"] #mref) ∗
    "#His_lock" ∷ is_lock Nlock #lref (allocator_linv γ mref) ∗
    "#Halloc_inv" ∷ ncinv Ninv (allocator_inv γ d)
.

Definition is_allocator_mem_pre (l: loc) σ : iProp Σ :=
  ∃ (lref mref: loc),
    "%Hpostcrash" ∷ ⌜ alloc_post_crash σ ⌝ ∗
    "#m" ∷ readonly (l ↦[Allocator :: "m"] #lref) ∗
    "#free" ∷ readonly (l ↦[Allocator :: "free"] #mref) ∗
    "Hfreemap" ∷ is_addrset mref (alloc.free σ) ∗
    "Hfree_lock" ∷ is_free_lock lref ∗
    "Hltok" ∷ pre_borrow.

Theorem is_allocator_pre_post_crash l σ :
  is_allocator_mem_pre l σ -∗ ⌜alloc_post_crash σ⌝.
Proof.
  iNamed 1; eauto.
Qed.

(* TODO: prove something useful for initializing from zero blocks *)

Lemma alloc_post_crash_free_used σ :
  alloc.free σ = alloc.domain σ ∖ alloc.used σ ↔
  alloc_post_crash σ.
Proof.
  clear.
  rewrite /alloc_post_crash.
  pose proof (alloc.unused_used_domain σ).
  pose proof (alloc.unused_used_disjoint σ).
  set_solver.
Qed.

Lemma elem_of_filter_dom {A B} `{Countable A} (P': A * B → Prop) `{∀ x, Decision (P' x)} (m: gmap A B) (x: A) :
  x ∈ dom (filter P' m) ↔ (∃ (y: B), m !! x = Some y ∧ P' (x,y)).
Proof.
  split; intros.
  - apply elem_of_dom in H1 as [y [H1 Hy]%map_filter_lookup_Some];
      simpl in *; subst.
    exists y; eauto.
  - destruct H1 as [y [Hlookup HP]].
    apply elem_of_dom; eexists.
    apply map_filter_lookup_Some; eauto.
Qed.

Lemma alloc_post_crash_no_reserved σ :
  alloc_post_crash σ ↔
  dom (filter (λ '(_,s), s = block_reserved) σ) = ∅.
Proof.
  rewrite /alloc_post_crash.
  split; intros.
  - apply gset_elem_is_empty; intros.
    rewrite elem_of_filter_dom.
    destruct 1 as [y [? ->]].
    assert (x ∈ alloc.free σ).
    { rewrite H.
      rewrite /alloc.unused elem_of_filter_dom.
      eexists; eauto. }
    apply elem_of_filter_dom in H1 as [? [? Heq]]; simpl in Heq; congruence.
  - apply set_eq; intros.
    rewrite /alloc.free /alloc.unused.
    rewrite !elem_of_filter_dom.
    split; intros.
    + destruct H0 as [? [? ?]]; simpl in *; eauto.
      exists x0; split; eauto.
      congruence.
    + destruct H0 as [? [? ?]]; simpl in *; eauto.
      exists x0; split; eauto.
      destruct x0; eauto; try congruence.
      cut (x ∈ (∅: gset u64)).
      { rewrite elem_of_empty; contradiction. }
      rewrite -H.
      apply elem_of_filter_dom.
      eauto.
Qed.

(* this code is no longer used, but left here in case we need to construct an
allocator state from nothing (say for initialization) since it's a bit
complicated. *)
Section new_alloc_state.
Definition new_alloc_state (start sz: Z) (used: gset u64): alloc.t :=
  gset_to_gmap block_used used ∪
  gset_to_gmap block_free (rangeSet start sz).

Lemma new_alloc_state_no_reserved start sz used :
  dom (filter (λ '(_, s), s = block_reserved)
                          (new_alloc_state start sz used)) = ∅.
Proof.
  clear.
  apply gset_elem_is_empty; intros x Helem.
  apply elem_of_dom in Helem as [s1 [Helem Hs1]%map_filter_lookup_Some];
    simpl in *; subst.
  apply lookup_union_Some_raw in Helem as [Helem | [? Helem]].
  - apply lookup_gset_to_gmap_Some in Helem.
    intuition congruence.
  - apply lookup_gset_to_gmap_Some in Helem.
    intuition congruence.
Qed.

Theorem new_alloc_state_properties start sz used :
  used ⊆ rangeSet start sz →
  let σ := new_alloc_state start sz used in
  alloc.domain σ = rangeSet start sz ∧
  alloc_post_crash σ ∧
  alloc.used σ = used ∧
  alloc.unused σ = rangeSet start sz ∖ used.
Proof.
  clear.
  intros.
  rewrite /alloc.domain /alloc_post_crash.
  assert (alloc.used σ = used).
  { subst σ; rewrite /new_alloc_state /alloc.used.
    apply set_eq; intros.
    rewrite elem_of_filter_dom /=.
    setoid_rewrite lookup_union_Some_raw.
    setoid_rewrite lookup_gset_to_gmap_Some.
    setoid_rewrite lookup_gset_to_gmap_None.
    split.
    - destruct 1 as [y [Hlookup ->]].
      intuition congruence.
    - intros.
      exists block_used; intuition eauto.
  }
  assert (alloc.domain σ = rangeSet start sz).
  { rewrite /alloc.domain /σ.
    rewrite /new_alloc_state.
    rewrite dom_union_L.
    rewrite !dom_gset_to_gmap.
    set_solver. }
  rewrite -H0.
  split_and!; auto.
  - apply alloc_post_crash_no_reserved.
    apply new_alloc_state_no_reserved.
  - pose proof (alloc.unused_used_disjoint σ).
    pose proof (alloc.unused_used_domain σ).
    rewrite -H1.
    set_solver.
Qed.
End new_alloc_state.

Theorem wp_newAllocator {mref} {start sz: u64} σ (used: gset u64) :
  int.Z start + int.Z sz < 2^64 →
  alloc.domain σ = rangeSet (int.Z start) (int.Z sz) →
  alloc.used σ = used →
  alloc_post_crash σ →
  {{{ is_addrset mref used  }}}
    New #start #sz #mref
  {{{ l, RET #l; is_allocator_mem_pre l σ }}}.
Proof using allocG0.
  iIntros (Hoverflow Hdom Hused Hfree Φ) "Hused HΦ".
  iApply wp_crash_borrow_generate_pre; auto.
  wp_call.
  wp_apply wp_freeRange; first by auto.
  iIntros (mref') "Hfree".
  wp_pures.
  wp_apply (wp_mapRemove with "[$Hfree $Hused]"); iIntros "(Hfree & Hused)".
  wp_apply wp_new_free_lock.
  iIntros (lk) "Hlock".
  rewrite -wp_fupd.
  wp_apply wp_allocStruct; auto.
  iIntros (l) "Hallocator".
  iDestruct (struct_fields_split with "Hallocator") as "(m&free&_)".
  iMod (readonly_alloc_1 with "m") as "#m".
  iMod (readonly_alloc_1 with "free") as "#free".
  iModIntro.
  iIntros "Htoks".
  iApply "HΦ".
  iExists _, _; iFrame "# ∗".
  iSplitR; first auto.
  (*
  iSplitR "Htoks"; last first.
  { iDestruct "Htoks" as "($&$&$&$&_)". }
   *)
  iExactEq "Hfree".
  rewrite /named.
  f_equal.
  apply alloc_post_crash_free_used in Hfree.
  congruence.
Qed.

Context {Hitemcrash: ∀ x, IntoCrash (Ψ x) (λ _, Ψ x)}.

Global Instance is_allocator_Persistent l γ d:
  Persistent (is_allocator l d γ).
Proof. apply _. Qed.

Definition alloc_crash_cond' σ : iProp Σ :=
  [∗ set] k ∈ alloc.unused σ, Ψ k.

Definition alloc_crash_cond (d: gset u64) (post_crash: bool) : iProp Σ :=
  ∃ σ, "%Halloc_post_crash" ∷ ⌜if post_crash then alloc_post_crash σ else True⌝ ∗
       "%Halloc_dom" ∷ ⌜dom σ = d⌝ ∗
       "HPalloc" ∷ ▷ P σ ∗
       "Hunused" ∷ [∗ set] k ∈ alloc.unused σ, Ψ k.

Definition alloc_crash_cond_no_later (d: gset u64) (post_crash: bool) : iProp Σ :=
  ∃ σ, "%Halloc_post_crash" ∷ ⌜if post_crash then alloc_post_crash σ else True⌝ ∗
       "%Halloc_dom" ∷ ⌜dom σ = d⌝ ∗
       "HPalloc" ∷ P σ ∗
       "Hunused" ∷ [∗ set] k ∈ alloc.unused σ, Ψ k.

Lemma alloc_crash_cond_from_post_crash d :
  alloc_crash_cond d true -∗ alloc_crash_cond d false.
Proof.
  iNamed 1.
  iExists _; iFrame "% ∗".
Qed.

Lemma alloc_crash_cond_strip_later `{∀ σ, Timeless (P σ)} d b :
  alloc_crash_cond d b ={⊤}=∗ alloc_crash_cond_no_later d b.
Proof.
  iNamed 1.
  iDestruct "HPalloc" as ">HPalloc".
  iExists _; by iFrame.
Qed.

Lemma alloc_crash_cond_no_later_from_post_crash d :
  alloc_crash_cond_no_later d true -∗ alloc_crash_cond_no_later d false.
Proof.
  iNamed 1.
  iExists _; iFrame "% ∗".
Qed.

Definition revert_reserved (σ : alloc.t) : alloc.t :=
  (λ x, if decide (x = block_reserved) then block_free else x) <$> (σ: gmap u64 block_status).

Lemma alloc_post_crash_revert_reserved σ:
  alloc_post_crash (revert_reserved σ).
Proof.
  clear.
  rewrite /alloc_post_crash /revert_reserved /alloc.free /alloc.unused.
  rewrite !map_filter_fmap /= !dom_fmap_L.
  f_equal. apply map_filter_ext. intros i x. simpl. destruct x.
  - rewrite decide_False //; auto.
  - rewrite decide_True //; discriminate.
  - rewrite decide_False //; auto.
Qed.

Lemma unused_revert_reserved σ:
  alloc.unused (revert_reserved σ) = alloc.unused σ.
Proof.
  clear.
  rewrite /alloc.unused /revert_reserved.
  rewrite map_filter_fmap /= dom_fmap_L.
  f_equal. apply map_filter_ext. intros i x. simpl. destruct x.
  - rewrite decide_False //; auto.
  - rewrite decide_True //; discriminate.
  - rewrite decide_False //; auto.
Qed.

Lemma dom_revert_reserved σ:
 dom (revert_reserved σ) = dom σ.
Proof.
  clear.
  rewrite /revert_reserved dom_fmap_L //.
Qed.

Lemma used_revert_reserved (σ0: alloc.t):
  alloc.used (revert_reserved σ0) = alloc.used σ0.
Proof.
  clear.
  rewrite /alloc.used /revert_reserved.
  rewrite map_filter_fmap /= dom_fmap_L.
  f_equal. apply map_filter_ext. intros i x. simpl. destruct x.
  - rewrite decide_False //; auto.
  - rewrite decide_True //; discriminate.
  - rewrite decide_False //; auto.
Qed.

Lemma alloc_crash_cond_crash_true d E :
  (∀ σ, ▷ P σ ={E}=∗ ▷ P (revert_reserved σ)) -∗
  alloc_crash_cond d false ={E}=∗ alloc_crash_cond d true.
Proof.
  clear.
  iIntros "H".
  iNamed 1.
  iMod ("H" with "HPalloc"). iModIntro. iExists _. iFrame.
  rewrite unused_revert_reserved. iFrame.
  iPureIntro; split.
  - apply alloc_post_crash_revert_reserved.
  - rewrite dom_revert_reserved. auto.
Qed.

Lemma alloc_crash_cond_no_later_crash_true d E :
  (∀ σ, P σ ={E}=∗ P (revert_reserved σ)) -∗
  alloc_crash_cond_no_later d false ={E}=∗ alloc_crash_cond_no_later d true.
Proof.
  clear.
  iIntros "H".
  iNamed 1.
  iMod ("H" with "HPalloc"). iModIntro. iExists _. iFrame.
  rewrite unused_revert_reserved. iFrame.
  iPureIntro; split.
  - apply alloc_post_crash_revert_reserved.
  - rewrite dom_revert_reserved. auto.
Qed.

(* TODO: this is a more general property about filter *)
Lemma dom_filter_unfree σ :
  dom (filter (λ x : u64 * block_status, x.2 ≠ block_free) σ) = alloc.domain σ ∖ alloc.free σ.
Proof.
  clear.
  apply dom_filter_L.
  intros i. rewrite /alloc.domain/alloc.free.
  set_unfold. split.
  * intros (Hi&Hnin).
    apply elem_of_dom in Hi. destruct Hi as [x Hin].
    exists x. split; eauto. intros Hin'. eapply Hnin.
    apply elem_of_filter_dom; eauto.
  * intros (x&Hi&Hneq). split.
    ** apply elem_of_dom; eauto.
    ** intros Hdom. apply elem_of_filter_dom in Hdom as (?&?&Hfree). simpl in Hfree. congruence.
Qed.

Theorem reserved_block_weaken γ k R R' :
  □ (R -∗ R') -∗
  □ (R' -∗ block_cinv γ k) -∗
  reserved_block γ k R -∗
  reserved_block γ k R'.
Proof.
  iIntros "#HR' #Hwand"; iNamed 1.
  iFrame. iApply (crash_borrow_conseq with "[] [] [] Hcrashinv"); eauto.
Qed.

Lemma free_big_sepS_to_all σ (Φ: u64 → iProp Σ):
  ([∗ set] k ∈ alloc.free σ, Φ k) ⊣⊢
  [∗ map] k↦v ∈ σ, match v with block_free => Φ k | _ => True end.
Proof.
  rewrite -big_opM_dom big_sepM_filter'.
  apply big_sepM_proper. intros ? []; eauto => //=;
  try (by rewrite decide_False);
  try (by rewrite decide_True).
Qed.

Lemma alloc_post_crash_big_sepM_split_free σ (Φ : u64 → _ → iProp Σ):
  alloc_post_crash σ →
  ([∗ map] k↦v ∈σ, Φ k v) -∗
  ([∗ set] k ∈ alloc.free σ, Φ k block_free) ∗
  ([∗ set] k ∈ (alloc.domain σ ∖ alloc.free σ), Φ k block_used).
Proof.
  iIntros (Hcrashed) "Hpts".
  iDestruct (big_sepM_filter_split _ (λ x, x.2 = block_free) with "Hpts") as "(Hfree&Hnfree)".
  iSplitL "Hfree".
  { iApply big_sepM_dom. iApply (big_sepM_mono with "Hfree").
    iIntros (?? Hlookup).
    apply map_filter_lookup_Some in Hlookup as (?&Heq). simpl in Heq. subst.
    eauto. }
  iAssert ([∗ map] k↦x ∈ filter (λ x : u64 * block_status, x.2 ≠ block_free) σ, Φ k block_used)%I
           with "[Hnfree]" as "Hused".
  { iApply (big_sepM_mono with "Hnfree").
    iIntros (?? Hfilter) "H".
    apply map_filter_lookup_Some in Hfilter as (?&Heq).
    simpl in Heq. destruct x; try iFrame; try congruence.
    exfalso. eapply alloc_post_crash_lookup_not_reserved; eauto.
  }
  iDestruct (big_sepM_dom with "Hused") as "Hused".
  rewrite dom_filter_unfree. eauto.
Qed.

Lemma free_block_init γ σ E :
  alloc_post_crash σ →
  pre_borrow -∗
  ([∗ set] k ∈ alloc.unused σ, Ψ k) -∗
  ([∗ map] k↦v ∈ σ, k ↪[alloc_status_name γ] v) -∗
  |={E}=> init_cancel (([∗ set] k ∈ alloc.free σ, k ↪[alloc_status_name γ] block_free) ∗
                       crash_borrow ([∗ set] k ∈ alloc.free σ, Ψ k)
                                    ([∗ set] k ∈ alloc.free σ, block_cinv γ k))
                      ([∗ set] k ∈ dom σ, block_cinv γ k).
Proof.
  clear.
  iIntros (Hcrashed) "Hpre Hfree Hpts".
  rewrite -?Hcrashed.
  iModIntro.
  iDestruct (crash_borrow_init_cancel ([∗ set] k ∈ alloc.free σ, Ψ k)
                                      ([∗ set] k ∈ alloc.free σ, block_cinv γ k) with "Hpre Hfree []") as "H".
  { iIntros "!>". iApply big_sepS_mono.
    iIntros (??) "H"; by iLeft. }

  assert (dom σ = (alloc.domain σ ∖ alloc.free σ) ∪ alloc.free σ) as ->.
  { rewrite /alloc.domain difference_union_L.
    apply alloc_post_crash_free_used in Hcrashed.
    set_solver. }
  iDestruct (alloc_post_crash_big_sepM_split_free with "Hpts") as "(Hfree&Hused)".
  { auto. }
  iApply (init_cancel_wand with "H [Hfree]").
  { iIntros "$". eauto. }
  iIntros "H".
  iApply big_sepS_union.
  { set_solver+. }
  iFrame. iApply (big_sepS_mono with "Hused").
  { iIntros (??) "H". by iRight. }
Qed.

Theorem is_allocator_alloc l σ :
  ([∗ set] k ∈ alloc.unused σ, Ψ k) -∗
  ▷ P σ -∗
  is_allocator_mem_pre l σ
  ={⊤}=∗ init_cancel (∃ γ, is_allocator l (alloc.domain σ) γ)
                     (alloc_crash_cond (alloc.domain σ) false).
Proof.
  clear Hitemcrash.
  iIntros "Hunused HP". iNamed 1.
  iMod (ghost_map_alloc σ) as (γheap) "(Hctx&Hpts)".
  iMod (ghost_var_alloc (alloc.free σ)) as (γfree) "(Hfree&Hfree_frag)".
  set (γ := {| alloc_status_name := γheap;
               alloc_free_name := γfree |}).

  iMod (ncinv_alloc Ninv _ (allocator_inv γ (alloc.domain σ)) with "[HP Hctx Hfree]") as "(#Hinv&Hallocinv)".
  { iNext. iExists _. iFrame. eauto. }

  iMod (free_block_init γ with "[$] [$] [$]") as "Hic"; first done.
  iModIntro.
  iApply (init_cancel_fupd ⊤).
  iApply (init_cancel_cfupd ⊤).
  iApply (init_cancel_wand with "Hic [Hfreemap Hfree_lock Hfree_frag]").
  { iIntros "Hblock".
    iMod (alloc_lock Nlock ⊤ _ (allocator_linv γ mref)%I
            with "[$Hfree_lock] [Hfreemap Hblock Hfree_frag]") as "#Hlock".
    { iExists _; iFrame. }
    iModIntro.
    iExists γ.
    rewrite /is_allocator.
    { iExists _, _; iFrame "#". }
  }
  iMod (own_disc_fupd_elim with "Hallocinv") as "Hallocinv".
  iIntros "Hpending HC".
  iModIntro.
  iMod (fupd_mask_subseteq (↑Ninv)) as "Hclo".
  { set_solver+. }
  iMod ("Hallocinv" with "[$]") as "Hallocinner".
  iDestruct "Hallocinner" as (?) "(>%Hdom&>Hstatus&>?&HP)".
  iNamed.
  iMod "Hclo".
  iModIntro.
  rewrite /alloc_crash_cond.

  iExists _. iFrame.
  fold (alloc.domain σ).
  rewrite /alloc.unused.
  rewrite -Hdom.
  iSplitR; first by auto.
  rewrite /alloc.free.
  rewrite -?big_sepM_dom ?big_sepM_filter'.
  iDestruct (big_sepM_mono_with_inv with "Hstatus Hpending") as "(_&$)".
  iIntros (k x Hlookup) "(Hctx&Hfree)".
  rewrite /free_block_pending.
  iDestruct "Hfree" as "[HΨ|Hused]".
  - iFrame. destruct (decide _); eauto.
  - iDestruct (ghost_map_lookup with "[$] Hused") as %Hlookup'.
    iFrame. rewrite decide_False //= => Heq. congruence.
Qed.

Lemma map_empty_difference `{Countable K} {V} (m: gmap K V) :
  ∅ ∖ m = ∅.
Proof.
  apply map_eq; intros.
  rewrite lookup_difference_None; eauto.
Qed.

Lemma set_empty_difference `{Countable K} (m: gset K) :
  ∅ ∖ m = ∅.
Proof.
  clear.
  set_solver.
Qed.

Theorem alloc_free_reserve σ new :
  alloc.free (<[new := block_reserved]> σ) =
  alloc.free σ ∖ {[new]}.
Proof.
  clear.
  rewrite /alloc.free /=.
  rewrite map_filter_insert_False //=.
  rewrite map_filter_delete dom_delete_L //.
Qed.

Theorem alloc_free_free σ new :
  alloc.free (<[new := block_free]> σ) =
  alloc.free σ ∪ {[new]}.
Proof.
  clear.
  rewrite /alloc.free /=.
  rewrite map_filter_insert_True //= dom_insert_L. set_solver.
Qed.

Theorem reserved_not_in_alloc_free σ a :
  σ !! a = Some block_reserved →
  a ∉ alloc.free σ.
Proof.
  clear.
  rewrite /alloc.free /= => Hlook.
  rewrite elem_of_dom. intros (x&(His&Heq)%map_filter_lookup_Some).
  simpl in Heq. rewrite Heq Hlook in His. congruence.
Qed.

Theorem alloc_free_subset σ :
  alloc.free σ ⊆ dom σ.
Proof. by apply dom_filter_subseteq. Qed.

(*
Theorem alloc_free_use σ new :
  alloc.free (set alloc.used (union new) σ) =
  alloc.free σ ∖ new.
Proof.
  clear.
  rewrite /alloc.free /=.
  set_solver.
Qed.
*)
  Opaque crash_borrow.

Theorem wp_Reserve (Q: option u64 → iProp Σ) l dset γ E1:
  ↑N ⊆ E1 →
  {{{ is_allocator l dset γ ∗
     (∀ σ σ' ma,
          ⌜match ma with
           | Some a => a ∈ alloc.free σ ∧ σ' = <[a := block_reserved]> σ
           | None => σ' = σ ∧ alloc.free σ = ∅
           end⌝ -∗
          ▷ P σ ={E1 ∖ ↑N}=∗ ▷ P σ' ∗ Q ma)
  }}}
    Allocator__Reserve #l @ E1
  {{{ a (ok: bool), RET (#a, #ok);
      if ok then Q (Some a) ∗ reserved_block γ a (Ψ a)
      else Q None }}}.
Proof.
  clear.
  iIntros (Hsub0 Φ) "(Hinv&Hfupd) HΦ". iNamed "Hinv".
  assert ((↑Nlock : coPset) ⊆ E1) as Hsub1.
  { solve_ndisj. }
  rewrite /Allocator__Reserve.

  wp_pures.
  iMod (readonly_load with "m") as (?) "m'".
  iMod (readonly_load with "free") as (?) "free'".

  wp_bind (lock.acquire _).
  wp_loadField.
  wp_apply (acquire_spec' with "His_lock"); first assumption.
  iIntros "(His_locked & Hinner)"; iNamed "Hinner".

  wp_loadField.
  wp_apply (wp_findKey with "Hfreemap").
  iIntros (k ok) "[%Hk Hfreemap]".

  wp_loadField.
  iDestruct "Hfreemap" as (m') "[Hfreemap %Hdom]".
  wp_apply (wp_MapDelete with "Hfreemap"); iIntros "Hfreemap".

  iAssert (is_addrset mref (freeset ∖ {[k]})) with "[Hfreemap]" as "Hfreemap".
  { iExists _; iFrame.
    iPureIntro.
    rewrite /map_del.
    rewrite dom_delete_L.
    set_solver. }

  wp_seq.
  (* Linearization point here. *)
  wp_bind (Skip).
  destruct ok.

  - (* extract block *)
    iApply (wp_crash_borrow_split _ _ _ _ _  (Ψ k) ([∗ set] k0 ∈ freeset ∖ {[k]} , Ψ k0)
                                             (block_cinv γ k) ([∗ set] k0 ∈ freeset ∖ {[k]} , block_cinv γ k0)
              with "Hborrows").
    { auto. }
    { iNext. rewrite big_sepS_delete; auto. }
    { iIntros "!> !> H". iLeft. auto. }
    { iIntros "!> !> H". iApply (big_sepS_mono with "H").
      iIntros. by iLeft. }
    {  rewrite -big_sepS_delete //. eauto. }
    iDestruct (big_sepS_delete _ _ k with "Hblocks") as "(Hmapsto&Hblocks)".
    { eassumption. }

    iInv "Halloc_inv" as "H" "Hclo".
    wp_pures.
    iNamed "H".

    iDestruct (ghost_var_agree with "Hfreeset_auth [$]") as %<-.
    iMod (fupd_mask_subseteq (E1 ∖ ↑N)) as "Hrestore_mask"; first solve_ndisj.
    iMod ("Hfupd" $! σ _ (Some k) with "[] [$]") as "(HP&HQ)".
    { iPureIntro; split; last by reflexivity. eauto. }
    iMod "Hrestore_mask" as "_".

    iMod (ghost_map_update block_reserved with "[$] Hmapsto") as "(Hctx&Hmapsto)".
    iCombine "Hfreeset_frag Hfreeset_auth" as "Hfreeset".
    iMod (ghost_var_update (alloc.free (<[k := block_reserved]>σ)) with "[$]")
         as "(Hfreeset_auth&Hfreeset_frag)".
    iMod ("Hclo" with "[HP Hfreeset_auth Hctx]").
    { iNext. iExists _. iFrame. iPureIntro.
      rewrite dom_insert_L.
      assert (k ∈ dom σ).
      { by apply alloc_free_subset. }
      set_solver.
    }
    iModIntro.
    iIntros "(Hborrow&Hborrows)".
    wp_loadField.
    wp_apply (release_spec' with "[Hfreeset_frag Hblocks Hborrows Hfreemap $His_locked $His_lock]");
      first assumption.
    { iExists _; iFrame.
      rewrite alloc_free_reserve. eauto.
    }
    wp_pures.
    iApply "HΦ"; iFrame.

    iFrame.
    { iExists _. eauto. }
  -
    iInv "Halloc_inv" as "H".
    wp_pures.
    iNamed "H".
    iDestruct (ghost_var_agree with "Hfreeset_auth [$]") as %<-.
    iMod (fupd_mask_subseteq (E1 ∖ ↑N)) as "Hrestore_mask"; first solve_ndisj.
    iMod ("Hfupd" $! σ _ None with "[] [$]") as "(HP&HQ)".
    { iPureIntro; split; first by reflexivity. congruence. }
    iMod "Hrestore_mask" as "_".

    iModIntro. iSplitL "HP Hfreeset_auth Hstatus".
    { iNext. iExists _. iFrame. iPureIntro. eauto. }

    wp_loadField.
    wp_apply (release_spec' with "[Hfreeset_frag Hblocks Hborrows Hfreemap $His_locked $His_lock]");
      first assumption.
    { iExists _; iFrame. rewrite Hk set_empty_difference. iFrame. }
    wp_pures.
    iApply "HΦ"; by iFrame.
Qed.

(* NOTE: we used to have a proof of this (with nearly the same proof script as
above). This spec supports using durable resources for the fupd, preserving them
on crash. We don't need this feature for our examples, though. *)
Theorem wpc_Reserve (Q: option u64 → iProp Σ) (Qc: iProp Σ) l dset γ E1 :
  ↑N ⊆ E1 →
  □ (∀ o, Q o -∗ Qc) -∗
  {{{ is_allocator l dset γ ∗
     (∀ σ σ' ma,
          ⌜match ma with
           | Some a => a ∈ alloc.free σ ∧ σ' = <[a := block_reserved]> σ
           | None => σ' = σ ∧ alloc.free σ = ∅
           end⌝ -∗
          ▷ P σ ={E1 ∖ ↑N}=∗ ▷ P σ' ∗ Q ma) ∧
      Qc
  }}}
    Allocator__Reserve #l @ E1
  {{{ a (ok: bool), RET (#a, #ok);
      if ok then Q (Some a) ∗ reserved_block γ a (Ψ a)
      else Q None }}}
  {{{ Qc }}}.
Proof.
  iIntros (?) "#HQc".
  iIntros "!>" (Φ Φc) "[Halloc Hfupd] HΦ".
Abort.

Lemma block_cinv_free_pred γ a :
  Ψ a -∗ block_cinv γ a.
Proof.
  iIntros "HΨ".
  iLeft; auto.
Qed.

Lemma block_cinv_from_used γ a :
  used_block γ a -∗ block_cinv γ a.
Proof.
  rewrite /used_block /block_cinv.
  iIntros "Hused".
  iRight; auto.
Qed.

Lemma prepare_reserved_block_reuse R' R γ e a Φ Φc :
  language.to_val e = None →
  reserved_block γ a R -∗
   Φc ∧
  (R -∗
   reserved_block_in_prep γ a -∗
   WPC e @ ⊤ {{ λ v, (reserved_block γ a (R' v) -∗ Φc ∧ Φ v) ∗
                                           (R' v) ∗
                                           reserved_block_in_prep γ a ∗
                                           □ (R' v -∗ block_cinv γ a) }}
                                   {{ Φc ∗ block_cinv γ a }}) -∗
  WPC e @ ⊤ {{ Φ }} {{ Φc }}.
Proof.
  iIntros (?) "Hreserved H".
  iNamed "Hreserved".
  iDestruct "Halloc_inv" as (?) "#Hinv".
  iApply (wpc_crash_borrow_open_modify _ _ _ with "Hcrashinv [H Hmapsto]"); try iFrame; auto.
  iSplit.
  - iDestruct "H" as "($&_)".
  - iIntros "HR". iDestruct "H" as "(_&H)".
    iSpecialize ("H" with "[$] [Hmapsto]").
    { iFrame. iExists _. eauto. }
    iApply (wpc_strong_mono with "H"); eauto.
    iSplit.
    * iIntros (?) "(Hclose&HR&Hprep&#Hcinv)". iModIntro. iFrame. iFrame "#".
      iExists (R' v).
      iFrame "HR".
      iSplitL "".
      { iModIntro. eauto. }
      iIntros. iApply "Hclose". iSplitR "Hprep".
      ** by iFrame.
      ** iIntros. eauto.
    * eauto.
Qed.

Lemma prepare_reserved_block E1 R γ e a Φ Φc :
  language.to_val e = None →
  reserved_block γ a R -∗
  Φc ∧
  (R -∗
   reserved_block_in_prep γ a -∗
   WPC e @ E1 {{ λ v, (Φc ∧ Φ v) ∗ block_cinv γ a }} {{ Φc ∗ block_cinv γ a }}) -∗
  WPC e @  E1 {{ Φ }} {{ Φc }}.
Proof.
  iIntros (?) "Hreserved H".
  iNamed "Hreserved".
  iDestruct "Halloc_inv" as (?) "#Hinv".
  iApply (wpc_crash_borrow_open_modify  _ _ with "[$] [H Hmapsto]"); try iFrame; auto.
  iSplit.
  - iDestruct "H" as "($&_)".
  - iIntros "HR". iDestruct "H" as "(_&H)".
    iSpecialize ("H" with "[$] [Hmapsto]").
    { iFrame. iExists _. eauto. }
    iApply (wpc_strong_mono with "H"); eauto.
    iSplit.
    * iIntros (?) "(Hclose&Hcinv)". iModIntro.
      iExists (block_cinv γ a). iFrame.
      iSplitL "".
      ** eauto.
      ** eauto.
    * eauto.
Qed.

Lemma free_mark_used_non_free σ a:
  σ !! a ≠ Some block_free →
  alloc.free (<[a := block_used]> σ) = alloc.free σ.
Proof.
  intros Hneq. rewrite /alloc.free.
  rewrite map_filter_insert_not' //=.
  { intros []; subst; eauto. }
Qed.

Lemma dom_update_status σ a x x':
  σ !! a = Some x →
  dom (<[a := x']>σ) = dom σ.
Proof.
  intros Hlookup. rewrite dom_insert_L.
  cut (a ∈ dom σ).
  { set_solver+. }
  apply elem_of_dom; eauto.
Qed.

Lemma mark_used' E γ a Q:
  ↑Ninv ⊆ E →
   reserved_block_in_prep γ a -∗
   (∀ σ, ⌜ σ !! a = Some block_reserved ⌝ -∗
         ▷ P σ -∗ |NC={E ∖ ↑ N}=> ▷ P (<[a := block_used]> σ) ∗ Q)
   -∗ |NC={E}=> Q ∗ used_block γ a.
Proof.
  iIntros (?) "Hprep Hfupd".
  iNamed "Hprep".
  iDestruct "Halloc_inv" as (d) "#Hinv".
  iInv "Hinv" as "H" "Hclo".
  rewrite /allocator_inv.
  iDestruct "H" as (?) "(>Hdom&>Hstatus&>Hauth&HP)".
  iNamed "Hdom". iNamed "Hstatus". iNamed "Hauth".
  iDestruct (ghost_map_lookup with "[$] Hmapsto") as %Hlookup'.
  iMod (ncfupd_mask_subseteq (E ∖ ↑N)) as "Hrestore_mask"; first solve_ndisj.
  iMod ("Hfupd" with "[//] [$]") as "(HP&HQ)".
  iMod "Hrestore_mask" as "_".
  iMod (ghost_map_update block_used with "[$] Hmapsto") as "(Hctx&Hmapsto)".
  iMod ("Hclo" with "[HP Hctx Hfreeset_auth]").
  { iNext. iExists _. iFrame "HP Hctx".
    rewrite (dom_update_status σ a block_reserved) //=.
    iFrame "%".
    rewrite (free_mark_used_non_free) //=.
    intros Heq; subst; eauto. rewrite Heq in Hlookup'. congruence.
  }
  iModIntro. by iFrame.
Qed.

Lemma mark_used E γ a Q:
  ↑Ninv ⊆ E →
   reserved_block_in_prep γ a -∗
   (∀ σ, ⌜ σ !! a = Some block_reserved ⌝ -∗
         P σ -∗ |NC={E ∖ ↑ N}=> ▷ P (<[a := block_used]> σ) ∗ Q)
   -∗ |NC={E, E ∖ ↑Ninv}=> ▷ |NC={E ∖ ↑Ninv, E}=> Q ∗ used_block γ a.
Proof.
  iIntros (?) "Hprep Hfupd".
  iNamed "Hprep".
  iDestruct "Halloc_inv" as (d) "#Hinv".
  iInv "Hinv" as "H" "Hclo".
  iModIntro. iNext. iNamed "H".
  iDestruct (ghost_map_lookup with "[$] Hmapsto") as %Hlookup'.
  iMod (ncfupd_mask_subseteq (E ∖ ↑N)) as "Hrestore_mask"; first solve_ndisj.
  iMod ("Hfupd" with "[//] [$]") as "(HP&HQ)".
  iMod "Hrestore_mask" as "_".
  iMod (ghost_map_update block_used with "[$] Hmapsto") as "(Hctx&Hmapsto)".
  iMod ("Hclo" with "[HP Hctx Hfreeset_auth]").
  { iNext. iExists _. iFrame "HP Hctx".
    rewrite (dom_update_status σ a block_reserved) //=.
    iFrame "%".
    rewrite (free_mark_used_non_free) //=.
    intros Heq; subst; eauto. rewrite Heq in Hlookup'. congruence.
  }
  iModIntro. by iFrame.
Qed.

(*
Lemma gset_difference_difference `{Countable K} (A B C: gset K) :
  C ⊆ A →
  A ∖ (B ∖ C) = A ∖ B ∪ C.
Proof using.
  clear.
  intros.
  apply set_eq; intros k.
  rewrite !elem_of_difference.
  intuition.
  - destruct (decide (k ∈ C)); set_solver.
  - set_solver.
  - set_solver.
Qed.

Theorem alloc_free_free σ new :
  new ⊆ σ.(alloc.domain) →
  alloc.free (set alloc.used (λ used, used ∖ new) σ) =
  alloc.free σ ∪ new.
Proof.
  intros Hsub.
  rewrite /alloc.free /=.
  rewrite gset_difference_difference //.
Qed.

Lemma alloc_used_valid γ a used :
  ghost_map_auth (γ.(alloc_status_name)) 1 (gset_to_gmap () used) -∗
  alloc_used γ a -∗
  ⌜a ∈ used⌝.
Proof.
  rewrite /alloc_used.
  iIntros "Hctx Hused".
  iDestruct (ghost_map_lookup with "Hctx Hused") as %Hlookup.
  iPureIntro.
  apply lookup_gset_to_gmap_Some in Hlookup as [? _]; auto.
Qed.
*)

(** XXX: should probably make this a WPC in case the fupd requires a durable resource *)
Theorem wp_Free (Q: iProp Σ) E l d γ (a: u64) :
  ↑N ⊆ E →
  {{{ is_allocator l d γ ∗ reserved_block γ a (Ψ a) ∗
     (∀ σ, ⌜ σ !! a = Some block_reserved ⌝ -∗ ▷ P σ -∗ |NC={E ∖↑N}=> ▷ P (<[ a := block_free ]> σ) ∗ Q)
  }}}
    Allocator__Free #l #a @ E
  {{{ RET #(); Q }}}.
Proof.
  clear Hitemcrash.
  iIntros (Hsub1 Φ) "(Halloc&Hreserved&Hfupd) HΦ".
  iNamed "Halloc".
  assert (↑Nlock ⊆ E) as Hsub2 by solve_ndisj.
  iMod (readonly_load with "m") as (?) "m'".
  iMod (readonly_load with "free") as (?) "free'".
  wp_call.
  wp_loadField.
  wp_apply (acquire_spec' with "His_lock").
  { auto. }
  iIntros "(Hlocked&Hinv)"; iNamed "Hinv".
  wp_loadField.
  iDestruct "Hfreemap" as (m) "[Hfreemap %Hdom]".
  wp_apply (wp_MapInsert _ _ _ _ () with "Hfreemap"); first by auto.
  iIntros "Hfreemap".
  do 2 wp_pure1.
  wp_bind (Skip).

  iInv "Halloc_inv" as "H" "Hclo".
  wp_pure1.
  iNamed "H".
  (* TODO: iNamed doesn't work because reserved_block re-uses the name
  Halloc_inv from is_allocator *)
  iDestruct "Hreserved" as "(Hcrashinv&Hmapsto&Halloc_inv_block)".
  iDestruct (ghost_var_agree with "Hfreeset_auth [$]") as %<-.
  iDestruct (ghost_map_lookup with "[$] Hmapsto") as %Hlookup'.
  iMod (ghost_map_update block_free with "[$] Hmapsto") as "(Hctx&Hmapsto)".
  iCombine "Hfreeset_auth Hfreeset_frag" as "Hfreeset".
  iMod (ghost_var_update (alloc.free (<[a := block_free]>σ)) with "[$]")
    as "(Hfreeset_auth&Hfreeset_frag)".
  iMod (fupd_mask_subseteq (E ∖ ↑N)) as "Hrestore_mask"; first solve_ndisj.
  iMod ("Hfupd" $! σ with "[%//] HP") as "[HP HQ]".
  iMod "Hrestore_mask" as "_".
  iMod ("Hclo" with "[HP Hctx Hfreeset_auth]") as "_".
  { iNext. iExists _. iFrame. erewrite dom_update_status; eauto. }
  iModIntro. wp_pures.
  iAssert (is_addrset mref (alloc.free (<[a := block_free]>σ))) with "[Hfreemap]" as "Hfreemap".
  { iExists _; iFrame.
    iPureIntro.
    rewrite /map_insert dom_insert_L alloc_free_free.
    set_solver. }
  wp_bind (struct.loadF _ _ _).
  iApply (wp_crash_borrow_combine _ _ _
                                ([∗ set] k0 ∈ alloc.free (<[a := block_free]> σ), Ψ k0)%I
                                ([∗ set] k0 ∈ alloc.free (<[a := block_free]> σ), block_cinv γ k0)%I
            with "Hcrashinv Hborrows").
  { auto. }
  { iNext. iModIntro. iApply big_sepS_mono. iIntros (??) "H"; by iLeft. }
  { iNext.
    rewrite alloc_free_free. rewrite big_sepS_union; last first.
    { apply disjoint_singleton_r; auto. by apply reserved_not_in_alloc_free. }
    rewrite big_opS_singleton.
    iIntros "($&$)". }
  { iNext.
    rewrite alloc_free_free. rewrite big_sepS_union; last first.
    { apply disjoint_singleton_r; auto. by apply reserved_not_in_alloc_free. }
    rewrite big_opS_singleton.
    iIntros "($&$)". eauto. }
  wp_loadField.
  iIntros "Hborrows".
  wp_apply (release_spec' with "[$His_lock $Hlocked Hmapsto Hfreemap Hfreeset_frag Hblocks Hborrows]").
  { auto. }
  {
    iExists _. iFrame.
    rewrite alloc_free_free.
    rewrite big_sepS_union; last first.
    { apply disjoint_singleton_r; auto. by apply reserved_not_in_alloc_free. }
    rewrite big_opS_singleton.
    iFrame.
  }
  wp_pures.
  iApply ("HΦ" with "[$]").
Qed.

End goose.

Section goose.
Context `{ffi_sem: ffi_semantics}.
Context `{!ffi_interp ffi}.
Context {ext_tys: ext_types ext}.
Context `{!heapGS Σ}.
Context `{!allocG Σ}.

Context (P: heapGS Σ → alloc.t → iProp Σ).
Context (Ψ: heapGS Σ → u64 → iProp Σ).

Instance allocator_crash_cond_stable d b :
  (∀ x, IntoCrash (▷ P _ x) (λ hG, ▷ P hG x)%I) →
  (∀ x, IntoCrash (Ψ _ x) (λ hG, Ψ hG x)) →
  IntoCrash (alloc_crash_cond (P _) (Ψ _) d b) (λ hG, alloc_crash_cond (P hG) (Ψ hG) d b).
Proof.
  intros.
  hnf; iNamed 1.
  iCrash.
  iExists _. iFrame. eauto.
Qed.

Instance allocator_crash_cond_no_later_stable d b :
  (∀ x, IntoCrash (P _ x) (λ hG, P hG x)%I) →
  (∀ x, IntoCrash (Ψ _ x) (λ hG, Ψ hG x)) →
  IntoCrash (alloc_crash_cond_no_later (P _) (Ψ _) d b) (λ hG, alloc_crash_cond_no_later (P hG) (Ψ hG) d b).
Proof.
  intros.
  hnf; iNamed 1.
  iCrash.
  iExists _. iFrame. eauto.
Qed.

End goose.


(* This is slightly modified version of iris/theories/heap_lang/lib/counter.v *)
From iris.proofmode Require Import tactics.
From iris.algebra Require Import lib.frac_auth auth.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang lib.par.
From iris.heap_lang Require Import proofmode notation.

Definition incr : expr :=
λ: "l", let: "n" := !"l" in
        "l" <− "n" + #1.

Lemma incr_spec (l : loc) (n : Z)


Require Import Bool Arith List CpdtTactics SfLib LibTactics Omega.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

Require Import Identifier Environment Imperative Types Augmented.

Inductive low_event : typenv -> level -> event -> Prop :=
| low_assigment_is_low_event:
    forall Γ ℓ ℓ' x u,
      ( ℓ' ⊑ ℓ) ->
      low_event Γ ℓ (AssignmentEvent ℓ' x u).

Hint Constructors low_event.

Definition high_event Γ ℓ evt := ~low_event Γ ℓ evt.

Definition low_event_step  Γ ℓ evt cfg cfg' :=
  event_step Γ evt cfg cfg' /\ low_event Γ ℓ evt.
Definition high_event_step Γ ℓ evt cfg cfg' :=
  event_step Γ evt cfg cfg' /\ high_event Γ ℓ evt.

Hint Unfold high_event.
Hint Unfold high_event_step.
Hint Unfold low_event_step.

Definition event_low_eq Γ ev1 ev2 :=
     (low_event Γ Low ev1 <-> low_event Γ Low ev2)
      /\  (low_event Γ Low ev1 -> ev1 = ev2).
Hint Unfold event_low_eq.

Inductive bridge_step_num:
  typenv -> level -> config -> config -> event -> nat -> Prop :=
| bridge_low_num:
    forall Γ ℓ evt cfg cfg',
      low_event_step Γ ℓ evt cfg cfg' ->
      bridge_step_num Γ ℓ cfg cfg' evt 0
| bridge_stop_num:
    forall Γ ℓ evt cfg cfg',
      high_event_step Γ ℓ evt cfg cfg' ->
      is_stop cfg' ->
      bridge_step_num Γ ℓ cfg cfg' evt 0
| bridge_trans_num:
    forall Γ ℓ evt' evt'' cfg cfg' cfg'' n,
      high_event_step Γ ℓ evt' cfg cfg' ->
      is_not_stop cfg' ->
      bridge_step_num Γ ℓ  cfg' cfg'' evt''  n ->
      bridge_step_num Γ ℓ  cfg cfg'' evt'' (S n).

Tactic Notation "bridge_num_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "bridge_low_num" | Case_aux c "bridge_stop_num" | Case_aux c "bridge_trans_num" ].

Notation " t '⇨+/(SL,' Γ ',' obs ',' n ')'  t' " :=
  (bridge_step_num Γ Low t t' obs n) (at level 40).

Notation " t '↷' '(' Γ ',' obs ',' n ')'  t' " :=
  (bridge_step_num Γ Low t t' obs n) (at level 40).

(* Multi-step reduction *)

Inductive multi {X:Type} (R: relation X): relation X :=
   | multi_refl : forall (x : X), multi R x x
   | multi_step : forall (x y z : X),
         R x y ->
         multi R y z ->
         multi R x z.
Hint Resolve multi_refl.

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> (multi R) x y.
Proof.
  intros X R x y H.
  apply multi_step with y. apply H. apply multi_refl. Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y ->
      multi R y z ->
      multi R x z.
Proof.
   intros.
   multi_cases (induction H) Case.
   Case "multi_refl".
      assumption.
  Case "multi_step".
      apply multi_step with y; try apply IHmulti; assumption.

Qed.

(* Multi-step transitions *)
Definition multistep := multi step.
Notation " t '⇒*' t' " := (multistep t t') (at level 40).

(* Indexed multi relation *)

Definition relation_idx := fun X : Type => X -> X -> nat -> Prop.

Inductive multi_idx {X:Type} (R: relation X) :relation_idx X :=
   | multi_refl_zero : forall (x : X), multi_idx R x x 0
   | multi_step_more : forall (x y z : X) n,
                         R x y ->
                         multi_idx R y z n ->
                         multi_idx R x z (S n).

Hint Resolve multi_refl_zero.

Tactic Notation "multi_idx_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl_zero" | Case_aux c "multi_step_more" ].

(* Indexed multi-step transitions *)
Definition multistep_idx := multi_idx step.
Notation " t '⇒/+' n '+/' s" := (multi_idx step t s n) (at level 40).

(* A pair of sanity check theorems; we don't really use them *)

Theorem multi_idx_R:
  forall (X:Type) (R: relation X) ( x y : X),
    R x y -> (multi_idx R) x y 1.
Proof.
  intros.
  eapply multi_step_more; eauto.
Qed.

Theorem multi_idx_trans:
  forall n (X: Type) (R: relation X) ( x y z: X ) m,
    multi_idx R x y n ->
    multi_idx R y z m ->
    multi_idx R x z (n + m).
Proof.
  intros n X R.
  induction n; intros.
  -     inverts* H.

  - inversion H; subst; auto.
    assert (multi_idx R x y0 1) by (econstructor; eauto).

    specialize (IHn y0 y z m H5 H0).
    replace (S n + m) with (S (n + m)) by omega.
    eapply multi_step_more; eauto.
Qed.

(* A relation from multi to indexed multi; this is used in the proof of Standard TINI *)

Theorem from_multi_to_multi_idx:
  forall (X:Type) (R:relation X) (x y : X),
    multi R x y -> exists n, (multi_idx R x y n).
Proof.
  intros.
  induction H.
  - (exists 0; constructor).
  - destruct IHmulti as [n ?IHmulti].
    (exists (S n)).
    econstructor; eauto.
Qed.