Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq fintype finfun finset.
Require Import rels heaps path.
Set Implicit Arguments.
Unset Strict Implicit. 
Unset Printing Implicit Defensive. 

Ltac add_morphism_tactic := SetoidTactics.add_morphism_tactic.
Notation " R ===> R' " := (@Morphisms.respectful _ _ R R')
  (right associativity, at level 55) : signature_scope.

Definition star (p1 p2 : Pred heap) : Pred heap :=
  [Pred h | exists h1, exists h2, h = h1 :+ h2 /\ h1 \In p1 /\ h2 \In p2].

Definition emp : Pred heap := [Pred i | i = empty].
Definition this i : Pred heap := [Pred h : heap | i = h].
Definition ppts A x (v : A) : Pred heap := [Pred h | locked x :-> v = h].
Definition top : Pred heap := PredT. 

Notation "p1 '#' p2" := (star p1 p2) 
  (at level 57, right associativity) : rel_scope.
Notation "x ':-->' v" := (ppts x v) (at level 50) : rel_scope.

Add Parametric Morphism : star with signature 
  @EqPred _ ===> @EqPred _ ===> @EqPred _ as star_morph. 
Proof.
by move=>p1 q1 H1 p2 q2 H2 h /=; split; case=>h1 [h2][->][H3] H4; 
exists h1; exists h2; [rewrite -H1 -H2 | rewrite H1 H2].
Qed.

Definition Def (p : Pred heap) := forall h, h \In p -> def h. 

Section BasicProperties.

Lemma starC p1 p2 : p1 # p2 <~> p2 # p1.
Proof. 
move=>h /=; split; case=>h1 [h2][->][H1] H2;
by exists h2; exists h1; rewrite unC.
Qed.

Lemma starp0 p : p # emp <~> p.
Proof.
move=>h /=; split; first by case=>h1 [h2][->][H1][->]; rewrite unh0.
by move=>H1; exists h; exists empty; rewrite unh0.
Qed.

Lemma star0p p : emp # p <~> p.
Proof. by rewrite starC starp0. Qed.

Lemma starCA p1 p2 p3 : p1 # p2 # p3 <~> p2 # p1 # p3.
Proof.
move=>h; split; case=>h1 [_][->][H1][h2][h3][->][H2] H3 /=; 
by rewrite unCA; do !esplit.
Qed.

Lemma starA p1 p2 p3 : (p1 # p2) # p3 <~> p1 # p2 # p3.
Proof. by rewrite (starC p2) starCA starC. Qed.

Lemma starAC p1 p2 p3 : (p1 # p2) # p3 <~> (p1 # p3) # p2.
Proof. by rewrite -2!(starC p3) starA. Qed.

End BasicProperties.

(* Two heaps agree if they are subset of a common heap *)

Definition agree h1 h2 := exists h1', exists h2', def (h1 :+ h1') /\ h1 :+ h1' = h2 :+ h2'. 

Lemma agree_refl h : def h -> agree h h.
Proof. by move=>D; exists empty; exists empty; rewrite unh0. Qed.

Hint Resolve agree_refl.  

Lemma agreeC h1 h2 : agree h1 h2 <-> agree h2 h1.
Proof. by split; move=>[h1'][h2'][D] E; exists h2'; exists h1'; rewrite -E. Qed.
      
Lemma agreehUnl t2 h t1 : agree h (t1 :+ t2) -> agree h t1. 
Proof. by move=>[h1'][h2'][D] E; exists h1'; exists (t2 :+ h2'); rewrite unA. Qed.

Lemma agreehUnr t1 h t2 : agree h (t1 :+ t2) -> agree h t2.
Proof. by rewrite unC; move/agreehUnl. Qed.

Lemma agreeUnhl t2 h t1 : agree (t1 :+ t2) h -> agree t1 h.
Proof. by rewrite !(agreeC _ h); move/agreehUnl. Qed.

Lemma agreeUnhr t1 h t2 : agree (t1 :+ t2) h -> agree t2 h.
Proof. by rewrite !(agreeC _ h); move/agreehUnr. Qed.

Lemma agreeUnK t2 h2 t1 h1 : agree (t1 :+ t2) (h1 :+ h2) -> agree t1 h1.
Proof. by move/agreeUnhl; move/agreehUnl. Qed.

Lemma agreeKUn t1 h1 t2 h2 : agree (t1 :+ t2) (h1 :+ h2) -> agree t2 h2.
Proof. by move/agreeUnhr; move/agreehUnr. Qed.

(* Invertibility *)

Section Invertibility.
Variables (A : Type) (F : A -> Pred heap).
 
Definition invertible := 
  forall x1 x2 h1 h2, h1 \In F x1 -> h2 \In F x2 -> agree h1 h2 -> 
                        x1 = x2 /\ h1 = h2.

Definition invert := forall x1 x2 h, h \In F x1 -> h \In F x2 -> x1 = x2.

Definition proper (R : Pred heap) := forall h, h \In R -> def h.

Lemma iinv : invertible -> (forall x, proper (F x)) -> invert.
Proof.
move=>H P x1 x2 h H1 H2.
by case: (H _ _ _ _ H1 H2 (agree_refl (P x1 h H1))).
Qed.
End Invertibility.  

(* SepIter over a finite set, and partitioning *)

(* Iteration over sequences *)
Module Iter.
Section General.
Variable A : Type.

Fixpoint iter (s : seq A) (f : A -> heap) {struct s} : heap :=
  if s is x::s' then f x :+ (iter s' f) else empty.

Fixpoint sepit (s : seq A) (f : A -> Pred heap) {struct s} : Pred heap :=
  if s is x::s' then f x # (sepit s' f) else emp.

Lemma it0 f : iter [::] f = empty.
Proof. by []. Qed.

Lemma it_cons x s f : iter (x::s) f = f x :+ iter s f.
Proof. by []. Qed.

Lemma it_cat s1 s2 f : iter (s1 ++ s2) f = iter s1 f :+ iter s2 f.
Proof.
elim: s1; first by rewrite un0h.
by move=> x s1 IH /=; rewrite IH unA.
Qed.

Lemma it_add_last s x f : iter (rcons s x) f = iter s f :+ f x.
Proof.
elim: s=>/=; first by rewrite unh0 un0h. 
by move=> y s IH; rewrite IH unA.
Qed.

Lemma sepit0 f : sepit [::] f = emp. Proof. by []. Qed.

Lemma sepit_cons x s f : sepit (x::s) f = f x # (sepit s f).
Proof. by []. Qed.

Lemma has_takedrop (p : pred A) (s : seq A) x :
        has p s ->
          s = take (find p s) s ++ [::nth x s (find p s)] ++ drop (find p s).+1 s.
Proof.
move=>H.
set i := find p s.
have L1 : i < size s by rewrite /i -has_find.
rewrite -{1}(cat_take_drop i s).
by rewrite (drop_nth x).
Qed.
End General.

Section EqualityTp.

Variable (A : eqType).

Lemma filter_predU p (s : seq A) : 
        s =i filter p s ++ filter (predC p) s.
Proof.
move=>x.
rewrite -{1}(filter_predT s).
rewrite mem_cat !mem_filter /=.
case E: (p x)=>//=.
by rewrite orbF.
Qed.

Lemma sepit_inv (s : seq A) f1 f2 h1 h2 : 
        h1 \In sepit s f1 -> h2 \In sepit s f2 -> agree h1 h2 ->
        (forall k h1 h2, k \in s -> h1 \In f1 k -> h2 \In f2 k -> agree h1 h2 -> h1 = h2) ->
        h1 = h2.
Proof.
elim: s h1 h2=>[|x s IH] h1 h2/=; first by case=>->->.
move=>[r1][t1][->][H1] D1[r2][t2][->][H2] D2 L H.
have S : x \in x :: s. by rewrite inE eq_refl.
rewrite (H x r1 r2 S H1 H2 (agreeUnK L)); heap_congr.
apply: (IH _ _ _ _ (agreeKUn L))=>// k h3 h4 E.
by apply: H; rewrite inE E orbT.
Qed.

End EqualityTp.

End Iter.

