(**
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.


(* 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.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export Omega.
Require Export tactics2.
Require Export Morphisms Setoid Field.

Class Cast A B := cast: A -> B.
Arguments cast _ _ {Cast} _.
Notation "' x" := (cast _ _ x) (at level 20).
Typeclasses Transparent Cast.

Section DTime.

  Fixpoint ntimes {T} (n : nat) (zero one : T) (add : T -> T -> T) : T :=
    match n with
    | 0 => zero
    | S n => add one (ntimes n zero one add)
    end.

  Class DTimeContext :=
    MkDTimeContext
      {
        dt_T                : Type;
        dt_0                : dt_T;
        dt_1                : dt_T;
        dt_add              : dt_T -> dt_T -> dt_T;
        dt_mul              : dt_T -> dt_T -> dt_T;
        dt_sub              : dt_T -> dt_T -> dt_T;
        dt_opp              : dt_T -> dt_T;
        dt_eq               : relation dt_T;
        dt_lt               : relation dt_T;
        dt_le               : relation dt_T;
        dt_eqv              : Equivalence dt_eq;
        dt_ring             : ring_theory dt_0 dt_1 dt_add dt_mul dt_sub dt_opp dt_eq;
        dt_nat_inj          : nat -> dt_T;
        dt_approx           : dt_T -> nat;

        dt_add_morph        : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_eq (dt_add x u) (dt_add y v);
        dt_mul_morph        : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_eq (dt_mul x u) (dt_mul y v);
        dt_opp_morph        : forall x y, dt_eq x y -> dt_eq (dt_opp x) (dt_opp y);
        dt_le_morph         : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_le x u -> dt_le y v;
        dt_lt_morph         : forall x y, dt_eq x y -> forall u v, dt_eq u v -> dt_lt x u -> dt_lt y v;

        dt_nat_inj_cond     : forall (n : nat), dt_eq (dt_nat_inj n) (ntimes n dt_0 dt_1 dt_add);
        dt_le_refl          : forall t , dt_le t t;
        dt_lt_irrefl        : forall x, ~ (dt_lt x x);
        dt_add_le_compat    : forall a b c d, dt_le a c -> dt_le b d -> dt_le (dt_add a b) (dt_add c d);
        dt_add_lt_le_compat : forall a b c d, dt_lt a c -> dt_le b d -> dt_lt (dt_add a b) (dt_add c d);
        dt_mul_le_compat_r  : forall a b c, dt_le a b -> dt_le dt_0 c -> dt_le (dt_mul a c) (dt_mul b c);
        dt_mul_lt_compat_r  : forall a b c, dt_lt a b -> dt_lt dt_0 c -> dt_lt (dt_mul a c) (dt_mul b c);
        dt_le_trans         : forall a b c, dt_le a b -> dt_le b c -> dt_le a c;
        dt_lt_trans         : forall a b c, dt_lt a b -> dt_lt b c -> dt_lt a c;
        dt_le_lt_trans      : forall a b c, dt_le a b -> dt_lt b c -> dt_lt a c;
        dt_lt_le_trans      : forall a b c, dt_lt a b -> dt_le b c -> dt_lt a c;

        dt_mul_0_l          : forall x, dt_eq (dt_mul dt_0 x) dt_0;
        dt_mul_le_r_le      : forall x y z, dt_lt dt_0 z -> dt_le (dt_mul x z) (dt_mul y z) -> dt_le x y;
        dt_mul_lt_r_lt      : forall x y z, dt_lt dt_0 z -> dt_lt (dt_mul x z) (dt_mul y z) -> dt_lt x y;
        dt_lt_0_1           : dt_lt dt_0 dt_1;
        dt_lt_le_weak       : forall a b, dt_lt a b -> dt_le a b;
        dt_lt_le_dec        : forall x y, {dt_lt x y} + {dt_le y x};
        dt_eq_dec           : forall x y, {dt_eq x y} + {~ dt_eq x y};
        dt_nat_inj_add_dist : forall n m, dt_eq (dt_add (dt_nat_inj n) (dt_nat_inj m)) (dt_nat_inj (n + m));
        dt_nat_nat_inj_le   : forall n m, n <= m -> dt_le (dt_nat_inj n) (dt_nat_inj m);
        dt_nat_nat_inj_lt   : forall n m, n < m -> dt_lt (dt_nat_inj n) (dt_nat_inj m); (* FIX: DO we really need this one? *)
        dt_nat_inj_lt_nat   : forall n m, dt_lt (dt_nat_inj n) (dt_nat_inj m) -> n < m;
      }.

  Context { dtc : DTimeContext }.

  Global Add Parametric Relation :
    dt_T dt_eq
      reflexivity  proved by (@Equivalence_Reflexive  dt_T dt_eq dt_eqv)
      symmetry     proved by (@Equivalence_Symmetric  dt_T dt_eq dt_eqv)
      transitivity proved by (@Equivalence_Transitive dt_T dt_eq dt_eqv)
    as dt_eq_rel.

  Global Add Parametric Relation :
    dt_T dt_le
      reflexivity  proved by dt_le_refl
      transitivity proved by dt_le_trans
    as dt_le_rel.

  Global Add Parametric Relation :
    dt_T dt_lt
      transitivity proved by dt_lt_trans
    as dt_lt_rel.

  Global Add Morphism dt_add with signature (dt_eq ==> dt_eq ==> dt_eq) as dt_add_ext.
  Proof. exact dt_add_morph. Qed.

  Global Add Morphism dt_mul with signature (dt_eq ==> dt_eq ==> dt_eq) as dt_mul_ext.
  Proof. exact dt_mul_morph. Qed.

  Global Add Morphism dt_opp with signature (dt_eq ==> dt_eq) as dt_opp_ext.
  Proof. exact dt_opp_morph. Qed.

  Add Ring rg_dt : dt_ring.

  Global Instance dt_le_eq : Proper (dt_eq ==> dt_eq ==> flip impl) dt_le.
  Proof.
    introv h1 h2 h3.
    eapply dt_le_morph; try exact h3; symmetry; auto.
  Qed.

  Global Instance dt_le_eq1 : forall x,  Proper (dt_eq ==> flip impl) (dt_le x).
  Proof.
    introv h1 h2.
    eapply dt_le_morph; try exact h2; try symmetry; auto; try reflexivity.
  Qed.

  Global Instance dt_lt_eq : Proper (dt_eq ==> dt_eq ==> flip impl) dt_lt.
  Proof.
    introv h1 h2 h3.
    eapply dt_lt_morph; try exact h3; symmetry; auto.
  Qed.

  Global Instance dt_add_eq : Proper (dt_eq ==> dt_eq ==> dt_eq) dt_add.
  Proof.
    introv h1 h2.
    eapply dt_add_morph; auto.
  Qed.

  (* We use positive rationals to model time *)
  Record PosDTime :=
    MkPosDTime
      {
        pos_dt_t :> dt_T;
        pos_dt_le : dt_le dt_0 pos_dt_t
      }.

  Lemma dt_le_0_ntimes :
    forall n,
      dt_le dt_0 (ntimes n dt_0 dt_1 dt_add).
  Proof.
    induction n; simpl; try reflexivity;[].
    pose proof (Radd_0_l dt_ring dt_0) as z.
    pose proof (dt_add_le_compat dt_0 dt_0 dt_1 (ntimes n dt_0 dt_1 dt_add)) as w.
    repeat (autodimp w hyp).
    { apply dt_lt_le_weak; apply dt_lt_0_1. }
    eapply dt_le_trans;[|exact w].
    rewrite z; reflexivity.
  Qed.

  Definition pdt_lt (q1 q2 : PosDTime) := dt_lt q1 q2.

  Definition pdt_mult (q1 q2 : PosDTime) : PosDTime.
  Proof.
    exists (dt_mul q1 q2).
    destruct q1 as [q1 c1], q2 as [q2 c2]; simpl.
    pose proof (dt_mul_le_compat_r dt_0 q1 q2) as w.
    repeat (autodimp w hyp).
    eapply dt_le_trans;[|exact w]; clear w.
    rewrite dt_mul_0_l; try reflexivity; auto.
  Defined.

  Definition pdt_plus (q1 q2 : PosDTime) : PosDTime.
  Proof.
    exists (dt_add q1 q2).
    destruct q1 as [q1 c1], q2 as [q2 c2]; simpl.
    pose proof (dt_add_le_compat dt_0 dt_0 q1 q2) as w.
    repeat (autodimp w hyp).
    eapply dt_le_trans;[|exact w]; clear w.
    rewrite (Radd_0_l dt_ring dt_0); try reflexivity.
  Defined.

  Delimit Scope dtime with dtime.
  Open Scope dtime.
  Infix "<"  := dt_lt  (at level 70) : dtime.
  Infix "<=" := dt_le  (at level 70) : dtime.
  Infix "+"  := dt_add : dtime.
  Infix "-"  := dt_sub : dtime.
  Infix "*"  := dt_mul : dtime.
  Infix "==" := dt_eq  (at level 70) : dtime.
  Notation "a <= b <= c" := ((a <= b) /\ (b <= c)) : dtime.
  Close Scope dtime.

  Definition nat2pdt : nat -> PosDTime.
  Proof.
    introv n.
    exists (dt_nat_inj n).
    rewrite dt_nat_inj_cond.
    apply dt_le_0_ntimes.
  Defined.

  Global Coercion nat2pdt : nat >-> PosDTime.

  Global Instance n2t : Cast nat PosDTime.
  Proof.
    introv n.
    exists (dt_nat_inj n).
    rewrite dt_nat_inj_cond.
    apply dt_le_0_ntimes.
  Defined.

  Class TimeConstraint :=
    {
      mu  : PosDTime; (* maximum message generation and transmission delay *)
      tau : PosDTime; (* maximum clock drift *)

      dlt : PosDTime; (* minimum message generation and transmission delay *)

      mu_strict_pos  : (0 < mu)%dtime;
      tau_strict_pos : (0 < tau)%dtime;
      dlt_strict_pos : (0 < dlt)%dtime;

      dlt_le_mu      : (dlt <= mu)%dtime;
    }.

  Context { tc : TimeConstraint }.

  (* use this abstraction instead of [mu + tau] *)
  Definition epoch_duration : dt_T := (mu + tau)%dtime.

  Lemma eq_dt_0 : dt_eq (dt_nat_inj 0) dt_0.
  Proof.
    rewrite dt_nat_inj_cond; simpl; auto; try reflexivity.
  Qed.

  Lemma eq_dt_1 : dt_eq (dt_nat_inj 1) dt_1.
  Proof.
    rewrite dt_nat_inj_cond; simpl; auto.
    rewrite (Radd_comm dt_ring).
    rewrite (Radd_0_l dt_ring); reflexivity.
  Qed.

  Lemma mu_plus_tau_pos : (0 < mu + tau)%dtime.
  Proof.
    pose proof (dt_add_lt_le_compat dt_0 dt_0 mu tau) as w.
    rewrite (Radd_0_l dt_ring dt_0) in w.
    rewrite <- eq_dt_0 in w; apply w; auto;
      try (apply mu_strict_pos).
      try (apply dt_lt_le_weak; apply tau_strict_pos).
  Qed.
  Hint Resolve mu_plus_tau_pos : dtime.

  Lemma mu_plus_tau_pos2 : (dt_0 < mu + tau)%dtime.
  Proof.
    rewrite <- eq_dt_0; eauto 2 with dtime.
  Qed.
  Hint Resolve mu_plus_tau_pos2 : dtime.

  Lemma mu_plus_tau_ge_0 : (0 <= mu + tau)%dtime.
  Proof.
    apply dt_lt_le_weak; apply mu_plus_tau_pos.
  Qed.
  Hint Resolve mu_plus_tau_ge_0 : dtime.

  Lemma mu_plus_tau_ge_dt0 : (dt_0 <= mu + tau)%dtime.
  Proof.
    rewrite <- eq_dt_0; eauto 2 with dtime.
  Qed.
  Hint Resolve mu_plus_tau_ge_dt0 : dtime.

  Lemma dt_le_lt_dec : forall x y, {(x <= y)%dtime} + {(y < x)%dtime}.
  Proof.
    introv.
    destruct (dt_lt_le_dec y x); tcsp.
  Defined.

  Definition PosDTime0 : PosDTime.
  Proof.
    exact (MkPosDTime dt_0 (dt_le_refl _)).
  Defined.

  Lemma time_plus_tau_le_aux :
    forall (t : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t <= n1 * (mu + tau))%dtime
      -> (t + (mu + tau) <= (S n2) * (mu + tau))%dtime.
  Proof.
    introv w1 w2.

    eapply dt_le_trans;[apply dt_add_le_compat;[eauto|apply dt_le_refl] |]; clear w2.

    pose proof (Rdistr_l
                  dt_ring
                  n1
                  1
                  (mu + tau)%dtime) as xx.
    simpl in *.
    rewrite eq_dt_1, (Rmul_1_l dt_ring) in xx.
    rewrite <- xx; clear xx.
    apply dt_mul_le_compat_r;[|rewrite <- eq_dt_0;eauto 2 with dtime];[].
    rewrite <- eq_dt_1.
    rewrite dt_nat_inj_add_dist; simpl.
    apply dt_nat_nat_inj_le; try omega.
  Qed.

  Lemma time_plus_mu_tau_lt :
    forall (t1 t2 : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t1 <= n1 * (mu + tau))%dtime
      -> ((S n2) * (mu + tau) < t2)%dtime
      -> (t1 + (mu + tau) < t2)%dtime.
  Proof.
    introv w1 w2 w3.
    eapply dt_le_lt_trans;[|eauto]; clear w3.
    eapply time_plus_tau_le_aux; eauto.
  Qed.

  Lemma time_plus_mu_tau_le :
    forall (t1 t2 : PosDTime) (n1 n2 : nat),
      n1 < S n2
      -> (t1 <= n1 * (mu + tau))%dtime
      -> ((S n2) * (mu + tau) < t2)%dtime
      -> (t1 + (mu + tau) <= t2)%dtime.
  Proof.
    introv w1 w2 w3.
    apply dt_lt_le_weak.
    eapply time_plus_mu_tau_lt; eauto.
  Qed.

  Lemma dt_mul_1_l :
    forall t, (dt_nat_inj 1 * t == t)%dtime.
  Proof.
    introv; simpl.
    rewrite eq_dt_1.
    apply (Rmul_1_l dt_ring).
  Qed.

  Lemma dt_add_0_l :
    forall t, (dt_nat_inj 0 + t == t)%dtime.
  Proof.
    introv; simpl.
    rewrite eq_dt_0.
    apply (Radd_0_l dt_ring).
  Qed.

  Lemma dt_mul_le_r :
    forall x y z, (0 < z)%dtime -> (x * z <= y * z)%dtime <-> (x <= y)%dtime.
  Proof.
    introv gt0; split; intro h.

    { eapply dt_mul_le_r_le;eauto.
      rewrite <- eq_dt_0; auto. }

    { apply dt_mul_le_compat_r; auto.
      apply dt_lt_le_weak.
      rewrite <- eq_dt_0; auto. }
  Qed.

  Lemma lt_0_twice_implies_lt_prod :
    forall a b,
      (nat2pdt 0 < a)%dtime
      -> (nat2pdt 0 < b)%dtime
      -> (nat2pdt 0 < a * b)%dtime.
  Proof.
    introv H1 H2.
    pose proof (dt_mul_lt_compat_r (nat2pdt 0) a b) as xx.
    repeat (autodimp xx hyp);[rewrite <- eq_dt_0; eauto |].
    pose proof (dt_mul_0_l b) as yy.
    rewrite <- eq_dt_0 in yy. simpl in *.
    rewrite yy in xx. clear yy.
    eauto.
  Qed.
  Hint Resolve lt_0_twice_implies_lt_prod : dtime.

  Lemma lt_implies_trans :
    forall a b c d,
      a < b
      -> (dt_0 < c)%dtime
      -> (d <= nat2pdt(S a) * c)%dtime
      -> (d <= nat2pdt(S b) * c)%dtime.
  Proof.
    introv h1 h2 h3.
    eapply dt_lt_le_weak.

    assert (nat2pdt(S a) < nat2pdt(S b))%dtime as temp1
        by (eapply lt_n_S in h1; eapply dt_nat_nat_inj_lt; eauto).

    pose proof(dt_mul_lt_compat_r (nat2pdt(S a)) (nat2pdt(S b)) c) as xx.
    repeat(autodimp xx hyp). clear temp1.

    eapply dt_le_lt_trans in h3; eauto.
  Qed.
  Hint Resolve lt_implies_trans : dtime.

  Lemma S_dt_T_mul :
    forall a b,
      ((dt_nat_inj (S a)) * b == ((dt_nat_inj a) * b) + b)%dtime.
  Proof.
    introv.
    assert (S a = a + 1) as xx by omega.
    rewrite xx; clear xx.
    rewrite <- dt_nat_inj_add_dist.
    pose proof (Rdistr_l dt_ring (dt_nat_inj a) (dt_nat_inj 1) b) as xx.
    rewrite xx; clear xx.
    apply dt_add_ext; try reflexivity.
    rewrite dt_mul_1_l; try reflexivity.
  Qed.

End DTime.

(* What's up with dt_lt_rel? *)
Existing Instances dt_eq_rel dt_le_rel (*dt_lt_rel*).

Hint Resolve mu_plus_tau_pos : dtime.
Hint Resolve mu_plus_tau_ge_0 : dtime.
Hint Resolve mu_plus_tau_pos2 : dtime.
Hint Resolve mu_plus_tau_ge_dt0 : dtime.
Hint Resolve lt_0_twice_implies_lt_prod : dtime.
Hint Resolve lt_implies_trans : dtime.

Delimit Scope dtime with dtime.
Open Scope dtime.
Infix "<"  := dt_lt  (at level 70) : dtime.
Infix "<=" := dt_le  (at level 70) : dtime.
Infix "+"  := dt_add : dtime.
Infix "-"  := dt_sub : dtime.
Infix "*"  := dt_mul : dtime.
Infix "==" := dt_eq  (at level 70) : dtime.
Notation "a <= b <= c" := ((a <= b) /\ (b <= c)) : dtime.
Close Scope dtime.


Require Export XR_frac_part.
Require Export XR_Ropp_le_contravar.
Require Export XR_up_tech.
Require Export XR_IZR_eq.
Require Export XR_Rplus_lt_le_compat.

Local Open Scope R_scope.

Lemma Rminus_Int_part1 : forall r1 r2:R,
  frac_part r2 <= frac_part r1 ->
  Int_part (r1 - r2) = (Int_part r1 - Int_part r2)%Z.
Proof.
  intros x y.
  unfold frac_part.
  unfold Int_part.
  intro h.
  set (u:=up(x-y)).
  apply eq_IZR.
  repeat rewrite minus_IZR.
  repeat rewrite minus_IZR in h.
  simpl.
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  repeat rewrite Rplus_assoc.
  rewrite (Rplus_comm (-R1)).
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_r.
  unfold Rminus in h.
  repeat rewrite Ropp_plus_distr in h.
  repeat rewrite Ropp_involutive in h.
  repeat rewrite <- Rplus_assoc in h.
  apply Rplus_le_reg_r in h.
  apply Rplus_eq_reg_r with R1.
  rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
  apply Ropp_le_contravar in h.
  repeat rewrite Ropp_plus_distr in h.
  repeat rewrite Ropp_involutive in h.
  rewrite (Rplus_comm (-x)) in h.
  rewrite (Rplus_comm (-y)) in h.

  assert (hax:=archimed x).
  assert (hay:=archimed y).

  destruct hax as [ haxl haxr ].
  destruct hay as [ hayl hayr ].

  assert (ut:=up_tech).

  specialize (ut (x-y)).
  symmetry.

  change R1 with (IZR 1).
  rewrite <- opp_IZR.
  repeat rewrite <- plus_IZR.
  apply IZR_eq.
  fold u in ut.

  specialize (ut (up x - up y))%Z.
  apply ut.

  {
    rewrite minus_IZR.
    apply Rplus_le_reg_r with (-x).
    unfold Rminus.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm x).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    apply Rplus_le_reg_r with (IZR (up y)).
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (- IZR (up y))).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    rewrite (Rplus_comm (-y)).
    exact h.
  }
  {
    rewrite plus_IZR.
    rewrite minus_IZR.
    unfold Rminus.
    repeat rewrite Rplus_assoc.
    apply Rplus_lt_le_compat.
    { exact haxl. }
    {
      apply Rplus_le_reg_l with (IZR (up y)).
      repeat rewrite <- Rplus_assoc.
      rewrite Rplus_opp_r.
      rewrite Rplus_0_l.
      unfold Rminus in hayr.
      exact hayr.
    }
  }
Qed.


Require Import Rupicola.Lib.Api.

Section Tree.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Notation address := word.

  Inductive annotation :=
  | Borrowed (a: address)
  | Reserved (a: address)
  | Owned.

  Notation Annotated alpha := (annotation * alpha)%type.

  Inductive tree {alpha : Type} :=
  | Empty : tree
  | Node : alpha -> tree -> tree -> tree.

  Arguments tree : clear implicits.

  Section defs.
    Context {alpha : Type}.

    Fixpoint owned (t : tree alpha)
      : tree (Annotated alpha) :=
      match t with
      | Empty => Empty
      | Node a l r => Node (Owned, a) (owned l) (owned r)
      end.

    Definition setRoot (t : tree alpha) (a : alpha)
      : tree alpha :=
      match t with
      | Empty => Empty
      | Node _ l r => Node a l r
      end.

    Fixpoint lookup
             (t : tree alpha)
             (cond : alpha -> bool)
      : option alpha :=
      match t with
      | Empty => None
      | Node a l r =>
        if cond a then Some a
        else match lookup l cond with
             | Some a => Some a
             | None => lookup r cond
             end
      end.

    Fixpoint replace
             (t : tree alpha)
             (cond : alpha -> bool)
             (a' : alpha)
      : tree alpha * bool :=
      match t with
      | Empty => (t, false)
      | Node a l r =>
        if cond a then (Node a' l r, true)
        else match replace l cond a' with
             | (l', true) => (Node a l' r, true)
             | (_, false) =>
               match replace r cond a' with
               | (r', true) => (Node a l r', true)
               | (_,false) => (Node a l r, false)
               end
             end
      end.

    Section sep.
      Context {Alpha : word -> alpha -> mem -> Prop}
              {word_size_in_bytes : Z}.

      Local Notation word_offset :=
        (word.of_Z word_size_in_bytes).

      Definition AnnotatedAlpha
                 (addr : word)
                 (x : Annotated alpha)
        : mem -> Prop :=
        match x with
        | (Borrowed p, _) => emp (addr = p)
        | (Reserved p, a) => sep (Alpha addr a) (emp (addr = p))
        | (Owned, a) => Alpha addr a
        end.

      Fixpoint Tree
               (addr : word)
               (t : tree (Annotated alpha))
        : mem -> Prop :=
        match t with
        | Empty => emp (addr = word.of_Z 0)
        | Node a r l =>
          let laddr := word.add addr word_offset in
          let raddr := word.add laddr word_offset in
          sep (AnnotatedAlpha addr a)
              (sep (Tree laddr l) (Tree raddr r))
        end.
    End sep.
  End defs.

  Section proofs.
    Context {alpha : Type}.
    Lemma owned_setRoot_comm t (a : alpha) :
      setRoot (owned t) (Owned, a) = owned (setRoot t a).
    Proof. destruct t; reflexivity. Qed.

    Definition lift {T} (f : alpha -> T) (x : Annotated alpha) :=
      f (snd x).

    Lemma owned_replace_comm t cond (a : alpha) :
      replace (owned t) (lift cond) (Owned, a)
      = (owned (fst (replace t cond a)),
         snd (replace t cond a)).
    Proof.
      induction t; cbn [replace owned];
        try reflexivity.
      repeat match goal with
             | _ => progress subst
             | _ => progress unfold lift in *
             | _ => progress cbn [owned fst snd] in *
             | H : (_,_) = (_,_) |- _ =>
               inversion H; clear H
             | |- context [match ?x with _ => _ end] =>
               destruct x eqn:?
             | _ => reflexivity
             end.
    Qed.

    Section sep.
      Context
        {word_ok : word.ok word} {mem_ok : map.ok mem}
        {locals_ok : map.ok locals}
        {env_ok : map.ok env}
        {ext_spec_ok : Semantics.ext_spec.ok ext_spec}
        {Alpha : word -> alpha -> mem -> Prop}
        {word_size_in_bytes : Z}.

      Local Notation word_offset :=
        (word.of_Z word_size_in_bytes).
      Local Notation Tree :=
        (@Tree _ Alpha word_size_in_bytes).

      Lemma lookup_replace t cond :
        forall a olda pt pa R mem,
          sep (sep (Tree pt t) (Alpha pa a)) R mem ->
          lookup t cond = Some (Borrowed pa, olda) ->
          sep (Tree pt (fst (replace t cond (Owned, a)))) R mem.
      Proof.
        induction t; intros;
          repeat match goal with
                 | _ => progress subst
                 | _ => progress cbn in *
                 | H : Some _ = Some _ |- _ =>
                   inversion H; clear H
                 | H : context [match ?x with _ => _ end] |- _ =>
                   destruct x eqn:?
                 | |- context [match ?x with _ => _ end] =>
                   destruct x eqn:?
                 | H : sep (sep (sep _ _) _) _ _ |- _ =>
                   apply sep_assoc in H; progress sepsimpl
                 | _ => congruence
                 | _ => ecancel_assumption
                 end.
        1: use_sep_assumption; cancel.
        2: exfalso.
        3: exfalso.
        4: exfalso.
        5: use_sep_assumption; cancel.
        6: exfalso.
      Abort.
    End sep.

    Lemma replace_replace t cond (a1 a2 : alpha) :
      cond a1 = true ->
      replace (fst (replace t cond a1)) cond a2 =
      replace t cond a2.
    Proof.
      (* induction t; intros; *)
      (*   repeat match goal with *)
      (*          | _ => progress cbn [replace fst snd] in * *)
      (*          | _ => progress subst *)
      (*          | _ => progress intuition *)
      (*          | H : (_,_) = (_,_) |- _ => *)
      (*            inversion H; clear H *)
      (*          | |- context [match ?x with _ => _ end] => *)
      (*            destruct x eqn:? *)
      (*          | _ => reflexivity *)
      (*          | _ => congruence *)
      (*          end. *)
    Abort.

    Section borrowing.
      Context {Alpha : word -> alpha -> mem -> Prop}
              {word_size_in_bytes : Z}.

      Open Scope nat_scope.
      Definition a (n: nat) := n + 1.
      Definition b (n: nat) := a n + 1.
      Definition c (n: nat) := b n + 1.

      Hint Unfold a : test.
      Hint Unfold b : test.
      Hint Unfold c : test.

      (* Goal c 3 = 5. *)
      (*   autounfold with test. *)

      (* Lemma borrow_reserved : *)
      (*   forall addr t cond pa a, *)
      (*     find t (lift cond) = Some (Reserved pa, a) -> *)
      (*     Tree (Alpha := Alpha) addr t -> *)
      (*     sep (Alpha a) (Tree addr (replace t (lift cond) (Borrowed pa, a))). *)
      (* Abort. *)

      (* Lemma owned_replace_comm t cond (a : alpha) : *)
      (*   replace (owned t) (lift cond) (Owned, a) *)
      (*   = (owned (fst (replace t cond a)), *)
      (*       snd (replace t cond a)). *)
      (* Abort. *)
    End borrowing.
  End proofs.
End Tree.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils.

Set Implicit Arguments.

Set Default Proof Using "Type".

Reserved Notation " e '⇢' x " (at level 58).
Reserved Notation " e [ v / x ] " (at level 57, v at level 0, x at level 0,
                                   left associativity, format "e [ v / x ]").
Reserved Notation " e ⦃  x '⇠' v ⦄ " (at level 57, v at level 0, x at level 0, left associativity).

Section env.

  Variable (X Y : Type) (X_eq_dec : eqdec X) (Y_default : Y).

  Definition env := X -> Y.

  Implicit Type e : env.

  Definition get_env e x := e x.

  Definition set_env e x v : env := fun y => if X_eq_dec x y then v else e y.

  Definition nil_env : env := fun _ => Y_default.

  Fact get_set_env_eq e v p q : p = q -> get_env (set_env e p v) q = v.
  Proof. intros []; unfold set_env, get_env; destruct (X_eq_dec p p) as [ | [] ]; auto. Qed.

  Fact get_set_env_neq e v p q : p <> q -> get_env (set_env e p v) q = get_env e q.
  Proof. simpl; intros H; unfold set_env, get_env; destruct (X_eq_dec p q); auto; destruct H; auto. Qed.

End env.

Arguments nil_env {X}.

Opaque get_env.
Opaque set_env.

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ _ e x v).

(* find the value of x inside the environment t *)

Ltac find_val x t :=
  match t with
    | ?s⦃x⇠?v⦄ => v
    | ?s⦃_⇠_⦄ => find_val x s
  end.

Tactic Notation "rew" "env" :=
  repeat once lazymatch goal with
    |              |- context[ _⦃ ?x⇠_⦄⇢?x ] => rewrite get_set_env_eq  with (1 := eq_refl x)
    | _ : ?x = ?y  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?y = ?x  |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_eq  with (p := x) (q := y)
    | _ : ?x <> ?y |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    | _ : ?y <> ?x |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y)
    |              |- context[ _⦃ ?x⇠_⦄⇢?y ] => rewrite get_set_env_neq with (p := x) (q := y);
                                                  [ | discriminate ]
  end; auto.

(*
Tactic Notation "rew" "envi" :=
  repeat once lazymatch goal with
    | |- context f[ _[_/?l]#>?l ] => rewrite get_set_env_eq with (x := l)
    | _ : ?l <> ?m |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | _ : ?m <> ?l |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m)
    | |- context f[ _[_/?l]#>?m ] => rewrite get_set_env_neq with (x := l) (y := m); [ | discriminate ]
  end; auto.
*)

Tactic Notation "rew" "env" "in" hyp(H) := revert H; rew env; intros H.


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  omit.v }%*)
(** - (omit v i) = $\langle v_0...v_{i-1},v_{i+1}...v_{n-1}\rangle$ *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export empty.
Require Export conshdtl.

(** %\label{omit}% *)
Definition omit :
  forall (A : Setoid) (n : Nat), seq n A -> fin n -> seq (pred n) A.
destruct n.
auto.
induction  n as [| n Hrecn].
intros.
apply (empty_seq A).
intros.
case X0.
intro x; case x.
intro.
exact (Seqtl X).
intros.
exact (head X;; Hrecn (Seqtl X) (Build_finiteT (lt_S_n _ _ in_range_prf))).
Defined.

Lemma omit_comp :
 forall (A : Setoid) (n : Nat) (v v' : seq n A) (i i' : fin n),
 v =' v' in _ -> i =' i' in _ -> omit v i =' omit v' i' in _.
destruct n.
intros.
auto with algebra.
induction  n as [| n Hrecn].
intros.
unfold omit in |- *.
unfold nat_rect in |- *.
auto with algebra.
intros v v' i.
case i.
intros x l i'.
case i'.
intros.
apply Trans with (omit v' (Build_finiteT l)).
unfold omit in |- *.
unfold nat_rect in |- *.
generalize l H0; clear H0 l.
destruct x as [| n0].
intros.
change (Seqtl v =' Seqtl v' in _) in |- *.
apply Seqtl_comp; auto with algebra.
intros.
simpl in |- *.
apply cons_comp; auto with algebra.
unfold omit in Hrecn.
unfold nat_rect in Hrecn.
apply Hrecn.
change (Seqtl v =' Seqtl v' in _) in |- *.
apply Seqtl_comp; auto with algebra.
auto with algebra.
unfold omit in |- *.
unfold nat_rect in |- *.
generalize l H0; clear H0 l.
destruct x as [| n0].
destruct index as [| n0].
intros; auto with algebra.
intros.
simpl in H0.
inversion H0.
intros.
generalize l H0; clear H0 l.
destruct index as [| n1].
intros.
simpl in H0.
inversion H0.
intros.
simpl in |- *.
apply cons_comp; auto with algebra.
unfold omit in Hrecn.
unfold nat_rect in Hrecn.
apply Hrecn; auto with algebra.
Qed.

Hint Resolve omit_comp: algebra.

(** - The following are actually definitions. omit_removes does the following:
 suppose v:(seq n A) and i:(fin n). Define w:=(omit v i). Then given j, (w j)
 = (v j') for some j'. Omit_removes returns this j' and a proof of this fact
 (packed together in a sigma-type). *)

Lemma omit_removes :
 forall (n : Nat) (A : Setoid) (v : seq n A) (i : fin n) (j : fin (pred n)),
 sigT (fun i' => v i' =' omit v i j in _).
destruct n.
intros.
apply False_rect; auto with algebra.

intros.
generalize (j:fin n).
clear j.
intro j.

induction  n as [| n Hrecn].
apply False_rect.
apply fin_O_nonexistent; auto with algebra.

case i.
intro x; case x.
intros.
set (l := in_range_prf) in *.
case j.
intros.
set (l0 := in_range_prf0) in *.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' omit v (Build_finiteT l) (Build_finiteT l0) in _)
    (Build_finiteT (lt_n_S _ _ l0))).
apply Trans with (Seqtl v (Build_finiteT l0)); auto with algebra.

intros.
rename in_range_prf into l.
case j.
intro x0; case x0.
intro l0.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' Ap (omit v (Build_finiteT l)) (Build_finiteT l0) in _)
    (Build_finiteT (lt_O_Sn (S n)))).
apply Trans with (head (omit v (Build_finiteT l))); auto with algebra.

intros.
rename in_range_prf into l0.
generalize
 (Hrecn (Seqtl v) (Build_finiteT (lt_S_n _ _ l))
    (Build_finiteT (lt_S_n _ _ l0))).
intro.
inversion_clear X.
generalize H.
clear H.
case x1.
intros.
apply
 (existT
    (fun i' : fin (S (S n)) =>
     Ap v i' =' Ap (omit v (Build_finiteT l)) (Build_finiteT l0) in _)
    (Build_finiteT (lt_n_S _ _ in_range_prf))).
apply
 Trans
  with
    ((head v;; omit (Seqtl v) (Build_finiteT (lt_S_n _ _ l)))
       (Build_finiteT l0)); auto with algebra.
Defined.

(** - omit_removes' on the other hand does this: suppose again v:(seq n A) and i:(fin n)
 and define w:=(omit v i). Suppose that this time j:(fin n). If [~i='j] then (v j)='(w j')
 for some j'; again omit_removes' returns this j' and a proof. *)

Lemma omit_removes' :
 forall (n : Nat) (A : Setoid) (v : seq n A) (i j : fin n),
 ~ i =' j in _ -> sigT (fun j' => v j =' omit v i j' in _).
destruct n.
intros.
apply False_rect; auto with algebra.

induction  n as [| n Hrecn].
intros.
absurd (i =' j in _).
auto.
apply fin_S_O_unique; auto with algebra.
intros A v i.
elim i.
intro i'; case i'.
intros Hi j.
elim j.
intro j'; case j'.
intros.
simpl in H.
absurd (0 = 0); auto.
intros n0 p0 H.
exists (Build_finiteT (lt_S_n _ _ p0)).
simpl in |- *.
apply Ap_comp; auto with algebra.
simpl in |- *.
auto.

intros gat Hg vraag.
elim vraag.
intro vr; case vr.
intros Hvr H.
exists (Build_finiteT (lt_O_Sn n)).
simpl in |- *.
unfold head in |- *.
apply Ap_comp; auto with algebra.
simpl in |- *.
auto.

intros vr' Hvr H.
assert
 (~ Build_finiteT (lt_S_n _ _ Hg) =' Build_finiteT (lt_S_n _ _ Hvr) in fin _).
simpl in |- *; simpl in H; auto.
set (aw := Hrecn _ (Seqtl v) _ _ H0) in *.
case aw.
intro x; elim x.
intros.
exists (Build_finiteT (lt_n_S _ _ in_range_prf)).
apply Trans with (Seqtl v (Build_finiteT (lt_S_n vr' (S n) Hvr))).
apply Sym.
apply Seqtl_to_seq; auto with algebra.
apply
 Trans
  with
    (omit (Seqtl v) (Build_finiteT (lt_S_n gat (S n) Hg))
       (Build_finiteT in_range_prf)); auto with algebra.
Defined.