Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors.

Definition Empty_map {A: Empty_set → Type} : ∀ x : Empty_set, A x := λ x, match x with end.
Local Notation E := Empty_map.

Instance: Arrows Empty_set := E.
Instance: CatComp Empty_set := E.
Instance: CatId Empty_set := E.
Instance: ∀ x y, Equiv (x ⟶ y) := E.
Instance: ∀ x y, Setoid (x ⟶ y) := E.
Instance: Category Empty_set.
Proof. constructor; exact E. Qed.

Section another_category.
  Context `{Category C}.

  Global Instance: Fmap (E: _ → C) := E.

  Global Instance: Functor (E: _ → C) E.
  Proof. constructor; exact E || typeclasses eauto. Qed.
End another_category.


From iris.proofmode Require Import proofmode.
From lrust.lang Require Import heap.
From lrust.typing Require Export type.
From lrust.typing Require Import util lft_contexts type_context programs.
From iris.prelude Require Import options.

Section uniq_bor.
  Context `{!typeGS Σ}.

  Program Definition uniq_bor (κ:lft) (ty:type) :=
    {| ty_size := 1;
       ty_own tid vl :=
         match vl return _ with
         | [ #(LitLoc l) ] => &{κ} (l ↦∗: ty.(ty_own) tid)
         | _ => False
         end;
       ty_shr κ' tid l :=
         ∃ l':loc, &frac{κ'}(λ q', l ↦{q'} #l') ∗
           □ ∀ F q, ⌜↑shrN ∪ ↑lftN ⊆ F⌝ -∗ q.[κ⊓κ']
               ={F}[F∖↑shrN]▷=∗ ty.(ty_shr) (κ⊓κ') tid l' ∗ q.[κ⊓κ']
    |}%I.
  Next Obligation. by iIntros (q ty tid [|[[]|][]]) "H". Qed.
  Next Obligation.
    move=> κ ty N κ' l tid ??/=. iIntros "#LFT Hshr Htok".
    iMod (bor_exists with "LFT Hshr") as ([|[[|l'|]|][]]) "Hb"; first solve_ndisj;
      (iMod (bor_sep with "LFT Hb") as "[Hb1 Hb2]"; first solve_ndisj);
      try (iMod (bor_persistent with "LFT Hb2 Htok") as "[>[] _]"; solve_ndisj).
    iFrame. iExists l'. subst. rewrite heap_mapsto_vec_singleton.
    iMod (bor_fracture (λ q, l ↦{q} #l')%I with "LFT Hb1") as "$"; first solve_ndisj.
    iApply delay_sharing_nested; try done. iApply lft_incl_refl.
  Qed.
  Next Obligation.
    intros κ0 ty κ κ' tid l. iIntros "#Hκ #H".
    iDestruct "H" as (l') "[Hfb Hvs]". iAssert (κ0⊓κ' ⊑ κ0⊓κ)%I as "#Hκ0".
    { iApply lft_intersect_mono; last done. iApply lft_incl_refl. }
    iExists l'. iSplit; first by iApply (frac_bor_shorten with "[]").
    iIntros "!> %F %q % Htok". iApply (step_fupd_mask_mono F _ (F∖↑shrN)); try solve_ndisj.
    iMod (lft_incl_acc with "Hκ0 Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
    iMod ("Hvs" with "[%] Htok") as "Hvs'"; first solve_ndisj. iModIntro. iNext.
    iMod "Hvs'" as "[#Hshr Htok]". iMod ("Hclose" with "Htok") as "$".
    by iApply (ty_shr_mono with "Hκ0").
  Qed.

  Global Instance uniq_bor_wf κ ty `{!TyWf ty} : TyWf (uniq_bor κ ty) :=
    { ty_lfts := [κ]; ty_wf_E := ty_wf_E ty ++ ty_outlives_E ty κ }.

  Lemma uniq_type_incl κ1 κ2 ty1 ty2 :
    κ2 ⊑ κ1 -∗
    ▷ type_equal ty1 ty2 -∗
    type_incl (uniq_bor κ1 ty1) (uniq_bor κ2 ty2).
  Proof.
    iIntros "#Hlft #Hty". iSplit; first done.
    iSplit; iModIntro.
    - iIntros (? [|[[]|][]]) "H"; try done.
      iApply (bor_shorten with "Hlft"). iApply bor_iff; last done.
      iNext. iModIntro.
      iDestruct "Hty" as "(_ & Hty & _)".
      iSplit; iIntros "H"; iDestruct "H" as (vl) "[??]";
      iExists vl; iFrame; by iApply "Hty".
    - iIntros (κ ??) "H". iAssert (κ2 ⊓ κ ⊑ κ1 ⊓ κ)%I as "#Hincl'".
      { iApply lft_intersect_mono; first done. iApply lft_incl_refl. }
      iDestruct "H" as (l') "[Hbor #Hupd]". iExists l'. iIntros "{$Hbor}!> %%% Htok".
      iMod (lft_incl_acc with "Hincl' Htok") as (q') "[Htok Hclose]"; first solve_ndisj.
      iMod ("Hupd" with "[%] Htok") as "Hupd'"; try done. iModIntro. iNext.
      iMod "Hupd'" as "[H Htok]". iMod ("Hclose" with "Htok") as "$".
      iDestruct "Hty" as "(_ & _ & Hty)".
      iApply ty_shr_mono; last by iApply "Hty".
      done.
  Qed.

  Global Instance uniq_mono E L :
    Proper (flip (lctx_lft_incl E L) ==> eqtype E L ==> subtype E L) uniq_bor.
  Proof.
    intros κ1 κ2 Hκ ty1 ty2. rewrite eqtype_unfold=>Hty. iIntros (??) "HL".
    iDestruct (Hty with "HL") as "#Hty". iDestruct (Hκ with "HL") as "#Hκ".
    iIntros "!> #HE".
    iApply uniq_type_incl.
    - iDestruct ("Hκ" with "HE") as %H.
      apply lft_incl_syn_sem in H. iApply H.
    - iNext. iApply "Hty". done.
  Qed.
  Global Instance uniq_mono_flip E L :
    Proper (lctx_lft_incl E L ==> eqtype E L ==> flip (subtype E L)) uniq_bor.
  Proof. intros ??????. apply uniq_mono; first done. by symmetry. Qed.
  Global Instance uniq_proper E L :
    Proper (lctx_lft_eq E L ==> eqtype E L ==> eqtype E L) uniq_bor.
  Proof. intros ??[]; split; by apply uniq_mono. Qed.

  Global Instance uniq_type_contractive κ : TypeContractive (uniq_bor κ).
  Proof. solve_type_proper. Qed.

  Global Instance uniq_ne κ : NonExpansive (uniq_bor κ).
  Proof. apply type_contractive_ne, _. Qed.

  Global Instance uniq_send κ ty :
    Send ty → Send (uniq_bor κ ty).
  Proof.
    iIntros (Hsend tid1 tid2 [|[[]|][]]) "H"; try done.
    iApply bor_iff; last done. iNext. iModIntro. iApply bi.equiv_iff.
    do 3 f_equiv. iSplit; iIntros "."; by iApply Hsend.
  Qed.

  Global Instance uniq_sync κ ty :
    Sync ty → Sync (uniq_bor κ ty).
  Proof.
    iIntros (Hsync κ' tid1 tid2 l) "H". iDestruct "H" as (l') "[Hm #Hshr]".
    iExists l'. iFrame "Hm". iModIntro. iIntros (F q) "% Htok".
    iMod ("Hshr" with "[] Htok") as "Hfin"; first done. iClear "Hshr".
    iModIntro. iNext. iMod "Hfin" as "[Hshr $]". iApply Hsync. done.
  Qed.
End uniq_bor.

Notation "&uniq{ κ }" := (uniq_bor κ) (format "&uniq{ κ }") : lrust_type_scope.

Section typing.
  Context `{!typeGS Σ}.

  Lemma uniq_mono' E L κ1 κ2 ty1 ty2 :
    lctx_lft_incl E L κ2 κ1 → eqtype E L ty1 ty2 →
    subtype E L (&uniq{κ1}ty1) (&uniq{κ2}ty2).
  Proof. by intros; apply uniq_mono. Qed.
  Lemma uniq_proper' E L κ1 κ2 ty1 ty2 :
    lctx_lft_eq E L κ1 κ2 → eqtype E L ty1 ty2 → eqtype E L (&uniq{κ1}ty1) (&uniq{κ2}ty2).
  Proof. by intros; apply uniq_proper. Qed.

  Lemma tctx_reborrow_uniq E L p ty κ κ' :
    lctx_lft_incl E L κ' κ →
    tctx_incl E L [p ◁ &uniq{κ}ty] [p ◁ &uniq{κ'}ty; p ◁{κ'} &uniq{κ}ty].
  Proof.
    iIntros (Hκκ' tid ??) "#LFT HE HL H". iDestruct (Hκκ' with "HL HE") as %H.
    iDestruct (lft_incl_syn_sem κ' κ H) as "Hκκ'".
    iFrame. rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[% Hb]"; try done.
    iMod (rebor with "LFT Hκκ' Hb") as "[Hb Hext]"; first done. iModIntro.
    iSplitL "Hb"; iExists _; auto.
  Qed.

  Lemma tctx_extract_hasty_reborrow E L p ty ty' κ κ' T :
    lctx_lft_incl E L κ' κ → eqtype E L ty ty' →
    tctx_extract_hasty E L p (&uniq{κ'}ty) ((p ◁ &uniq{κ}ty')::T)
                       ((p ◁{κ'} &uniq{κ}ty')::T).
  Proof.
    intros. apply (tctx_incl_frame_r _ [_] [_;_]). rewrite tctx_reborrow_uniq //.
    by apply (tctx_incl_frame_r _ [_] [_]), subtype_tctx_incl, uniq_mono'.
  Qed.

  Lemma read_uniq E L κ ty :
    Copy ty → lctx_lft_alive E L κ → ⊢ typed_read E L (&uniq{κ}ty) ty (&uniq{κ}ty).
  Proof.
    rewrite typed_read_eq. iIntros (Hcopy Halive) "!>".
    iIntros ([[]|] tid F qmax qL ?) "#LFT #HE Htl HL Hown"; try done.
    iMod (Halive with "HE HL") as (q) "[Hκ Hclose]"; first solve_ndisj.
    iMod (bor_acc with "LFT Hown Hκ") as "[H↦ Hclose']"; first solve_ndisj.
    iDestruct "H↦" as (vl) "[>H↦ #Hown]".
    iDestruct (ty_size_eq with "Hown") as "#>%". iIntros "!>".
    iExists _, _, _. iSplit; first done. iFrame "∗#". iIntros "H↦".
    iMod ("Hclose'" with "[H↦]") as "[$ Htok]"; first by iExists _; iFrame.
    by iMod ("Hclose" with "Htok") as "($ & $ & $)".
  Qed.

  Lemma write_uniq E L κ ty :
    lctx_lft_alive E L κ → ⊢ typed_write E L (&uniq{κ}ty) ty (&uniq{κ}ty).
  Proof.
    rewrite typed_write_eq. iIntros (Halive) "!>".
    iIntros ([[]|] tid F qmax qL ?) "#LFT HE HL Hown"; try done.
    iMod (Halive with "HE HL") as (q) "[Htok Hclose]"; first solve_ndisj.
    iMod (bor_acc with "LFT Hown Htok") as "[H↦ Hclose']"; first solve_ndisj.
    iDestruct "H↦" as (vl) "[>H↦ Hown]". rewrite ty.(ty_size_eq).
    iDestruct "Hown" as ">%". iModIntro. iExists _, _. iSplit; first done.
    iFrame. iIntros "Hown". iDestruct "Hown" as (vl') "[H↦ Hown]".
    iMod ("Hclose'" with "[H↦ Hown]") as "[$ Htok]"; first by iExists _; iFrame.
    by iMod ("Hclose" with "Htok") as "($ & $ & $)".
  Qed.
End typing.

Global Hint Resolve uniq_mono' uniq_proper' write_uniq read_uniq : lrust_typing.
Global Hint Resolve tctx_extract_hasty_reborrow | 10 : lrust_typing.


(* * Syntax and semantics of the Jasmin source language *)

(* ** Imports and settings *)
Require Export ZArith Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import Psatz xseq.
Require Export utils array gen_map type word memory_model.
Import Utf8 ZArith.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Variant arr_access :=
  | AAdirect
  | AAscale.

Scheme Equality for arr_access.

Lemma arr_access_eq_axiom : Equality.axiom arr_access_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_arr_access_dec_bl.
  by apply: internal_arr_access_dec_lb.
Qed.

Definition arr_access_eqMixin     := Equality.Mixin arr_access_eq_axiom.
Canonical  arr_access_eqType      := Eval hnf in EqType arr_access arr_access_eqMixin.

Local Open Scope Z_scope.

Definition arr_size (ws:wsize) (len:positive)  :=
   (wsize_size ws * len).

Lemma arr_sizeE ws len : arr_size ws len = (wsize_size ws * len).
Proof. done. Qed.

Lemma ge0_arr_size ws len : 0 <= arr_size ws len.
Proof. rewrite arr_sizeE; have := wsize_size_pos ws; nia. Qed.

Opaque arr_size.

Definition mk_scale (aa:arr_access) ws :=
  if aa is AAscale then wsize_size ws else 1.

Module WArray.

  Record array (s:positive)  :=
    { arr_data : Mz.t u8 }.

  Definition empty (s:positive) : array s :=
    {| arr_data := Mz.empty _ |}.

  Local Notation pointer := [eqType of Z].

  (* We set the priority to 1, so that memory_model.Pointer is selected by
     default.
  *)
#[global]
  Instance PointerZ : pointer_op pointer | 1.
  Proof.
    refine {| add x y := (x + y)%Z
            ; sub x y := (x - y)%Z
            ; p_to_z x := x        |}.
    - abstract (move => /= ??; ring).
    - abstract (move => /= ???; ring).
    - abstract (move => /= ?; ring).
  Defined.

  Lemma addE x y : add x y = (x + y)%Z.
  Proof. by []. Qed.

  Lemma subE x y : sub x y = (x - y)%Z.
  Proof. by []. Qed.

  Lemma p_to_zE x : p_to_z x = x.
  Proof. by []. Qed.

  Global Opaque PointerZ.

  Section WITH_POINTER_DATA.
  Context {pd: PointerData}.

  Lemma is_align_scale (p:pointer) ws : is_align (p * mk_scale AAscale ws)%Z ws.
  Proof. by rewrite /is_align /mk_scale /= Z_mod_mult. Qed.

  Lemma arr_is_align i ws :
    is_align (wrepr Uptr i) ws = is_align i ws.
  Proof.
    by rewrite /is_align p_to_zE memory_model.p_to_zE wunsigned_repr mod_wbase_wsize_size.
  Qed.

  Section CM.
    Variable (s:positive).

    Definition in_bound (_:array s) p := (0 <=? p) && (p <? s).

    Lemma in_boundP m p : reflect (0 <= p < s) (in_bound m p).
    Proof. by apply (iffP andP); rewrite !zify. Qed.

    Definition is_init (m:array s) (i:pointer) :=
      match Mz.get m.(arr_data) i with
      | Some _ => true
      | None   => false
      end.

    Definition get8 (m:array s) (i:pointer) :=
      Let _ := assert (in_bound m i) ErrOob in
      Let _ := assert (is_init m i) ErrAddrUndef in
      ok (odflt 0%R (Mz.get m.(arr_data) i)).

    Definition set8 (m:array s) (i:pointer) (v:u8) : result _ (array s):=
      Let _ := assert (in_bound m i) ErrOob in
      ok {| arr_data := Mz.set m.(arr_data) i v |}.

    Lemma valid8P m p w : reflect (exists m', set8 m p w = ok m') (in_bound m p).
    Proof.
      by (rewrite /set8; case: in_bound => /=; constructor); [eexists; eauto | move=> []].
    Qed.

    Lemma get_valid8 m p w : get8 m p = ok w -> in_bound m p.
    Proof. by rewrite /get8; t_xrbindP. Qed.

    Lemma valid8_set m p w m' p' : set8 m p w = ok m' -> in_bound m' p' = in_bound m p'.
    Proof. by rewrite /set8; t_xrbindP => _ <-. Qed.

    Lemma set8P m p w p' m' :
      set8 m p w = ok m' ->
      get8 m' p' = if p == p' then ok w else get8 m p'.
    Proof.
      rewrite /get8 /set8 => /dup[] /valid8_set ->; t_xrbindP => hb <-.
      case heq: in_bound => //=; last by case: eqP => // h;move: heq; rewrite -h hb.
      by rewrite /is_init /= Mz.setP; case: eqP.
    Qed.

    Global Instance array_CM : coreMem pointer (array s) :=
      CoreMem set8P valid8P get_valid8 valid8_set.

    Definition in_range (p:pointer) (ws:wsize) :=
      ((0 <=? p) && (p + wsize_size ws <=? s))%Z.

    Lemma in_rangeP p ws:
      reflect (0 <= p /\ p + wsize_size ws <= s)%Z (in_range p ws).
    Proof.
      rewrite /in_range; case: andP => h; constructor; move: h; rewrite !zify; Psatz.nia.
    Qed.

    Lemma validw_in_range m p ws : validw m p ws = (is_align p ws && in_range p ws).
    Proof.
      apply (sameP (validwP m p ws)).
      apply (iffP andP).
      + move=> [] ? /in_rangeP ?;split => // k hk.
        by rewrite -valid8_validw /valid8 /= /in_bound !zify !addE; Psatz.lia.
      move=> [] ? h; split => //; apply /in_rangeP.
      move: (wsize_size_pos ws) (h 0) (h (wsize_size ws - 1)).
      by rewrite add_0 addE -!valid8_validw /array_CM /valid8 /in_bound !zify; Psatz.lia.
    Qed.

  End CM.

  Definition get len (aa:arr_access) ws (a:array len) (p:Z) :=
    CoreMem.read a (p * mk_scale aa ws)%Z ws.

  Definition set {len ws} (a:array len) aa p (v:word ws) : exec (array len) :=
    CoreMem.write a (p * mk_scale aa ws)%Z v.

  Definition fcopy ws len (a t: WArray.array len) i j :=
    foldM (fun i t =>
             Let w := get AAscale ws a i in set t AAscale i w) t
          (ziota i j).

  Definition copy ws p (a:array (Z.to_pos (arr_size ws p))) :=
    fcopy ws a (WArray.empty _) 0 p.

  Definition fill len (l:list u8) : exec (array len) :=
    Let _ := assert (Pos.to_nat len == size l) ErrType in
    Let pt :=
      foldM (fun w pt =>
             Let t := set pt.2 AAscale pt.1 w in
             ok (pt.1 + 1, t)) (0%Z, empty len) l in
    ok pt.2.

  Definition get_sub_data (aa:arr_access) ws len (a:Mz.t u8) p :=
     let size := arr_size ws len in
     let start := (p * mk_scale aa ws)%Z in
     foldr (fun i data =>
       match Mz.get a (start + i) with
       | None => Mz.remove data i
       | Some w => Mz.set data i w
       end) (Mz.empty _) (ziota 0 size).

  Definition get_sub lena (aa:arr_access) ws len (a:array lena) p  : exec (array (Z.to_pos (arr_size ws len))) :=
     let size := arr_size ws len in
     let start := (p * mk_scale aa ws)%Z in
     if (0 <=? start) && (start + size <=? lena) then
       ok (Build_array (Z.to_pos size) (get_sub_data aa ws len (arr_data a) p))
     else Error ErrOob.

  Definition set_sub_data (aa:arr_access) ws len (a:Mz.t u8) p (b:Mz.t u8) :=
    let size := arr_size ws len in
    let start := (p * mk_scale aa ws)%Z in
    foldr (fun i data =>
      match Mz.get b i with
      | None => Mz.remove data (start + i)
      | Some w => Mz.set data (start + i) w
      end) a (ziota 0 size).

  Definition set_sub lena (aa:arr_access) ws len (a:array lena) p (b:array (Z.to_pos (arr_size ws len))) : exec (array lena) :=
    let size := arr_size ws len in
    let start := (p * mk_scale aa ws)%Z in
    if (0 <=? start) && (start + size <=? lena) then
      ok (Build_array lena (set_sub_data aa ws len (arr_data a) p (arr_data b)))
    else Error ErrOob.

  Definition cast len len' (a:array len) : result error (array len') :=
    if (len' <=? len)%Z then ok {| arr_data := a.(arr_data) |}
    else type_error.

  Definition uincl {len1 len2} (a1 : array len1) (a2 : array len2) :=
    (len1 <= len2)%Z /\
    ∀ i w, read a1 i U8 = ok w -> read a2 i U8 = ok w.

  Lemma uincl_refl len (a: array len) : uincl a a.
  Proof. by split => //; reflexivity. Qed.

  Lemma uincl_trans {len1 len2 len3}
    (a2: array len2) (a1: array len1) (a3: array len3) :
    uincl a1 a2 -> uincl a2 a3 -> uincl a1 a3.
  Proof.
    move=> [l1 h1] [l2 h2]; split; first by lia.
    by move=> ?? /h1 /h2.
  Qed.

  End WITH_POINTER_DATA.

  Lemma castK len (a:array len) : WArray.cast len a = ok a.
  Proof. by rewrite /cast Z.leb_refl; case: a. Qed.

  Lemma cast_len len1 len2 (t2:WArray.array len2) t1: WArray.cast len1 t2 = ok t1 -> len1 <= len2.
  Proof. by rewrite /cast; case: ZleP. Qed.

  Lemma cast_empty len1 len2 :
    WArray.cast len1 (empty len2) = if len1 <=? len2 then ok (empty len1) else type_error.
  Proof. by rewrite /WArray.cast. Qed.

  Lemma cast_empty_ok len1 len2 t:
    WArray.cast len1 (empty len2) = ok t -> t = empty len1.
  Proof. by move=> /dup[]/cast_len/ZleP; rewrite cast_empty => -> [<-]. Qed.

  Lemma cast_get8 len1 len2 (m : array len2) m' :
    cast len1 m = ok m' ->
    forall k,
      read m' k U8 =
        if k <? len1 then read m k U8 else Error ErrOob.
  Proof.
    rewrite /cast; case: ZleP => // hle [<-] k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound /=.
    by case: ZleP => /=; case: ZltP => //=; case: ZltP => //; lia.
  Qed.

  Lemma cast_uincl len1 len2 (t2 : WArray.array len2) t1 :
    cast len1 t2 = ok t1 -> uincl t1 t2.
  Proof.
    move=> hc; split; first by apply: cast_len hc.
    by move=> i w; rewrite (cast_get8 hc); case: ifP.
  Qed.

  Lemma uincl_cast len1 len2 (a1: array len1) (a2:array len2) len a1' :
    uincl a1 a2 ->
    cast len a1 = ok a1' ->
    exists a2', cast len a2 = ok a2' /\ uincl a1' a2'.
  Proof.
    move=> [hle hu] hc.
    have:= (cast_get8 hc). have:= @cast_get8 len len2 a2.
    move: hc; rewrite /cast; case: ZleP => // hle1 _.
    case: ZleP => hle2 hg2 hg1; last lia.
    eexists;split; first by eauto.
    split; first by lia.
    by move=> ??; rewrite hg1 hg2 //; case: ifP => // _ /hu.
  Qed.

  Lemma mk_scale_U8 aa : mk_scale aa U8 = 1%Z.
  Proof. by rewrite /mk_scale wsize8; case aa. Qed.

  Lemma get8_read len (m : array len) aa k :
    get aa U8 m k = read m k U8.
  Proof. by rewrite /get mk_scale_U8 Z.mul_1_r. Qed.

  Lemma set_get8 len (m m':array len) aa p ws (v: word ws) :
    set m aa p v = ok m' ->
    forall k,
      read m' k U8 =
        let i := (k - p * mk_scale aa ws)%Z in
         if ((0 <=? i) && (i <? wsize_size ws))%Z then ok (LE.wread8 v i)
         else read m k U8.
  Proof. by apply: write_read8. Qed.

  Lemma setP len (m m':array len) p1 p2 ws (v: word ws) :
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p2 = if p1 == p2 then ok v else get AAscale ws m p2.
  Proof.
    rewrite /set /get; case:eqP => [<- | hne hw]; first by apply writeP_eq.
    apply: (CoreMem.writeP_neq hw); move=> ??; rewrite !addE /mk_scale;nia.
  Qed.

  Lemma setP_eq len (m m':array len) p1 ws (v: word ws) :
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p1 = ok v.
  Proof. by move=> /setP ->; rewrite eqxx. Qed.

  Lemma setP_neq len (m m':array len) p1 p2 ws (v: word ws) :
    p1 != p2 ->
    set m AAscale p1 v = ok m' ->
    get AAscale ws m' p2 = get AAscale ws m p2.
  Proof. by move=> /negPf h /setP ->; rewrite h. Qed.

  Lemma mk_scale_bound aa ws : (1 <= mk_scale aa ws <= wsize_size ws)%Z.
  Proof. rewrite /mk_scale; have := wsize_size_pos ws; case:aa; lia. Qed.

  Lemma get_bound ws len aa (t:array len) i w :
    get aa ws t i = ok w ->
    [/\ 0 <= i * mk_scale aa ws,
        i * mk_scale aa ws + wsize_size ws <= len &
        is_align (i * mk_scale aa ws) ws]%Z.
  Proof.
    move=> hg; assert (h := readV hg); move: h.
    by rewrite validw_in_range => /andP [] ? /in_rangeP [].
  Qed.

  Lemma set_bound ws len aa (a t:array len) i (w:word ws) :
    set a aa i w = ok t ->
    [/\ 0 <= i * mk_scale aa ws,
        i * mk_scale aa ws +  wsize_size ws <= len &
        is_align (i * mk_scale aa ws) ws]%Z.
  Proof.
    move=> hs; have : validw a (i * mk_scale aa ws) ws by apply /(writeV w); exists t.
    by rewrite validw_in_range => /andP [] ? /in_rangeP [].
  Qed.

  Lemma get_empty (n:positive) off :
    read (empty n) off U8 = if (0 <=? off) && (off <? n) then Error ErrAddrUndef else Error ErrOob.
  Proof.
    by rewrite -get_read8 /memory_model.get /= /get8 /in_bound /is_init /=; case: ifP.
  Qed.

  Lemma get0 (n:positive) off : (0 <= off ∧ off < n)%Z ->
    read (empty n) off U8 = Error ErrAddrUndef.
  Proof. by rewrite get_empty => -[/ZleP -> /ZltP ->]. Qed.

  Lemma uincl_empty len len' (t:array len') :
    Zpos len <= len' -> uincl (empty len) t.
  Proof.
    split; first Psatz.lia.
    by move=> i w; rewrite get_empty; case: ifP.
  Qed.

  Lemma uincl_validw {len1 len2} (a1 : array len1) (a2 : array len2) ws i :
    uincl a1 a2 -> validw a1 i ws -> validw a2 i ws.
  Proof.
    move=> [h1 _]; rewrite !validw_in_range => /andP [] -> /= /in_rangeP ?; apply /in_rangeP; lia.
  Qed.

  Lemma uincl_get {len1 len2} (a1 : array len1) (a2 : array len2) aa ws i w :
    uincl a1 a2 ->
    get aa ws a1 i = ok w ->
    get aa ws a2 i = ok w.
  Proof.
    rewrite /get => -[_ hu] hr; have {hr}[ha hr] := read_read8 hr.
    by rewrite (read8_read (v:=w)) ?ha // => k /hr /hu.
  Qed.

  Lemma uincl_set {ws len1 len2} (a1 a1': array len1) (a2: array len2) aa i (w:word ws) :
    uincl a1 a2 ->
    set a1 aa i w = ok a1' ->
    exists a2', set a2 aa i w = ok a2' /\ uincl a1' a2'.
  Proof.
    rewrite /set; set k := _ * _ => hu hw1.
    have /(writeV w) [a2' hw2]: validw a2 k ws by apply /(uincl_validw hu) /(writeV w); exists a1'.
    exists a2'; split => //.
    case: hu => hle hu; split => //.
    move=> j wj; rewrite (write_read8 hw1) (write_read8 hw2) /=.
    by case:ifP => // _; apply: hu.
  Qed.

  Lemma fcopy_uincl ws len (a t1 t2 a1 : array len) i j:
    uincl t1 t2 ->
    fcopy ws a t1 i j = ok a1 ->
    exists2 a2, fcopy ws a t2 i j = ok a2 & uincl a1 a2.
  Proof.
    rewrite /fcopy; elim: (ziota i j) t1 t2 => {i j} [ | i il hrec] t1 t2 hu /=.
    + by move=> [<-]; exists t2.
    t_xrbindP => t1' w -> hset hfold /=.
    by have [t2' [-> /hrec ]] /= := uincl_set hu hset; apply.
  Qed.

  Lemma uincl_copy ws p a1 a2 a1' :
     uincl a1 a2 ->
     @copy ws p a1 = ok a1' ->
     @copy ws p a2 = ok a1'.
  Proof.
    move=> hu; rewrite /copy /fcopy.
    elim: ziota (empty _) => [ | i il hrec] a //=.
    t_xrbindP => a' w /(uincl_get hu) -> /= ->; apply: hrec.
  Qed.

  Definition fill_size len l a :
    fill len l = ok a ->
    Pos.to_nat len = size l.
  Proof. by rewrite /fill; t_xrbindP => /eqP. Qed.

  Lemma fill_get8 len l a :
    fill len l = ok a ->
    forall k,
      read a k U8 =
        if (0 <=? k) && (k <? len) then ok (nth 0%R l (Z.to_nat k))
        else Error ErrOob.
  Proof.
    rewrite /fill; t_xrbindP=> /eqP hsize -[z {a}a] /= hfold <- k.
    have: forall z0 a0,
      foldM (fun w pt => Let t := set pt.2 AAscale pt.1 w in ok (pt.1 + 1, t)) (z0, a0) l = ok (z, a) ->
      read a k U8 =
        let i := k - z0 in
        if (0 <=? i) && (i <? Z.of_nat (size l)) then ok (nth 0%R l (Z.to_nat i))
        else read a0 k U8;
      last first.
    + move=> /(_ _ _ hfold) ->.
      rewrite Z.sub_0_r get_empty /=.
      rewrite -hsize positive_nat_Z.
      by case: andb.
    elim: l {hsize hfold} => [ | w l ih] z0 a0 /=.
    + move=> [_ <-].
      by case: ifP => //; rewrite !zify; lia.
    t_xrbindP=> _ a1 hset <- /ih -> /=.
    have ->:
      (0 <=? k - z0) && (k - z0 <? Pos.of_succ_nat (size l)) =
      (k == z0) || (0 <=? k - (z0 + 1)) && (k - (z0 + 1) <? Z.of_nat (size l)).
    + by apply /idP/idP; rewrite !zify (rwR2 (@eqP _)); lia.
    have := setP k hset; rewrite !get8_read => ->.
    rewrite orbC.
    case: ifP => /=.
    + rewrite !zify => h.
      by have ->: Z.to_nat (k - z0) = S (Z.to_nat (k - (z0+1))) by lia.
    move=> _.
    rewrite eq_sym.
    case: eqP => [<- | //].
    by rewrite Z.sub_diag.
  Qed.

  Lemma set_sub_data_get8 aa ws a len p t k:
    Mz.get (@set_sub_data aa ws len a p t) k =
      let i := (k - p * mk_scale aa ws)%Z in
      if (0 <=? i) && (i <? arr_size ws len) then Mz.get t i
      else Mz.get a k.
  Proof.
    rewrite /set_sub_data.
    elim /natlike_ind: (arr_size ws len) a; last by apply ge0_arr_size.
    + move=> data; rewrite ziota0 /=; case: andP => // -[]; rewrite !zify; lia.
    move=> sz hsz ih data; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih.
    case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //.
    + nia.
    + case heq: (Mz.get t) => [w|].
      + rewrite Mz.setP; case: eqP => [<- | ?]; last nia.
        rewrite -heq; f_equal; ring.
      rewrite Mz.removeP; case eqP => [<- | ?]; last nia.
      rewrite -heq; f_equal; ring.
    case heq: (Mz.get t) => [w|].
    + rewrite Mz.setP; case: eqP => [? | //]; lia.
    rewrite Mz.removeP; case eqP => [? | //]; lia.
  Qed.

  Lemma set_sub_get8 aa ws lena a len p t a' :
    @set_sub lena aa ws len a p t = ok a' ->
    forall k,
      read a' k U8 =
        let i := (k - p * mk_scale aa ws)%Z in
        if (0 <=? i) && (i <? arr_size ws len) then read t i U8
        else read a k U8.
  Proof.
    rewrite /set_sub; case: andP => // -[/ZleP h1 /ZleP h2] [<-] /= k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound set_sub_data_get8 /=.
    case: andP; rewrite !zify //= => ?; case: andP; rewrite !zify //= => ?; lia.
  Qed.

  Lemma set_sub_bound aa ws lena a len p t a' :
    @set_sub lena aa ws len a p t = ok a' ->
    0 <= p * mk_scale aa ws /\ p * mk_scale aa ws + arr_size ws len <= lena.
  Proof. by rewrite /set_sub; case: ifP => //; rewrite !zify. Qed.

  Lemma get_sub_data_get8 aa ws a len p k:
    Mz.get (get_sub_data aa ws len a p) k =
      let start := (p * mk_scale aa ws)%Z in
      if (0 <=? k) && (k <? arr_size ws len) then Mz.get a (start + k)
      else None.
  Proof.
    rewrite /get_sub_data -(Mz.get0 u8 k).
    elim /natlike_ind: (arr_size ws len) (Mz.empty u8); last by apply ge0_arr_size.
    + move => b; rewrite ziota0 /=; case: andP => //; rewrite !zify; lia.
    move=> sz hsz ih b; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih.
    case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //.
    + nia.
    + case heq: (Mz.get a) => [w|].
      + by rewrite Mz.setP; case: eqP => [<- | ]; [rewrite heq | nia].
      by rewrite Mz.removeP; case: eqP => [<- | ]; [rewrite heq | nia].
    case heq: (Mz.get a) => [w|].
    + by rewrite Mz.setP; case: eqP => //; nia.
    by rewrite Mz.removeP; case: eqP => //; nia.
  Qed.

  Lemma get_sub_get8 aa ws lena a len p a' :
    @get_sub lena aa ws len a p = ok a' ->
    forall k,
      read a' k U8 =
        let start := (p * mk_scale aa ws)%Z in
        if (0 <=? k) && (k <? arr_size ws len) then read a (start + k) U8
        else Error ErrOob.
  Proof.
    rewrite /get_sub; case: andP => // -[/ZleP h1 /ZleP h2] [<-] /= k.
    rewrite -!get_read8 /memory_model.get /= /get8 /is_init /in_bound get_sub_data_get8 /=.
    case: andP; rewrite !zify //= => ?; case: andP; rewrite !zify //= => ?; lia.
  Qed.

  Lemma get_sub_bound aa ws lena a len p a' :
    @get_sub lena aa ws len a p = ok a' ->
    0 <= p * mk_scale aa ws /\ p * mk_scale aa ws + arr_size ws len <= lena.
  Proof. by rewrite /get_sub; case: ifP => //; rewrite !zify. Qed.

  Lemma uincl_get_sub {len1 len2} (a1 : array len1) (a2 : array len2)
      aa ws len i t1 :
    uincl a1 a2 ->
    get_sub aa ws len a1 i = ok t1 ->
    exists2 t2, get_sub aa ws len a2 i = ok t2 & uincl t1 t2.
  Proof.
    move=> [hlen hu] hget.
    have := get_sub_get8 hget.
    have := @get_sub_get8 aa ws len2 a2 len i _.
    move: hget; rewrite /get_sub; case: andP => // -[/ZleP h1 /ZleP h2] [_].
    case: andP; rewrite !zify => h3; last by lia.
    move=> /(_ _ refl_equal) hr2 hr1; eexists => //; split; first by lia.
    by move=> k w; rewrite hr1 hr2; case: ifP => // ? /hu.
  Qed.

  Lemma uincl_set_sub {ws len1 len2 len} (a1 a1': array len1) (a2: array len2) aa i
        (t1 t2:array (Z.to_pos (arr_size ws len))) :
    uincl a1 a2 -> uincl t1 t2 ->
    set_sub aa a1 i t1 = ok a1' ->
    exists2 a2', set_sub aa a2 i t2 = ok a2' & uincl a1' a2'.
  Proof.
    move=> [hlen1 hget1] [hlen2 hget2] hset.
    have := set_sub_get8 hset.
    have := @set_sub_get8 aa ws len2 a2 len i _.
    move: hset; rewrite /set_sub; case: andP => // -[/ZleP h1 /ZleP h2] [_].
    case: andP; rewrite !zify => h3; last by lia.
    move=> /(_ _ _ refl_equal) hr2 hr1; eexists => //; split; first by lia.
    by move=> k w; rewrite hr1 hr2; case: ifP => // [ ? /hget2| ? /hget1].
  Qed.

End WArray.

#[global]
Hint Resolve WArray.uincl_refl : core.


Lemma and_commutative : forall A B, A /\ B -> B /\ A.
Proof.
  intros.
  elim H.
  split.
  exact H1.
  exact H0.
Qed.

Lemma or_commutative : forall A B, A \/ B -> B \/ A.
Proof.
  intros.
  destruct H.
  right; exact H.
  left; exact H.
Qed.s


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* this file contains some cardinal functions, which are message
   dependent *)

Require Export reduce.
Require Export DistributedReferenceCounting.machine3.machine.

Section COUNT_MESSAGE.

Definition dec_predicate (m : Message) :=
  match m with
  | dec => true
  | _ => false
  end.

Definition inc_predicate (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

(* the next one only recognises inc_dec messages related to s0 *)

Variable s0 : Site.

Definition site_inc_predicate (m : Message) :=
  match m with
  | inc_dec s => if eq_site_dec s s0 then true else false
  | _ => false
  end.

Definition copy_predicate (m : Message) :=
  match m with
  | copy => true
  | _ => false
  end.

Definition dec_count (m : Message) :=
  match m with
  | dec => 1%Z
  | _ => 0%Z
  end.

Definition inc_count (m : Message) := 0%Z.

Definition copy_count (m : Message) :=
  match m with
  | copy => 1%Z
  | _ => 0%Z
  end.

Definition cardinal_count :=
  fun_sum Message dec_count (fun_sum Message inc_count copy_count).

Definition cardinal := reduce Message cardinal_count.

Lemma disjoint_cardinal :
 forall q : queue Message,
 cardinal q =
 (reduce Message dec_count q +
  (reduce Message inc_count q + reduce Message copy_count q))%Z.
Proof.
  intro.
  rewrite <- disjoint_reduce.
  rewrite <- disjoint_reduce.
  unfold cardinal in |- *.
  unfold cardinal_count in |- *.
  auto.
Qed.

Lemma cardinal_first_out :
 forall (q : queue Message) (m : Message),
 first Message q = value Message m ->
 cardinal (first_out Message q) = (cardinal q - cardinal_count m)%Z.
Proof.
  intros.
  unfold cardinal in |- *.
  apply reduce_first_out.
  auto.
Qed.

End COUNT_MESSAGE.

Section SIG_WEIGHT.
Let Bag_of_message := Bag_of_Data Message.

Definition sigma_weight (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) (fun s1 s2 : Site => cardinal) bm.

End SIG_WEIGHT.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.

Require Import Bedrock.Platform.Malloc Bedrock.Platform.Cito.examples.Seq.

Module Type ADT.
  Parameter arr : list W -> W -> HProp.

  Axiom arr_fwd : forall ws self, arr ws self ===> [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).
  Axiom arr_bwd : forall ws (self : W), [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8) ===> arr ws self.
End ADT.

Module Adt : ADT.
  Open Scope Sep_scope.

  Definition arr (ws : list W) (self : W) : HProp :=
    [| self <> 0 |] * [| freeable self (2 + length ws) |] * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).

  Theorem arr_fwd : forall ws self, arr ws self ===> [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8).
    unfold arr; sepLemma.
  Qed.

  Theorem arr_bwd : forall ws (self : W), [| self <> 0 |] * [| freeable self (2 + length ws) |]
    * [| goodSize (2 + length ws) |]
    * (Ex junk, self ==*> $ (length ws), junk)
    * array ws (self ^+ $8) ===> arr ws self.
    unfold arr; sepLemma.
  Qed.
End Adt.

Import Adt.
Export Adt.

Lemma allocated_out'' : forall p len offset,
  allocated p offset len ===> Ex ws, ptsto32m' nil p offset ws * [| length ws = len |].
  induction len; sepLemmaLhsOnly.
  apply himp_ex_c; exists nil; sepLemma.
  etransitivity; [ apply himp_star_frame; [ apply IHlen | reflexivity ] | ].
  sepLemmaLhsOnly.
  apply himp_ex_c; exists (x :: x0); sepLemma.
  destruct offset; sepLemma.
Qed.

Lemma allocated_out' : forall p len offset,
  allocated p offset len ===> Ex ws, ptsto32m nil p offset ws * [| length ws = len |].
  intros; eapply Himp_trans; [ apply allocated_out'' | ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  apply ptsto32m'_out.
Qed.

Inductive view_shift (n : nat) := ViewShift.
Local Hint Constructors view_shift.

Lemma allocated_out : forall p offset len,
  view_shift offset
  -> allocated p offset len ===> Ex ws, array ws (p ^+ $ (offset)) * [| length ws = len |].
  intros; eapply Himp_trans; [ apply allocated_out' | ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  eapply Himp_trans; [ apply ptsto32m_shift_base' | ].
  instantiate (1 := offset); auto.
  rewrite Minus.minus_diag; apply Himp_refl.
Qed.

Lemma allocated_in'' : forall p len offset,
  (Ex ws, ptsto32m' nil p offset ws * [| length ws = len |]) ===> allocated p offset len.
  induction len; sepLemmaLhsOnly.
  destruct x; sepLemma.
  destruct x; sepLemma.
  apply himp_star_frame.
  etransitivity; [ | apply IHlen ].
  sepLemma.
  destruct offset; sepLemma.
Qed.

Lemma allocated_in' : forall p len offset,
  (Ex ws, ptsto32m nil p offset ws * [| length ws = len |]) ===> allocated p offset len.
  intros; eapply Himp_trans; [ | apply allocated_in'' ].
  apply Himp_ex; intro.
  apply Himp_star_frame; try apply Himp_refl.
  apply Arrays.ptsto32m'_in.
Qed.

Lemma allocated_in : forall p ws,
  goodSize (S (S (length ws)))
  -> p =?> 2 * array ws (p ^+ $8) ===> p =?> wordToNat (natToW (S (S (length ws)))).
  intros.

  replace (wordToNat (natToW (S (S (length ws))))) with (S (S (length ws))).
  eapply Himp_trans; [ | apply allocated_join ].
  apply Himp_star_frame; try apply Himp_refl.
  2: auto.
  simpl.
  eapply Himp_trans; [ | apply allocated_in' ].
  sepLemma.
  instantiate (1 := ws); omega.
  etransitivity; [ | apply ptsto32m_shift_base ].
  instantiate (1 := 8); reflexivity.
  auto.
  rewrite wordToNat_natToWord_idempotent; auto.
Qed.

Definition hints : TacPackage.
  prepare (arr_fwd, allocated_out) (arr_bwd, allocated_in).
Defined.

Definition newS := newS arr 8.
Definition deleteS := deleteS arr 7.
Definition readS := readS arr 0.
Definition writeS := writeS arr 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "ArraySeq" {{
    bfunction "new"("extra_stack", "len", "x") [newS]
      "x" <- 2 + "len";;
      "x" <-- Call "malloc"!"malloc"(0, "x")
      [PRE[V, R] R =?> (2 + wordToNat (V "len"))
        * [| R <> 0 |] * [| freeable R (2 + wordToNat (V "len")) |]
        * [| goodSize (2 + wordToNat (V "len")) |] * mallocHeap 0
       POST[R'] Ex ws, arr ws R' * [| length ws = wordToNat (V "len") |] * mallocHeap 0];;

      "x" *<- "len";;
      Note [view_shift 8];;
      Return "x"
    end

    with bfunction "delete"("extra_stack", "self", "x") [deleteS]
      "x" <-* "self";;
      "x" <- 2 + "x";;
      Call "malloc"!"free"(0, "self", "x")
      [PRE[_] Emp
       POST[_] Emp];;

      Return 0
    end

    with bfunction "read"("extra_stack", "self", "n") [readS]
      "n" <- 4 * "n";;
      "self" <- "self" + 8;;
      "self" <-* "self" + "n";;
      Return "self"
    end

    with bfunction "write"("extra_stack", "self", "n", "v") [writeS]
      "n" <- 4 * "n";;
      "self" <- "self" + 8;;
      "self" + "n" *<- "v";;
      Return 0
    end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Lemma twoPlus_le : forall w,
  goodSize (2 + wordToNat w)
  -> natToW 2 <= natToW 2 ^+ w.
  intros.
  rewrite <- (natToWord_wordToNat w).
  rewrite <- natToWord_plus.
  apply le_goodSize; auto.
Qed.

Local Hint Immediate twoPlus_le.

Local Hint Extern 1 (himp _ _ _) =>
  match goal with
    | [ H : _ = wordToNat _ |- _ ] =>
      rewrite H; unfold natToW; rewrite natToWord_wordToNat; solve [ step auto_ext ]
  end.

Lemma twoPlus_freeable : forall w len,
  freeable w (S (S len))
  -> goodSize (S (S len))
  -> freeable w (wordToNat (natToW (S (S len)))).
  intros; rewrite wordToNat_natToWord_idempotent; auto.
Qed.

Local Hint Immediate twoPlus_freeable.

Section hints.
  Hint Rewrite wordToNat_wplus using assumption : sepFormula.

  Theorem ok : moduleOk m.
    vcgen; abstract (sep hints; auto).
  Qed.
End hints.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import IEEE.

Definition t := Single.

Definition m := Rounding_nearest.

Definition test_add (x y : diadic) :=
  (Dadd x y,
  diadic_of_abstract t
    (fst
       (abstract_add t m (abstract_of_diadic t m x)
          (abstract_of_diadic t m y)))).

Definition verif (x y : diadic) := let (s1, s2) := test_add x y in Deq s1 s2.

Definition t1 := Diadic 10456 0.
Definition t2 := Diadic 10456 1.