Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.interfaces.rationals
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.Classes.theory.rings
               HoTT.Classes.orders.semirings
               HoTT.Classes.orders.rings
               HoTT.Classes.theory.dec_fields
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions
               Valuations LowerIntegrals
               D_op OpenFun Riesz1 Giry Cpo.

Set Implicit Arguments.

Definition qnp (n : nat) := pos_of_nat n.
Definition qn (n : nat) := pos (pos_of_nat n).
Coercion qn : nat >-> Q.
Coercion qnp : nat >-> Qpos.

(** * Interpretation of probabilistic programs *)
(**
      .  --> [.] ;

      v  --> unit v ;

 let x=a in b --> bind  [a] (fun x => [b]) ;

     f a  -->  bind  [a] (fun x => [f] x) ;

    if b then a1 else a2 --> bind  [b] (fun x:bool =>
    if b then [a1] else [a2]).
**)

(** * Interpretation of programs *)

(** Image distributions by a function f :  *)

Definition Iim_distr {A B : hSet} (f : A -> B) (J : IntPos A) : IntPos B
                                      := bind J (fun a => unit B (f a)).

Lemma Iim_distr_id {A : hSet}: forall (f : A -> A) (J : IntPos A),
          (forall x, f x = x) -> Iim_distr f J = J.
Proof.
intros f m Hx.
unfold Iim_distr.
assert (Hu : (fun a : A => unit A (f a)) = unit A).
apply path_forall; intros a.
rewrite (Hx a); reflexivity.
rewrite Hu. simpl; rewrite monad2; reflexivity.
Qed.

Lemma Iim_distr_comp {A B C: hSet} (f : A -> B) (g : B -> C) (m : IntPos A) :
   Iim_distr g (Iim_distr f m) = Iim_distr (fun a => g (f a)) m.
Proof.
apply IntPos_eq0; apply path_forall.
intros h; unfold Iim_distr; simpl;
reflexivity.
Qed.

(**
Conditional distribution *)
Definition bool : hSet := default_TruncType 0 bool hset_bool.

Definition Iif (A:hSet) (b: IntPos bool) (m1 m2:IntPos A) : IntPos A.
Proof.
exists (fun X => (bind b (fun x:bool => if x then m1 else m2)) X).
+ hnf; unfold bind; simpl.
  assert (Hb : (fun y : bool => (if y then m1 else m2) (fzero A)) =
               fun y : bool => RlP_0).
  apply path_forall; intros y.
  destruct y; rewrite I_def; reflexivity.
  rewrite Hb, I_def; reflexivity.
+ intros f g; unfold bind; simpl.
  rewrite <- I_add.
  assert (H : (fun x : bool => (if x then m1 else m2) (fplus f g)) =
             (fplus (fun x : bool => (if x then m1 else m2) f)
                    (fun x : bool => (if x then m1 else m2) g))).
  apply path_forall; intros y. unfold fplus.
  simpl; destruct y;
  apply I_add.
  rewrite H; reflexivity.
+ intros q Hq.
  unfold bind in Hq.
  simpl in Hq.
  assert (H : elt (b (fone bool)) q).
  revert Hq; apply Rlow_mon.
  reflexivity.
  apply I_mon.
  intros y; destruct y;
  apply I_prob.
  revert H; apply Rlow_mon.
  reflexivity.
  apply I_prob.
+ intros f g Hfg.
  apply I_mon; trivial.
+ intros F; unfold bind.
  simpl.
  pose (g := (fun n : nat =>
        (fun x:bool => (if x then m1 else m2)
           (fun x0 : A => (F n x0))))).
  assert (Hg : forall n, fle (g n) (g (S n))).
  intros n x; unfold g.
  destruct x.
  apply m1; intros x;
  apply F.
  apply m2; intros x;
  apply F.
  pose (G := Build_IncreasingSequence g Hg).
  assert (H : Rlle (b
     (fun x : canonical_names.bool =>
      (if x then m1 else m2) (fun x0 : A => RllubPos (fun n : nat => F n x0))))
      (b (Cpo.lub G))).
  apply I_mon.
  intros x.
  destruct x.
  apply m1.
  apply m2.
  assert (H2 : Rlle (b (Cpo.lub G)) (Rllub (toRlseq
        (fun n : nat => b (fun x : canonical_names.bool
         => (if x then m1 else m2) (F n)))))).
  pose (ff := (fun (n : nat) =>
   (fun x : bool =>  (if x then m1 else m2)
                     (fun x0 : A => F n x0)))).
  assert (Hff : forall n, fle (ff n) (ff (S n))).
  intros n; unfold ff; intros x.
  destruct x.
  apply m1; intros y; apply F.
  apply m2; intros y; apply F.
  pose (Hb := Build_IncreasingSequence ff Hff).
  assert (Hf : Rlle (b (Cpo.lub Hb))
     (RllubPos (fun n => b (Hb n)))).
  apply b.
  trivial.
  unfold Rlle in *; auto.
Defined.

(** Fixpoints *)

Section Fixpoints.

Context {P : Type} {lP : Le P}
        {wCP : cpo P}.

Context {A : hSet}.

Fixpoint iter (f : P -> P)
              (H : forall a b, lP a b -> lP (f a) (f b))
              n : P := match n with
                       | O => cpobot
                       | S m => f (iter f H m) end.

Lemma iter_mon f H : forall n, lP ((iter f H) n) ((iter f H) (S n)).
Proof.
intros n.
induction n.
apply cpobot_bot.
simpl in *.
apply H; trivial.
Qed.

Definition fixp f H : P :=
          lub (Build_IncreasingSequence (iter f H)
                                        (iter_mon f H)).

End Fixpoints.

Definition Ifix {A B:hSet} (F: (A -> IntPos B) -> A -> IntPos B) Monf
                 : A -> IntPos B := fixp F Monf.

(** * Correctness judgements *)

(** ok: the measure of F by the program associated
        to nu is at least p, here p plays the role of
        the probability.

    ok_up: the measure of F by the program associated
           to nu is at most p. *)

Definition ok {A} (p : RlowPos) (nu : IntPos A) (F : mf A) := Rlle p (nu F).

Definition ok_fun {A B} (f : mf A) (E : A -> IntPos B) (F : A -> mf B) :=
                     forall x:A, ok (f x) (E x) (F x).

Definition ok_up {A} (p : RlowPos) (nu : IntPos A) (F : mf A) := Rlle (nu F) p.

Definition up_fun {A B} (f : mf A) (E : A -> IntPos B) (F : A -> mf B) :=
                     forall x:A, ok_up (f x) (E x) (F x).

Definition ok_sier {A} (p : Q) (nu : IntPos A) (F : mf A) := elt (nu F) p.

(** Correctness rules for applications *)

Lemma apply_rule {A B} : forall (J : IntPos A) (f : A -> IntPos B)
                                (r : RlowPos)
                                (F : mf A) (G : OS B),
          ok r J F -> ok_fun F f (fun x => G) ->
          ok r (bind J f) G.
Proof.
intros nu f r F G H1 H2.
unfold ok_fun, ok in *.
unfold bind.
simpl.
assert (H : Rlle r (nu F)); trivial.
assert (H' : Rlle (nu F) (nu (fun x : A => (f x) (fun x0 : B => G x0)))).
apply I_mon; trivial.
unfold Rlle in *; auto.
Qed.

Lemma apply_rule_up {A B} : forall (J : IntPos A) (f : A -> IntPos B)
                      (r : RlowPos) (F : mf A) (G : mf B),
    ok_up r J F -> up_fun F f (fun x => G) ->
    ok_up r (bind J f) G.
Proof.
intros nu f r U V H1 H2.
unfold up_fun, ok_up in *.
unfold bind; simpl.
assert (H : Rlle (nu (fun x : A => (f x) V)) (nu U)); trivial.
apply I_mon; trivial.
unfold Rlle in *; auto.
Qed.

(** Correctness rules for abstraction *)

Lemma lambda_rule {A B:hSet} : forall (f : A -> IntPos B) (F : mf A)
                                      (G : A -> mf B),
    (forall x:A, ok (F x) (f x) (G x)) -> ok_fun F f G.
Proof.
intros f F G HO.
unfold ok_fun, ok in *; trivial.
Qed.

Lemma lambda_rule_up {A B:hSet} : forall (f : A -> IntPos B)
                              (F : mf A) (G : A -> mf B),
       (forall x:A, ok_up (F x) (f x) (G x)) -> up_fun F f G.
Proof.
intros f F G HO.
unfold up_fun, ok_up in *; trivial.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import NatTrans.Main.
Require Import Adjunction.Adjunction Adjunction.Duality.
Require Import Ext_Cons.Comma.
Require Import Basic_Cons.Terminal Basic_Cons.Facts.Term_IsoCat.
Require Import Cat.Cat_Iso.
Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.

(** A functor G : D –≻ C has a left adjoint if and only if
the comma category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C).

Dually, a functor F : C –≻ D has a right adjoint if and only
if the comma category (Comma F (Func_From_SingletonCat x))
has a terminal object for any (x : D).
 *)

(**
If the comma category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C). Then G : D –≻ C has
a left adjoint.
*)

Section Universal_Morphism_Right_Adjonit.
  Context
    {C D : Category}
    (G : (D –≻ C)%functor)
    (HU_init : ∀ (x : C), (𝟘_ (Comma (Func_From_SingletonCat x) G))%object )
  .

  Local Definition Universal_Morphism_Lem :
    ∀ c a h,
      CMH_right (t_morph (HU_init c) a) = CMH_right h
  .
  Proof.
    intros c a h.
    apply f_equal.
    apply (t_morph_unique (HU_init c)).
  Qed.

  Local Ltac smart_apply_Universal_Morphism_Lem :=
    match goal with
      [|- CMH_right ?A = ?B] =>
      match type of A with
        ?W =>
        let M :=
            (eval cbn in W)
        in
        match M with
          Comma_Hom _ _ ?X ?Y =>
          evar (U : Comma_Hom _ _ X Y);
            replace B with (CMH_right ?U);
            [
              eapply
                (
                  Universal_Morphism_Lem
                    _
                    Y
                    (
                      Build_Comma_Hom
                        _
                        _
                        X
                        Y
                        tt
                        B
                        _
                    )
                )
            |
            reflexivity
            ]
        end
      end
    end.

  Program Definition Universal_Morphism_Right_Adjonit_Func : (C –≻ D)%functor
    :=
      {|
        FO :=
          fun c =>
            CMO_trg (terminal (HU_init c));
        FA :=
          fun c c' h =>
            CMH_right
              (t_morph
                 (HU_init c)
                 (@Build_Comma_Obj
                    _
                    _
                    _
                    (Const_Func 1 c)
                    G
                    tt
                    (CMO_trg (terminal (HU_init c')))
                    ((CMO_hom (terminal (HU_init c'))) ∘ h)%morphism
                 )
              )
      |}
  .

  Next Obligation.
  Proof.
    smart_apply_Universal_Morphism_Lem.
    Unshelve.
    cbn; auto.
  Qed.

  Next Obligation.
  Proof.
    smart_apply_Universal_Morphism_Lem.
    Unshelve.
    {
      cbn.
      rewrite F_compose.
      rewrite assoc.
      simpl_ids;
      match goal with
        [|- ((G _a) ((CMH_right ?A)) ∘ ((G _a) (CMH_right ?B)) ∘ _)%morphism = _] =>
        cbn_rewrite (CMH_com B);
          do 2 rewrite assoc_sym;
          cbn_rewrite (CMH_com A); auto
      end.
    }
  Qed.

  Local Obligation Tactic := idtac.

  Program Definition Universal_Morphism_Right_Adjonit_unit :
    (Functor_id C –≻ G ∘ Universal_Morphism_Right_Adjonit_Func)%nattrans
    :=
      {|
        Trans := fun c => CMO_hom (terminal (HU_init c))
      |}
  .

  Next Obligation.
  Proof.
    intros c c' h.
    cbn.
    match goal with
      [|- _ = (G _a (CMH_right ?A) ∘ _)%morphism] =>
      cbn_rewrite (CMH_com A)
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Universal_Morphism_Right_Adjonit_unit_obligation_1.
  Qed.

  Program Definition Universal_Morphism_Right_Adjonit :
    (Universal_Morphism_Right_Adjonit_Func ⊣ G)%functor
    :=
      {|
        adj_unit := Universal_Morphism_Right_Adjonit_unit;
        adj_morph_ex :=
          fun c d f =>
            CMH_right
              (t_morph
                 (HU_init c)
                 (@Build_Comma_Obj
                    _
                    _
                    _
                    (Const_Func 1 c)
                    G
                    tt
                    d
                    f
                 )
              )
      |}
  .

  Next Obligation.
  Proof.
    intros c d f.
    cbn in *.
    match goal with
      [|- _ = (G _a (CMH_right ?A) ∘ _)%morphism] =>
      cbn_rewrite (CMH_com A)
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    intros c d f g h H1 H2.
    cbn in *.
    rewrite <- (id_unit_right _ _ f) in H1, H2.
    symmetry in H1, H2.
    set (W :=
           @Build_Comma_Obj
             _
             _
             _
             (Const_Func 1 c)
             G
             tt
             d
             f
        )
    .
    let tac u H
        :=
        (
          change u with
          (
            CMH_right
              (
                Build_Comma_Hom
                  _
                  _
                  (terminal (HU_init c))
                  W
                  tt
                  u
                  H
              )
          )
        )
    in
    tac g H1;
      tac h H2
    .
    transitivity (CMH_right (t_morph (HU_init c) W));
      [symmetry|];
      apply (Universal_Morphism_Lem c W)
    .
  Qed.

End Universal_Morphism_Right_Adjonit.

(**
if a functor G : D –≻ C has a left adjoint then the comma
category (Comma (Func_From_SingletonCat x) G) has
an initial object for any (x : C).
*)
Section Right_Adjoint_Universal_Morphism.
  Context
    {C D : Category}
    {F : (C –≻ D)%functor}
    {G : (D –≻ C)%functor}
    (Adj : (F ⊣ G)%functor)
    (x : C)
  .

  Program Definition Right_Adjoint_Universal_Morphism_terminal :
    (Comma (Func_From_SingletonCat x) G)
    :=
      {|
        CMO_src := tt;
        CMO_trg := (F _o x)%object;
        CMO_hom := Trans (adj_unit Adj) x
      |}
  .

  Program Definition Right_Adjoint_Universal_Morphism_t_morph
          (u : (Comma (Func_From_SingletonCat x) G))
    :
      Comma_Hom _ _ Right_Adjoint_Universal_Morphism_terminal u
    :=
      {|
        CMH_left := tt;
        CMH_right :=
          @adj_morph_ex
            _
            _
            _
            _
            Adj
            x
            (CMO_trg u)
            (CMO_hom u)
      |}
  .

  Next Obligation.
  Proof.
    simpl_ids.
    symmetry.
    apply (@adj_morph_com _ _ _ _ Adj).
  Qed.

  Program Definition Right_Adjoint_Universal_Morphism :
    (𝟘_ (Comma (Func_From_SingletonCat x) G))%object
    :=
      {|
        terminal := Right_Adjoint_Universal_Morphism_terminal;
        t_morph := Right_Adjoint_Universal_Morphism_t_morph
      |}
  .

  Next Obligation.
  Proof.
    assert (Hf := CMH_com f).
    assert (Hg := CMH_com g).
    cbn in *.
    simpl_ids in Hf; simpl_ids in Hg.
    symmetry in Hf, Hg.
    apply Comma_Hom_eq_simplify.
    match goal with
      [|- ?A = ?B] =>
      destruct A; destruct B; trivial
    end.
    eapply (@adj_morph_unique _ _ _ _ Adj); eauto.
  Qed.

End Right_Adjoint_Universal_Morphism.

(**
If the comma category (Comma F (Func_From_SingletonCat x)) has
an initial object for any (x : D). Then F : D –≻ C has
a right adjoint.
*)
Section Universal_Morphism_Left_Adjonit.
  Context
    {C D : Category}
    (F : (C –≻ D)%functor)
    (HU_term : ∀ (x : D), (𝟙_ (Comma F (@Func_From_SingletonCat D x)))%object)
  .

  Definition Universal_Morphism_Left_Adjonit_HU_init
             (x : (D^op)%category)
    :
      (𝟘_ (Comma ((@Func_From_SingletonCat (D ^op) x)) (F^op)))%object
    :=
      Term_IsoCat
        (
          Opposite_Cat_Iso
            (
              Isomorphism_Compose
                (Comma_Opposite_Iso F (@Func_From_SingletonCat D x))
                (Comma_Left_Func_Iso
                   (@Func_From_SingletonCat_Opposite D x) (F ^op))
            )
        )
        (HU_term x)
  .

  Definition Universal_Morphism_Left_Adjonit
    :
      (F ⊣ (
               Universal_Morphism_Right_Adjonit_Func
                 (F ^op)
                 Universal_Morphism_Left_Adjonit_HU_init
             )^op
      )%functor
    :=
      Adjunct_Duality
        (
          @Universal_Morphism_Right_Adjonit
            (D^op)
            (C^op)
            (F^op)
            Universal_Morphism_Left_Adjonit_HU_init
        )
  .

End Universal_Morphism_Left_Adjonit.

(**
if a functor F : C –≻ D has a right adjoint then the comma
category (Comma F (Func_From_SingletonCat x)) has
an terminal object for any (x : D).
*)
Section Left_Adjoint_Universal_Morphism.
  Context
    {C D : Category}
    {F : (C –≻ D)%functor}
    {G : (D –≻ C)%functor}
    (Adj : (F ⊣ G)%functor)
    (x : D)
  .

  Definition Left_Adjoint_Universal_Morphism
    : (𝟙_ (Comma F (Const_Func 1 x)))%object
    :=
      Term_IsoCat
        (
          Opposite_Cat_Iso
            (
              Isomorphism_Compose
                (
                  Comma_Left_Func_Iso
                    (Inverse_Isomorphism (@Func_From_SingletonCat_Opposite D x))
                    (F ^op)
                )
                (Inverse_Isomorphism
                   (Comma_Opposite_Iso F (@Func_From_SingletonCat D x)))
            )
        )
        (Right_Adjoint_Universal_Morphism (Adjunct_Duality Adj) x)
  .

End Left_Adjoint_Universal_Morphism.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
Definition veq T (x : MId.m T) (y : Acc.MAcc.m T) : Prop := x = Acc.get_v y.

Lemma bind_veq :
  forall T (x1 : MId.m T) (x2 : Acc.MAcc.m T)
     U (f1 : T -> MId.m U) (f2 : T -> Acc.MAcc.m U)
     (Hx : veq x1 x2) (Hf : forall x, veq (f1 x) (f2 x)),
    veq (MId.bind x1 f1) (Acc.MAcc.bind x2 f2).
Proof.
i; unfold MId.bind, Acc.MAcc.bind.
rewrite Hf, Hx. destruct x2; s. destruct (f2 t); s. by auto.
Qed.

Ltac dest_veq :=
match goal with
| |- veq (MId.bind ?x1 ?f1) (Acc.MAcc.bind ?x2 ?f2) =>
  let Hx := fresh "Hx" in
  let Hf := fresh "Hf" in
  assert (veq x1 x2) as Hx
  ; [| assert (forall x, veq (f1 x) (f2 x)) as Hf
       ; [|eapply bind_veq; [by apply Hx|by apply Hf]] ]
| |- veq (MId.ret ?x1) (Acc.MAcc.ret ?y1) => reflexivity
end.

Definition mem_join (x : Acc.MAcc.m Mem.t) (y : Mem.t) :=
  (Mem.join (Acc.get_v x) y, Acc.get_acc x).

Lemma bind_mor
      T (teq : T -> T -> Prop) (Hteq : DLat.zb_equiv teq)
      U (ueq : U -> U -> Prop) (Hueq : DLat.zb_equiv ueq) :
  Proper (Acc.MAcc.eq Hteq
          ==> (teq ==> Acc.MAcc.eq Hueq)
          ==> Acc.MAcc.eq Hueq)
         (Acc.MAcc.bind (A:=T) (B:=U)).
Proof.
intros t1 t2 Ht u1 u2 Hu. unfold Acc.MAcc.bind, Acc.MAcc.eq.
destruct t1 as [t1 a1], t2 as [t2 a2].
remember (u1 t1) as v1; destruct v1 as [v1 a1'].
remember (u2 t2) as v2; destruct v2 as [v2 a2'].
assert (Acc.MAcc.eq Hueq (v1, a1') (v2, a2')) as Heqv.
{ rewrite Heqv1, Heqv2. by apply Hu, Ht. }
split; [by apply Heqv|apply Acc.join_eq; [by apply Ht|by apply Heqv]].
Qed.

Lemma ret_mor T (teq : T -> T -> Prop) (Hteq : DLat.zb_equiv teq) :
  Proper (teq ==> Acc.MAcc.eq Hteq) (Acc.MAcc.ret (A:=T)).
Proof.
intros x1 x2 Hx. unfold Acc.MAcc.ret, Acc.MAcc.eq.
split; [by auto|by apply Acc.eq_refl].
Qed.

Lemma if_dec_mor
      P (P_dec : sumbool P (~ P)) Q (Q_dec : sumbool Q (~ Q))
      (HPQ1 : P -> Q) (HPQ2 : Q -> P)
      T (teq : T -> T -> Prop) (Hteq : DLat.zb_equiv teq) :
  forall e1 e1' (He1 : Acc.MAcc.eq Hteq e1 e1')
     e2 e2' (He2 : Acc.MAcc.eq Hteq e2 e2'),
    Acc.MAcc.eq Hteq (if P_dec then e1 else e2) (if Q_dec then e1' else e2').
Proof.
i. destruct P_dec; destruct Q_dec.
- by auto.
- elim f. by auto.
- elim f. by auto.
- by auto.
Qed.

Lemma if_dec_not_mor
      P (P_dec : sumbool P (~ P)) Q (Q_dec : sumbool Q (~ Q))
      (HPQ1 : P -> Q) (HPQ2 : Q -> P)
      T (teq : T -> T -> Prop) (Hteq : DLat.zb_equiv teq) :
  forall e1 e1' (He1 : Acc.MAcc.eq Hteq e1 e1')
     e2 e2' (He2 : Acc.MAcc.eq Hteq e2 e2'),
    Acc.MAcc.eq Hteq
                (if Sumbool.sumbool_not P (~ P) P_dec then e1 else e2)
                (if Sumbool.sumbool_not Q (~ Q) Q_dec then e1' else e2').
Proof.
i. unfold Sumbool.sumbool_not.
destruct P_dec; destruct Q_dec.
- by auto.
- elim f. by auto.
- elim f. by auto.
- by auto.
Qed.

Lemma eqlistA_eq_refl T : forall (l : list T), SetoidList.eqlistA eq l l.
Proof. induction l; [by auto|constructor; by auto]. Qed.

Definition list_zb_eq T (teq : T -> T -> Prop) (Hteq : DLat.zb_equiv teq) :
  DLat.zb_equiv (SetoidList.eqlistA teq).
Proof.
constructor.
- induction x.
  + by constructor.
  + constructor; [by apply (DLat.zb_equiv_refl Hteq)|by auto].
- induction 1.
  + by constructor.
  + constructor; [by apply (DLat.zb_equiv_sym Hteq)|by apply IHHeq].
- intros x y z Hxy.
  generalize x y Hxy z; clear x y Hxy z.
  induction 1; inversion 1; subst.
  + by constructor.
  + constructor; [by apply (DLat.zb_equiv_trans Hteq) with x'|by apply IHHxy].
Qed.

Definition list_val_zb_eq : DLat.zb_equiv (SetoidList.eqlistA Val.eq) :=
  list_zb_eq Val.zb_eq.

Definition aeqm1 (f : Mem.t -> Acc.MAcc.m Mem.t) : Prop :=
  forall m m' (Hm' : disjoint m' (Acc.get_acc (f m))),
    Acc.MAcc.eq Mem.zb_eq (f (Mem.join m m')) (mem_join (f m) m').

Definition aeqm2 (f : Mem.t -> Mem.t -> Acc.MAcc.m Mem.t) : Prop :=
  forall m1 m2 m' (Hm' : disjoint m' (Acc.get_acc (f m1 m2))),
    Acc.MAcc.eq Mem.zb_eq
                (f (Mem.join m1 m') (Mem.join m2 m'))
                (mem_join (f m1 m2) m').

Lemma aeqm_deg1 : forall f (Hf : aeqm1 f), aeqm2 (fun m _ => f m).
Proof. unfold aeqm1, aeqm2; i. by apply Hf. Qed.

Lemma aeqm_deg2 : forall f (Hf : aeqm1 f), aeqm2 (fun _ m => f m).
Proof. unfold aeqm1, aeqm2; i. by apply Hf. Qed.

Lemma aeqm2_sym : forall f (Hf : aeqm2 f), aeqm2 (fun m m' => f m' m).
Proof. unfold aeqm2; i. by apply Hf. Qed.

Definition aeqv T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq)
           (f : Mem.t -> Acc.MAcc.m T) : Prop :=
  forall m m' (Hm' : disjoint m' (Acc.get_acc (f m))),
    Acc.MAcc.eq Ht (f (Mem.join m m')) (f m).

Lemma aeqv_1
      T (t_eq : T -> T -> Prop) (Hteq : DLat.zb_equiv t_eq)
      U (u_eq : U -> U -> Prop) (Hueq : DLat.zb_equiv u_eq) :
  forall (f : T -> Acc.MAcc.m U)
     (Hf_mor : Proper (t_eq ==> Acc.MAcc.eq Hueq) f)
     v (Hv : aeqv Hteq v),
    aeqv Hueq (fun m => Acc.MAcc.bind (v m) f).
Proof. {
unfold aeqv; i.
specialize (Hv m m').
remember (v m) as v1; destruct v1 as [v1 a1].
remember (v (Mem.join m m')) as v2; destruct v2 as [v2 a2].
simpl in *.
remember (f v1) as fv1; destruct fv1 as [fv1 fa1].
remember (f v2) as fv2; destruct fv2 as [fv2 fa2].
exploit Hv
; [eapply disjoint_mono; [|by apply Hm']; s; by apply Acc.join_left|].
intros [Hv21 Ha12].
assert (Acc.MAcc.eq Hueq (fv1, fa1) (fv2, fa2)) as Hf.
{ rewrite Heqfv1, Heqfv2. by apply Hf_mor, (DLat.zb_equiv_sym Hteq). }
constructor.
- by apply (DLat.zb_equiv_sym Hueq), Hf.
- apply Acc.join_eq; [by auto|by apply Acc.eq_sym, Hf].
} Qed.

Lemma aeqv_2
      T (t_eq : T -> T -> Prop) (Hteq : DLat.zb_equiv t_eq)
      U (u_eq : U -> U -> Prop) (Hueq : DLat.zb_equiv u_eq) :
  forall (f : Mem.t -> T -> Acc.MAcc.m U)
     (Hf : forall x, aeqv Hueq (fun m => f m x))
     (Hf_mor : Proper (Mem.eq ==> t_eq ==> Acc.MAcc.eq Hueq) f)
     v (Hv : aeqv Hteq v),
    aeqv Hueq (fun m => Acc.MAcc.bind (v m) (f m)).
Proof. {
unfold aeqv; i.
specialize (Hv m m').
remember (v m) as v1; destruct v1 as [v1 a1].
remember (v (Mem.join m m')) as v2; destruct v2 as [v2 a2].
simpl in *.
remember (f m v1) as fv1; destruct fv1 as [fv1 fa1].
remember (f (Mem.join m m') v2) as fv2; destruct fv2 as [fv2 fa2].
exploit Hv
; [eapply disjoint_mono; [|by apply Hm']; s; by apply Acc.join_left|].
intros [Hv21 Ha12].
assert (Acc.MAcc.eq Hueq (fv2, fa2) (fv1, fa1)) as Hf'.
{ rewrite Heqfv1, Heqfv2.
  apply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Hueq))
  with (f (Mem.join m m') v1); [apply Hf_mor; [by apply Mem.eq_refl|by auto]|].
  apply Hf.
  rewrite <- Heqfv1; eapply disjoint_right; by apply Hm'. }
constructor.
- by apply Hf'.
- apply Acc.join_eq; [by auto|by apply Hf'].
} Qed.

Lemma aeqv_3 T (t_eq : T -> T -> Prop) (Hteq : DLat.zb_equiv t_eq) :
  forall x, aeqv Hteq (fun _ => x).
Proof.
unfold aeqv; i.
by apply (DLat.zb_equiv_refl (Acc.MAcc.eq_equiv Hteq)).
Qed.

Definition aeqmm (f : Acc.MAcc.m Mem.t -> Acc.MAcc.m Mem.t) : Prop :=
  forall m m' (Hm' : disjoint m' (Acc.get_acc (f m))),
    Acc.MAcc.eq Mem.zb_eq (f (mem_join m m')) (mem_join (f m) m').

Definition aeqmv T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq)
           (f : Mem.t -> Acc.MAcc.m T -> Acc.MAcc.m T) : Prop :=
  forall m m' v (Hm' : disjoint m' (Acc.get_acc (f m v))),
    Acc.MAcc.eq Ht (f (Mem.join m m') v) (f m v).

Lemma aeqmv_1 T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq) :
  forall (f : Mem.t -> Acc.MAcc.m T -> Acc.MAcc.m T) (Hf : aeqmv Ht f) v,
    aeqv Ht (fun m => f m v).
Proof. unfold aeqmv, aeqv; i. by apply Hf, Hm'. Qed.

Lemma aeqm1_1 :
  forall (f : Acc.MAcc.m Mem.t -> Acc.MAcc.m Mem.t) (Hf : aeqmm f)
     g (Hg : forall m m', g (Mem.join m m') = mem_join (g m) m'),
    aeqm1 (fun m => f (g m)).
Proof. {
unfold aeqmm, aeqm1; i.
eapply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Mem.zb_eq))
; [|by apply Hf].
rewrite Hg; apply (DLat.zb_equiv_refl (Acc.MAcc.eq_equiv Mem.zb_eq)).
} Qed.

Lemma bind_mem1 :
  forall f (Hf : aeqm1 f)
     (Hf_mor : Proper (Mem.eq ==> Acc.MAcc.eq Mem.zb_eq) f)
     v (Hv : aeqm1 v),
    aeqm1 (fun m => Acc.MAcc.bind (v m) f).
Proof. {
unfold aeqm1; i.
unfold Acc.MAcc.bind.
remember (v (Mem.join m m')) as va1; destruct va1 as [v1 a1].
remember (f v1) as va2; destruct va2 as [v2 a2].
remember (v m) as va1'; destruct va1' as [v1' a1'].
remember (f v1') as va2'; destruct va2' as [v2' a2'].
s in Hm'. rewrite <- Heqva2' in Hm'. s in Hm'.

assert (Acc.MAcc.eq Mem.zb_eq (v1, a1) (mem_join (v1', a1') m')) as Heq1.
{ rewrite Heqva1, Heqva1'. apply Hv.
  rewrite <- Heqva1'. s.
  eapply disjoint_left; by apply Hm'. }
destruct Heq1 as [Heq11 Heq12]. simpl in Heq11, Heq12.

assert (Acc.MAcc.eq Mem.zb_eq (v2, a2) (mem_join (v2', a2') m')) as Heq2.
{ rewrite Heqva2, Heqva2'.
  apply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Mem.zb_eq))
  with (f (Mem.join v1' m')).
  - by apply Hf_mor.
  - apply Hf.
    rewrite <- Heqva2'. s.
    eapply disjoint_right; by apply Hm'. }
destruct Heq2 as [Heq21 Heq22]; simpl in Heq21, Heq22.

unfold mem_join. s. split.
- by auto.
- by apply Acc.join_eq.
} Qed.

Lemma bind_mem2 :
  forall f (Hf : aeqm2 f)
     (Hf_mor : Proper (Mem.eq ==> Mem.eq ==> Acc.MAcc.eq Mem.zb_eq) f)
     v (Hv : aeqm1 v),
    aeqm1 (fun m => Acc.MAcc.bind (v m) (fun m' => f m' m)).
Proof. {
unfold aeqm1; i.
unfold Acc.MAcc.bind.
remember (v (Mem.join m m')) as va1; destruct va1 as [v1 a1].
remember (f v1 (Mem.join m m')) as va2; destruct va2 as [v2 a2].
remember (v m) as va1'; destruct va1' as [v1' a1'].
remember (f v1' m) as va2'; destruct va2' as [v2' a2'].
s in Hm'. rewrite <- Heqva2' in Hm'. s in Hm'.

assert (Acc.MAcc.eq Mem.zb_eq (v1, a1) (mem_join (v1', a1') m')) as Heq1.
{ rewrite Heqva1, Heqva1'. apply Hv.
  rewrite <- Heqva1'. s.
  eapply disjoint_left; by apply Hm'. }
destruct Heq1 as [Heq11 Heq12]. simpl in Heq11, Heq12.

assert (Acc.MAcc.eq Mem.zb_eq (v2, a2) (mem_join (v2', a2') m')) as Heq2.
{ rewrite Heqva2, Heqva2'.
  apply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Mem.zb_eq))
  with (f (Mem.join v1' m') (Mem.join m m')).
  - apply Hf_mor; [by auto|by apply Mem.eq_refl].
  - apply Hf.
    rewrite <- Heqva2'. s.
    eapply disjoint_right; by apply Hm'. }
destruct Heq2 as [Heq21 Heq22]; simpl in Heq21, Heq22.

unfold mem_join. s. split.
- by auto.
- by apply Acc.join_eq.
} Qed.

Lemma bind_mem3 :
forall (v : Mem.t -> Acc.MAcc.m Mem.t) (f : Mem.t -> Mem.t -> Acc.MAcc.m Mem.t)
   (Hv : aeqm1 v) (Hf : aeqm2 f)
   (Hf_mor : Proper (Mem.eq ==> Mem.eq ==> Acc.MAcc.eq Mem.zb_eq) f),
  aeqm2 (fun m1 m2 => Acc.MAcc.bind (v m1) (fun m3 => f m2 m3)).
Proof.
unfold aeqm1, aeqm2; i.

exploit (Hv m1 m').
{ destruct (v m1). simpl in *.
  destruct (f m2 t). simpl in Hm'.
  eapply disjoint_left. by apply Hm'. }
clear Hv; intro Hv.
remember (v m1). destruct m as [v1 a1].
remember (v (Mem.join m1 m')). destruct m as [v1' a1'].
simpl in *. destruct Hv as [Hvm' Hva'].

exploit (Hf m2 v1 m').
{ destruct (f m2 v1). simpl in *.
  eapply disjoint_right. by apply Hm'. }
clear Hf; intro Hf.
assert (Acc.MAcc.eq Mem.zb_eq (f (Mem.join m2 m') v1') (mem_join (f m2 v1) m'))
  as Hf'.
{ eapply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Mem.zb_eq)); [|by apply Hf].
  apply Hf_mor; [by apply Mem.eq_refl|by auto]. }
remember (f m2 v1). destruct m as [v2 a2].
remember (f (Mem.join m2 m') v1'). destruct m as [v2' a2'].
simpl in *. destruct Hf' as [Hfm' Hfa'].

split; [by auto|by apply Acc.join_eq].
Qed.

Lemma bind_val1 T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq):
  forall f (Hf : forall v, aeqm1 (f v))
     (Hf_mor : Proper (t_eq ==> Mem.eq ==> Acc.MAcc.eq Mem.zb_eq) f)
     (v : Mem.t -> Acc.MAcc.m T) (Hv : aeqv Ht v),
    aeqm1 (fun m => Acc.MAcc.bind (v m) (fun v' => f v' m)).
Proof. {

i. unfold aeqm1, Acc.MAcc.eq. i.
remember (v (Mem.join m m')) as va1; destruct va1 as [v1 a1].
remember (v m) as va2; destruct va2 as [v2 a2].
simpl in Hm'. unfold Acc.MAcc.bind at 1.
remember (f v1 (Mem.join m m')) as ma3; destruct ma3 as [m3 a3].
remember (f v2 m) as ma4; destruct ma4 as [m4 a4].
simpl in Hm'. unfold Acc.MAcc.bind at 1.
unfold mem_join. rewrite <- Heqma4. s.

assert (Acc.MAcc.eq Ht (v1, a1) (v2, a2)) as Heq1.
{ rewrite Heqva1, Heqva2. apply Hv.
  rewrite <- Heqva2. s. eapply disjoint_left; by apply Hm'. }
destruct Heq1 as [Heq_v12 Heq_a12].

remember (f v1 m) as ma5; destruct ma5 as [m5 a5].
assert (Acc.MAcc.eq Mem.zb_eq (m5, a5) (m4, a4)) as Heq4.
{ rewrite Heqma5, Heqma4. apply Hf_mor; [by auto|by apply Mem.eq_refl]. }
destruct Heq4 as [Heq_m54 Heq_a54].

assert (Acc.MAcc.eq Mem.zb_eq (m3, a3) (mem_join (m5, a5) m')) as Heq3.
{ rewrite Heqma3, Heqma5. apply Hf.
  rewrite <- Heqma5. s.
  eapply disjoint_mor
  ; [by apply Mem.eq_refl|by apply Acc.eq_sym, Heq_a54|].
  eapply disjoint_right; by apply Hm'. }
destruct Heq3 as [Heq_m35 Heq_a35]; simpl in Heq_m35, Heq_a35.

split.
- eapply Mem.eq_trans; [by apply Heq_m35|].
  apply Mem.join_eq; [by auto|by apply Mem.eq_refl].
- apply Acc.join_eq; [by auto|].
  eapply Acc.eq_trans; [by apply Heq_a35|by auto].
} Qed.

Lemma bind_val2 T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq):
  forall f (Hf : forall v, aeqm2 (f v))
     (Hf_mor : Proper (t_eq ==> Mem.eq ==> Mem.eq ==> Acc.MAcc.eq Mem.zb_eq) f)
     (v : Mem.t -> Acc.MAcc.m T) (Hv : aeqv Ht v),
  aeqm2 (fun m m' : Mem.t => Acc.MAcc.bind (v m) (fun v' => f v' m m')).
Proof. {
i. unfold aeqm2, Acc.MAcc.eq. i.
remember (v (Mem.join m1 m')) as va1; destruct va1 as [v1 a1].
remember (v m1) as va2; destruct va2 as [v2 a2].
simpl in Hm'. unfold Acc.MAcc.bind.
remember (f v1 (Mem.join m1 m') (Mem.join m2 m')) as ma3; destruct ma3 as [m3 a3].
remember (f v2 m1 m2) as ma4; destruct ma4 as [m4 a4].
simpl in Hm'.
unfold mem_join. s.

assert (Acc.MAcc.eq Ht (v1, a1) (v2, a2)) as Heq1.
{ rewrite Heqva1, Heqva2. apply Hv.
  rewrite <- Heqva2. s. eapply disjoint_left; by apply Hm'. }
destruct Heq1 as [Heq_v12 Heq_a12].

remember (f v1 m1 m2) as ma5; destruct ma5 as [m5 a5].
assert (Acc.MAcc.eq Mem.zb_eq (m5, a5) (m4, a4)) as Heq4.
{ rewrite Heqma5, Heqma4.
  apply Hf_mor; [by auto|by apply Mem.eq_refl|by apply Mem.eq_refl]. }
destruct Heq4 as [Heq_m54 Heq_a54].

assert (Acc.MAcc.eq Mem.zb_eq (m3, a3) (mem_join (m5, a5) m')) as Heq3.
{ rewrite Heqma3, Heqma5. apply Hf.
  rewrite <- Heqma5. s.
  eapply disjoint_mor
  ; [by apply Mem.eq_refl|by apply Acc.eq_sym, Heq_a54|].
  eapply disjoint_right; by apply Hm'. }
destruct Heq3 as [Heq_m35 Heq_a35]; simpl in Heq_m35, Heq_a35.

split.
- eapply Mem.eq_trans; [by apply Heq_m35|].
  apply Mem.join_eq; [by auto|by apply Mem.eq_refl].
- apply Acc.join_eq; [by auto|].
  eapply Acc.eq_trans; [by apply Heq_a35|by auto].
} Qed.

Lemma bind_mmem :
  forall f (Hf : aeqm1 f), aeqmm (fun m_a => Acc.MAcc.bind m_a f).
Proof. {
unfold aeqm1, aeqmm; i.
destruct m as [m a]; s. specialize (Hf m m'). s in Hm'.
destruct (f m) as [fm' fa']. simpl in Hf, Hm'.
remember (f (Mem.join m m')) as fmm; destruct fmm as [fmm' fma']; s.
s in Hf.
assert (disjoint m' fa') as Hdis; [eapply disjoint_right; by apply Hm'|].
specialize (Hf Hdis).
destruct Hf as [Hm Ha].
split; [by auto|apply Acc.join_eq; [by apply Acc.eq_refl|by auto]].
} Qed.

Lemma bind_mval T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq) :
  forall (f : T -> Mem.t -> Acc.MAcc.m T) (Hf : forall v, aeqv Ht (f v)),
    aeqmv Ht (fun m acc_a => Acc.MAcc.bind acc_a (fun v => f v m)).
Proof. {
unfold aeqmv, aeqv; i.
unfold Acc.MAcc.bind, Acc.MAcc.ret in *.
destruct v as [v1 a1]. specialize (Hf v1 m m').
remember (f v1 m) as v2; destruct v2 as [v2 a2].
remember (f v1 (Mem.join m m')) as v2'; destruct v2' as [v2' a2'].
exploit Hf; [eapply disjoint_mono; [|by apply Hm']; s; apply Acc.join_right|].
s. intros [Hv Ha]. split; [by apply Hv|].
apply Acc.join_eq; [by apply Acc.eq_refl|by auto].
} Qed.

Lemma ret_mem1 :
  forall x (Hx : forall m m', Mem.eq (x (Mem.join m m')) (Mem.join (x m) m')),
    aeqm1 (fun m => Acc.MAcc.ret (x m)).
Proof. {
unfold Acc.MAcc.ret, aeqm1. i. split; s; [by apply Hx|by apply Acc.eq_refl].
} Qed.

Lemma ret_mem2 :
  forall (f : Acc.MAcc.m Mem.t -> Acc.MAcc.m Mem.t) (Hf : aeqmm f),
    aeqm1 (fun m => f (Acc.MAcc.ret m)).
Proof. i; apply aeqm1_1; by auto. Qed.

Lemma ret_mem3 :
  forall (x : Mem.t -> Mem.t -> Mem.t)
     (Hx : forall m1 m2 m', Mem.eq (x (Mem.join m1 m') (Mem.join m2 m'))
                               (Mem.join (x m1 m2) m')),
    aeqm2 (fun m1 m2 => Acc.MAcc.ret (x m1 m2)).
Proof. {
unfold Acc.MAcc.ret, aeqm2. i. split; s; [by apply Hx|by apply Acc.eq_refl].
} Qed.

Lemma fold_access_sound :
  forall f s (Hf_ext : forall e m, Acc.le (Acc.get_acc m) (Acc.get_acc (f e m)))
     (Hf_access_sound : forall e (He : PowLoc.mem e s = true), aeqmm (f e))
     (Hf_mor : forall e,
         Proper
           (Acc.MAcc.eq Mem.zb_eq ==> Acc.MAcc.eq Mem.zb_eq)
           (f e)),
    aeqmm (PowLoc.fold f s).
Proof.
i. unfold aeqmm. i. generalize Hm'; clear Hm'.
apply PowLoc.fold2_5 with (f1:=f) (f2:=f) (i1:=mem_join m m') (i2:=m); i
; [|by apply (DLat.zb_equiv_refl (Acc.MAcc.eq_equiv Mem.zb_eq))].
apply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Mem.zb_eq))
with (f e (mem_join t2 m')).
- apply Hf_mor, Ht.
  eapply disjoint_mono; [by apply Hf_ext|by apply Hm'].
- apply Hf_access_sound; [by auto|by auto].
Qed.

Lemma fold_access_sound' T (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq) :
  forall f s (Hf_ext : forall m e v, Acc.le (Acc.get_acc v) (Acc.get_acc (f m e v)))
     (Hf_access_sound : forall e (He : PowLoc.mem e s = true), aeqmv Ht (fun m => f m e))
     (Hf_mor :
        forall m e, Proper (Acc.MAcc.eq Ht ==> Acc.MAcc.eq Ht) (f m e)),
     aeqmv Ht (fun m => PowLoc.fold (f m) s).
Proof.
i; unfold aeqmv; i. generalize Hm'; clear Hm'.
apply PowLoc.fold2_5 with (f1:=f (Mem.join m m')) (f2:=f m) (i1:=v) (i2:=v); i
; [|by apply (DLat.zb_equiv_refl (Acc.MAcc.eq_equiv Ht))].
apply (DLat.zb_equiv_trans (Acc.MAcc.eq_equiv Ht))
with (f (Mem.join m m') e t2).
- apply Hf_mor, Ht0.
  eapply disjoint_mono; [by apply Hf_ext|by apply Hm'].
- apply Hf_access_sound; [by auto|by auto].
Qed.

Lemma list_fold_access_sound
      (T : Type) (t_eq : T -> T -> Prop) (Ht : DLat.zb_equiv t_eq)
      (U : Type) (u_eq : U -> U -> Prop) (Hu : DLat.zb_equiv u_eq) :
  forall (l : list U) f (i : Mem.t -> Acc.MAcc.m T)
     (Hf : forall i (Hi : aeqv Ht i)
              (Hi_mor : Proper (Mem.eq ==> Acc.MAcc.eq Ht) i)
              e,
         aeqv Ht (fun m : Mem.t => f m e (i m)))
     (Hf_mor : Proper (Mem.eq ==> u_eq ==> Acc.MAcc.eq Ht ==> Acc.MAcc.eq Ht) f)
     (Hi : aeqv Ht i) (Hi_mor : Proper (Mem.eq ==> Acc.MAcc.eq Ht) i),
    aeqv Ht (fun m : Mem.t => list_fold (f m) l (i m)).
Proof.
unfold list_fold; induction l; i.
- s. by auto.
- simpl List.fold_left. apply IHl.
  + i; by apply Hf.
  + by auto.
  + by apply Hf.
  + intros m1 m2 Hm; apply Hf_mor
    ; [by auto|by apply (DLat.zb_equiv_refl Hu)|by apply Hi_mor].
Qed.

Lemma list_fold_access_sound1 U :
  forall (l : list U) f
     (Hf : forall i (Hi : aeqm1 i) e, aeqm1 (fun m : Mem.t => f m e (i m)))
     (i : Mem.t -> Acc.MAcc.m Mem.t) (Hi : aeqm1 i),
    aeqm1 (fun m : Mem.t => list_fold (f m) l (i m)).
Proof.
unfold list_fold; induction l; i.
- s. by auto.
- simpl List.fold_left. by apply IHl, Hf.
Qed.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                       *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence.    *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms

     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence.    *)
(**************************************************************************)

Require Import Utf8.
Require Import Reals.
Require Import SetoidDec.
Require Import Lia.
Require Import SetoidList.
Require Import Pactole.Util.Preliminary.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.R2.
Require Import Pactole.Observations.SetObservation.
Require Import Pactole.Models.Rigid.
Require Import Pactole.Models.NoByzantine.
Require Import Pactole.Models.Similarity.
Set Implicit Arguments.
Close Scope R_scope.
Import Datatypes.
Import List.
Import SetoidClass.
Typeclasses eauto := (bfs).

Section ConvergenceAlgo.
(** There are [n] good robots and no byzantine one. *)
Variable n : nat.
Hypothesis n_non_0 : n <> 0%nat.

Instance MyRobots : Names := Robots n 0.
Instance NoByz : NoByzantine.
Proof. now split. Qed.

(* BUG?: To help finding correct instances, loops otherwise! *)
Instance Loc : Location := {| location := R2 |}.
Instance Loc_VS : RealVectorSpace location := R2_VS.
Instance Loc_ES : EuclideanSpace location := R2_ES.
Remove Hints R2_Setoid R2_EqDec : typeclass_instances.
Instance Info : State location := OnlyLocation (fun _ => True).
Instance Obs : Observation := set_observation.
Instance Robots : robot_choice location := { robot_choice_Setoid := location_Setoid }.
Instance FDC : frame_choice (Similarity.similarity location) := FrameChoiceSimilarity.
Instance NoActiveChoice : update_choice unit := {update_choice_EqDec := unit_eqdec}.
Instance NoInactiveChoice : inactive_choice unit := {inactive_choice_EqDec := unit_eqdec}.

Instance UpdateFun : update_function location (Similarity.similarity location) unit := {
  update := fun _ _ _ pt _ => pt;
  update_compat := ltac:(repeat intro; subst; auto) }.

Instance InactiveFun : inactive_function unit := {
  inactive := fun config id _ => config id;
  inactive_compat := ltac:(repeat intro; subst; auto) }.

Instance Update : RigidSetting.
Proof using . split. now intros. Qed.

(* Refolding typeclass instances *)
Ltac changeR2 :=
  change R2 with location in *;
  change R2_Setoid with location_Setoid in *;
  change state_Setoid with location_Setoid in *;
  change R2_EqDec with location_EqDec in *;
  change state_EqDec with location_EqDec in *;
  change R2_VS with Loc_VS in *;
  change R2_ES with Loc_ES in *.

(** The observation is a set of positions *)
Notation "!!" := (fun config => @obs_from_config location _ _ _ set_observation config origin).

Implicit Type config : configuration.
Implicit Type da : demonic_action.
Implicit Type pt : location.

(** As there are robots, the observation can never be empty. *)
Lemma obs_non_empty : forall config pt, obs_from_config config pt =/= @empty location _ _ _.
Proof using n_non_0.
intros config pt.
rewrite obs_from_config_ignore_snd. intro Habs.
assert (Hn : 0%nat < n). { generalize n_non_0. intro. lia. }
pose (g := exist _ 0%nat Hn : G).
specialize (Habs (config (Good g))).
rewrite empty_spec in Habs.
assert (Hin := pos_in_config config origin (Good g)).
simpl in Hin. unfold id in Hin. tauto.
Qed.

Hint Resolve obs_non_empty : core.

(** ** Properties of executions  *)

Open Scope R_scope.

(** All robots are contained in the disk defined by [center] and [radius]. *)
Definition contained (center : R2) (radius : R) (config : configuration) : Prop :=
  forall g, dist center (get_location (config (Good g))) <= radius.

(** Expressing that all good robots stay confined in a small disk. *)
Definition imprisoned (center : R2) (radius : R) (e : execution) : Prop :=
  Stream.forever (Stream.instant (contained center radius)) e.

(** The execution will end in a small disk. *)
Definition attracted (c : R2) (r : R) (e : execution) : Prop := Stream.eventually (imprisoned c r) e.

Instance contained_compat : Proper (equiv ==> Logic.eq ==> equiv ==> iff) contained.
Proof using .
intros ? ? Hc ? ? Hr ? ? Hconfig. subst. unfold contained.
setoid_rewrite Hc. setoid_rewrite Hconfig. reflexivity.
Qed.

Instance imprisoned_compat : Proper (equiv ==> Logic.eq ==> @equiv _ Stream.stream_Setoid ==> iff) imprisoned.
Proof using .
unfold imprisoned. repeat intro.
apply Stream.forever_compat; trivial; []. repeat intro.
apply Stream.instant_compat; trivial; [].
now apply contained_compat.
Qed.

Instance attracted_compat : Proper (equiv ==> eq ==> @equiv _ Stream.stream_Setoid ==> iff) attracted.
Proof using . intros ? ? Heq ? ? ?. now apply Stream.eventually_compat, imprisoned_compat. Qed.

(** A robogram solves convergence if all robots are attracted to a point,
    no matter what the demon and the starting configuration are. *)
Definition solution_SSYNC (r : robogram) : Prop :=
  forall (config : configuration) (d : similarity_demon), Fair d →
  forall (ε : R), 0 < ε → exists (pt : R2), attracted pt ε (execute r d config).

Definition solution_FSYNC (r : robogram) : Prop :=
  forall (config : configuration) (d : similarity_demon), FSYNC (similarity_demon2demon d) →
  forall (ε : R), 0 < ε → exists (pt : R2), attracted pt ε (execute r d config).

Lemma synchro : ∀ r, solution_SSYNC r → solution_FSYNC r.
Proof using .
unfold solution_SSYNC. intros r Hfair config d Hd.
apply Hfair, FSYNC_implies_fair; autoclass.
Qed.

Close Scope R_scope.

(** * Proof of correctness of a convergence algorithm with no byzantine robot. *)

Definition convergeR2_pgm (s : observation) : location :=
  isobarycenter (elements s).

Instance convergeR2_pgm_compat : Proper (equiv ==> equiv) convergeR2_pgm.
Proof using . intros ? ? Heq. unfold convergeR2_pgm. apply isobarycenter_compat. now rewrite Heq. Qed.

Definition convergeR2 : robogram := {| pgm := convergeR2_pgm |}.

(** Rewriting round using only the global frame fo reference. *)
Theorem round_simplify : forall da config, SSYNC_da da ->
  round convergeR2 da config
  == fun id => if da.(activate) id
               then isobarycenter (@elements location _ _ _ (!! config))
               else config id.
Proof using n_non_0.
intros da config HSSYNC. rewrite SSYNC_round_simplify; trivial; [].
intro id. pattern id. apply no_byz. clear id. intro g.
unfold round. destruct_match; try reflexivity; [].
remember (change_frame da config g) as sim.
change (Bijection.section (inverse (frame_choice_bijection sim)))
  with (Bijection.section (sim ⁻¹)).
cbn -[equiv location mul map_config lift precondition inverse].
unfold convergeR2_pgm. unfold map_config at 2.
rewrite <- obs_from_config_map, map_injective_elements; autoclass; try apply Similarity.injective; [].
cbn -[inverse isobarycenter equiv].
rewrite obs_from_config_ignore_snd, isobarycenter_sim_morph.
+ now simpl; rewrite Bijection.retraction_section.
+ rewrite elements_nil. apply obs_non_empty.
Qed.

(** Once robots are contained within a circle, they will never escape it. *)

(* First, we assume a geometric property of the isobarycenter:
   if all points are included in a circle, then so is their isobarycenter. *)
Axiom isobarycenter_circle : forall center radius (l : list R2),
  List.Forall (fun pt => dist center pt <= radius)%R l ->
  (dist center (isobarycenter l) <= radius)%R.

Lemma contained_isobarycenter : forall c r config,
  contained c r config -> (dist c (isobarycenter (elements (!! config))) <= r)%R.
Proof using n_non_0.
intros c r config Hc. apply isobarycenter_circle.
rewrite Forall_forall. intro.
rewrite <- InA_Leibniz. change eq with (@equiv location _).
rewrite elements_spec, obs_from_config_In.
intros [id Hpt]. rewrite <- Hpt.
pattern id. apply no_byz. apply Hc.
Qed.

Lemma contained_next : forall da c r config, SSYNC_da da ->
  contained c r config -> contained c r (round convergeR2 da config).
Proof using n_non_0.
intros da c r config HSSYNC Hconfig g.
rewrite round_simplify; trivial; [].
destruct_match.
- now apply contained_isobarycenter.
- auto.
Qed.

Lemma converge_forever : forall d c r config, SSYNC d ->
  contained c r config -> imprisoned c r (execute convergeR2 d config).
Proof using n_non_0.
cofix Hcorec. intros d c r config [] Hrec. constructor.
- apply Hrec.
- apply Hcorec; auto using contained_next.
Qed.

(************************)
(** *  Final theorems  **)
(************************)

Theorem convergence_FSYNC : solution_FSYNC convergeR2.
Proof using n_non_0.
intros config d [Hfair ?] ε Hε.
exists (isobarycenter (elements (obs_from_config (Observation := set_observation) config 0))).
apply Stream.Later, Stream.Now. rewrite execute_tail.
apply converge_forever; auto using FSYNC_SSYNC; [].
intro g. rewrite round_simplify; auto using FSYNC_SSYNC_da; [].
rewrite Hfair. changeR2.
transitivity 0%R; try (now apply Rlt_le); [].
apply Req_le. now apply dist_defined.
Qed.

Theorem convergence_SSYNC : solution_SSYNC convergeR2.
Proof.
Abort.

End ConvergenceAlgo.


Require Export Denotational.
Require Import TranslateExp.
Require Import FunctionalExtensionality.
Require Import Tactics.

Require Import DenotationalTyped.

(********** Equivalence of contracts **********)

(* Full equivalence. *)

Definition equiv (g : TyEnv) (c1 c2 : Contr) : Prop
  := g |-C c1 /\ g |-C c2 /\
    (forall (env : Env) (ext : ExtEnv),
      TypeExt ext -> TypeEnv g env -> C[|c1|]env ext = C[|c2|]env ext).
Notation "c1 '≡[' g ']' c2" := (equiv g c1 c2) (at level 50).

Lemma equiv_typed g c1 c2 : g |-C c1 -> g |-C c2 -> (forall t1 t2 env ext, TypeExt ext -> TypeEnv g env -> C[|c1|]env ext = Some t1 -> C[|c2|]env ext = Some t2 -> t1 = t2) -> c1 ≡[g] c2.
Proof.
  intros T1 T2 E. unfold equiv. repeat split;auto. intros.
  eapply Csem_typed_total in T1;eauto. destruct T1 as [t1 T1].
  eapply Csem_typed_total in T2;eauto. destruct T2 as [t2 T2].
  rewrite T1. rewrite T2. f_equal. eauto.
Qed.

Lemma delay_trace_at d t : delay_trace d t d = t O.
Proof.
  unfold delay_trace.
  assert (leb d d = true) as E by (apply leb_correct; auto).
  rewrite E. rewrite minus_diag. reflexivity.
Qed.

Hint Resolve translateExp_type.

Theorem transl_ifwithin g e d t c1 c2 : g |-C c1 -> g |-C c2 -> g |-E e ∶ BOOL ->
  If (translateExp (Z.of_nat d) e) t (Translate d c1) (Translate d c2) ≡[g]
  Translate d (If e t c1 c2).
Proof.
  unfold equiv. intros. repeat split; eauto. intros env ext R V.
  generalize dependent ext. induction t; intros.
  - eapply Esem_typed_total with (ext:=(adv_ext (Z.of_nat d) ext)) in H1;eauto.
    decompose [ex and] H1. simpl in *. rewrite translateExp_ext, H3 in *.
    destruct x; try destruct b; reflexivity.
  - pose H1 as H1'. eapply Esem_typed_total with (ext:=(adv_ext (Z.of_nat d) ext)) in H1';eauto.
    decompose [ex and] H1'. simpl in *. rewrite translateExp_ext, H3. destruct x; try reflexivity. destruct b. reflexivity.
    rewrite IHt;eauto. rewrite adv_ext_swap. repeat rewrite liftM_liftM. apply liftM_ext.
    intros. unfold compose. apply delay_trace_swap.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export computation_minus.
Require Export approx_props2.
Require Export sequents_tacs.
Require Export sequents_tacs2.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export per_props_nat.
Require Export per_can.
Require Export per_props_top.
Require Export integer_type.

Definition mk_conclax_pair {p} (typ1 typ2 : @NTerm p) : conclusion :=
   mk_concl (mk_prod typ1 typ2) (mk_pair mk_axiom mk_axiom).

Lemma covered_axiom_pair :
  forall (p : POpid) (vs : list NVar), covered (mk_pair (@mk_axiom p) mk_axiom) vs.
Proof. unfold covered; sp; simpl.
Qed.

(*
   H |- a in Z /\ b in Z

     By callbyvalueArith

     H |- halts (a op b)
     H |- a in Base
     H |- b in Base
 *)
Definition rule_callbyvalue_arith {o}
           (H : barehypotheses)
           (op: ArithOp )
           (a b: @NTerm o)
            :=
  mk_rule
    (mk_baresequent H (mk_conclax_pair (mk_member a mk_int) (mk_member b mk_int)))
    [ mk_baresequent H (mk_conclax
       (mk_halts (mk_arithop op a b))),
     mk_baresequent H (mk_conclax
       (mk_member  a mk_base)),
     mk_baresequent H (mk_conclax
       (mk_member b mk_base))
    ]
    [].

Lemma rule_callbyvalue_arith_true {o} :
  forall lib (H : barehypotheses)
         op
         (a b: @NTerm o),
    rule_true lib (rule_callbyvalue_arith H op a b).
Proof.
  unfold rule_callbyvalue_arith, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom_pair o (nh_vars_hyps H)).
  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as abase; clear hyp2.
  exrepnd.
  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as bbase; clear hyp3.
  exrepnd.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms b1.
  generalize_lsubstc_terms a2.
  generalize_lsubstc_terms b2.
  apply equality_in_halts in hyp1;exrepd.
  apply tequality_mkc_halts in hyp0; lsubst_tac.
  spcast.
    rename c into hasv.
  apply hasvaluec_mkc_arithop in hasv; exrepnd.
  dup hasv0 as a1int.
  apply computes_to_integer_member_int in a1int.
  dup hasv1 as b1int.
  apply computes_to_integer_member_int in b1int.
  apply @tequality_mkc_member_base in abase0.
  apply @tequality_mkc_member_base in bbase0.
  spcast.
  assert (equality lib a1 a2 mkc_int) as aeq by (apply equality_respects_cequivc; auto).
  assert (equality lib b1 b2 mkc_int) as beq by (apply equality_respects_cequivc; auto).
  dup aeq as a2int; apply equality_sym in a2int; apply equality_refl in a2int.
  dup beq as b2int; apply equality_sym in b2int; apply equality_refl in b2int.
  split.
  - (* tequality *)
    apply tequality_mkc_prod; split.
    + apply tequality_mkc_member; sp. apply tequality_int.
    + intro. apply tequality_mkc_member; sp. apply tequality_int.
  - (* equality *)
    apply equality_in_prod; sp;
   try apply tequality_mkc_member; sp;
   try apply tequality_int.
   eexists. eexists. eexists. eexists; sp;
   spcast; try apply computes_to_valc_refl;
   try  apply equality_in_member; sp; spcast; eauto 3 with slow.
Qed.

(*
   H |- a in Z

     By callbyvalueMinus

     H |- halts (-a)
     H |- a in Base

 *)
Definition rule_callbyvalue_minus {o}
           (H : barehypotheses)
           (op: ArithOp )
           (a: @NTerm o)  :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_member a mk_int)))
    [ mk_baresequent H (mk_conclax
       (mk_halts (mk_minus a))),
     mk_baresequent H (mk_conclax
       (mk_member  a mk_base))
    ]
    [].

Lemma rule_callbyvalue_minus_true {o} :
  forall lib (H : barehypotheses)
         op
         (a: @NTerm o),
    rule_true lib (rule_callbyvalue_minus H op a).
Proof.
  unfold rule_callbyvalue_minus, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).
  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as abase; clear hyp2.
  exrepnd.
  lsubst_tac.
  generalize_lsubstc_terms a1.
  generalize_lsubstc_terms a2.
  apply equality_in_halts in hyp1;exrepd.
  apply tequality_mkc_halts in hyp0; lsubst_tac.
  spcast.
    rename c into hasv.
  apply hasvaluec_mkc_minus in hasv; exrepnd.
  dup hasv0 as a1int.
  apply computes_to_integer_member_int in a1int.
  apply @tequality_mkc_member_base in abase0.
  spcast.
  assert (equality lib a1 a2 mkc_int) as aeq by (apply equality_respects_cequivc; auto).
  dup aeq as a2int; apply equality_sym in a2int; apply equality_refl in a2int.
  split.
  - (* tequality *)
   apply tequality_mkc_member; sp. apply tequality_int.
  - (* equality *)
   apply equality_in_member. sp; spcast; eauto 3 with slow.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Export prosa.analysis.definitions.busy_interval.

(** * Cumulative Priority Inversion for JLFP-models *)
(** In this module we define the notion of cumulative priority inversion for uni-processor for JLFP schedulers. *)
Section CumulativePriorityInversion.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** Next, consider any ideal uniprocessor schedule of this arrival sequence. *)
  Variable sched : schedule (ideal.processor_state Job).

  (** Assume a given JLFP policy. *)
  Context `{JLFP_policy Job}.

  (** In this section, we define a notion of bounded priority inversion experienced by a job. *)
  Section JobPriorityInversionBound.

    (** Consider an arbitrary task [tsk]. *)
    Variable tsk : Task.

    (** Consider any job j of [tsk]. *)
    Variable j : Job.
    Hypothesis H_from_arrival_sequence : arrives_in arr_seq j.
    Hypothesis H_job_task : job_of_task tsk j.

    (** We say that the job incurs priority inversion if it has higher
        priority than the scheduled job. Note that this definition
        implicitly assumes that the scheduler is
        work-conserving. Therefore, it cannot be applied to models
        with jitter or self-suspensions. *)
    Definition is_priority_inversion (t : instant) :=
      if sched t is Some jlp then
        ~~ hep_job jlp j
      else false.

    (** Then we compute the cumulative priority inversion incurred by
         a job within some time interval <<[t1, t2)>>. *)
    Definition cumulative_priority_inversion (t1 t2 : instant) :=
      \sum_(t1 <= t < t2) is_priority_inversion t.

    (** We say that priority inversion of job [j] is bounded by a constant [B] iff cumulative
         priority inversion within any busy interval prefix is bounded by [B]. *)
    Definition priority_inversion_of_job_is_bounded_by (B : duration) :=
      forall (t1 t2 : instant),
        busy_interval_prefix arr_seq sched j t1 t2 ->
        cumulative_priority_inversion t1 t2 <= B.

  End JobPriorityInversionBound.

  (** In this section, we define a notion of the bounded priority inversion for task. *)
  Section TaskPriorityInversionBound.

    (** Consider an arbitrary task [tsk]. *)
    Variable tsk : Task.

    (** We say that task [tsk] has bounded priority inversion if all
         its jobs have bounded cumulative priority inversion. *)
    Definition priority_inversion_is_bounded_by (B : duration) :=
      forall (j : Job),
        arrives_in arr_seq j ->
        job_task j = tsk ->
        job_cost j > 0 ->
        priority_inversion_of_job_is_bounded_by j B.

  End TaskPriorityInversionBound.

End CumulativePriorityInversion.


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

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 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 Fcore.
Require Import Fcalc_ops.

Definition Zrnd_odd x :=  match Req_EM_T x (Z2R (Zfloor x))  with
  | left _   => Zfloor x
  | right _  => match (Zeven (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 Zle_trans with (Zfloor y).
now apply Zfloor_le.
unfold Zrnd_odd; destruct (Req_EM_T  y (Z2R (Zfloor y))).
now apply Zle_refl.
case (Zeven (Zfloor y)).
apply le_Z2R.
apply Rle_trans with y.
apply Zfloor_lb.
apply Zceil_ub.
now apply Zle_refl.
unfold Zrnd_odd at 1.
(* . *)
destruct (Req_EM_T  x (Z2R (Zfloor x))) as [Hx|Hx].
(* .. *)
apply H.
(* .. *)
case_eq (Zeven (Zfloor x)); intros Hx2.
2: apply H.
unfold Zrnd_odd; destruct (Req_EM_T  y (Z2R (Zfloor y))) as [Hy|Hy].
apply Zceil_glb.
now rewrite <- Hy.
case_eq (Zeven (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 Z2R_le; omega.
now apply sym_not_eq.
contradict Hy2.
rewrite <- H1, Hx2; discriminate.
(* . *)
intros n; unfold Zrnd_odd.
rewrite Zfloor_Z2R, Zceil_Z2R.
destruct (Req_EM_T  (Z2R n) (Z2R n)); trivial.
case (Zeven n); trivial.
Qed.

Lemma Zrnd_odd_Zodd: forall x, x <> (Z2R (Zfloor x)) ->
  (Zeven (Zrnd_odd x)) = false.
Proof.
intros x Hx; unfold Zrnd_odd.
destruct (Req_EM_T  x (Z2R (Zfloor x))) as [H|H].
now contradict H.
case_eq (Zeven (Zfloor x)).
(* difficult case *)
intros H'.
rewrite Zceil_floor_neq.
rewrite Zeven_plus, H'.
reflexivity.
now apply sym_not_eq.
trivial.
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 canonic := (canonic beta fexp).
Notation cexp := (canonic_exp 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 /\ canonic g /\ Zeven (Fnum g) = false)).

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

Theorem Rnd_odd_pt_sym :   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_DN_UP_pt_sym...
apply generic_format_opp.
left.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
apply Rnd_UP_DN_pt_sym...
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 canonic_opp.
simpl.
now rewrite Zeven_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) (Z2R (Zfloor (- r)))).
case (Req_EM_T r (Z2R (Zfloor r))).
intros Y1 Y2.
apply eq_Z2R.
now rewrite Z2R_opp, <- Y1, <-Y2.
intros Y1 Y2.
absurd (r=Z2R (Zfloor r)); trivial.
pattern r at 2; replace r with (-(-r))%R by ring.
rewrite Y2, <- Z2R_opp.
rewrite Zfloor_Z2R.
rewrite Z2R_opp, <- Y2.
ring.
case (Req_EM_T r (Z2R (Zfloor r))).
intros Y1 Y2.
absurd (-r=Z2R (Zfloor (-r)))%R; trivial.
pattern r at 2; rewrite Y1.
rewrite <- Z2R_opp, Zfloor_Z2R.
now rewrite Z2R_opp, <- Y1.
intros Y1 Y2.
unfold Zceil; rewrite Ropp_involutive.
replace  (Zeven (Zfloor (- r))) with (negb (Zeven (Zfloor r))).
case (Zeven (Zfloor r));  simpl; ring.
apply trans_eq with (Zeven (Zceil r)).
rewrite Zceil_floor_neq.
rewrite Zeven_plus.
simpl; reflexivity.
now apply sym_not_eq.
rewrite <- (Zeven_opp (Zfloor (- r))).
reflexivity.
apply canonic_exp_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_sym.
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)
     (Z2R (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 (Zeven (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 := canonic_exp beta fexp f).
set (mf := Ztrunc (scaled_mantissa beta fexp f)).
exists (Float beta mf ef).
unfold Fcore_generic_fmt.canonic.
rewrite <- H0.
repeat split; try assumption.
apply trans_eq with (negb (Zeven (Zfloor (scaled_mantissa beta fexp x)))).
2: rewrite H1; reflexivity.
apply trans_eq with (negb (Zeven (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 Fcore_generic_fmt.canonic.
simpl.
apply sym_eq, canonic_exp_DN...
unfold Fcore_generic_fmt.canonic.
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 (ln_beta 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 canonic_0.
unfold Fcore_generic_fmt.canonic.
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_Z2R, 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 := canonic_exp beta fexp x).
set (mf := Zfloor (scaled_mantissa beta fexp x)).
exists (Float beta mf ef).
unfold Fcore_generic_fmt.canonic.
repeat split; try assumption.
simpl.
apply trans_eq with (cexp (round beta fexp Zfloor x )).
apply sym_eq, canonic_exp_DN...
reflexivity.
intros Hrx; contradict Y.
replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z.
simpl; discriminate.
apply eq_Z2R, 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_unicity :
  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_unicity 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 (Zeven (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_unicity with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- L1; apply Rnd_UP_pt_unicity 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 (Zeven (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_unicity with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
apply Rnd_UP_pt_unicity 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_unicity 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_unicity with y; try assumption.
apply round_odd_pt.
Qed.

End Fcore_rnd_odd.

Section Odd_prop_aux.

Variable beta : radix.
Hypothesis Even_beta: Zeven (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_ln_beta with fexp; trivial; intros Hx2.
generalize (fexpe_fexp (ln_beta beta x)).
omega.
Qed.

Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R),
      (exists f:float beta, F2R f = x /\ (c (ln_beta beta x) < Fexp f)%Z) ->
      exists f:float beta, F2R f =x /\ canonic beta c f /\ Zeven (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 (ln_beta beta x)))
     (c (ln_beta beta x))).
assert (F2R (Float beta
     (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x)))
     (c (ln_beta beta x))) = x).
unfold F2R; simpl.
rewrite Z2R_mult, Z2R_Zpower.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Hg1; unfold F2R.
apply f_equal, f_equal.
ring.
omega.
split; trivial.
split.
unfold canonic, canonic_exp.
now rewrite H.
simpl.
rewrite Zeven_mult.
rewrite Zeven_Zpower.
rewrite Even_beta.
apply Bool.orb_true_intro.
now right.
omega.
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: canonic beta fexp d.
Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u).
Hypothesis Cu: canonic 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_unicity 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_unicity 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 ln_beta_d:  (0< F2R d)%R ->
    (ln_beta beta (F2R d) = ln_beta beta x :>Z).
Proof with auto with typeclass_instances.
intros Y.
rewrite d_eq; apply ln_beta_DN...
now rewrite <- d_eq.
Qed.

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

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

Lemma format_bpow_d: (0 < F2R d)%R ->
  generic_format beta fexp (bpow (ln_beta beta (F2R d))).
Proof with auto with typeclass_instances.
intros Y; apply generic_format_bpow.
apply valid_exp.
apply ln_beta_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonic.
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 ln_beta_m: (0 < F2R d)%R -> (ln_beta beta m =ln_beta beta (F2R d) :>Z).
Proof with auto with typeclass_instances.
intros dPos; apply ln_beta_unique_pos.
split.
apply Rle_trans with (F2R d).
destruct (ln_beta 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 ln_beta_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonic.
case (Rle_or_lt x (bpow (ln_beta beta (F2R d)))); trivial; intros Z.
absurd ((bpow (ln_beta beta (F2R d)) <= (F2R d)))%R.
apply Rlt_not_le.
destruct  (ln_beta 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 ln_beta_generic_gt...
now apply Rgt_not_eq.
now apply generic_format_canonic.
now left.
replace m with (F2R d).
destruct (ln_beta 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 ln_beta_m_0: (0 = F2R d)%R
    -> (ln_beta beta m =ln_beta beta (F2R u)-1:>Z)%Z.
Proof with auto with typeclass_instances.
intros Y.
apply ln_beta_unique_pos.
unfold m; rewrite <- Y, Rplus_0_l.
rewrite u_eq.
destruct (ln_beta 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 ln_beta_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 (Z2R_le 2).
specialize (radix_gt_1 beta).
omega.
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 (ln_beta 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 beta (Float beta b (-1)) (Fplus beta 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, Z2R_mult.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp (Fplus beta d u'))%Z.
unfold Fmult.
destruct  (Fplus beta 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; omega.
Qed.

Lemma m_eq_0: (0 = F2R d)%R ->  exists f:float beta,
   F2R f = m /\ (Fexp f = fexp (ln_beta 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 beta (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, Z2R_mult.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
rewrite Rmult_0_r, <- (Z2R_mult 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 (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z.
Proof with auto with typeclass_instances.
intros Y.
assert ((fexp (ln_beta beta (F2R u) - 1) <= fexp (ln_beta beta (F2R u))))%Z.
2: omega.
destruct (ln_beta 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 ln_beta_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)); omega.
apply sym_eq, valid_exp; omega.
Qed.

Lemma Fm:  generic_format beta fexpe m.
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 canonic_exp; rewrite Hg2.
rewrite ln_beta_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold canonic_exp.
generalize (fexpe_fexp (ln_beta beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
assumption.
intros H; unfold canonic_exp; rewrite Hg2.
rewrite ln_beta_m_0; try assumption.
apply Zle_trans with (1:=fexpe_fexp _).
assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega].
now apply fexp_m_eq_0.
Qed.

Lemma Zm:
   exists g : float beta, F2R g = m /\ canonic beta fexpe g /\ Zeven (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 ln_beta_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
unfold canonic_exp.
generalize (fexpe_fexp  (ln_beta beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
rewrite ln_beta_m_0; trivial.
apply Zle_lt_trans with (1:=fexpe_fexp _).
assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega].
now apply fexp_m_eq_0.
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; absurd (z < z)%R.
auto with real.
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; absurd (z < z)%R.
auto with real.
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.

Theorem round_odd_prop_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 canonic_unicity 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 canonic_exp.
apply Zle_lt_trans with (1:=fexpe_fexp _).
omega.
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
apply canonic_unicity 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: Zeven (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 canonizer: forall f, generic_format beta fexp f
   -> exists g : float beta, f = F2R g /\ canonic beta fexp g.
Proof with auto with typeclass_instances.
intros f Hf.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)).
assert (L:(f = F2R (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)))).
apply trans_eq with (round beta fexp Ztrunc f).
apply sym_eq, round_generic...
reflexivity.
split; trivial.
unfold canonic; rewrite <- L.
reflexivity.
Qed.

Theorem round_odd_prop: 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 (canonizer (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonizer (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_odd_prop_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 (canonizer (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
apply generic_format_round...
destruct (canonizer (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
apply generic_format_round...
apply round_odd_prop_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
Qed.

End Odd_prop.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2008-02-22, 2009-10-20 (rpo)

convert CoLoR terms into Coccinelle terms
*)

Set Implicit Arguments.

Require Import Relation_Definitions Setoid Bool Arith ATerm VecUtil
EqUtil LogicUtil List more_list term_spec NatUtil.

(* Define symbol. *)

Section symb.

  Variable Sig: Signature.

  Definition A_symb       := symbol Sig.
  Definition eq_bool_symb := @beq_symb Sig.

  Lemma eq_bool_symb_ok : forall a1 a2,
    match eq_bool_symb a1 a2 with
      | true  => a1 = a2
      | false => ~ a1 = a2
    end.

  Proof.
    intros a1 a2. unfold eq_bool_symb. case_beq_symb Sig a1 a2. auto.
    rewrite <- (beq_ko (@beq_symb_ok Sig)). apply H.
   Qed.

  Definition symb_arity (f: Sig) : arity_type  := Free (ASignature.arity f).

End symb.

(* Define var *)

Section var.

  Definition var         := nat.
  Definition var_eq_bool := beq_nat.

  Lemma var_eq_bool_ok: forall a1 a2,
    match var_eq_bool a1 a2 with
      | true => a1 = a2
      | false => ~ a1 = a2
    end.

  Proof.
    intros a1 a2. unfold var_eq_bool. case_beq_nat a1 a2. auto.
    rewrite <- (beq_ko beq_nat_ok). hyp.
  Qed.

End var.

(* [term] in cocc *)

Section Term.

  Variable Sig: Signature.

  Notation A               := (symbol Sig).
  Notation eq_symb_bool    := (eq_bool_symb Sig).
  Notation eq_symb_bool_ok := (eq_bool_symb_ok Sig).
  Notation eq_var_bool     := var_eq_bool.
  Notation eq_var_bool_ok  := var_eq_bool_ok.
  Notation symbol          := (symbol Sig).
  Notation variable        := nat (only parsing).

  Inductive term : Type :=
  | Var  : variable -> term
  | Term : symbol   -> list term -> term.

  Fixpoint size (t: term) : nat :=
    match t with
      | Var v    => 1
      | Term _ l =>
        let size_list :=
          (fix size_list (l : list term) {struct l} : nat :=
            match l with
              | nil     => 0
              | t :: lt => size t + size_list lt
            end) in
          1 + size_list l
    end.

   Definition size_unfold :
    forall t,
      size t = match t with
                 | Var _    => 1
                 | Term f l => 1 + list_size size l
               end.
  Proof.
    intro t; case t; clear t.
    intro v; reflexivity.
    intros f l; simpl; apply f_equal.
    revert l; fix 1.
    intro l; case l; clear l.
    reflexivity.
    intros t l; simpl; rewrite size_unfold; reflexivity.
  Defined.

  Lemma size_ge_one : forall t, 1 <= size t.
  Proof.
    intro t; case t; clear t.
    intro v; apply le_n.
    intros f l; rewrite size_unfold; apply le_n_S; apply le_O_n.
  Qed.

   Function var_in_term_list (x : variable) (l : list term)
    { measure (list_size size) l } : bool :=
    match l with
      | nil              => false
      | (Var y) :: l     => orb (eq_var_bool x y)       (var_in_term_list x l)
      | (Term _ ll) :: l => orb (var_in_term_list x ll) (var_in_term_list x l)
    end.
  Proof.
    intros _ l t l' y H1 H2;  simpl; auto with arith.
    intros _ l t l' f ll H1 H2; simpl; auto with arith.
    intros _ l t l' f ll H1 H2; simpl; apply lt_le_trans with (size (Term f ll)).
    rewrite size_unfold; simpl; auto with arith.
    simpl; auto with arith.
  Defined.

   Definition direct_subterm t1 t2 : Prop :=
    match t2 with
      | Var _    => False
      | Term _ l => In t1 l
    end.

  Definition size_direct_subterm :
    forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.

  Proof.
    intros t1 t2; unfold direct_subterm; case t2; clear t2.
    intros a Abs; elim Abs.
    intros f l; rewrite (size_unfold (Term f l)).
    revert t1 l; clear f; fix 2.
    intros t1 l; case l; clear l; simpl.
    intro Abs; elim Abs.
    intros t l t1_in_tl; case t1_in_tl; clear t1_in_tl.
    intro t_eq_t1; subst t1; apply le_n_S; apply le_plus_l.
    intro t_in_l; apply lt_le_trans with (1 + list_size size l).
    apply size_direct_subterm; assumption.
    apply le_n_S; apply le_plus_r.
  Defined.

  Fixpoint t_eq_bool (t1 t2 : term) : bool :=
    match t1, t2 with
      | Var v1,     Var v2     => eq_var_bool v1 v2
      | Var _,      Term _ _   => false
      | Term _ _,   Var _      => false
      | Term f1 l1, Term f2 l2 =>
        if eq_symb_bool f1 f2
          then
            let eq_bool_list :=
              (fix eq_bool_list (l1 l2: list term) {struct l1} : bool :=
                match l1, l2 with
                  | nil, nil      => true
                  | nil, (_ :: _) => false
                  | (_::_), nil   => false
                  | t1 :: k1, t2 :: k2 =>
                    if   t_eq_bool t1 t2
                    then eq_bool_list k1 k2
                    else false
                end) in
              eq_bool_list l1 l2
          else false
    end.

  Lemma t_eq_bool_ok : forall t1 t2,
    match t_eq_bool t1 t2 with
      | true => t1 = t2
      | false => t1<> t2
    end.

    fix 1.
    intro t1; case t1; [intro v1 | intros f1 l1];
      (intro t2; case t2; [intro v2 | intros f2 l2]); simpl.
    generalize (eq_var_bool_ok v1 v2); case (eq_var_bool v1 v2).
    intros v1_eq_v2; rewrite v1_eq_v2; reflexivity.
    intros v1_diff_v2 v1_eq_v2; apply v1_diff_v2;
      injection v1_eq_v2; intro; assumption.
    discriminate.
    discriminate.
    generalize (eq_symb_bool_ok f1 f2); case (eq_symb_bool f1 f2).
    intros f1_eq_f2; rewrite f1_eq_f2.
    assert (eq_bool_list_ok : match (fix eq_bool_list (l0 l3 : list term) : bool :=
      match l0 with
        | nil => match l3 with
                   | nil => true
                   | _ :: _ => false
                 end
        | t3 :: k1 =>
          match l3 with
            | nil => false
            | t4 :: k2 => if t_eq_bool t3 t4 then eq_bool_list k1 k2 else false
          end
      end) l1 l2 with true => l1 = l2 | false => l1 <> l2 end).
    revert l1 l2; clear -t_eq_bool_ok.
    fix t_eq_bool_list_ok 1.
    intro l1; case l1; [idtac | intros t1 k1]; (intro l2; case l2; [idtac | intros t2 k2]).
    reflexivity.
    discriminate.
    discriminate.
    generalize (t_eq_bool_ok t1 t2); case (t_eq_bool t1 t2).
    intro t1_eq_t2; rewrite t1_eq_t2.
    generalize (t_eq_bool_list_ok k1 k2);
      case ((fix eq_bool_list (l0 l3 : list term) : bool :=
        match l0 with
          | nil => match l3 with
                     | nil => true
                     | _ :: _ => false
                   end
          | t3 :: k3 =>
            match l3 with
              | nil => false
              | t4 :: k4 => if t_eq_bool t3 t4 then eq_bool_list k3 k4 else false
            end
        end) k1 k2).
    intro k1_eq_k2; rewrite k1_eq_k2; reflexivity.
    intros k1_diff_k2 tk1_eq_tk2; apply k1_diff_k2; injection tk1_eq_tk2; intro; assumption.
    intros t1_diff_t2 tk1_eq_tk2; apply t1_diff_t2; injection tk1_eq_tk2; intros; assumption.
    revert eq_bool_list_ok;
      case ((fix eq_bool_list (l0 l3 : list term) : bool :=
        match l0 with
          | nil =>
            match l3 with
              | nil => true
              | _ :: _ => false
            end
          | t3 :: k1 =>
            match l3 with
              | nil => false
              | t4 :: k2 =>
                if t_eq_bool t3 t4
                  then eq_bool_list k1 k2
                  else false
            end
        end) l1 l2).
    intro l1_eq_l2; rewrite l1_eq_l2; reflexivity.
    intros l1_diff_l2 fl1_eq_fl2; apply l1_diff_l2; injection fl1_eq_fl2; intros; assumption.
    intros f1_diff_f2 fl1_eq_fl2; apply f1_diff_f2; injection fl1_eq_fl2; intros; assumption.
  Defined.

  Definition term_A          := term.
  Definition term_eq_bool    := t_eq_bool.
  Definition term_eq_bool_ok := t_eq_bool_ok.

  Definition eq_term_dec : forall t t': term, {t=t'}+{t<>t'}.
  intros t t'; generalize (t_eq_bool_ok t t').
  case (t_eq_bool t t').
  intro t_eq_t'; left; assumption.
  intro t_diff_t'; right; assumption.
  Defined.

  (** ** Recursion on terms. *)

  Section Recursion.

    Variable P  : term      -> Type.
    Variable Pl : list term -> Type.

    Definition term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.

    Proof.
      intros H t; apply (H (size t) t); apply le_n.
    Defined.

    Definition term_rec3 :
      (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t)
        -> P (Term f l)) -> forall t, P t.

    Proof.
      intros Hv Halg.
      fix 1.
      intro t;case t.
      exact Hv.
      intro a.
      intro l. apply Halg.
      revert l.
      fix term_list_rec_3 1  .
      intro l;case l.
      simpl;intros t0 abs;elim abs.
      intros t0 l0 t1 .
      simpl.
      intros H.
      case (eq_term_dec t0 t1).
      intros t_eq_t1.
      rewrite <- t_eq_t1.
      apply term_rec3.
      intro t_eq_t1. assert (In t1 l0).
      case H. intro abs;elim t_eq_t1;exact abs.
      intro h;exact h.
      apply term_list_rec_3 with l0.
      exact H0.
    Defined.

  End Recursion.

  (** ** Substitutions. *)

  Definition substitution := list (variable * term).

  Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
    match t with
      | Var v =>
        match find eq_var_bool v sigma with
          | None         => t
          | Some v_sigma => v_sigma
        end
      | Term f l => Term f (map (apply_subst sigma) l)
    end.

  (** ** Positions in a term.*)

  Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
    match p with
  | nil => true
      | i :: q =>
        match t with
          | Var _    => false
          | Term _ l =>
            match nth_error l i with
              | Some ti => is_a_pos ti q
              | None    => false
            end
        end
    end.

  Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
    match p with
      | nil    => u
      | i :: q =>
        match t with
          | Var _    => t
          | Term f l =>
            let replace_at_pos_list :=
              (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
                match l with
                  | nil     => nil
                  | h :: tl =>
                    match j with
                      | O   => (replace_at_pos h u q) :: tl
                      | S k => h :: (replace_at_pos_list k tl)
                    end
                end) in
              Term f (replace_at_pos_list i l)
        end
    end.

  Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
    {struct l}: list term :=
    match l with
      | nil     => nil
      | h :: tl =>
        match i with
          | O   =>      (replace_at_pos h u p)         :: tl
          | S j => h :: (replace_at_pos_list tl  u j p)
        end
    end.

  Lemma replace_at_pos_unfold :
    forall f l u i q,
      replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).

  Proof.
    intros f l u i q; simpl; apply (f_equal (fun l => Term f l));
      generalize u i q; clear u i q;
        induction l as [| t l]; intros u i q; trivial.
    simpl; destruct i as [ | i ]; trivial.
    rewrite <- IHl; trivial.
  Qed.

  Lemma replace_at_pos_list_replace_at_pos_in_subterm :
    forall l1 ui l2 u i p, length l1 = i ->
      replace_at_pos_list (l1 ++ ui :: l2) u i p =
      l1 ++ (replace_at_pos ui u p) :: l2.

  Proof.
    intros l1; induction l1 as [ | u1 l1 ]; intros ui l2 u i p L; simpl in L.
    subst i; trivial.
    destruct i as [ | i ].
    discriminate.
    simpl; rewrite IHl1; trivial.
    inversion L; trivial.
  Qed.

End Term.