Module Type STRAT_MODEL.
Declare Module AV : ADR_VAL.
Inductive res (PRED : Type) : Type :=
| NO':  forall sh: Share.t, ~(readable_share sh) -> res PRED
| YES': forall sh: Share.t, readable_share sh -> kind -> fpreds PRED -> res PRED
| PURE': kind -> fpreds PRED -> res PRED.
Definition res_fmap (A B:Type) (f:A->B) (g:B->A)(x:res A) : res B :=
match x with
| NO' rsh nsh => NO' B rsh nsh
| YES' sh rsh k pds => YES' B sh rsh k (fmap fpreds f g pds)
| PURE' k pds => PURE' B k (fmap fpreds f g pds)
end.
Definition f_res : functor := Functor ff_res.
Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
| res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
join sh1 sh2 sh3 ->
res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
(NO' PRED sh3 nsh3)
| res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
(YES' PRED sh3 rsh3 k p)
| res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
(YES' PRED sh3 rsh3 k p)
| res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
| res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).
Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
Definition f_res : functor := Functor ff_res.
Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
| res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
join sh1 sh2 sh3 ->
res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
(NO' PRED sh3 nsh3)
| res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
(YES' PRED sh3 rsh3 k p)
| res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
(YES' PRED sh3 rsh3 k p)
| res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
join sh1 sh2 sh3 ->
res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
| res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).
Instance Join_res (PRED: Type) : Join (res PRED) := res_join PRED.
Instance pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
Definition res_option (PRED : Type) (r: res PRED) : option (rshare * kind):=
match r with
| NO' _ _ => None
| YES' sh rsh k _ => Some (readable_part rsh,k)
| PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
end.
Definition ghost (PRED : Type) : Type :=
list (option ({g: Ghost & {a: @G g | ghost.valid a}} * fpreds PRED)%type).
Definition ghost_fmap (A B:Type) (f:A->B) (g:B->A)(x:ghost A) : ghost B :=
fmap (flist (foption (fpair (fconst _) fpreds))) f g x.
Definition f_ghost : functor := Functor ff_ghost.
Instance preds_join PRED : Join _ := Join_equiv (fpreds PRED).
Inductive ghost_elem_join : Join {g: Ghost & {a: @G g | ghost.valid a}} :=
| elem_join_I g a b c va vb vc: join a b c ->
ghost_elem_join (existT _ g (exist _ a va)) (existT _ g (exist _ b vb))
(existT _ g (exist _ c vc)).
Existing Instance ghost_elem_join.
Inductive ghost_join PRED : Join (ghost PRED) :=
| ghost_join_nil_l m: ghost_join PRED nil m m
| ghost_join_nil_r m: ghost_join PRED m nil m
| ghost_join_cons a1 a2 m1 m2 a3 m3: join a1 a2 a3 -> ghost_join PRED m1 m2 m3 ->
ghost_join PRED (a1 :: m1) (a2 :: m2) (a3 :: m3).
Hint Constructors ghost_join : core.
Existing Instance ghost_join.
Instance pa_gej : @Perm_alg _ ghost_elem_join.
Instance pa_gj : forall PRED, @Perm_alg _ (ghost_join PRED).
Instance sa_gj : forall PRED, @Sep_alg _ (ghost_join PRED).
Definition pre_rmap (A:Type) := ((address -> res A) * ghost A)%type.
Definition f_pre_rmap : functor :=
fpair (ffunc (fconst address) f_res) f_ghost.
Notation Join_obj A := (Join_prod _ (Join_fun address (res A) (res_join A)) _ (ghost_join A)).
Instance Join_pre_rmap (A: Type) : Join (pre_rmap A) :=
Join_obj A.
Definition paf_pre_rmap : @pafunctor f_pre_rmap Join_pre_rmap :=
paf_pair (paf_fun address paf_res) paf_ghost.
Definition Perm_pre_rmap (A: Type): Perm_alg (pre_rmap A) :=
Perm_prod (Perm_fun address _ _ _) (pa_gj A).
Definition Sep_pre_rmap (A: Type): Sep_alg (pre_rmap A) :=
Sep_prod (Sep_fun address _ _ _) (sa_gj A).

Lemma pre_rmap_core:
forall (A : Type) (m : f_pre_rmap A),
@core (f_pre_rmap A) (Join_pre_rmap A) (Sep_pre_rmap A) m =
(@core ((fpair (ffunc (fconst address) f_res) f_ghost) A)
(Join_prod ((ffunc (fconst address) f_res) A)
(Join_pi ((fconst address) A)
(fun _ : (fconst address) A => f_res A)
(fun _ : (fconst address) A => Join_res A))
(f_ghost A) (ghost_join A))
(@Sep_prod ((ffunc (fconst address) f_res) A)
(Join_pi ((fconst address) A)
(fun _ : (fconst address) A => f_res A)
(fun _ : (fconst address) A => Join_res A))
(f_ghost A) (ghost_join A)
(Sep_pi ((fconst address) A)
(fun _ : (fconst address) A => f_res A)
(fun _ : (fconst address) A => Join_res A)
(fun _ : (fconst address) A => sa_rj A))
(sa_gj A)) m).