Module KSa := KnotHeredSa(TyFSA)(K).
Definition rmap := K.knot.
Instance Join_rmap: Join rmap := KSa.Join_knot.
Instance Perm_rmap : Perm_alg rmap:= KSa.Perm_knot.
Instance Sep_rmap : Sep_alg rmap:= KSa.Sep_knot Sep_pre_rmap.
Instance Canc_rmap : Canc_alg rmap:= KSa.Canc_knot Canc_pre_rmap.
Instance Disj_rmap : Disj_alg rmap:= KSa.Disj_knot Disj_pre_rmap.
Instance ag_rmap : ageable rmap := KSa.K.ag_knot.
Instance Age_rmap: Age_alg rmap := KSa.asa_knot.
Inductive preds : Type :=
SomeP : forall A : list Type, (listprod A -> pred rmap) -> preds.
Definition NoneP := SomeP ((Void:Type)::nil) (fun _ => FF).
Definition hair := preds.
Inductive resource : Type :=
| NO
| YES: pshare -> kind -> preds -> resource
| PURE : kind -> preds -> resource.
Definition resource2res (r: resource): res (pred rmap) :=
match r with
| NO => NO' (pred rmap)
| YES p k (SomeP A l) => YES' (pred rmap) p k (existT _ A l)
| PURE k (SomeP A l) => PURE' (pred rmap) k (existT _ A l)
end.
Definition res2resource (r: res (pred rmap)) : resource :=
match r with
| NO' => NO
| YES' p k (existT A l) => YES p k (SomeP A l)
| PURE' k (existT A l) => PURE k (SomeP A l)
end.
Instance Sep_resource: Sep_alg resource.
Instance Disj_resource: Disj_alg resource.
Definition rmap' := sig valid.
Definition preds_fmap (f:(pred rmap)->(pred rmap)) (x:preds) : preds :=
match x with SomeP A ls => SomeP A (f oo ls) end.
Definition resource_fmap (f:(pred rmap)->(pred rmap)) (x:resource) : resource :=
match x with
| NO => NO
| YES sh k p => YES sh k (preds_fmap f p)
| PURE k p => PURE k (preds_fmap f p)
end.
Definition rmap_fmap (f:(pred rmap)->(pred rmap)) (x:rmap') : rmap' :=
match x with exist m H => exist (fun m => valid m) (resource_fmap f oo m) (valid_res_map f m H) end.
Definition rmap'2pre_rmap (r: rmap') : pre_rmap (pred rmap).
destruct r as [f ?].
unfold pre_rmap.
assert (valid' _ (fun x: address => resource2res (f x))).
unfold valid'. unfold valid, compose in v.
eapply same_valid; try apply v.
intros. simpl.
destruct (f x); simpl; auto. destruct p0; simpl; auto. destruct p; simpl; auto.
eauto.
Defined.
Definition pre_rmap2rmap' (r: pre_rmap (pred rmap)) : rmap'.
destruct r as [f ?].
unfold rmap', valid' in *.
assert (valid (fun l: address => res2resource (f l))).
unfold valid, compose.
replace (fun l : address => res_option (res2resource (f l))) with (fun l : address => SM.res_option (pred rmap) (f l)); auto.
extensionality l. rewrite res_option_rewrite.
unfold compose; simpl. rewrite res2resource2res. auto.
eauto.
Defined.
Program Definition p2p (p:(pred rmap)) : K.predicate :=
fun phi_e => p (fst phi_e).
Next Obligation.
destruct a as [a b]; destruct a' as [a' b'].
unfold age, age1 in H. simpl in H. invSome. simpl in *.
eapply pred_hereditary; eauto.
Qed.
Program Definition p2p' (p:K.predicate) : (pred rmap) :=
fun (v:rmap) => p (v, tt).
Next Obligation.
unfold age in H; simpl in H.
unfold rmap in *.
eapply pred_hereditary; eauto.
unfold age, age1; simpl.
unfold ag_rmap in H. rewrite H. auto.
Qed.
Definition squash (n_rm:nat * rmap') : rmap :=
match n_rm with (n,rm) => K.squash (n, fmap p2p (rmap'2pre_rmap rm)) end.
Definition unsquash (phi:rmap) : (nat * rmap') :=
match K.unsquash phi with (n,rm) => (n, pre_rmap2rmap' (fmap p2p' rm)) end.
Definition rmap_level (phi:rmap) : nat := fst (unsquash phi).
Definition resource_at (phi:rmap) : address -> resource := proj1_sig (snd (unsquash phi)).
Infix "@" := resource_at (at level 50, no associativity).
Program Definition approx (n:nat) (p: (pred rmap)) : (pred rmap) :=
fun w => level w < n /\ p w.
Next Obligation.
destruct H0.
split.
apply age_level in H.
simpl in *. omega.
apply pred_hereditary with a; auto.
Qed.

Lemma unsquash_squash : forall n rm, (unsquash (squash (n,rm))) = (n,rmap_fmap (approx n) rm).