(* ** Imports and settings *)

From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Import strings word utils.
Import Utf8 ZArith.
Import ssrring.

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

Local Open Scope Z_scope.

(* LittleEndian *)
Module LE.

  Definition encode sz (w: word sz) : seq u8 := split_vec U8 w.
  Definition decode sz (n: seq u8)  : word sz := make_vec sz n.

  Lemma size_encode sz (w: word sz) :
    size (encode w) = Z.to_nat (wsize_size sz).
  Proof.
    by rewrite /encode /split_vec size_map size_iota => {w}; case: sz.
  Qed.

  Lemma decodeK sz (w: word sz) :
    decode sz (encode w) = w.
  Proof. by rewrite /decode /encode make_vec_split_vec. Qed.

  Lemma decode_inj sz (bs bs': seq u8) :
    size bs = size bs' →
    size bs = Z.to_nat (wsize_size sz) →
    decode sz bs = decode sz bs' →
    bs = bs'.
  Proof.
    by move => eqsz hsz /make_vec_inj; apply.
  Qed.

  Definition wread8 ws (v:word ws) (k:Z) :=
    nth 0%R (encode v) (Z.to_nat k).

  Lemma encode8E (w: u8): encode w = [:: w].
  Proof.
    have {2}<-:= decodeK w.
    rewrite /encode /decode /make_vec /split_vec divnn modnn /= mul0n.
    by rewrite Z.lor_0_r /wrepr word.ureprK.
  Qed.

  Lemma encodeE s (w:word s) : encode w = [seq wread8 w k | k <- ziota 0 (wsize_size s)].
  Proof.
    symmetry; apply (eq_from_nth (x0 := 0%R)).
    + by rewrite size_map size_ziota size_encode.
    move=> i; rewrite size_map size_ziota => hi.
    by rewrite (nth_map 0%Z) ?size_ziota // nth_ziota // Z.add_0_l /wread8 Nat2Z.id.
  Qed.

End LE.

Section POINTER.

Context (pointer: eqType).

Class pointer_op (pointer: eqType) : Type := PointerOp {

  add : pointer -> Z -> pointer;
  sub : pointer -> pointer -> Z;
  p_to_z : pointer -> Z;

  add_sub : forall p k, add p (sub k p) = k;
  sub_add : forall p k, 0 <= k < wsize_size U256 -> sub (add p k) p = k;
  add_0   : forall p, add p 0 = p;

}.

Context {Pointer: pointer_op pointer}.

Definition is_align (p:pointer) (sz:wsize) :=
  (p_to_z p mod wsize_size sz == 0)%Z.

Lemma is_align8 p : is_align p U8.
Proof. by rewrite /is_align Zmod_1_r. Qed.

Class coreMem (core_mem: Type) := CoreMem {
  get : core_mem -> pointer -> exec u8;
  set : core_mem -> pointer -> u8 -> exec core_mem;
  valid8 : core_mem -> pointer -> bool;
  setP :
    forall m p w p' m',
      set m p w = ok m' ->
      get m' p' = if p == p' then ok w else get m p';
  valid8P : forall m p w, reflect (exists m', set m p w = ok m') (valid8 m p);
  get_valid8 : forall m p w, get m p = ok w -> valid8 m p;
  valid8_set : forall m p w m' p', set m p w = ok m' -> valid8 m' p' = valid8 m p';
}.

End POINTER.

Module Export CoreMem.
Section CoreMem.

  Context {pointer: eqType} {Pointer: pointer_op pointer}.
  Context {core_mem: Type} {CM: coreMem pointer core_mem}.

  Definition read (m: core_mem) (ptr: pointer) (sz: wsize) : exec (word sz) :=
    Let _ := assert (is_align ptr sz) ErrAddrInvalid in
    Let l := mapM (fun k => get m (add ptr k)) (ziota 0 (wsize_size sz)) in
    ok (LE.decode sz l).

  Definition write (m:core_mem) (ptr:pointer) (sz:wsize) (w: word sz) : exec core_mem :=
    Let _ := assert (is_align ptr sz) ErrAddrInvalid in
    foldM (fun k m => set m (add ptr k) (LE.wread8 w k)) m (ziota 0 (wsize_size sz)).

  Definition validw (m:core_mem) (ptr:pointer) (sz:wsize) :=
    is_align ptr sz && all (fun k => valid8 m (add ptr k)) (ziota 0 (wsize_size sz)).

  Lemma valid8_validw m p : valid8 m p = validw m p U8.
  Proof. by rewrite /validw /= is_align8 /= add_0 andbT. Qed.

  Lemma validwP m p ws :
    reflect (is_align p ws ∧ ∀ k, 0 <= k < wsize_size ws -> validw m (add p k) U8) (validw m p ws).
  Proof.
    apply (iffP andP).
    + by move=> [? /allP h]; split => // k hk; rewrite -valid8_validw; apply h; rewrite in_ziota !zify.
    by move=> [? h]; split => //;apply/allP => k; rewrite in_ziota !zify valid8_validw; apply h.
  Qed.

  Lemma get_read8 m p: get m p = read m p U8.
  Proof.
    rewrite /read /= is_align8 /= add_0.
    by case: get => //= w; rewrite -LE.encode8E LE.decodeK.
  Qed.

  Lemma set_write8 m p w: set m p w = write m p w.
  Proof.
    rewrite /write /= is_align8 /= add_0.
    have := LE.encode8E w; rewrite LE.encodeE /= => -[->].
    by case: set.
  Qed.

  Lemma readE m p sz :
    read m p sz =
      Let _ := assert (is_align p sz) ErrAddrInvalid in
      Let l := mapM (fun k => read m (add p k) U8) (ziota 0 (wsize_size sz)) in
      ok (LE.decode sz l).
  Proof.
    by rewrite {1}/read; case: is_align => //=; f_equal; apply eq_mapM => k _; apply get_read8.
  Qed.

  Lemma write_valid8_eq m m' p s (v :word s) :
    write m p v = ok m' ->
    forall p',
    valid8 m' p' = valid8 m p'.
  Proof.
    rewrite /write; t_xrbindP => ? hfold p'; move: m hfold.
    apply ziota_ind => /= [ m [->]//| i l _ hrec m]; t_xrbindP => ? h /hrec ->.
    by apply (valid8_set _ h).
  Qed.

  Lemma write_validw_eq m m' p s (v :word s) :
    write m p v = ok m' ->
    forall p' s',
    validw m' p' s' = validw m p' s'.
  Proof.
    by move=> hw p' s'; rewrite /validw; f_equal; apply all_ziota => ? _; apply (write_valid8_eq hw).
  Qed.

  Lemma write_read8 m m' p ws (v: word ws) :
    write m p v = ok m' ->
    forall k, read m' k U8 =
      let i := sub k p in
       if (0 <=? i) && (i <? wsize_size ws) then ok (LE.wread8 v i)
       else read m k U8.
  Proof.
    rewrite /write; t_xrbindP => _ h k; move: h.
    rewrite -(@in_ziota 0 (wsize_size ws)).
    move: m; apply ziota_ind => /=; first by move=> ? [<-].
    move=> i l hi hrec m; t_xrbindP => mi hset /hrec ->.
    rewrite in_cons -!get_read8 (setP _ hset) orbC.
    case: ifP => //= _.
    case: eqP => [<- | hne].
    + rewrite sub_add ?eq_refl //.
      have : wsize_size ws <= wsize_size U256 by case: (ws).
      Psatz.lia.
    by case: eqP => // heq; case: hne; rewrite -heq add_sub.
  Qed.

  Lemma eq_read m1 m2 p ws :
    (forall i, 0 <= i < wsize_size ws -> read m1 (add p i) U8 = read m2 (add p i) U8) ->
    read m1 p ws = read m2 p ws.
  Proof.
    move=> h8; rewrite !readE; case: is_align => //=; f_equal.
    by apply eq_mapM => k; rewrite in_ziota !zify; apply h8.
  Qed.

  Lemma writeV s (v:word s) m p:
    reflect (exists m', write m p v = ok m') (validw m p s).
  Proof.
    rewrite /write /validw; case: is_align => //=; last by constructor => -[].
    elim: ziota m => /=; first by move=> ?; constructor; eauto.
    move=> k l hrec m.
    apply (iffP andP).
    + move=> [] /valid8P -/(_ (LE.wread8 v k)) [m'] hset hall.
      by rewrite hset;apply/hrec; apply: sub_all hall => i; rewrite (valid8_set _ hset).
    move=> [m'];t_xrbindP => m'' hset hf; split.
    + by apply/valid8P; eexists; eauto.
    apply/sub_all; last by apply/hrec; eexists; eauto.
    by move=> i;rewrite (valid8_set _ hset).
  Qed.

  Lemma readV m ptr sz w :
    read m ptr sz = ok w ->
    validw m ptr sz.
  Proof.
    move=> h; apply /validwP; move: h; rewrite /read; t_xrbindP => -> l h _; split => //.
    move=> k hk; have {hk}: k \in ziota 0 (wsize_size sz).
    + by rewrite in_ziota !zify.
    rewrite -valid8_validw.
    move: l h;apply ziota_ind => //= i li hi hr ?.
    t_xrbindP => wi hwi; have ?:= get_valid8 hwi.
    by move=> l /hr{hr}hr _; rewrite inE => /orP [/eqP ->| /hr].
  Qed.

  Lemma read8_read m p s v:
    (forall i, 0 <= i < wsize_size s -> read m (add p i) U8 = ok (LE.wread8 v i)) ->
    read m p s = if is_align p s then ok v else Error ErrAddrInvalid.
  Proof.
    rewrite readE => h8; case: is_align => //=.
    have -> /= : mapM (λ k, read m (add p k) U8) (ziota 0 (wsize_size s)) =
                   ok (map (λ k, LE.wread8 v k) (ziota 0 (wsize_size s))).
    + by apply ziota_ind => //= k l hk ->; rewrite h8.
    by rewrite -{2}(LE.decodeK v) LE.encodeE.
  Qed.

  Lemma read_read8 m p s v:
    read m p s = ok v ->
    is_align p s /\ (forall i, 0 <= i < wsize_size s -> read m (add p i) U8 = ok (LE.wread8 v i)).
  Proof.
    rewrite readE; t_xrbindP => ha l hl.
    rewrite -{1}(LE.decodeK v) => /LE.decode_inj.
    rewrite -(size_mapM hl) size_ziota LE.size_encode => /(_ refl_equal refl_equal) ?; subst l.
    rewrite LE.encodeE in hl.
    split => // i hi.
    have : i \in ziota 0 (wsize_size s) by rewrite in_ziota !zify.
    move: hl; apply ziota_ind => //= k l hk hrec.
    t_xrbindP => w hw ws hws ??; subst w ws.
    by rewrite inE => /orP [/eqP -> | /(hrec hws)].
  Qed.

  Lemma writeP_eq m m' p s (v :word s):
    write m p v = ok m' ->
    read m' p s = ok v.
  Proof.
    move=> hw.
    rewrite (read8_read (m:=m') (v:= v) (p:=p)).
    + by have /validwP [->] : validw m p s by apply /writeV; eexists; eauto.
    move=> k hk.
    rewrite (write_read8 hw) sub_add /=.
    + by case: andP => //; rewrite !zify; Psatz.lia.
    have : wsize_size s <= wsize_size U256 by case: (s).
    Psatz.lia.
  Qed.

  Definition disjoint_range p s p' s' :=
    forall i i', 0 <= i < wsize_size s -> 0 <= i' < wsize_size s' ->
       add p i <> add p' i'.

  Lemma disjoint_range_U8 p sz p' :
    (∀ i, 0 <= i < wsize_size sz → p' ≠ add p i) →
    disjoint_range p sz p' U8.
  Proof.
    move => h i i' i_range.
    change (wsize_size U8) with 1%Z => i'_range.
    have -> : i' = 0 by Lia.lia.
    rewrite {i' i'_range} add_0 => ?.
    exact: (h _ i_range).
  Qed.

  Lemma writeP_neq m m' p s (v :word s) p' s':
    write m p v = ok m' ->
    disjoint_range p s p' s' ->
    read m' p' s' = read m p' s'.
  Proof.
    move=> hw hd; apply eq_read => k hk.
    rewrite (write_read8 hw) /=.
    case: andP => //; rewrite !zify => hin.
    elim: (hd (sub (add p' k) p) k) => //; by rewrite add_sub.
  Qed.

  Lemma read_write_any_mem m1 m1' pr pw szw (vw:word szw) m2 m2':
    read m1 pr U8 = read m1' pr U8 ->
    write m1 pw vw = ok m2 ->
    write m1' pw vw = ok m2' ->
    read m2 pr U8 = read m2' pr U8.
  Proof.
    move=> hr hw hw'.
    by rewrite (write_read8 hw) (write_read8 hw') /=; case: andP.
 Qed.

End CoreMem.
End CoreMem.

(* ** Memory
 * -------------------------------------------------------------------- *)

Notation pointer := (word Uptr) (only parsing).

Section WITH_POINTER_DATA.
Context {pd: PointerData}.

Definition no_overflow (p: pointer) (sz: Z) : bool :=
  (wunsigned p + sz <=? wbase Uptr)%Z.

Definition disjoint_zrange (p: pointer) (s: Z) (p': pointer) (s': Z) :=
  [/\ no_overflow p s,
      no_overflow p' s' &
      wunsigned p + s <= wunsigned p' \/
        wunsigned p' + s' <= wunsigned p]%Z.

Definition disjoint_range p s p' s' :=
  disjoint_zrange p (wsize_size s) p' (wsize_size s').

Definition zbetween (pstk : pointer) (sz : Z) (p : pointer) (sz' : Z) : bool :=
  ((wunsigned pstk <=? wunsigned p) && (wunsigned p + sz' <=? wunsigned pstk + sz))%Z.

Definition between (pstk : pointer)  (sz : Z) (p : pointer) (s : wsize) : bool :=
  zbetween pstk sz p (wsize_size s).

Lemma no_overflow_incl p1 sz1 p2 sz2 :
  zbetween p1 sz1 p2 sz2 ->
  no_overflow p1 sz1 ->
  no_overflow p2 sz2.
Proof. by rewrite /zbetween /no_overflow !zify; Psatz.lia. Qed.

Lemma zbetween_refl p sz : zbetween p sz p sz.
Proof. by rewrite /zbetween !zify; Psatz.lia. Qed.

Lemma zbetween_trans p1 sz1 p2 sz2 p3 sz3 :
  zbetween p1 sz1 p2 sz2 ->
  zbetween p2 sz2 p3 sz3 ->
  zbetween p1 sz1 p3 sz3.
Proof.
  rewrite /between => /andP [] /ZleP a /ZleP b /andP [] /ZleP c /ZleP d.
  apply/andP; split; apply/ZleP; Psatz.lia.
Qed.

Lemma zbetween_le p sz1 sz2 :
  sz2 <= sz1 ->
  zbetween p sz1 p sz2.
Proof. by rewrite /zbetween !zify; Psatz.lia. Qed.

Lemma between_byte pstk sz b i sz' :
  no_overflow b sz' →
  zbetween pstk sz b sz' →
  0 <= i ∧ i < sz' →
  between pstk sz (b + wrepr Uptr i) U8.
Proof.
  rewrite /zbetween !zify; change (wsize_size U8) with 1 => novf [] lo hi i_range.
  rewrite wunsigned_add; first Psatz.lia.
  move: (wunsigned_range b); Psatz.lia.
Qed.

Lemma zbetween_not_disjoint_zrange p1 s1 p2 s2 :
  zbetween p1 s1 p2 s2 ->
  0 < s2 ->
  ~ disjoint_zrange p1 s1 p2 s2.
Proof. by rewrite /zbetween !zify => hb hlt [_ _ ?]; Psatz.lia. Qed.

Lemma disjoint_zrange_sym p1 sz1 p2 sz2 :
  disjoint_zrange p1 sz1 p2 sz2 ->
  disjoint_zrange p2 sz2 p1 sz1.
Proof.
  rewrite /disjoint_zrange; move=> [*]; split=> //; Psatz.lia.
Qed.

Lemma disjoint_zrange_incl p1 s1 p2 s2 p1' s1' p2' s2' :
  zbetween p1 s1 p1' s1' ->
  zbetween p2 s2 p2' s2' ->
  disjoint_zrange p1 s1 p2 s2 ->
  disjoint_zrange p1' s1' p2' s2'.
Proof.
  rewrite /zbetween /disjoint_zrange /no_overflow !zify.
  by move=> ?? [/ZleP ? /ZleP ? ?]; split; rewrite ?zify; Psatz.lia.
Qed.

Lemma disjoint_zrange_incl_l p1 s1 p2 s2 p1' s1' :
  zbetween p1 s1 p1' s1' ->
  disjoint_zrange p1 s1 p2 s2 ->
  disjoint_zrange p1' s1' p2 s2.
Proof. by move=> ?; apply disjoint_zrange_incl=> //; apply zbetween_refl. Qed.

Lemma disjoint_zrange_incl_r p1 s1 p2 s2 p2' s2' :
  zbetween p2 s2 p2' s2' ->
  disjoint_zrange p1 s1 p2 s2 ->
  disjoint_zrange p1 s1 p2' s2'.
Proof. by move=> ?; apply disjoint_zrange_incl=> //; apply zbetween_refl. Qed.

Lemma disjoint_zrange_byte p1 sz1 p2 sz2 i :
  disjoint_zrange p1 sz1 p2 sz2 ->
  0 <= i /\ i < sz2 ->
  disjoint_zrange p1 sz1 (p2 + wrepr _ i) (wsize_size U8).
Proof.
  move=> hd hrange.
  case: (hd) => _ hover _.
  apply: disjoint_zrange_incl_r hd.
  apply: (between_byte hover) => //.
  by apply zbetween_refl.
Qed.

Lemma disjoint_zrange_add p sz p' sz1 sz2 :
  0 < sz ->
  0 <= sz1 ->
  0 < sz2 ->
  no_overflow p' (sz1 + sz2) ->
  disjoint_zrange p sz p' sz1 ->
  disjoint_zrange p sz (p' + wrepr _ sz1) sz2 ->
  disjoint_zrange p sz p' (sz1 + sz2).
Proof.
  move=> hsz hsz1 hsz2 hover' [hover _ hdisj] [_ _ hdisj'].
  split=> //.
  move: hdisj'; rewrite wunsigned_add; first by Psatz.lia.
  by move: hover'; rewrite /no_overflow zify; have := wunsigned_range p'; Psatz.lia.
Qed.

Lemma disjoint_zrange_U8 p sz p' sz' :
  0 < sz ->
  0 < sz' ->
  no_overflow p' sz' ->
  (forall k, 0 <= k /\ k < sz' -> disjoint_zrange p sz (p' + wrepr _ k) (wsize_size U8)) ->
  disjoint_zrange p sz p' sz'.
Proof.
  move=> hsz /dup[] /Z.lt_le_incl.
  move: sz'; apply: natlike_ind; first by Psatz.lia.
  move=> sz' hsz' ih _ hover hdisj.
  have /Z_le_lt_eq_dec [?|?] := hsz'.
  + apply disjoint_zrange_add => //; last by apply hdisj; Psatz.lia.
    apply ih => //.
    + by move: hover; rewrite /no_overflow !zify; Psatz.lia.
    by move=> k hk; apply hdisj; Psatz.lia.
  subst sz'.
  rewrite -(GRing.addr0 p') -wrepr0.
  by apply hdisj; Psatz.lia.
Qed.

Definition pointer_range (lo hi: pointer) : pred pointer :=
  λ p, (wunsigned lo <=? wunsigned p) && (wunsigned p <? wunsigned hi).

Lemma pointer_range_between lo hi p :
  pointer_range lo hi p →
  between lo (wunsigned hi - wunsigned lo) p U8.
Proof.
  rewrite /pointer_range /between !zify.
  change (wsize_size U8) with 1.
  Psatz.lia.
Qed.

(* -------------------------------------------------- *)
(** Pointer arithmetic *)

#[ global ]
Instance Pointer : pointer_op pointer.
Proof.
refine
  {| add p k   := (p + wrepr Uptr k)%R
   ; sub p1 p2 := wunsigned (p1 - p2)%R
   ; p_to_z p  := wunsigned p
  |}.
- abstract (move=> p k; rewrite wrepr_unsigned; ssring).
- abstract (move=> p k => hk;
  rewrite -{2}(@wunsigned_repr_small Uptr k);
    [ f_equal; ssring
    | have := wsize_size_wbase U256;
      have := wbase_m (wsize_le_U8 (@Uptr pd));
      Lia.lia ]).
- abstract (move => p; rewrite wrepr0; ssring).
Defined.

Lemma addE p k : add p k = (p + wrepr Uptr k)%R.
Proof. by []. Qed.

Lemma subE p1 p2 : sub p1 p2 = wunsigned (p1 - p2).
Proof. by []. Qed.

Lemma addC p i j : add (add p i) j = add p (i + j).
Proof. rewrite /= wrepr_add; ssring. Qed.

Lemma p_to_zE p : p_to_z p = wunsigned p.
Proof. done. Qed.

Global Opaque Pointer.

Lemma disjoint_range_alt p1 ws1 p2 ws2 :
  disjoint_range p1 ws1 p2 ws2 ->
  CoreMem.disjoint_range p1 ws1 p2 ws2.
Proof.
  case; rewrite /no_overflow !zify => hover1 hover2 hdisj i1 i2 hi1 hi2.
  rewrite !addE => /(f_equal wunsigned).
  have h1 := wunsigned_range p1.
  have h2 := wunsigned_range p2.
  by rewrite !wunsigned_add; Psatz.lia.
Qed.

Lemma is_align_modE ptr sz : (wunsigned ptr mod wsize_size sz == 0)%Z = is_align ptr sz.
Proof. by rewrite /is_align p_to_zE (rwP eqP). Qed.

Lemma is_align_mod ptr sz : reflect (wunsigned ptr mod wsize_size sz = 0)%Z (is_align ptr sz).
Proof. rewrite -is_align_modE; apply eqP. Qed.

Lemma is_align_addE (ptr1:pointer) sz :
  is_align ptr1 sz ->
  forall ptr2, is_align (ptr1 + ptr2)%R sz = is_align ptr2 sz.
Proof.
  have hn := wsize_size_pos sz.
  move => /is_align_mod h ptr2; rewrite -!is_align_modE.
  by rewrite /wunsigned mathcomp.word.word.addwE -/(wbase Uptr) mod_wbase_wsize_size -Zplus_mod_idemp_l h.
Qed.

Lemma is_align_add (ptr1 ptr2:pointer) sz :
  is_align ptr1 sz -> is_align ptr2 sz -> is_align (ptr1 + ptr2)%R sz.
Proof. by move=> /is_align_addE ->. Qed.

Lemma is_align_m sz sz' (ptr: pointer) :
  (sz' ≤ sz)%CMP →
  is_align ptr sz →
  is_align ptr sz'.
Proof.
  have wsnz s : wsize_size s ≠ 0.
  - by have := wsize_size_pos s.
  move => /wsize_size_le le /eqP /Z.mod_divide - /(_ (wsnz _)) /(Z.divide_trans _ _ _ le) {le} le.
  by apply/eqP/Z.mod_divide.
Qed.

Lemma is_align_mul sz j : is_align (wrepr Uptr (wsize_size sz * j)) sz.
Proof.
  have hn := wsize_size_pos sz.
  have hnz : wsize_size sz ≠ 0%Z by Psatz.lia.
  by rewrite /is_align p_to_zE wunsigned_repr mod_wbase_wsize_size Z.mul_comm Z_mod_mult.
Qed.

Lemma is_align_no_overflow ptr sz :
  is_align ptr sz → no_overflow ptr (wsize_size sz).
Proof.
  rewrite /no_overflow /is_align p_to_zE => /eqP ha; apply/ZleP.
  have hn := wsize_size_pos sz.
  have hnz : wsize_size sz ≠ 0%Z by Psatz.lia.
  move: (wunsigned ptr) (wunsigned_range ptr) ha => {ptr} ptr.
  have [a ->] := wsize_size_div_wbase sz Uptr.
  move: (wsize_size sz) hn hnz => n hn hnz hr /Zmod_divides [] // q ?; subst ptr.
  cut (q + 1 <= a)%Z; Psatz.nia.
Qed.

Notation do_align := align_word (only parsing).

Lemma do_align_is_align sz p : is_align (do_align sz p) sz.
Proof. apply align_word_aligned. Qed.

Lemma is_align_array ptr sz j :
  is_align ptr sz → is_align (wrepr _ (wsize_size sz * j) + ptr)%R sz.
Proof. by move=> hptr; apply is_align_add => //; apply is_align_mul. Qed.

(** Rounds the given size to the next larger-or-equal multiple of [ws] *)
Definition round_ws (ws:wsize) (sz: Z) : Z :=
  (let d := wsize_size ws in
   let: (q, r) := Z.div_eucl sz d in
   if r == 0 then sz else (q + 1) * d)%Z.

Lemma round_ws_aligned ws sz :
  (round_ws ws sz) mod wsize_size ws == 0.
Proof.
  have ws_pos : wsize_size ws ≠ 0 by case: ws.
  apply/eqP; rewrite Z.mod_divide // /round_ws.
  elim_div => z z' /(_ ws_pos) [] ->{sz} D.
  case: eqP => ?.
  - exists z; Psatz.lia.
  exists (z + 1); Psatz.lia.
Qed.

Lemma round_ws_range ws sz :
  sz <= round_ws ws sz < sz + wsize_size ws.
Proof.
  have ws_pos := wsize_size_pos ws.
  rewrite /round_ws; elim_div => ? ? [] // -> []; last by Psatz.lia.
  case: eqP; Psatz.lia.
Qed.

Lemma round_wsE ws sz : round_ws ws sz =
  if (sz mod wsize_size ws == 0)%Z then sz else sz + wsize_size ws - sz mod wsize_size ws.
Proof.
  have ws_pos: wsize_size ws ≠ 0 by case: ws.
  rewrite /round_ws.
  elim_div => ? ? /(_ ws_pos) [] ->{sz} D.
  case: eqP => ? //.
  by Psatz.lia.
Qed.

Class memory (mem: Type) (CM: coreMem pointer mem) : Type :=
  Memory {
      stack_root : mem -> pointer
    ; stack_limit : mem -> pointer
    ; frames : mem -> seq pointer
    ; alloc_stack : mem -> wsize -> Z -> Z -> Z -> exec mem (* alignement, size, extra initial size, extra-size *)
    ; free_stack : mem -> mem
    ; init : seq (pointer * Z) → pointer → exec mem

    ; stack_region_is_free : ∀ (m: mem) (p: pointer), wunsigned (stack_limit m) <= wunsigned p < wunsigned (head (stack_root m) (frames m)) → ~~ validw m p U8
    ; top_stack_below_root: ∀ (m: mem), wunsigned (head (stack_root m) (frames m)) <= wunsigned (stack_root m)
    }.

#[ global ] Arguments Memory {mem CM} _ _ _ _ _ _ _.
#[ global ] Arguments top_stack_below_root {mem CM} _.

Definition top_stack {mem: Type} {CM: coreMem pointer mem} {M: memory CM} (m: mem) : pointer :=
  head (stack_root m) (frames m).

Section SPEC.
  Context mem (CM: coreMem pointer mem) (M: memory CM)
    (m: mem) (ws:wsize) (sz: Z) (ioff:Z) (sz': Z) (m': mem) .
  Let pstk := top_stack m'.

  Definition top_stack_after_alloc (top: pointer) (ws: wsize) (sz: Z) : pointer :=
    do_align ws (top + wrepr Uptr (- sz)).

  Record alloc_stack_spec : Prop := mkASS {
    ass_read_old8 : forall p, validw m p U8 -> read m p U8 = read m' p U8;
    ass_read_new  : forall p, ~validw m p U8 -> validw m' p U8 -> read m' p U8 = Error ErrAddrInvalid;
    ass_valid     : forall p, validw m' p U8 = validw m p U8 || between (pstk + wrepr _ ioff) (sz - ioff) p U8;
    ass_align_stk : is_align pstk ws;
    ass_above_limit: wunsigned (stack_limit m) <= wunsigned pstk ∧ wunsigned pstk +  sz + Z.max 0 sz' <= wunsigned (top_stack m);
    ass_ioff      : 0 <= ioff <= sz;
    ass_fresh     : forall p s, validw m p s ->
                        (wunsigned p + wsize_size s <= wunsigned pstk \/
                         wunsigned pstk + sz <= wunsigned p)%Z;
    ass_root      : stack_root m' = stack_root m;
    ass_limit     : stack_limit m' = stack_limit m;
    ass_frames    : frames m' = top_stack_after_alloc (top_stack m) ws (sz + sz') :: frames m;
  }.

  Record stack_stable : Prop := mkSS {
    ss_root: stack_root m = stack_root m';
    ss_limit: stack_limit m = stack_limit m';
    ss_frames: frames m = frames m';
  }.

  Record free_stack_spec : Prop := mkFSS {
    fss_read_old8 : forall p, validw m' p U8 -> read m p U8 = read m' p U8;
    fss_valid    : ∀ p, validw m' p U8 = validw m p U8 && ~~ pointer_range (top_stack m) (top_stack m') p;
    fss_root : stack_root m' = stack_root m;
    fss_limit : stack_limit m' = stack_limit m;
    fss_frames : frames m' = behead (frames m);
   }.

  Lemma ass_align (ass:alloc_stack_spec) ofs s :
    (s <= ws)%CMP ->
    is_align (pstk + wrepr _ ofs)%R s = is_align (wrepr _ ofs) s.
  Proof.
    by move=> hs; apply/is_align_addE;apply: is_align_m (ass_align_stk ass).
  Qed.

  Lemma ass_add_ioff (ass: alloc_stack_spec) :
    wunsigned (pstk + wrepr _ ioff) = wunsigned pstk + ioff.
  Proof.
    have ? := ass_above_limit ass; have ? := ass_ioff ass.
    rewrite wunsigned_add //.
    assert (h := wunsigned_range (top_stack m)).  assert (h' := wunsigned_range pstk).
    Psatz.lia.
  Qed.

  Lemma ass_read_old (ass:alloc_stack_spec) p s : validw m p s -> read m p s = read m' p s.
  Proof.
    move /validwP => [] ha hv; apply eq_read => k hk.
    by apply (ass_read_old8 ass); apply hv.
  Qed.

  Lemma fss_read_old (fss:free_stack_spec) p s :
    validw m' p s -> read m p s = read m' p s.
  Proof.
    move /validwP => [] ha hv; apply eq_read => k hk.
    by apply (fss_read_old8 fss); apply hv.
  Qed.

  (* ass_fresh using pointer_range *)
  Lemma ass_fresh_alt (ass:alloc_stack_spec) p :
    validw m p U8 ->
    ~ pointer_range pstk (top_stack m) p.
  Proof.
    move=> hvalid.
    rewrite /pointer_range !zify => hpointer.
    have habove := ass.(ass_above_limit).
    move: hvalid; apply /negP.
    apply stack_region_is_free.
    by rewrite -/(top_stack _); Psatz.lia.
  Qed.

  Lemma ass_no_overflow (ass:alloc_stack_spec) :
    no_overflow pstk sz.
  Proof.
    rewrite /no_overflow zify.
    assert (hover := wunsigned_range (top_stack m)).
    have := ass.(ass_above_limit).
    by Psatz.lia.
  Qed.

End SPEC.

#[ global ] Arguments alloc_stack_spec {_ _ _} _ _ _ _ _.
#[ global ] Arguments stack_stable {_ _ _} _ _.
#[ global ] Arguments free_stack_spec {_ _ _} _ _.

Lemma top_stack_after_aligned_alloc p ws sz :
  is_align p ws ->
  top_stack_after_alloc p ws sz = (p + wrepr Uptr (- round_ws ws sz))%R.
Proof.
  rewrite /is_align p_to_zE => /eqP hal.
  rewrite round_wsE.
  rewrite /top_stack_after_alloc.
  apply wunsigned_inj.
  rewrite align_wordE.
  rewrite !wrepr_opp.

  have h: (wunsigned (p - wrepr Uptr sz) mod wsize_size ws = - (sz mod wsize_size ws) mod wsize_size ws)%Z.
  + by rewrite wunsigned_sub_mod Zminus_mod hal Z.sub_0_l wunsigned_repr mod_wbase_wsize_size.

  case: eqP => hsz.
  + by rewrite h Z.mod_opp_l_z // ?Zmod_mod // Z.sub_0_r.
  rewrite Z.mod_opp_l_nz // Zmod_mod // in h.
  rewrite -Z.add_sub_assoc -h.
  rewrite wrepr_add -{1}[p in RHS](GRing.subrK (wrepr Uptr sz)) GRing.addrKA.
  rewrite [RHS]wunsigned_sub //.
  have [hle hlt] := wunsigned_range (p - wrepr Uptr sz).
  have := Z.mod_le _ _ hle (wsize_size_pos ws).
  have := Z_mod_lt (wunsigned (p - wrepr Uptr sz)) (wsize_size ws) ltac:(done).
  by Psatz.lia.
Qed.

Lemma top_stack_after_alloc_bounded p ws sz :
  0 <= sz ∧ sz <= wunsigned p ->
  wunsigned p - wunsigned (top_stack_after_alloc p ws sz) <= sz + wsize_size ws - 1.
Proof.
  move=> hsz.
  rewrite /top_stack_after_alloc.
  have := align_word_range ws (p + wrepr _ (- sz)).
  rewrite wunsigned_add; first by Psatz.lia.
  by have := wunsigned_range p; Psatz.lia.
Qed.

End WITH_POINTER_DATA.

Module Type MemoryT.

Parameter mem : PointerData -> Type.
#[ global ] Arguments mem {_}.

Section WITH_POINTER_DATA.
Context {pd: PointerData}.

#[ global ] Declare Instance CM : coreMem pointer mem.
#[ global ] Declare Instance M : memory CM.

(*Parameter readV : forall m p s v,
  read m p s = ok v -> validw m p s. *)

(* -------------------------------------------------------------------- *)
Parameter alloc_stackP : forall m m' ws sz ioff sz',
  alloc_stack m ws sz ioff sz' = ok m' -> alloc_stack_spec m ws sz ioff sz' m'.

Parameter alloc_stack_complete : forall m ws sz ioff sz',
  let: old_size := wunsigned (stack_root m) - wunsigned (top_stack m) in
  let: max_size := wunsigned (stack_root m) - wunsigned (stack_limit m) in
  let: available := max_size - old_size in
  [&& 0 <=? ioff, ioff <=? sz, 0 <=? sz' &
  if is_align (top_stack m) ws
  then round_ws ws (sz + sz') <=? available (* tight bound *)
  else sz + sz' + wsize_size ws - 1 <=? available (* loose bound, exact behavior is under-specified *)
  ] →
  ∃ m', alloc_stack m ws sz ioff sz' = ok m'.

Parameter write_mem_stable : forall m m' p s (v:word s),
  write m p v = ok m' -> stack_stable m m'.

Parameter free_stackP : forall m,
  free_stack_spec m (free_stack m).

End WITH_POINTER_DATA.
End MemoryT.


(*===========================================================================
    Specification logic -- step-indexed and with hidden frames

    This is a step-indexed version of the specification logic defined in Chapter
    3 of Krishnaswami's thesis, which is adapted from Birkedal et al.
    A specification S is a predicate on nat and SPred, where it holds for a pair
    (k,P) if it denotes a "desirable" machine execution for up to k steps
    starting from any machine configuration that has a sub-state satisfying P.
    The meaning of "desirable" depends on S; it might, for example, mean "safe
    under certain assumptions". Note the wording "up to" and "sub-state" above:
    they suggest that formally, S must be closed under decreasing k and starring
    on assertions to P.

    The utility of this is to get a higher-order frame rule in the specification
    logic, which is very valuable for a low-level language that does not have
    structured control flow and therefore does not have the structure required
    to define a Hoare triple. When frames cannot be fixed by the symmetry of
    pre- and postconditions, they must float freely around the specification
    logic, which is exactly what the higher-order frame rule allows -- see
    [spec_frame].
  ===========================================================================*)
Require Import ssreflect ssrbool ssrfun ssrnat eqtype tuple seq fintype.
Require Import bitsrep procstate procstatemonad SPred septac.
Require Import instr eval monad monadinst reader step cursor.
Require Import common_tactics.

(* Importing this file really only makes sense if you also import ilogic, so we
   force that. *)
Require Export ilogic later.
Transparent ILPre_Ops.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Setoid RelationClasses Morphisms.

(* The ssreflect inequalities on nat are just getting in the way here. They
   don't work with non-Equivalence setoids. *)
Local Open Scope coq_nat_scope.

(* The natural numbers in descending order. *)
(*
Instance ge_Pre: PreOrder ge.
Proof. repeat constructor. hnf. eauto with arith. Qed.
*)
(* SPred, ordered by extension with **. *)
Definition extSP (P Q: SPred) := exists R, (P ** R) -|- Q.
Instance extSP_Pre: PreOrder extSP.
Proof.
  split.
  - exists empSP. apply empSPR.
  - move=> P1 P2 P3 [R1 H1] [R2 H2]. exists (R1 ** R2).
    by rewrite <-H1, sepSPA in H2.
Qed.

Instance extSP_impl_m :
  Proper (extSP --> extSP ++> Basics.impl) extSP.
Proof.
  rewrite /extSP. intros P P' [RP HP] Q Q' [RQ HQ] [R H].
  eexists. rewrite -HQ -H -HP. split; by ssimpl.
Qed.

Instance extSP_iff_m :
  Proper (lequiv ==> lequiv ==> iff) extSP.
Proof.
  rewrite /extSP. intros P P' HP Q Q' HQ.
  setoid_rewrite HP. setoid_rewrite HQ. done.
Qed.

Instance extSP_sepSP_m :
  Proper (extSP ++> extSP ++> extSP) sepSP.
Proof.
  rewrite /extSP. intros P P' [RP HP] Q Q' [RQ HQ].
  eexists. rewrite -HP -HQ. split; by ssimpl.
Qed.

Instance subrelation_equivSP_extSP: subrelation lequiv extSP.
Proof. rewrite /extSP => P P' HP. exists empSP. rewrite HP. apply empSPR. Qed.

Instance subrelation_equivSP_inverse_extSP: subrelation lequiv (inverse extSP).
Proof. rewrite /extSP => P P' HP. exists empSP. rewrite HP. apply empSPR. Qed.

Hint Extern 0 (extSP ?P ?P) => reflexivity.

(*
   Definition of "spec" and properties of it as a logic
*)
Section ILSpecSect.

Local Existing Instance ILPre_Ops.
Local Existing Instance ILPre_ILogic.
Local Existing Instance ILLaterPreOps.
Local Existing Instance ILLaterPre.

Definition spec := ILPreFrm ge (ILPreFrm extSP Prop).
Global Instance ILSpecOps: ILLOperators spec | 2 := _.
Global Instance ILOps: ILogicOps spec | 2 := _.
Global Instance ILSpec: ILLater spec | 2 := _.

End ILSpecSect.

Local Obligation Tactic := try solve [Tactics.program_simpl|auto].

(* This uses 'refine' instead of Program Definition to work around a Coq 8.4
   bug. *)
Definition mkspec (f: nat -> SPred -> Prop)
  (Hnat: forall k P, f (S k) P -> f k P)
  (HSPred: forall k P P', extSP P P' -> f k P -> f k P') : spec.
  refine (mkILPreFrm (fun k => mkILPreFrm (f k) _) _).
Proof.
  have Hnat' : forall k' k P, k' >= k -> f k' P -> f k P.
  - move => k' k P. elim; by auto.
  move=> k' k Hk P /= Hf.
  eapply Hnat'; eassumption.
Grab Existential Variables.
Proof.
  move=> P P' HP /= Hf. eapply HSPred; eassumption.
Defined.
Implicit Arguments mkspec [].

Definition spec_fun (S: spec) := fun k P => S k P.
Coercion spec_fun: spec >-> Funclass.

Add Parametric Morphism (S: spec) : S with signature
  ge ++> extSP ++> Basics.impl
  as spec_impl_m.
Proof.
  rewrite /spec_fun. move => k k' Hk P P' HP.
  rewrite -[Basics.impl _ _]/(@lentails _ ILogicOps_Prop _ _).
  by rewrite ->HP, ->Hk.
Qed.

Add Parametric Morphism (S: spec) : S with signature
  eq ==> lequiv ==> iff
  as spec_iff_m.
Proof.
  move=> k P P' HP. split => HS.
  - by rewrite ->HP in HS.
  - by rewrite <-HP in HS.
Qed.

(* The default definition of spec equivalence is sometimes inconvenient.
   Here is an alternative one. *)
Lemma spec_equiv (S S': spec):
  (forall k P, S k P <-> S' k P) -> S -|- S'.
Proof. move=> H; split => k P /=; apply H. Qed.

Lemma spec_downwards_closed (S: spec) P k k':
  k <= k' -> S k' P -> S k P.
Proof.
  move=> Hk. have Hk' : k' >= k by auto. by rewrite ->Hk'.
Qed.

(*
   Properties of spec_at
*)

Program Definition spec_at (S: spec) (R: SPred) :=
  mkspec (fun k P => S k (R ** P)) _ _.
Next Obligation.
  move=> S R k P P'. eauto using spec_downwards_closed.
Qed.
Next Obligation.
  move=> S R k P P' HP. by rewrite ->HP.
Qed.

Infix "@" := spec_at (at level 44, left associativity).

Lemma spec_frame (S : spec) (R : SPred) :
  S |-- S @ R.
Proof.
  move => k P H. rewrite /spec_at /=.
  assert (extSP P (P ** R)) as HPR by (exists R; reflexivity).
  rewrite ->sepSPC in HPR. by rewrite <-HPR.
Qed.

(* For variations of this instance with lentails instead of extSP, look at
   [spec_at_covar_m] and [spec_at_contra_m]. *)
Instance spec_at_entails_m:
  Proper (lentails ++> extSP ++> lentails) spec_at.
Proof.
  move=> S S' HS R R' HR k P. rewrite /spec_at /= /spec_fun /=.
  by rewrite <- HR, -> HS.
Qed.

Instance spec_at_equiv_m:
  Proper (lequiv ++> lequiv ++> lequiv) spec_at.
Proof.
  move => S S' HS R R' HR.
  split; cancel2; by (rewrite HS || rewrite HR).
Qed.

Lemma spec_at_emp S: S @ empSP -|- S.
Proof.
  split; last exact: spec_frame.
  move=> k P. rewrite /spec_at /spec_fun /=. by rewrite empSPL.
Qed.

Lemma spec_at_at S R R': S @ R @ R' -|- S @ (R ** R').
Proof.
  apply spec_equiv => k P. rewrite /spec_at /spec_fun /=.
  split; by [rewrite -sepSPA | rewrite sepSPA].
Qed.

Lemma spec_at_forall {T} F R: (Forall x:T, F x) @ R -|- Forall x:T, (F x @ R).
Proof. split; rewrite /= /spec_fun /=; auto. Qed.

Lemma spec_at_exists {T} F R: (Exists x:T, F x) @ R -|- Exists x:T, (F x @ R).
Proof. split; rewrite /= /spec_fun /= => k P [x Hx]; eauto. Qed.

Lemma spec_at_true R: ltrue @ R -|- ltrue.
Proof. split; rewrite /= /spec_fun /=; auto. Qed.

Lemma spec_at_false R: lfalse @ R -|- lfalse.
Proof. split; rewrite /= /spec_fun /=; auto. Qed.

Lemma spec_at_and S S' R: (S //\\ S') @ R -|- (S @ R) //\\ (S' @ R).
Proof. split; rewrite /spec_at /= /spec_fun /= => k P H; auto. Qed.

Lemma spec_at_or S S' R: (S \\// S') @ R -|- (S @ R) \\// (S' @ R).
Proof. split; rewrite /spec_at /= /spec_fun /= => k P H; auto. Qed.

Lemma spec_at_propimpl p S R: (p ->> S) @ R -|- p ->> (S @ R).
Proof. split; rewrite /= /spec_fun /=; auto. Qed.

Lemma spec_at_propand p S R: (p /\\ S) @ R -|- p /\\ (S @ R).
Proof. split; rewrite /= /spec_fun /=; auto. Qed.

Lemma spec_at_impl S S' R: (S -->> S') @ R -|- (S @ R) -->> (S' @ R).
Proof.
  split.
  - apply: limplAdj. rewrite <-spec_at_and.
    cancel2. exact: landAdj.
  - rewrite /spec_at /= /spec_fun /= => k P H.
    (* This proof follows the corresponding one (Lemma 25) in Krishnaswami's
       PhD thesis. *)
    intros k' Hk' P' [Pext HPext] HS.
    move/(_ k' Hk' (P ** Pext)): H => H.
    rewrite ->sepSPA in HPext.
    (* The rewriting by using explicit subrelation instances here is a bit
       awkward. *)
    rewrite <-(subrelation_equivSP_extSP HPext).
    apply H; first by exists Pext.
    rewrite ->(subrelation_equivSP_inverse_extSP HPext). done.
Qed.

Hint Rewrite
  spec_at_at
  spec_at_true
  spec_at_false
  spec_at_and
  spec_at_or
  spec_at_impl
  @spec_at_forall
  @spec_at_exists
  spec_at_propimpl
  spec_at_propand
  : push_at.

(* This lemma is what [spec_at_at] really should be in order to be consistent
   with the others in the hint database, but this variant is not suitable for
   autorewrite. *)
Lemma spec_at_swap S R1 R2:
  S @ R1 @ R2 -|- S @ R2 @ R1.
Proof. autorewrite with push_at. by rewrite sepSPC. Qed.

(*
   "Rule of consequence" for spec_at
*)

Class AtCovar S := at_covar: forall P Q, P |-- Q -> S @ P |-- S @ Q.
Class AtContra S := at_contra: forall P Q, P |-- Q -> S @ Q |-- S @ P.

Instance: Proper (lequiv ==> iff) AtCovar.
Proof. move=> S S' HS. rewrite /AtCovar. by setoid_rewrite HS. Qed.

Instance: Proper (lequiv ==> iff) AtContra.
Proof. move=> S S' HS. rewrite /AtContra. by setoid_rewrite HS. Qed.

Instance AtCovar_forall A S {HS: forall a:A, AtCovar (S a)} :
  AtCovar (Forall a, S a).
Proof.
  move=> P Q HPQ. autorewrite with push_at. cancel1 => a.
  by rewrite ->(HS _ _ _ HPQ).
Qed.

Instance AtContra_forall A S {HS: forall a:A, AtContra (S a)} :
  AtContra (Forall a, S a).
Proof.
  move=> P Q HPQ. autorewrite with push_at. cancel1 => a.
  by rewrite ->(HS _ _ _ HPQ).
Qed.

Instance AtCovar_and S1 S2 {H1: AtCovar S1} {H2: AtCovar S2} :
  AtCovar (S1 //\\ S2).
Proof. rewrite land_is_forall. by apply AtCovar_forall => [[]]. Qed.

Instance AtContra_and S1 S2 {H1: AtContra S1} {H2: AtContra S2} :
  AtContra (S1 //\\ S2).
Proof. rewrite land_is_forall. by apply AtContra_forall => [[]]. Qed.

Instance AtCovar_true : AtCovar ltrue.
Proof. rewrite ltrue_is_forall. by apply AtCovar_forall => [[]]. Qed.

Instance AtContra_true : AtContra ltrue.
Proof. rewrite ltrue_is_forall. by apply AtContra_forall => [[]]. Qed.

Instance AtCovar_exists A S {HS: forall a:A, AtCovar (S a)} :
  AtCovar (Exists a, S a).
Proof.
  move=> P Q HPQ. autorewrite with push_at. cancel1 => a.
  by rewrite ->(HS _ _ _ HPQ).
Qed.

Instance AtContra_exists A S {HS: forall a:A, AtContra (S a)} :
  AtContra (Exists a, S a).
Proof.
  move=> P Q HPQ. autorewrite with push_at. cancel1 => a.
  by rewrite ->(HS _ _ _ HPQ).
Qed.

Instance AtCovar_or S1 S2 {H1: AtCovar S1} {H2: AtCovar S2} :
  AtCovar (S1 \\// S2).
Proof. rewrite lor_is_exists. by apply AtCovar_exists => [[]]. Qed.

Instance AtContra_or S1 S2 {H1: AtContra S1} {H2: AtContra S2} :
  AtContra (S1 \\// S2).
Proof. rewrite lor_is_exists. by apply AtContra_exists => [[]]. Qed.

Instance AtCovar_false : AtCovar lfalse.
Proof. rewrite lfalse_is_exists. by apply AtCovar_exists => [[]]. Qed.

Instance AtContra_false : AtContra lfalse.
Proof. rewrite lfalse_is_exists. by apply AtContra_exists => [[]]. Qed.

Instance AtCovar_impl S1 S2 {H1: AtContra S1} {H2: AtCovar S2} :
  AtCovar (S1 -->> S2).
Proof.
  move=> P Q HPQ. autorewrite with push_at.
  by rewrite ->(H1 _ _ HPQ), <-(H2 _ _ HPQ).
Qed.

Instance AtContra_impl S1 S2 {H1: AtCovar S1} {H2: AtContra S2} :
  AtContra (S1 -->> S2).
Proof.
  move=> P Q HPQ. autorewrite with push_at.
  by rewrite ->(H1 _ _ HPQ), <-(H2 _ _ HPQ).
Qed.

Instance AtCovar_at S R {HS: AtCovar S} : AtCovar (S @ R).
Proof.
  move=> P Q HPQ. rewrite [_ @ P]spec_at_swap [_ @ Q]spec_at_swap.
  by rewrite <-(HS _ _ HPQ).
Qed.

Instance AtContra_at S R {HS: AtContra S} : AtContra (S @ R).
Proof.
  move=> P Q HPQ. rewrite [_ @ Q]spec_at_swap [_ @ P]spec_at_swap.
  by rewrite <-(HS _ _ HPQ).
Qed.

Instance spec_at_covar_m S {HS: AtCovar S} :
  Proper (lentails ++> lentails) (spec_at S).
Proof. move=> P Q HPQ. by apply HS. Qed.

Instance spec_at_contra_m S {HS: AtContra S} :
  Proper (lentails --> lentails) (spec_at S).
Proof. move=> P Q HPQ. by apply HS. Qed.

Instance at_contra_entails_m (S: spec) `{HContra: AtContra S}:
  Proper (ge ++> lentails --> lentails) S.
Proof.
  move => k k' Hk P P' HP H. rewrite <-Hk.
  specialize (HContra P' P HP k empSP).
  simpl in HContra. rewrite ->!empSPR in HContra. by auto.
Qed.

Instance at_covar_entails_m (S: spec) `{HCovar: AtCovar S}:
  Proper (ge ++> lentails ++> lentails) S.
Proof.
  move => k k' Hk P P' HP H. rewrite <-Hk.
  specialize (HCovar P P' HP k empSP).
  simpl in HCovar. rewrite ->!empSPR in HCovar. by auto.
Qed.

(*
   Rules for pulling existentials from the second argument of spec_at. These
   rules together form a spec-level analogue of the "existential rule" for
   Hoare triples.

   Whether an existential quantifier can be pulled out of the R in [S @ R]
   depends on S. Rewrite by <-at_ex to pull it out from a positive position in
   the goal. Rewrite by ->at_ex' to pull it out from a negative position in the
   goal.
 *)

Class AtEx S := at_ex: forall A f, Forall x:A, S @ f x |-- S @ lexists f.

(* The reverse direction of at_ex. This not only follows from AtContra but is
   actually equivalent to it. The proof is in revision 22259 (spec.v#22). *)
Lemma at_ex' S {HS: AtContra S} :
  forall A f, S @ lexists f |-- Forall x:A, S @ f x.
Proof.
  move=> A f. apply: lforallR => x. apply HS. ssplit. reflexivity.
Qed.

Instance: Proper (lequiv ==> iff) AtEx.
Proof. move=> S S' HS. rewrite /AtEx. by setoid_rewrite HS. Qed.

Lemma spec_at_and_or S R1 R2 {HS: AtEx S}:
  S @ R1 //\\ S @ R2 |-- S @ (R1 \\// R2).
Proof.
  rewrite ->land_is_forall, lor_is_exists.
  transitivity (Forall b, S @ (if b then R1 else R2)).
  - apply: lforallR => [[|]].
    - by apply lforallL with true.
    - by apply lforallL with false.
  apply: at_ex.
Qed.

Lemma spec_at_or_and S R1 R2 {HNeg: AtContra S}:
  S @ (R1 \\// R2) |-- S @ R1 //\\ S @ R2.
Proof.
  rewrite ->land_is_forall, lor_is_exists.
  transitivity (Forall b, S @ (if b then R1 else R2)); last first.
  - apply: lforallR => [[|]].
    - by apply lforallL with true.
    - by apply lforallL with false.
  apply: at_ex'.
Qed.

Instance AtEx_forall A S {HS: forall a:A, AtEx (S a)} :
  AtEx (Forall a, S a).
Proof.
  move=> T f.
  rewrite -> spec_at_forall. apply: lforallR => a.
  rewrite <- at_ex; cancel1 => x.
  rewrite spec_at_forall; by apply lforallL with a.
Qed.

Instance AtEx_and S1 S2 {H1: AtEx S1} {H2: AtEx S2} : AtEx (S1 //\\ S2).
Proof. rewrite land_is_forall. by apply AtEx_forall => [[]]. Qed.

Instance AtEx_true : AtEx ltrue.
Proof. rewrite ltrue_is_forall. by apply AtEx_forall => [[]]. Qed.

Instance AtEx_impl S1 S2 {H1: AtContra S1} {H2: AtEx S2} : AtEx (S1 -->> S2).
Proof.
  move=> A f. setoid_rewrite spec_at_impl.
  rewrite ->at_ex', <-at_ex => //. (*TODO: why does at_ex' leave a subgoal? *)
  apply: limplAdj. apply: lforallR => x. apply: landAdj.
  apply lforallL with x. apply: limplAdj. rewrite landC. apply: landAdj.
  apply lforallL with x. apply: limplAdj. rewrite landC. apply: landAdj.
  reflexivity.
Qed.

Instance AtEx_at S R {HS: AtEx S} : AtEx (S @ R).
Proof.
  move=> A f. rewrite spec_at_at.
  assert (R ** lexists f -|- Exists x, R ** f x) as Hpull.
  - split; sbazooka.
  rewrite Hpull. rewrite <-at_ex. cancel1 => x. by rewrite spec_at_at.
Qed.

(* The payoff for all this: a tactic for pulling quantifiers *)
Module Export PullQuant.
  Implicit Type S: spec.

  Definition PullQuant {A} S (f: A -> spec) := lforall f |-- S.

  Lemma pq_rhs S {A} S' (f: A -> spec) {HPQ: PullQuant S' f}:
    (forall a:A, S |-- f a) ->
    S |-- S'.
  Proof. move=> H. red in HPQ. rewrite <-HPQ. by apply: lforallR. Qed.

  Lemma PullQuant_forall A (f: A -> spec): PullQuant (lforall f) f.
  Proof. red. reflexivity. Qed.

  (* Hint Resolve worked here in Coq 8.3 but not since 8.4. *)
  Hint Extern 0 (PullQuant (lforall _) _) =>
    apply PullQuant_forall : pullquant.

  Lemma PullQuant_propimpl p S:
    PullQuant (p ->> S) (fun H: p => S).
  Proof. red. reflexivity. Qed.

  (* Hint Resolve worked here in Coq 8.3 but not since 8.4. *)
  Hint Extern 0 (PullQuant (?p ->> ?S) _) =>
    apply (@PullQuant_propimpl p S) : pullquant.

  Lemma pq_at_rec S R A f:
    PullQuant S f ->
    PullQuant (S @ R) (fun a:A => f a @ R).
  Proof.
    rewrite /PullQuant => Hf. rewrite <-Hf. by rewrite spec_at_forall.
  Qed.

  (* If we didn't find anything to pull from the frame itself, recurse under it. *)
  (* Unfortunately, Hint Resolve doesn't work here. For some obscure reason,
     there has to be an underscore for the last argument. *)
  Hint Extern 1 (PullQuant (?S @ ?R) _) =>
    eapply (@pq_at_rec S R _ _) : pullquant.

  Lemma pq_impl S S' A f:
    PullQuant S f ->
    PullQuant (S' -->> S) (fun a:A => S' -->> f a).
  Proof.
    rewrite /PullQuant => Hf. rewrite <-Hf. apply: limplAdj.
    apply: lforallR => a. apply: landAdj. eapply lforallL. reflexivity.
  Qed.

  Hint Extern 1 (PullQuant (?S' -->> ?S) _) =>
    eapply (@pq_impl S S' _ _) : pullquant.

  Import Existentials.

  Lemma pq_at S t:
    match find t with
    | Some (mkf _ f) =>
        AtEx S -> PullQuant (S @ eval t) (fun a => S @ f a)
    | None => True
    end.
  Proof.
    move: (@find_correct t). case: (find t) => [[A f]|]; last done.
    move=> Heval HS. red. rewrite ->Heval. by rewrite <-at_ex.
  Qed.

  Hint Extern 0 (PullQuant (?S @ ?R) _) =>
    let t := quote_term R in
    apply (@pq_at S t); [apply _] : pullquant.

  (* It's a slight breach of abstraction to [cbv [eval]] here, but it's easier
     than dealing with it in the hints that use reflection. *)
  (* For some reason, auto sometimes hangs when there are entailments among the
     hypotheses. As a workaround, we clear those first. Another workaround is
     to use [typeclasses eauto], but that sometimes fails. *)
  Ltac specintro :=
    eapply pq_rhs; [
      repeat match goal with H: _ |-- _ |- _ => clear H end;
      solve [auto with pullquant]
    |];
    instantiate;
    cbv [eval].

  Ltac specintros :=
    specintro; let x := fresh "x" in move=> x; try specintros; move: x.

End PullQuant.

(*
   The spec_reads connective, [S <@ R].

   It is like spec_at but requires S to not only preserve the validity of R but
   keep the memory in R's footprint unchanged.
*)

Definition spec_reads S R := Forall s : PState, (eq_pred s |-- R) ->> S @ eq_pred s.

Infix "<@" := spec_reads (at level 44, left associativity).

Instance spec_reads_entails:
  Proper (lentails ++> lentails --> lentails) spec_reads.
Proof.
  move=> S S' HS R R' HR. red in HR. rewrite /spec_reads. cancel1 => s.
  by rewrite ->HS, ->HR.
Qed.

Instance spec_reads_equiv:
  Proper (lequiv ==> lequiv ==> lequiv) spec_reads.
Proof.
  move=> S S' HS R R' HR. rewrite /spec_reads. setoid_rewrite HS.
  by setoid_rewrite HR.
Qed.

Lemma spec_reads_alt S R:
  S <@ R -|- Forall s, (eq_pred s |-- R ** ltrue) ->> S @ eq_pred s.
Proof.
  rewrite /spec_reads. split.
  - specintros => s Hs. rewrite <-lentails_eq in Hs.
    case: Hs => sR [sframe [Hs [HsR _]]].
    apply lforallL with sR. apply lpropimplL.
    - by apply-> lentails_eq.
    etransitivity; [apply (spec_frame (eq_pred sframe))|]. autorewrite with push_at.
    rewrite stateSplitsAs_eq; [|eapply Hs]. done.
  - cancel1 => s. apply: lpropimplR => Hs. apply lpropimplL => //.
    rewrite ->Hs. by ssimpl.
Qed.

(* This definition can be more convenient in metatheory. *)
Lemma spec_reads_alt_meta S R : S <@ R -|- Forall s, R s ->> S @ eq_pred s.
Proof. rewrite /spec_reads. by setoid_rewrite <-lentails_eq. Qed.

Lemma spec_reads_ex S T f: Forall x:T, S <@ f x -|- S <@ lexists f.
Proof.
  setoid_rewrite spec_reads_alt_meta. split.
  - specintros => s [x Hx]. apply lforallL with x. apply lforallL with s.
    by apply lpropimplL.
  - specintros => x s Hf.
    apply lforallL with s. apply: lpropimplL => //. econstructor. eassumption.
Qed.

Lemma spec_reads_frame S R:
  S |-- S <@ R.
Proof. rewrite /spec_reads. specintros => s Hs. apply spec_frame. Qed.

Lemma spec_reads_entails_at S {HEx: AtEx S} R:
  S <@ R |-- S @ R.
Proof.
  rewrite spec_reads_alt_meta. rewrite ->(ILFun_exists_eq R).
  specintros => s Hs. apply lforallL with s. by apply: lpropimplL.
Qed.
Local Transparent ILFun_Ops SABIOps.
Lemma emp_unit : empSP -|- eq_pred sa_unit.
  split; simpl; move => x H.
  + destruct H as [H _]; assumption.
  + exists H; tauto.
Qed.

Lemma spec_at_entails_reads S {HContra: AtContra S} R:
  S @ R |-- S <@ R.
Proof. rewrite /spec_reads. specintros => s Hs. by rewrite <-Hs. Qed.

Lemma spec_reads_eq_at S s:
  S <@ eq_pred s -|- S @ eq_pred s.
Proof.
  rewrite /spec_reads. split.
  - apply lforallL with s. exact: lpropimplL.
  - specintros => s' Hs'. rewrite <-lentails_eq in Hs'.
    simpl in Hs'; rewrite -> Hs'; reflexivity.
Qed.

Lemma spec_reads_emp S:
  S <@ empSP -|- S.
Proof.
  rewrite emp_unit spec_reads_eq_at -emp_unit. by rewrite spec_at_emp.
Qed.

Corollary spec_reads_byteIs S p b:
  S <@ byteIs p b -|- S @ byteIs p b.
Proof. apply spec_reads_eq_at. Qed.

Corollary spec_reads_flagIs S (p:Flag) b:
  S <@ (p~=b) -|- S @ (p~=b).
Proof. apply spec_reads_eq_at. Qed.

Corollary spec_reads_regIs S (p:AnyReg) b:
  S <@ (p~=b) -|- S @ (p~=b).
Proof. apply spec_reads_eq_at. Qed.

Lemma spec_reads_merge S R1 R2:
  S <@ R1 <@ R2 |-- S <@ (R1 ** R2).
Proof.
  setoid_rewrite spec_reads_alt_meta.
  specintros => s [s1 [s2 [Hs [Hs1 Hs2]]]].
  apply lforallL with s2. apply lpropimplL; first done.
  rewrite spec_reads_alt_meta.
  assert ((Forall s', R1 s' ->> S @ eq_pred s') |-- S @ eq_pred s1) as Htmp.
  - apply lforallL with s1. by apply lpropimplL.
  rewrite ->Htmp => {Htmp}. autorewrite with push_at.
  rewrite stateSplitsAs_eq; [|eapply Hs]. done.
Qed.

Lemma spec_reads_split S {HS: AtEx S} R1 R2:
  S <@ (R1 ** R2) |-- S <@ R1 <@ R2.
Proof.
  rewrite /spec_reads.
  specintros => s2 Hs2 s1 Hs1. autorewrite with push_at.
  rewrite (ILFun_exists_eq (eq_pred s1 ** eq_pred s2)).
  specintros => s Hs. rewrite ->lentails_eq in Hs. apply lforallL with s.
  apply lpropimplL => //. by rewrite <-Hs1, <-Hs2.
Qed.

Lemma spec_reads_swap' S R1 R2:
  S <@ R1 <@ R2 |-- S <@ R2 <@ R1.
Proof.
  rewrite /spec_reads.
  specintros => s1 Hs1 s2 Hs2. rewrite spec_at_swap.
  apply lforallL with s2. apply lpropimplL => //. rewrite spec_at_forall.
  apply lforallL with s1. rewrite spec_at_propimpl. exact: lpropimplL.
Qed.

Lemma spec_reads_swap S R1 R2:
  S <@ R1 <@ R2 -|- S <@ R2 <@ R1.
Proof. split; apply spec_reads_swap'. Qed.

Lemma spec_reads_forall A S R:
  (Forall a:A, S a) <@ R -|- Forall a:A, (S a <@ R).
Proof.
  rewrite /spec_reads. split.
  - specintros => a s' Hs'. apply lforallL with s'. apply: lpropimplL => //.
    autorewrite with push_at. by apply lforallL with a.
  - specintros => s' Hs' a.
    apply lforallL with a. apply lforallL with s'. exact: lpropimplL.
Qed.

Lemma spec_reads_true R: ltrue <@ R -|- ltrue.
Proof.
  rewrite ltrue_is_forall. rewrite spec_reads_forall.
  split; specintro => [[]].
Qed.

Lemma spec_reads_and S1 S2 R:
  (S1 //\\ S2) <@ R -|- (S1 <@ R) //\\ (S2 <@ R).
Proof.
  rewrite !land_is_forall. rewrite spec_reads_forall.
  split; by cancel1 => [[]].
Qed.

Lemma spec_reads_exists A S R:
  Exists a:A, (S a <@ R) |-- (Exists a:A, S a) <@ R.
Proof.
  rewrite /spec_reads. apply: lexistsL => a. specintros => s' Hs'.
  autorewrite with push_at. apply lexistsR with a. apply lforallL with s'.
  exact: lpropimplL.
Qed.

Lemma spec_reads_or S1 S2 R:
  (S1 <@ R) \\// (S2 <@ R) |-- (S1 \\// S2) <@ R.
Proof.
  rewrite !lor_is_exists. rewrite <-spec_reads_exists. by cancel1 => [[]].
Qed.

Lemma spec_reads_impl S1 S2 R:
  (S1 -->> S2) <@ R |-- S1 <@ R -->> S2 <@ R.
Proof.
  rewrite /spec_reads. apply: limplAdj. specintros => s Hs.
  apply: landAdj. apply lforallL with s. apply lpropimplL => //.
  apply: limplAdj. rewrite landC. apply: landAdj.
  apply lforallL with s. apply lpropimplL => //. apply: limplAdj.
  autorewrite with push_at. rewrite landC. apply: landAdj. reflexivity.
Qed.

Lemma spec_at_reads S R1 R:
  S <@ R1 @ R -|- S @ R <@ R1.
Proof.
  rewrite /spec_reads. split.
  - specintros => s Hs. autorewrite with push_at.
    apply lforallL with s. autorewrite with push_at.
    apply lpropimplL => //. by rewrite sepSPC.
  - autorewrite with push_at. specintro => s.
    autorewrite with push_at. specintro => Hs.
    apply lforallL with s. apply: lpropimplL => //.
    autorewrite with push_at. by rewrite sepSPC.
Qed.

Hint Rewrite spec_at_reads : push_at.

Instance AtEx_reads S R {HS: AtEx S}: AtEx (S <@ R) := _.
Instance AtCovar_reads S R {HS: AtCovar S}: AtCovar (S <@ R) := _.
Instance AtContra_reads S R {HS: AtContra S}: AtContra (S <@ R) := _.

Module Export PullQuant_reads.
  Import Existentials.

  Lemma pq_reads S t:
    match find t with
    | Some (mkf _ f) =>
        PullQuant (S <@ eval t) (fun a => S <@ f a)
    | None => True
    end.
  Proof.
    move: (@find_correct t). case: (find t) => [[A f]|]; last done.
    move=> Heval. red. rewrite ->Heval. by apply_and spec_reads_ex.
  Qed.

  Hint Extern 0 (PullQuant (?S <@ ?R) _) =>
    let t := quote_term R in
    apply (@pq_reads S t) : pullquant.

  Lemma pq_reads_rec S R A f:
    PullQuant S f ->
    PullQuant (S <@ R) (fun a:A => f a <@ R).
  Proof.
    rewrite /PullQuant => Hf. rewrite <-Hf. by rewrite spec_reads_forall.
  Qed.

  (* If we didn't find anything to pull from the frame itself, recurse under it. *)
  (* Unfortunately, Hint Resolve doesn't work here. For some obscure reason,
     there has to be an underscore for the last argument. *)
  Hint Extern 1 (PullQuant (?S <@ ?R) _) =>
    eapply (@pq_reads_rec S R _ _) : pullquant.

End PullQuant_reads.

Lemma spec_at_later S R:
  (|> S) @ R  -|- |> (S @ R).
Proof.
  split => k P; reflexivity.
Qed.

Hint Rewrite spec_at_later : push_at.

Local Transparent ILLaterPreOps.

Lemma spec_reads_later S R: (|> S) <@ R  -|- |> (S <@ R).
 split => k P /=; rewrite /spec_fun /=; eauto.
Qed.

Hint Rewrite <-
  spec_at_later
  spec_reads_later
  : push_later.

Hint Rewrite @spec_later_exists_inhabited
  using repeat constructor : push_later.

Lemma spec_lob_context C S: (C //\\ |> S |-- S) -> C |-- S.
Proof.
  etransitivity.
  - apply landR; first apply ltrueR. reflexivity.
  apply: landAdj. apply: spec_lob. rewrite spec_later_impl.
  apply: limplAdj. apply: limplL; last by rewrite landC.
  apply spec_later_weaken.
Qed.

Instance AtEx_later S {HS: AtEx S} : AtEx (|> S).
Proof.
  move=> A f. rewrite spec_at_later.
  red in HS. rewrite <-HS. rewrite spec_later_forall. cancel1 => x.
  by rewrite spec_at_later.
Qed.

Instance AtCovar_later S {HS: AtCovar S} : AtCovar (|> S).
Proof.
  move=> P Q HPQ. autorewrite with push_at. by rewrite ->(HS _ _ HPQ).
Qed.

Instance AtContra_later S {HS: AtContra S} : AtContra (|> S).
Proof.
  move=> P Q HPQ. autorewrite with push_at. by rewrite ->(HS _ _ HPQ).
Qed.


Require Export Iron.Language.SystemF.Base.

(* Kind expressions *)
Inductive ki : Type :=
 | KStar   : ki.

(* Kind environments. *)
Definition kienv := list ki.
Hint Unfold kienv.


Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Graph.
Require Import Dict.
Require Import Misc.
Require Import SpaceSearch.CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import SpaceSearch.EqDec.
Require Import Enumerable.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Classical_Prop.
Require Import Omega.

Import ListNotations.

Section BGP.
  (* the bgp spec: https://tools.ietf.org/html/rfc4271

     We don't care about error-handling, session management,
     low level bit representation, etc. This means we can
     ignore sections:
     - 4.1 Message Header Format
     - 4.2 OPEN Message Format
     - 4.4 KEEPALIVE Message Format
     - 4.5 NOTIFICATION Message Format
     - 6.  BGP Error Handling.
     - 7.  BGP Version Negotiation.
     - 8.  BGP Finite State machine.
     - 9.1.2.1.  Route Resolvability Condition

     We also don't support
     - Route aggregation and information reduction techniques
     - Route reflectors
  *)

  Class PrefixClass := {
    Prefix : Type;
    eqDecPrefix :> eqDec Prefix;
    enumerablePrefix :> enumerable Prefix
  }.
  Context `{PrefixClass}.

  (* 5.  Path Attributes *)
  Class PathAttributesClass := {
    PathAttributes : Type;
    eqDecPathAttributes :> eqDec PathAttributes;
    leDecPathAttributes : PathAttributes -> PathAttributes -> bool;
    leDecPathAttributesEq : forall a, leDecPathAttributes a a = true
  }.
  Context `{PathAttributesClass}.

  Inductive RoutingInformation :=
  | available (_:PathAttributes)
  | notAvailable.

  Global Instance eqDecRoutingInformation : eqDec RoutingInformation.
    constructor. decide equality. apply eqDecide.
  Defined.

  Global Instance enumerableRoutingInformation `{enumerable PathAttributes} : enumerable RoutingInformation.
    refine {|enumerate := notAvailable :: map available enumerate |}.
  Proof.
    intro a.
    cbn.
    destruct a.
    - right.
      apply in_map.
      apply enumerateContainsEverything.
    - left.
      reflexivity.
  Qed.

  Definition bindRoutingInformation (a:RoutingInformation) (f:PathAttributes -> RoutingInformation) : RoutingInformation :=
    match a with
    | notAvailable => notAvailable
    | available a => f a
    end.

  Definition leDecRoutingInformation (a a':RoutingInformation) : bool :=
    match a,a' with
    | notAvailable,_ => true
    | available _, notAvailable => false
    | available a, available a' => leDecPathAttributes a a'
    end.

  Inductive Mode := ibgp | ebgp.
  Global Instance eqDecMode : eqDec Mode.
    constructor. decide equality.
  Defined.

  Class TopologyClass := {
    Router : Type;
    eqDecRouter :> eqDec Router;
    enumerableRouter :> enumerable Router;
    connections : graph Router;
    eqDecConnection s d :> eqDec (edge connections s d);
    enumerableConnection s d :> enumerable (edge connections s d);
    mode {s d} : edge connections s d -> Mode;
    UninterpretedState : Type;
    initialUninterpretedState : UninterpretedState
  }.
  Context `{TopologyClass}.

  Definition connection s d := edge connections s d.
  Typeclasses Transparent connection.
  Definition Connection :=  {c : Router * Router & connection (fst c) (snd c)}.
  Typeclasses Transparent Connection.

  (* 4.3 UPDATE Message Format

     The BGP Spec is very confusing regarding the meaning of multiple
     prefixes in the NLRI field of an Update Message. But the following
     sentence (added to RFC 4271) explains it:

     > Routes are advertised between BGP speakers in UPDATE messages.
     > Multiple routes that have the same path attributes can be advertised
     > in a single UPDATE message by including multiple prefixes in the NLRI
     > field of the UPDATE message.

     Update messages support the withdrawl and announcement of multiple routes
     at the same time. We limit it to one route withdrawl xor announcement.
  *)
  Record UpdateMessage : Type := updateMessage {
    (* the routes's prefix *)
    nlri : Prefix;
    attributes : RoutingInformation
  }.
  Global Instance eqDecUpdateMessage : eqDec UpdateMessage.
    idtac.
    constructor.
    repeat decide equality; apply eqDecide.
  Defined.

  Section RouterInternal.
    Variable r:Router.

    Inductive incoming :=
    | injected : incoming
    | received : {s : Router & connection s r} -> incoming.

    Global Instance eqDecIncoming : eqDec incoming.
      constructor.
      intros i i'.
      destruct i, i'.
      - left. reflexivity.
      - decide equality. apply eqDecide.
      - decide equality. apply eqDecide.
      - decide equality. apply eqDecide.
    Defined.
    Global Instance enumerableIncoming : enumerable incoming.
      refine {|
        enumerate := injected :: (received <$> enumerate)
      |}.
      intro i; destruct i.
      + crush.
      + apply in_cons.
        apply in_map.
        apply enumerateContainsEverything.
    Defined.
    Definition outgoing := {d : Router & connection r d}.
    Typeclasses Transparent outgoing.

    Class ConfigurationClass := {
      import : incoming -> Prefix -> PathAttributes -> RoutingInformation;
      export : incoming -> outgoing -> Prefix -> PathAttributes -> RoutingInformation;

      (* 9.4.  Originating BGP routes

         > A BGP speaker may originate BGP routes by injecting routing
         > information acquired by some other means (e.g., via an IGP) into BGP.
         > A BGP speaker that originates BGP routes assigns the degree of
         > preference (e.g., according to local configuration) to these routes
         > by passing them through the Decision Process (see Section 9.1).
         > These routes MAY also be distributed to other BGP speakers within the
         > local AS as part of the update process (see Section 9.2).

         It's unclear which import filter is run, since import filters are
         defined per neighbor, and routes that I originate don't have a neighbor.

         Looking at selfnet's config, it appears that there simply is no import filter
         for internal routes, the routes are just injected directly into the locRIB,
         and then exported.

         A description of how to originate networks for Cisoc is here:
         http://www.cisco.com/c/en/us/support/docs/ip/border-gateway-protocol-bgp/26634-bgp-toc.html#networkcommand

         What we are doing now, is that we have a special adjRIBIn just for injected routes,
         which are then passed through the decision process as usual. The following
         function encodes the user's policy about installed static routes.
      *)
      originate : Prefix -> PathAttributes -> bool;
      bestIncoming : (incoming -> RoutingInformation) -> incoming;
      bestIncomingIsBest : forall f i, leDecRoutingInformation (f i) (f (bestIncoming f)) = true
    }.
    Context `{ConfigurationClass}.

    (* 3.2 Routing Information Bases *)

    (* The Routing Table (used for packet forwarding) is different from the RIB *)

    Record RIBs := {
      adjRIBsIn: dict (incoming * Prefix) RoutingInformation;
      locRIB: dict Prefix RoutingInformation;
      adjRIBsOut: dict (outgoing * Prefix) RoutingInformation
    }.

    Definition originate' p a :=
      match a with
      | notAvailable => true
      | available a => originate p a
      end.

    Definition import' s p a := bindRoutingInformation a (import s p).

    Definition export' (i:incoming) (o:outgoing) (p:Prefix) (a:RoutingInformation) : RoutingInformation :=
      match i with
      | injected => bindRoutingInformation a (export i o p)
      | received (existT _ _ ci) => let ' existT _ _ co := o in
                                    if (mode ci =? ibgp) && (mode co =? ibgp)
                                    then notAvailable
                                    else bindRoutingInformation a (export i o p)
      end.

    Definition decisionProcess (p:Prefix) (ribs:RIBs) : RIBs.
      refine(
      let in_ := adjRIBsIn ribs in
      let loc := locRIB ribs in
      let out := adjRIBsOut ribs in
      let in' := in_ in
      (* 9.1.  Decision Process

         > Once the BGP speaker updates the Adj-RIB-In, the speaker SHALL run
         > its Decision Process.

         Since adjsRIBin only changed for the prefix p, it is sufficient to run
         the decision process only the part of RIBs for prefix p.

         > The Decision Process takes place in three distinct phases,
      *)

      (* 9.1.1.  Phase 1: Calculation of Degree of Preference

         > a) Phase 1 is responsible for calculating the degree of preference
         >   for each route received from a peer.

         > The exact nature of this policy information, and the computation
         > involved, is a local matter.

         > The selection process is formalized by defining a function that takes
         > the attribute of a given route as an argument and returns either (a)
         > a non-negative integer denoting the degree of preference for the
         > route, or (b) a value denoting that this route is ineligible to be
         > installed in Loc-RIB and will be excluded from the next phase of
         > route selection.

         > If the AS_PATH attribute of a BGP route contains an AS loop, the BGP
         > route should be excluded from the Phase 2 decision function.

         We will implement that in the import function

         > The function that calculates the degree of preference for a given
         > route SHALL NOT use any of the following as its inputs: the existence
         > of other routes, the non-existence of other routes, or the path
         > attributes of other routes.  Route selection then consists of the
         > individual application of the degree of preference function to each
         > feasible route, followed by the choice of the one with the highest
         > degree of preference.
      *)

      (* 9.1.2.  Phase 2: Route Selection

         > The Phase 2 decision function is invoked on completion of Phase 1.

         > For each set of destinations for which a feasible route exists in the
         > Adj-RIBs-In, the local BGP speaker identifies the route that has:

         > a) the highest degree of preference of any route to the same set
         >    of destinations, or

         > c) is selected as a result of the Phase 2 tie breaking rules
         >    specified in Section 9.1.2.2.

         > The local speaker SHALL then install that route in the Loc-RIB,
         > replacing any route to the same destination that is currently being
         > held in the Loc-RIB.
      *)
      let n' := bestIncoming (fun s => import' s p (lookup (adjRIBsIn ribs) (s,p))) in
      let a' := import' n' p (lookup (adjRIBsIn ribs) (n',p)) in
      let loc' := overwrite loc p a' in

      (* 9.1.3.  Phase 3: Route Dissemination

         > The Phase 3 decision function is invoked on completion of Phase 2

         > c) Phase 3 is ...
         >    responsible for disseminating routes in the Loc-RIB to each
         >    peer

         > All routes in the Loc-RIB are processed into Adj-RIBs-Out according
         > to configured policy.  This policy MAY exclude a route in the Loc-RIB
         > from being installed in a particular Adj-RIB-Out.

         > 9.1.4.  Overlapping Routes

         > A BGP speaker may transmit routes with overlapping Network Layer
         > Reachability Information (NLRI) to another BGP speaker.

         We don't support aggregation

         > When a BGP speaker receives an UPDATE message from an internal peer,
         > the receiving BGP speaker SHALL NOT re-distribute the routing
         > information contained in that UPDATE message to other internal peers

         We implement that in the export' function
      *)
      let out' := build (fun k => let ' (o,p') := k in if p =? p' then export' n' o p a' else lookup out (o,p'))
      in  {| adjRIBsIn  := in'; locRIB := loc'; adjRIBsOut := out' |}
    ).
    Defined.

    Typeclasses Transparent const.

    Definition updateSendProcess (p:Prefix) (out out':dict (outgoing*Prefix) RoutingInformation) : dict outgoing (list UpdateMessage).
      (* 9.2 Update-Send Process

         > As part of Phase 3 of the route selection process, the BGP speaker
         > has updated its Adj-RIBs-Out.  All newly installed routes and all
         > newly unfeasible routes for which there is no replacement route SHALL
         > be advertised to its peers by means of an UPDATE message.
      *)
      refine(build (fun o => if lookup out (o,p) =? lookup out' (o,p)
                             then []
                             else [{| nlri:=p; attributes:=lookup out' (o,p) |}])).
    Defined.

    (* 9.  UPDATE Message Handling *)
    Definition messageHandling (s:incoming) (m:UpdateMessage) (ribs:RIBs) :
                               dict outgoing (list UpdateMessage) * RIBs.
      refine (
      let in_ := adjRIBsIn ribs in
      let loc := locRIB ribs in
      let out := adjRIBsOut ribs in
      let p := nlri m in
      let a := attributes m in

      (* > If the UPDATE message contains a non-empty WITHDRAWN ROUTES field,
         > the previously advertised routes, whose destinations (expressed as IP
         > prefixes) are contained in this field, SHALL be removed from the
         > Adj-RIB-In.

         > If the UPDATE message contains a feasible route, the Adj-RIB-In will
         > be updated with this route as follows: if the NLRI of the new route
         > is identical to the one the route currently has stored in the Adj-
         > RIB-In, then the new route SHALL replace the older route in the Adj-
         > RIB-In, thus implicitly withdrawing the older route from service.
         > Otherwise, if the Adj-RIB-In has no route with NLRI identical to the
         > new route, the new route SHALL be placed in the Adj-RIB-In.
      *)
      let in' := overwrite'' in_ (s,p) a in
      let rib' := decisionProcess p {| adjRIBsIn := in'; locRIB := loc; adjRIBsOut := out |} in
      let out' := adjRIBsOut rib' in
      let E := updateSendProcess p out out'
      in  (E, rib')).
    Defined.

  End RouterInternal.

  Context `{forall r, ConfigurationClass r}.

  Record NetworkState : Type := networkState {
    routerState : depDict Router RIBs;
    linkState : dict Connection (list UpdateMessage);
    uninterpretedState : UninterpretedState
  }.

  Definition routerHandler r (i:incoming r) (m:UpdateMessage) (rs:forall r, RIBs r) :
                           dict Connection (list UpdateMessage) * (forall r, RIBs r).
    refine (let ' (E, ribs) := messageHandling r i m (lookup rs r) in _).
    refine (let rs' := overwrite' rs r ribs in _).
    refine (let E' := build(fun c' => _) in (E',rs')).
    unfold const.
    destruct c' as [r'd c'].
    destruct r'd as [r' d].
    refine (if r =? r' then _ else []).
    subst.
    unfold outgoing in *.
    refine(lookup E (existT _ d c')).
  Defined.

  Definition forwardHandler (c:Connection) (m:UpdateMessage) (rs:forall r, RIBs r) :
                            dict Connection (list UpdateMessage) * (forall r, RIBs r).
    destruct c as [sr c].
    destruct sr as [s r].
    exact (routerHandler r (received r [s & c]) m rs).
  Defined.

  Definition generateHandler (r:Router) (m:UpdateMessage) (rs:forall r, RIBs r) :
                             dict Connection (list UpdateMessage) * (forall r, RIBs r).
    exact (routerHandler r (injected r) m rs).
  Defined.

  Fixpoint changeHandler (ps:list Prefix) (r:Router) (rs:forall r, RIBs r) {struct ps} :
                         dict Connection (list UpdateMessage) * (forall r, RIBs r).
    refine (match ps with
    | [] => (const [], rs)
    | p :: ps' => _
    end).
    refine (let Ers' := routerHandler r (injected r)
                                      (updateMessage p (adjRIBsIn r (rs r) (injected r,p)))
                                      rs in _).
    refine (let E' := fst Ers' in _).
    refine (let rs' := snd Ers' in _).
    refine (let Ers'' := changeHandler ps' r rs' in _).
    refine (let E'' := fst Ers'' in _).
    refine (let rs'' := snd Ers'' in _).
    refine ((fun c => E' c ++ E'' c), rs'').
  Defined.

  (* TODO combine commonalities between Generate and Forward *)
  Inductive Transition : NetworkState -> NetworkState -> Type :=
  | generate m r rs ls us : originate' r (nlri m) (attributes m) = true ->
      let Ers' := generateHandler r m rs in
      let E := fst Ers' in
      let rs' := snd Ers' in
      Transition
        {| routerState := rs; linkState := ls; uninterpretedState := us |}
        {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c); uninterpretedState := us |}
  | forward m c rs ls us :
      let Ers' := forwardHandler c m rs in
      let E := fst Ers' in
      let rs' := snd Ers' in
      Transition
        {| routerState := rs;  linkState := update' ls c (fun ms => m::ms); uninterpretedState := us |}
        {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c); uninterpretedState := us |}
  | change r rs ls us us' :
      let Ers' := changeHandler enumerate r rs in
      let E := fst Ers' in
      let rs' := snd Ers' in
      Transition
        {| routerState := rs;  linkState := ls; uninterpretedState := us |}
        {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c); uninterpretedState := us' |}
  | skip s : Transition s s.

  Definition emptyRIB {A} : dict A RoutingInformation := build (const notAvailable).

  Definition emptyNetworkState := {|
    routerState := build (fun _ => {|
        adjRIBsIn  := emptyRIB;
        locRIB     := emptyRIB;
        adjRIBsOut := emptyRIB
      |});
    linkState := build (fun _ => []);
    uninterpretedState := initialUninterpretedState
  |}.
End BGP.

Arguments adjRIBsIn {_ _ _ _} _ _.
Arguments locRIB {_ _ _ _} _ _.
Arguments adjRIBsOut {_ _ _ _} _ _.
Arguments available {_} _.
Arguments notAvailable {_}.
Arguments received {_ _} _.
Arguments injected {_ _}.