Load loadpath.
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq.
Require Import prelude heaps rels hprop domains secmod seclog.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* A Bob client with a kvmap as local state *)

Require Import kvmaps hashmap hospital.
Require Import ordtype finmap fintype ssrnat.

Module HashingClient. 

Notation K := nat_ordType. 
Notation V := nat_eqType.

(*just exhibit a value of appropriate type*)

Definition hash (n : nat_ordType) : 'I_100 := ord0. 

(* bob with an assoc list as his local state *)

Definition assoclist_bob := AssocList.HashableAssocList K hash.

(* bob with a filter hash table as his local state *)

Definition bob := build_map (0, 0) hash 1 (*setting this to 1 greatly speeds 
                                            up the Qed. at the end of this 
                                            proof*).

Definition G := finMap K V.

Definition bbshape (bb : d bob) (ff : d G) := 
  [Pred ii | HashTab.sshape bb ff ii].

Notation num_calls := 0.

Definition bcmp : G -> G := fun f => ins 18 1 (rem 17 f).

Lemma brefl : Hospital.breflP bbshape.
Proof. 
rewrite /bbshape/Hospital.breflP/HashMap.sshape/= =>bb kk tt. case=>H2 H3.
split; rewrite /Hospital.bshape.
split; apply: H2. 
split; apply: H3. 
Qed.

Program
Definition hashing_client (b : bob) :=
  Hospital.endorse_low (b := b) (bcmp := bcmp) brefl
    (Do (Hospital.read_emr @ (fun hosp pat => [hosp, pat]);;
         HashTab.insert b @ (fun emr hosp pat => [17, emr]);;
         HashTab.insert b @ (fun _ emr hosp pat => [18, 1]);;
         HashTab.remove b @ (fun _ _ emr hosp pat => [17]);;
         ret @ (fun _ _ _ emr hosp pat => [emr./2]))).
Next Obligation.
rewrite /Hospital.epost_low !gh; split=>[[hosp][pat][]|[hosp1][pat1][][hosp2][pat2][]] /=.
- move=>i[act][u][rost][j][H1][k][t][h][->]H4 H5; sauto; apply: sbnd_do=>/= D1.
by exists act; exists u; exists rost; exists j; exists (t :+ h); rewrite -!unA. 
move=>m [[/= -> ->]]. case: (H5). rewrite /fst/snd=>H6 _.
sauto. move=>D2.
apply: sbnd_do=>//=. move=> _. 
by exists k; exists t; exists (j :+ h); rewrite unAC (unC t); split=>//.
move=>? m1 H2. sauto. move=> D.
apply: sbnd_do=>//=. move=> _.
move: H2. case/(_ (k, k) (t, t) (j :+ h, j :+ h))=>//. 
- by rewrite/plus2/= unAC (unC t).
move=>[t1 t2][[/=-> ->]][_ H3].
exists (ins 17 D1 k); exists t2; exists (j :+ h). split=>//.
move=>? m2.
move: H2. case/(_ (k, k) (t, t) (j :+ h, j :+ h))=>//. 
- by rewrite/plus2/= unAC (unC t).
move=>[t1 t2][[/=-> ->]][_ H3].
case/(_ (ins 17 D1 k, ins 17 D1 k) (t2, t2) (j :+ h, j :+ h)).
- by rewrite/plus2/=. 
- by split.
move=>[t1_0 t2_0][[/=-> ->]][_ H8]. sauto. move=>D4.
apply: sbnd_do=>//=. move=> _.
exists (ins 18 1 (ins 17 D1 k)); exists t2_0; exists (j :+ h).
split=>//.
move=>i1 i2 [[[[[[[[]]]]]]]][act1 act2][u1 u2][r1 r2][j1 j2][k1 k2][t1 t2][h1 h2] /=.
case=>[[[->->]]] S U; case/Hospital.hrefl: (S)=>/= S1 S2 Q1 Q2.
rewrite -unA unC -unA; move/defUnl=>D1. 
rewrite -unA unC -unA; move/defUnl=> D2.
vauto. apply: bnd_do=>//=. 
case:(Q1)=>act3[u3][r3][j3][H1][k][t][h][E1]E2 E3.
case:(Q2)=>act4[u4][r4][j4][H2][k'][t'][h'][E4]E5 E6.
split=> _.
- rewrite unA unC unA E1.
by exists act3; exists u3; exists r3; exists j3; exists (t :+ h); rewrite unA; do !split.
- rewrite unA unC unA E4.
by exists act4; exists u4; exists r4; exists j4; exists (t' :+ h'); rewrite unA; do !split.
move=>y1 y2 m1 m2[[/=-> ->]]; vauto. 
apply: bnd_do=>//=. 
(* *)
- move: Q1 Q2=> _ _. 
case: U; rewrite/fst/snd=>Q1 Q2. split=> _.
by exists k1; exists t1; exists (h1 :+ j1); split=>[//|]; apply: Q1.
by exists k2; exists t2; exists (h2 :+ j2); split=>[//|]; apply: Q2.
move=>? ? m3 m4 H1. vauto.
apply: bnd_do=>//=.
(* *)
- move: Q1 Q2=> _ _.
move: H1; case/(_ (k1, k2) (t1, t2) (h1 :+ j1, h2 :+ j2)).
- by rewrite /plus2.
by split; rewrite/fst/snd; case: U; rewrite/fst/snd.
move=>[k1_0 k2_0][[/=-> ->]]H1.
rewrite /HashMap.sshape in H1. case: H1; rewrite /fst/snd=>H1 H2.
split=> _. 
- exists (ins 17 y1 k1); exists k1_0; exists (h1 :+ j1).
by split=>[//|]; apply: H1.
- exists (ins 17 y2 k2); exists k2_0; exists (h2 :+ j2).
by split=>[//|]; apply: H2.
move=>? ? m5 m6 H2. vauto.
apply: bnd_do=>//=.
(* *)
- move: Q1 Q2=> _ _.
move: H1; case/(_ (k1, k2) (t1, t2) (h1 :+ j1, h2 :+ j2)).
- by rewrite /plus2.
by split; rewrite/fst/snd; case: U; rewrite/fst/snd.
move=>[t1_0 t2_0][[/=H3 H4]]H5.
move: H2; case/(_ (ins 17 y1 k1, ins 17 y2 k2) 
  (t1_0, t2_0) (h1 :+ j1, h2 :+ j2)).
- by rewrite H3 H4 /plus2.
by split; rewrite/fst/snd; case: H5; rewrite/fst/snd.
move=>[t1_1 t2_1][[/=-> ->]]H6.
rewrite /HashMap.sshape in H6. case: H6; rewrite/fst/snd=>H7 H8.
split=> _.
- exists (ins 18 1 (ins 17 y1 k1)); exists t1_1; exists (h1 :+ j1).
by split=>[//|]; apply: H7.
- exists (ins 18 1 (ins 17 y2 k2)); exists t2_1; exists (h2 :+ j2).
by split=>[//|]; apply: H8.
(* *)
move=>? ? m7 m8 H3. vauto.
move=> _ _. move: Q1 Q2=> _ _.
move: H1; case/(_ (k1, k2) (t1, t2) (h1 :+ j1, h2 :+ j2)).
- by rewrite /plus2.
by split; rewrite/fst/snd; case: U; rewrite/fst/snd.
move=>[t1_0 t2_0][[/=H4 H5]]H6.
move: H2; case/(_ (ins 17 y1 k1, ins 17 y2 k2) 
  (t1_0, t2_0) (h1 :+ j1, h2 :+ j2)).
- by rewrite H4 H5 /plus2.
by split; rewrite/fst/snd; case: H6; rewrite/fst/snd.
move=>[t1_1 t2_1][[/=H7 H8]]H9.
move: H3; case/(_ (ins 18 1 (ins 17 y1 k1), 
                   ins 18 1 (ins 17 y2 k2))
  (t1_1, t2_1) (h1 :+ j1, h2 :+ j2)).
- by rewrite H7 H8 /plus2.
by split; rewrite/fst/snd; case: H9; rewrite/fst/snd.
move=>[t1_2 t2_2][[/=H10 H11]]H12.
exists (t1_2, t2_2).
rewrite H10 H11; split. 
- by rewrite/plus2/=; rewrite (unC j1) (unAC t1_2) -unA (unC j2) (unAC t2_2) -unA.
rewrite /bcmp.
have H: HashMap.sshape (b, b) (ins 18 1 (rem 17 k1), ins 18 1 (rem 17 k2)) (t1_2, t2_2).
- case: H12; rewrite/fst/snd=>H12 H13.
  split; rewrite/fst/snd.
  + move: H12; rewrite rem_ins. case: eqP. discriminate.
    rewrite rem_ins. case: eqP. by []. congruence.
  + move: H13; rewrite rem_ins. case: eqP. discriminate.
    rewrite rem_ins. case: eqP. by []. congruence.
split=>//. 
by move=>H14 H15; rewrite H14 in H; apply: (HashMap.sshape_fun H).
Qed.
 
End HashingClient.
