(**********)
(* Arrays *)
(**********)

Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype tuple finfun. 
Require Import finset rels heaps hprop domains stmod stsep stlog. 
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive. 

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) := 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.
Variable (I : finType) (T : Type). 
Notation array := {array I -> T}.
 
Definition shape (a : array) (f : {ffun I -> T}) := 
  [Pred h | h = updi a (fgraph f) /\ def h].

(*
Lemma shapeD a f : Def (shape a f). 
Proof. by move=>h [->]. Qed.

Lemma shape_invert : forall a, invertible (shape a).
Proof.
move=>a [f1][f2] h1 h2 [->] N [->] _ /= [h1'][h2'][H1]; move/(updi_iinv _ H1). 
by rewrite !size_tuple; case/(_ (refl_equal _)); move/val_inj=>->.
Qed. 

Lemma shape_inv : forall a, invert (shape a).
Proof. by move=>x; apply: iinv; [apply: shape_invert| apply: shapeD]. 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 updi_split (a : array) k (f : {ffun I -> T}) : 
        updi a (fgraph f) = updi a (take (indx k) (fgraph f)) :+ 
                            a.+(indx k) :-> f k :+ 
                            updi (a.+(indx k).+1) (drop (indx k).+1 (fgraph f)).
Proof.
rewrite fgraph_map /= {1}(enum_split k) map_cat updi_cat /=.
rewrite map_take map_drop size_takel ?unA ?ptrA ?addn1 //.
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 (x : T) : 
  STsep array (emp, fun y i h => exists a, y = Val a /\ h \In shape a [ffun => x]) :=
  Do (x <-- Allocb x #|I|; 
      ret (Array x)).
Next Obligation.
apply: bnd_allocb0=>// y; heval; hhauto; congr updi. 
by rewrite fgraph_map /= cardE; elim: (enum I)=>[|t ts /= ->] //; rewrite ffunE.
Qed.

Definition newf_loop a (f : {ffun I -> T}) : Type :=
  forall s : seq I, STsep array (fun i => exists g, exists s', [/\ i \In shape a g, 
                                            s' ++ s = enum I & 
                                            forall x, x \in s' -> g x = f x], 
                                 fun y i m => exists a, y = Val a /\ m \In shape a f).                                

Program Definition newf (f : {ffun I -> T}) : 
          STsep array (emp, fun y i h => exists a, y = Val a /\ h \In shape a f) :=
  Do (match_opt [pick x \in I] then ret (Array null)
      else [v] x <-- new (f v); 
               Fix (fun (loop : newf_loop x f) s =>  
                 Do (Match_seq s (ret (Array x))
                       (fun k t => x.+ (indx k) ::= f k;; loop t))) (enum I)). 
Next Obligation.
move: H H0 H1=>g s' [[->{i}]].
case: s=>[|k t] /= D H1 H2. 
- rewrite cats0 in H1; apply: val_ret=>//; hauto D.
  by have ->: g = f by rewrite -ffunP=>y; apply: H2; rewrite H1 mem_enum.
move: D; rewrite (updi_split x k); heval=>D; apply: cons0=>//.
exists (finfun [eta g with k |-> f k]); exists (s' ++ [:: k]).
rewrite -catA; hauto D.
- by rewrite unCA unA (updi_split x k) ffunE /= eq_refl takeord dropord.
move=>y; rewrite ffunE mem_cat !inE /=.
by case: eqP=>[->| _] //; rewrite orbF; apply: H2.
Qed. 
Next Obligation.
case: fintype.pickP=>[v|] H /=; last first.
- apply: val_ret=>//; exists (@Array I T null); split=>//; rewrite in_rel /=.
  have L: #|I| = 0 by rewrite cardE; case: (enum I)=>[|x s] //; move: (H x).
  by case: (fgraph f)=>/=; rewrite L; case.
have: def empty by []; rewrite -(unh0 empty).
apply: bnd_do=>[|y i1' [a][[->]] H1|??[?][]] //; rewrite unh0 //.
apply: cons0=>//; exists ([ffun => f v] : {ffun I -> T}); exists (Nil I).
by hauto D.
Qed. 

Definition loop_inv (a : array) : Type := 
  forall k, STsep unit (fun i => exists xs:seq T, [/\ i = updi (a .+ k) xs, def i &
                                   size xs + k = #|I|],
                        fun y i m => y = Val tt /\ m = empty).
 
Program 
Definition free (a : array) : STsep unit (fun i => exists f, i \In shape a f, 
                                          fun y i m => y = Val tt /\ m = empty) :=
  Do (Fix (fun (f : loop_inv a) k =>  
             Do (If k == #|I| then ret tt else dealloc a.+k;; f k.+1)) 0).
Next Obligation.
case: H H0=>[|v xs] /= [-> D]; first by rewrite add0n=>->; rewrite eq_refl; apply: val_ret.
case: eqP=>[->|_ H]; first by move/eqP; rewrite -{2}(add0n #|I|) eqn_addr. 
apply: bnd_dealloc=>[H2 /=|] //.
by apply: cons0=>//; exists xs; rewrite H2 offsetA addn1 -addSnnS.
Qed.
Next Obligation.
move: H H0=>f [->] D; apply: cons0=>//; exists (tval (fgraph f)).
by rewrite offset0 D fgraph_map /= size_map cardE.
Qed.

Program Definition read (a : array) (k : I) : 
          STsep T (fun i => exists f, i \In shape a f, 
                   fun y i m => forall f, i \In shape a f -> y = Val (f k) /\ i = m) := 
  Do (! a .+ indx k).
Next Obligation.
apply: (ghost1 H)=>[?|]; first by apply: shape_inv.
move: H H0=>f [->]; rewrite /shape (updi_split a k); heval.
Qed.

Program Definition write (a : array) (k : I) (x : T) : 
          STsep unit (fun i => exists f, i \In shape a f, 
                      fun y i m => forall f, i \In shape a f -> 
                        m \In shape a [ffun z => [eta f with k |-> x] z] /\ y = Val tt) :=
  Do (a .+ indx k ::= x). 
Next Obligation.
apply: (ghost1 H)=>[?|]; first by apply: shape_inv.
move: H H0=>f [->]; rewrite /shape !(updi_split a k); set g := finfun _. 
heval=>D; do !split=>//; heap_congr; last by rewrite ffunE /= eq_refl.
by rewrite takeord dropord.
Qed.
*)
End Array. End Array.

(*
(* Tabulating a finite function over another one *)
(* Useful in building linked data structures that are pointed to by *)
(* array elements, such as hashtables *)

Section Table.
Variables (I : finType) (T S : Type) (x : {array I -> T}) 
          (Ps : T -> S -> Rel heap).
Hypotheses IPs : forall t, invertible (Ps t).
Definition table := fun t b (i:I) => Ps (t i) (b i).

Notation Local "[ 'shape' t b ]" := (Array.shape x t # sepit setT (table t b))
  (at level 0, t ident, b ident, only parsing).

Lemma table_invert (t1 t2 : {ffun I -> T}) b1 b2 h1 h2:
        h1 \In [shape t1 b1] -> h2 \In [shape t2 b2] ->
        agree h1 h2 -> [/\ t1 = t2, forall i, b1 i = b2 i & h1 = h2].
Proof.
move=>t1 t2 b1 b2 h1 h2 /= [r1][g1][->][SH1][S1] _ [r2][g2][->][SH2][S2] D2 A.
case: (Array.shape_invert SH1 SH2 (agreeUnK A))=>H1 H2 {SH1 SH2}.
rewrite -{}H1 -{}H2 in D2 A S2 *; split=>//; last first.
- heap_congr; apply: (sepit_invert S1 S2 (agreeKUn A))=>m l1 l2 _ H1 H2.
  by case/(IPs H1 H2).
move=>i; move: S1 S2 A; rewrite !(sepitT1 i).
move=>[l1][w1][->][T1][_] _ [l2][w2][->][T2][_] _ A.
suff: agree l1 l2 by case/(IPs T1 T2).
by rewrite -(unCA l1) -(unCA l2) in A; apply: agreeUnK A.
Qed.

Lemma tableP (s : {set I}) t1 t2 b1 b2 h : 
        (forall x, x \in s -> t1 x = t2 x) -> 
        (forall x, x \in s -> b1 x = b2 x) -> 
        h \In sepit s (table t1 b1) -> h \In sepit s (table t2 b2). 
Proof.
move=>s t1 t2 b1 b2 h H1 H2 H.
rewrite (sepitF (table t1 b1)) //.
by move=>y R; rewrite /table (H1 _ R) (H2 _ R).
Qed.

Lemma tableP2 (s1 s2 : {set I}) t1 t2 b1 b2 h : 
        s1 =i s2 ->
        (forall x, s1 =i s2 -> x \in s1 -> t1 x = t2 x) ->
        (forall x, s1 =i s2 -> x \in s1 -> b1 x = b2 x) ->
        h \In sepit s1 (table t1 b1) -> h \In sepit s2 (table t2 b2).
Proof.
move=>s1 s2 t1 t2 b1 b2 h H1 H2 H3; rewrite (eq_sepit _ H1).
by apply: tableP=>y; rewrite -H1=>R; [apply: H2 | apply: H3].
Qed.

End Table.

Prenex Implicits table.
*)