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

Definition indx := fun (I : finType) (x : I) => index x (enum I).
Implicit Arguments indx [I].
Prenex Implicits indx.

(* Arrays indexed by a finite type *)

Record array (I : finType) (T : Type) : Type := Array {orig :> ptr}.
Implicit Arguments Array [I T]. 

Definition array_for (I : finType) (T : Type) of phant (I -> T) : predArgType := 
  array I T. 
Identity Coercion array_for_array : array_for >-> array.

Notation "{ 'array' aT }" := (array_for (Phant aT))
  (at level 0, format "{ 'array' '[hv' aT ']' }") : type_scope.

Module Array. Section Array.
Variables (I : finType) (T : Type).
Notation array := {array I -> T}.

Definition shape (a : array) (f : {ffun I -> T}) := 
  [Pred h | h = updi2 a (fgraph f) /\ def h].

Definition sshape aa ff := fun ii => 
  shape aa.1 ff.1 ii.1 /\ shape aa.2 ff.2 ii.2.

Lemma sshape_fun a f i1 i2 : sshape (a, a) (f, f) (i1, i2) -> i1 = i2.
Proof. by move=>[[/=-> _]][[/=-> _]]. Qed.

Lemma enum_split k : 
  enum I = take (indx k) (enum I) ++ k :: drop (indx k).+1 (enum I). 
Proof.
rewrite -{2}(@nth_index I k k (enum I)) ?mem_enum //.
by rewrite -drop_nth ?index_mem ?mem_enum // cat_take_drop.
Qed.

Lemma updi2_split (a : array) k (f : {ffun I -> T}) : 
  updi2 a (fgraph f) = 
  updi2 a (take (indx k) (fgraph f)) :+ a.+(2*(indx k)) :-> f k :+ 
  updi2 (a.+(2*((indx k).+1))) (drop ((indx k).+1) (fgraph f)).
Proof.
rewrite fgraph_map /= {1}(enum_split k) map_cat updi2_cat /=.
rewrite map_take map_drop size_takel ?unA.
by do 2! f_equal=>//; rewrite /ptr_offset mulnS addnA addnAC.
by rewrite size_map index_size.
Qed.

Lemma takeord k x (f : {ffun I -> T}) : 
  take (indx k) (fgraph [ffun y => [eta f with k |-> x] y]) = 
  take (indx k) (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in take (indx k) (enum I), f =1 f'}.
- by rewrite !fgraph_map -map_take; symmetry; rewrite -map_take (eq_in_map E). 
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= =>H4. 
by move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->; 
rewrite andbF.
Qed.

Lemma dropord k x (f : {ffun I -> T}) :
  drop (indx k).+1 (fgraph [ffun y => [eta f with k |->x] y]) = 
  drop (indx k).+1 (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in drop (indx k).+1 (enum I), f =1 f'}.
- by rewrite !fgraph_map -map_drop; symmetry; rewrite -map_drop (eq_in_map E).
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= => H4.
by move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->; 
rewrite !andbF.
Qed.    

Program Definition new (v0 : T) : STsec [:::] array 
  (fun i => True, 
   fun yy ii mm => 
     exists jj, mm = jj :++ ii /\ 
       sshape yy ([ffun => v0], [ffun => v0]) jj /\
       (ii.1 =~ ii.2 -> yy.1 = yy.2 /\ jj.1 = jj.2)) :=
  Do (lallocb @0 [v0, #|I|];;
      ret @ (fun p => [Array p])).
Next Obligation.
split=> [a i _ D|a1 a2 i1 i2 _ _ D1 D2]; first by apply: sbnd_do=>//.
vauto; apply: bnd_lallocb=> l1 l2.
apply: val_doL=>// y1 m1 [[/=A _]][[/=-> _]]; 
apply: val_doV=>// y2 m2 [[/=B _]][[/=-> _]] Def2 Def1 C _. 
set h1 := updi2 l1 _ in C; set h2 := updi2 l2 _ in C; exists (h1, h2).
split; rewrite /plus2 /=; f_equal=>//.
split=>//;[split=>/=;[rewrite /h1|rewrite /h2]|].
split; last by rewrite A in Def1; apply: (defUnl Def1).
- rewrite fgraph_map /= cardE; clear A B C h1 h2.
  by elim: (enum I) l1=>// t ts /= A l1; rewrite A; f_equal; rewrite ffunE.
split; last by rewrite B in Def2; apply: (defUnl Def2).
- rewrite fgraph_map /= cardE; clear A B C h1 h2.
  by elim: (enum I) l2=>// t ts /= A l2; rewrite A; f_equal; rewrite ffunE.
by move=> X; rewrite /h1 /h2; case: (C X (erefl _) (erefl _))=>[[-> D]]. 
Qed.

Definition pre_array a i := 
  exists j, exists h, exists f, i = j :+ h /\ shape a f j.

Definition post_read a kk yy ii mm :=
  mm = ii /\ forall jj hh ff,
               ii = jj :++ hh -> sshape (a, a) ff jj -> 
               yy.1 = ff.1 kk.1 /\ yy.2 = ff.2 kk.2.  
  
Program Definition read (a : array) :
  STsec [::: I] T (fun k => pre_array a, post_read a) :=
  Do (read _ @ (fun k => [a.+(2*(indx k))])).
Next Obligation.
split=> [av i [j][h][f][[->]][[-> Def]]A
|av1 av2 i1 i2 [j1][h1][f1][[[->]]][[[->]]]D1 [j2][h2][f2][[[->]]][[[->]]]D2].
apply: sval_do=>//= _; rewrite (updi2_split a av.1).
by rewrite -2!unA unC; eexists; exists (f av.1); rewrite -unA; f_equal. 
move=> _ _; apply: val_do=>/=.
- split=> _.
rewrite (updi2_split a av1.1) -2!unA unC unAC -unA.
by set k1 := updi2 a _ :+ _; exists k1; exists (f1 av1.1). 
rewrite (updi2_split a av2.1) -2!unA unC unAC -unA.
by set k1 := updi2 a _ :+ _; exists k1; exists (f2 av2.1). 
move=> y1 y2 m1 m2 [[/= -> ->]] A _ _ _.
split=>// [[j1' j2']][h1' h2'][f1' f2'][[C D]] /= E.
case: E =>/= [[F G]][[H J]]; move: F H C D=> -> -> C D. 
symmetry in C; rewrite (updi2_split a av1.1) -2!unA unC unAC -unA in C.
set k1 := (updi2 a _ :+ _) in C; rewrite -C in A.
symmetry in D; rewrite (updi2_split a av2.1) -2!unA unC unAC -unA in D.
set k2 := (updi2 a _ :+ _) in D; rewrite -D in A.
by move: (A (k1, k2) (f1' av1.1, f2' av2.1) (erefl _))=>[[-> ->]].
Qed.

Definition updf (k : I) (x : T) (f : {ffun I -> T}) := 
  [ffun z => [eta f with k |-> x] z].

Lemma updf_gss k x f : x = (updf k x f) k.
Proof. by rewrite /updf ffunE /= eq_refl. Qed.

Definition post_write a kk xx (yy : d unit) ii mm :=
  forall jj hh ff, 
    ii = jj :++ hh -> sshape (a, a) ff jj ->
    exists jj', 
      mm = jj' :++ hh /\ 
      sshape (a, a) (updf kk.1 xx.1 (ff.1), updf kk.2 xx.2 ff.2) jj'.

Program Definition write (a : array) :
  STsec [::: I; T] unit (fun k x => pre_array a, post_write a) :=
  Do (write @ (fun k x => [a .+ (2 * (indx k)), x])).
Next Obligation.
rewrite !gh. split=>[av i [j][h][f][[[->]]][[[->]]] _ D
|av1 av2 i1 i2 [[[[[]]]]] j1 j2 [h1 h2][f1 f2][[/= -> ->]][[/= -> _]][[/= -> _]]].  
rewrite (updi2_split a av.1) in D |- *. 
by rewrite -2!unA unC -unA; rewrite -2!unA unC -unA in D; apply: (sval_write D).
rewrite (updi2_split a av1.1) (updi2_split a av2.1)=> _ _ Def1 Def2.
rewrite -2!unA unC -unA; rewrite -2!unA unC -unA in Def1.
set F := a.+_ :-> _ :+ (_ :+ _ :+ _).
rewrite -2!unA unC -unA; rewrite -2!unA unC -unA in Def2.
rewrite /F; move: F=> _; vauto=> _ _.
rewrite -unAC unA; rewrite -unAC unA in Def1; set F := (a.+_ :-> _ :+ _). 
rewrite -unAC unA; rewrite -unAC unA in Def2; set G := (a.+_ :-> _ :+ _).
exists (F, G); do 3!split=>/=; last first.
- by rewrite /G; case: (defUnl Def2); rewrite 2!defPtUn.
by rewrite (updi2_split a av2.1) -unA unC -unA /G -updf_gss dropord takeord.
- by rewrite /F; case: (defUnl Def1); rewrite 2!defPtUn.
by rewrite (updi2_split a av1.1) -unA unC -unA /F -updf_gss dropord takeord.
Qed.

Lemma bnd_new B (e1 e2 : ST [::: array] B) v0 i1 i2 (r : d B -> d heap -> Prop) :
  (forall j1 j2 a1 a2,
    verify2 (j1 :+ i1) (j2 :+ i2) (e1 @0 [a1]) (e2 @0 [a2])
    (fun y m =>
      (sshape (a1, a2) ([ffun=> v0], [ffun=> v0]) (j1, j2) /\
        (i1 =~ i2 -> a1 = a2 /\ j1 = j2)) ->
      r y m)) ->
  verify2 i1 i2 (new v0 @0 tt;; e1) (new v0 @0 tt;; e2) r.
Proof.
move=>H; apply: bnd_do=>//=. 
move=> a1 a2 m1 m2 [[j1 j2]][[/= -> ->]] J D1 D2 b1 b2 h1 h2 K L.
by apply: (H j1 j2 a1 a2).
Qed.

Lemma bnd_read B (e1 e2 : ST [::: T] B) (a : array) k1 k2 
               j1 j2 h1 h2 f1 f2 (r : d B -> d heap -> Prop) :
  sshape (a, a) (f1, f2) (j1, j2) ->
  verify2 (j1 :+ h1) (j2 :+ h2) (e1 @0 [f1 k1]) (e2 @0 [f2 k2]) r ->
  verify2 (j1 :+ h1) (j2 :+ h2) (read a @0 [k1];; e1) (read a @0 [k2];; e2) r.
Proof.
move=>[S1 S2]H1. apply: bnd_do=>//. 
by split=>_; [exists j1, h1, f1|exists j2, h2, f2].
move=>y1 y2 m1 m2[[/=-> ->]]; case/(_ (j1, j2) (h1, h2) (f1, f2))=>//. 
by move=>->->.
Qed.

Lemma bnd_readV B (e : ST [::: T] B) (a : array) k
                j h f (r : B -> heap -> Prop) :
  shape a f j -> 
  verify (j :+ h) (e @0 [f k]) r -> 
  verify (j :+ h) (read a @0 [k];; e) r.
Proof.
move=>[-> D1]H1; apply:bnd_doV=>//=[H2|]; first by repeat eexists; eauto.
move=>t m[[/=-> _]]; set u := updi2 a _; case/(_ (u, u) (h, h) (f, f) _)=>//.
by move=>/=->->.
Qed.

Lemma val_readV (a : array) k j h f (r : T -> heap -> Prop) :
  shape a f j -> (def (j :+ h) -> r (f k) (j :+ h)) ->
  verify (j :+ h) (read a @0 [k]) r.
Proof.
move=>S1 H1; apply: val_doV=>//[D1|]; first by exists j, h, f.
by move=>y m[[/=-> _]]; case/(_ (j, j) (h, h) (f, f))=>//->.
Qed.

Lemma bnd_write B (e1 e2 : ST [::: unit] B) (a : array) k1 k2 x1 x2
               j1 j2 h1 h2 f1 f2 (r : d B -> d heap -> Prop) :
  sshape (a, a) (f1, f2) (j1, j2) ->
  (forall j1' j2', sshape (a, a) (updf k1 x1 f1, updf k2 x2 f2) (j1', j2') ->    
    verify2 (j1' :+ h1) (j2' :+ h2) (e1 @0 [tt]) (e2 @0 [tt]) r) ->
  verify2 (j1 :+ h1) (j2 :+ h2) 
      (write a @0 [k1, x1];; e1) (write a @0 [k2, x2];; e2) r.
Proof.
move=>[[[/=-> D1]]][[/=-> D2]]H1; apply: bnd_do=>//. 
by split=> _; repeat eexists; eauto.
move=>y1 y2 m1 m2; set u1 := updi2 _ _; set u2 := updi2 _ _.
case/(_ (u1, u2) (h1, h2) (f1, f2))=>//[[/=j1' j2']][[/=-> ->]][S1 S2].
by case: y1; case: y2; apply: H1.
Qed.

Lemma bnd_writeV B (e : ST [::: unit] B) (a : array) k x
                 j h f (r : B -> heap -> Prop) :
  shape a f j ->
  (forall j', shape a (updf k x f) j' -> verify (j' :+ h) (e @0 [tt]) r) ->
  verify (j :+ h) (write a @0 [k, x];; e) r.
Proof.
move=>[-> D1]H1; apply: bnd_doV=>//=[H2|]; first by repeat eexists; eauto.
move=>y m; set u := updi2 a _; case/(_ (u, u) (h, h) (f, f))=>//.
by move=>[/=j1' j2'][[/=-> ->]][S1 S2]; case: y; apply: H1.
Qed.

Lemma val_write (a : array) k1 k2 x1 x2 j1 j2 h1 h2 f1 f2 
                (r : d unit -> d heap -> Prop) : 
  sshape (a, a) (f1, f2) (j1, j2) ->
  (forall j1' j2', 
    sshape (a, a) (updf k1 x1 f1, updf k2 x2 f2) (j1', j2') -> 
    r [tt] (j1' :+ h1, j2' :+ h2)) ->
  verify2 (j1 :+ h1) (j2 :+ h2) (write a @0 [k1, x1]) (write a @0 [k2, x2]) r.
Proof.
move=>[S1 S2]H1; apply: val_do=>//. 
by split=>_; [exists j1, h1, f1|exists j2, h2, f2]. move=>y1 y2 m1 m2. 
case/(_ (j1, j2) (h1, h2) (f1, f2))=>//[[/=j1' j2']][[/=-> ->]][S3 S4]D1 D2.
by case: y1; case: y2; apply: H1.
Qed.

Lemma val_writeV (a : array) k x j h f (r : unit -> heap -> Prop) :
  shape a f j -> 
  (forall j', shape a (updf k x f) j' -> r tt (j' :+ h)) ->
  verify (j :+ h) (write a @0 [k, x]) r.
Proof.
move=>S1 H1; apply: val_doV=>//[D1|]; first by exists j, h, f.
move=>y m; case/(_ (j, j) (h, h) (f, f))=>//[[/=j1' j2']][[/=-> ->]][S2 S3]D1.
by case: y; apply H1.
Qed.

Lemma sbnd_read B (e : ST [::: T] B) (a : array) k j h f :
  (forall v, shape a f j -> def (j :+ h) -> (j :+ h) \In safe (e @0 [v])) ->
  shape a f j -> def (j :+ h) -> j :+ h \In safe (read a @0 [k];; e).
Proof.
move=>H1 H2 H3; apply: sbnd_do=>//; first by exists j, h, f.
by move=>y m[[/=-> ->]]; case/(_ (j, j) (h, h) (f, f))=>//-> -> ?; apply: H1.
Qed.

Lemma sbnd_write B (e : ST [::: unit] B) (a : array) k x j h f :
  (forall j', shape a (updf k x f) j' -> def (j' :+ h) -> 
    (j' :+ h) \In safe (e @0 [tt])) ->
  shape a f j -> def (j :+ h) -> j :+ h \In safe (write a @0 [k, x];; e).
Proof.
move=>H1 H2 H3; apply: sbnd_do=>//; first by exists j, h, f.
move=>y m; case/(_ (j, j) (h, h) (f, f))=>//[[j1' j2']][[/=-> ->]][S1 S2]D1.
by case: y; apply: H1.
Qed.

End Array. End Array.

Module D := DataType.

Module ArrayModel. Section ArrayModel.
Variables (I : finType) (T : Type) (v0 : T) (a : array I T).

Inductive O : Type := Read  | Write.

Definition init := [ffun _ : I => v0].

Definition shape f := Array.shape a f.

Lemma shape_fun f h1 h2 : shape f h1 -> shape f h2 -> h1 = h2.
Proof. by move=> /= [-> _] [-> _]. Qed.

Definition args_of (op : O) :=
  match op with Read => [::: I] | Write => [::: I; T]
  end.

Definition res_of (op : O) :=
  match op with Read => T | Write => unit end.

Definition trans op (f : {ffun I -> T})
  : args (args_of op) -> {ffun I -> T} * res_of op := 
  match op as op' return args (args_of op') -> {ffun I -> T} * res_of op' with
  | Read => fun av => (f, f av.1)
  | Write => fun av => (Array.updf av.1 av.2.1 f, tt)
  end.

Implicit Arguments trans [].

Definition array_spec_of op : spec (args_of op) (res_of op) :=
  match op as op' return spec (args_of op') (res_of op') with 
  | Read => (fun k => Array.pre_array a, Array.post_read a)
  | Write => (fun k x => Array.pre_array a, Array.post_write a)
  end.

Lemma shape_inv aalpha op av1 av2 yy ii mm :
  spec2 (array_spec_of op) av1 av2 yy ii mm ->
  shape aalpha.1 ii.1 -> shape aalpha.2 ii.2 ->
  shape (trans op aalpha.1 av1).1 mm.1 /\
  shape (trans op aalpha.2 av2).1 mm.2.
Proof.
elim: op yy av1 av2; rewrite /shape=>//= yy av1 av2 A [B0 B] [C0 C].
by case: A => A; move: A B0 B C0 C=> -> B0 B C0 C. 
case: (A ii (empty, empty) aalpha); first by rewrite /plus2 /= 2!unh0; case ii.
by split=>/=; move: B0 C0 B C=> -> -> B C.
move=> mm'; rewrite /plus2 /= 2!unh0; case: mm A=> [m1 m2] A.
by move=> [[-> ->] /= [/= [H J] [K L]]]; split.
Qed.

Implicit Arguments D.Datatype [].

Definition ArrayType := 
  D.Datatype {ffun I -> T} _ init shape _ _ _ trans shape_inv.

Lemma ArrayType_UR : D.UR ArrayType.
Proof. by apply: shape_fun. Qed.

Lemma ArrayType_SHI : D.SHI ArrayType.
Proof. apply: D.UR_SHI ArrayType_UR. Qed.

End ArrayModel. End ArrayModel.






