Require Import Decidable.

Require Import Predicate DemonicComposition DemonicJoin Specification Statement LeastFixpoint Predicative.

Open Scope stmt_scope.

Definition old_pred { T V : Type } := @pred T V.

Fixpoint  pred_seq { T U V: Type } (C : @Stmt T U) (spec : U >> V)
: T >> V :=
  match C in (@Stmt _ UU) return (forall (spec : UU >> V), T >> V) with
  | Void => fun spec s s' => False
  | Assignment effect => fun spec (s : T) (s' : V) => spec (effect s) s'
  | Seq cb ca => fun spec => pred_seq cb (pred_seq ca spec)
  | If p ct cf => fun spec s s' => (p s /\ pred_seq ct spec s s') \/ (~ p s /\ pred_seq cf spec s s')
  | While p cw => fun spec => (while p (pred_seq cw (fun s s' => s = s'))) ⊟ spec
  | Spec call_spec => fun spec => call_spec ⊟ spec
  | WWhen p Then cw End => fun spec s s' => (p s /\ pred_seq cw spec s s')
  | c1 ⫾ c2 => fun spec => (pred_seq c1 spec) ⊔ (pred_seq c2 spec)
  end spec.

Fixpoint pred_opt { T V : Type } (C : @Stmt T V) : T >> V :=
  match C with
  | Void => fun s s' => False
  | Assignment effect => fun s s' => effect s = s'
  | Seq c1 c2 => pred_seq c1 (pred_opt c2)
  | If p ct cf => fun s s' => (p s /\ pred_opt ct s s') \/ (~ p s /\ pred_opt cf s s')
  | While p c => while p (pred_opt c)
  | Spec spec => spec
  | WWhen p Then cw End => fun s s' => (p s /\ pred_opt cw s s')
  | c1 ⫾ c2 => (pred_opt c1) ⊔ (pred_opt c2)
  end.

Lemma pred_opt_pred_seq : forall { T U : Type } (c1 : @Stmt T U) V (c2 : @Stmt U V) s s',
    pred_seq c1 (pred_opt c2) s s' <-> ((pred_opt c1) ⊟ (pred_opt c2)) s s'.
Proof.
  intros T U c1.
  induction c1 as [ | T U effect | T U1 U2 cc1 IHcc1 cc2 IHcc2 | T U p ct IHct cf IHcf | T p cw IHcw | T call_spec | | ]; simpl.
 { intros c2 s s'; split; intros HH.
    { contradiction. }
    { destruct HH as [[sx [HH _]] _ ]; auto. }
  }
  { intros V c2 s s';  split; intros HH.
    { split.
      { exists (effect s); auto. }
      { intros sx HH1; subst sx; eauto. }
    }
    { destruct HH as [[sx [HHeql HHpred]] HH]; rewrite HHeql; exact HHpred. }
  }
  { intros V c2 s s'.
    rewrite (DemonicComposition.left_extensionality _ _ _ (IHcc1 _ _)).
    rewrite (IHcc1 _ (Statement.Seq cc2 c2)); simpl.
    rewrite (DemonicComposition.right_extensionality _ _ _ (IHcc2 _ _)).
    split; intros HH; apply DemonicComposition.assoc; auto.
  }
  { intros V c2 s s'; rewrite (IHcf _ _), (IHct _ _).
    split.
    { intros [ [HH1 [[sx [HH2 HH3]] HH4]] | [HH1 [[sx [HH2 HH3]] HH4]] ].
      { split; firstorder. }
      { split.
        { exists sx; split; auto. }
        { firstorder. }
      }
    }
    { intros [[sx [[[HH1 HH2] | [HH1 HH2]] HH3]] HH4].
      { left; split; auto; split; firstorder. }
      { right; split; auto; split; firstorder. }
    }
  }
  { intros V c2 s s'; apply DemonicComposition.left_extensionality.
    intros r r'. apply while_extensionality.
    { reflexivity. }
    { clear s s' r r'; intros.
      rewrite (IHcw _ (Spec (fun s s' => s = s'))); simpl.
      rewrite DemonicComposition.right_identity_neutrality.
      reflexivity.
    }
  }
  { reflexivity. }
  { intros; rewrite IHc1; simpl.
    firstorder.
  }
  { intros.
    rewrite DemonicComposition.ldistr_join.
    apply DemonicJoin.ext; auto.
  }
Qed.

Theorem pred_opt_IFF_old_pred : forall { T V : Type } (c : @Stmt T V) s s', old_pred c s s' <-> pred_opt c s s'.
Proof.
  induction c as [ | T U effect | T U1 U2 c1 IHc1 c2 IHc2 | T U p ct IHct cf IHcf | T p cw IHcw | T call_spec | | ]
  ; simpl; try reflexivity.
  { intros s s'; split; intros HHpred.
    { destruct HHpred as [[sx [HHpred1 HHpred2]] HHpred3].
      apply pred_opt_pred_seq; split.
      { exists sx; split; firstorder. }
      { intros sy HH1.
        rewrite <- (IHc1 _) in HH1.
        destruct (HHpred3 _ HH1) as (sy',HH2).
        exists sy'; apply IHc2; auto.
      }
    }
    { apply pred_opt_pred_seq in HHpred.
      apply (DemonicComposition.extensionality _ _ _ _ IHc1 IHc2); auto.
    }
  }
  { intros s s'; rewrite IHct,IHcf; reflexivity. }
  { apply while_extensionality; auto; reflexivity. }
  { intros; rewrite IHc; firstorder. }
  { intros; apply DemonicJoin.ext; auto. }
Qed.

Definition old_while { T : Type } := @Predicative.while T.

Definition while { T : Type } (C : @Predicate T) P := lfp (fun X s s' => (C s /\ pred_seq P X s s') \/ (~ C s /\ s = s')).

Theorem old_while_while : forall { T : Type } (C : @Predicate T) P s s', old_while C (pred_opt P) s s' <-> while C P s s'.
Proof.
  intros S C P s s'.
  unfold old_while,while,while_functional.
  apply lfp_extensionality.
  clear s s'; intros X s s'.
  rewrite (pred_opt_pred_seq _ _ (Spec X)).
  simpl.
  reflexivity.
Qed.

Fixpoint pred { T V : Type } (C : @Stmt T V) : Specification :=
  match C with
  | Void => fun s s' => False
  | Assignment effect => fun s s' => effect s = s'
  | Seq c1 c2 => pred_seq c1 (pred_opt c2)
  | If p ct cf => fun s s' => (p s /\ pred_opt ct s s') \/ (~ p s /\ pred_opt cf s s')
  | While p c => while p c
  | Spec spec => spec
  | WWhen p Then cw End => fun s s' => (p s /\ pred_opt cw s s')
  | c1 ⫾ c2 => (pred_opt c1) ⊔ (pred_opt c2)
  end.

Lemma pred_pred_opt : forall { T V : Type } (C : @Stmt T V), forall s s', pred C s s' <-> pred_opt C s s'.
Proof.
  intros T V C s s'.
  destruct C; simpl in *; try reflexivity.
  rewrite old_while_while.
  reflexivity.
Qed.

Theorem pred_old_pred : forall { T V : Type } (C : @Stmt T V), forall s s', pred C s s' <-> old_pred C s s'.
  intros T V C s s'.
  apply (iff_trans (pred_pred_opt C s s')).
  apply iff_sym.
  apply pred_opt_IFF_old_pred.
Qed.

Theorem while_end : forall (T V : Type) (C : @Predicate T) P s s', while C P s s' -> ~ C s'.
Proof.
  intros T V C P s s'.
  rewrite <- old_while_while.
  apply Predicative.while_end.
Qed.

Theorem while_destruct : forall { T : Type } (C : @Predicate T) P s s',
    while C P s s' -> (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s').
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_destruct. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_construct : forall { T : Type } (C : @Predicate T) P s s',
    (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s') -> while C P s s'.
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_construct. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_fix : forall { T : Type } (C : @Predicate T) P s s', while C P s s' <-> (C s /\ (pred_seq P (while C P)) s s') \/ (~ C s /\ s = s').
Proof.
  intros T C P s s'.
  rewrite <- old_while_while.
  rewrite (pred_opt_pred_seq P _ (Statement.Spec (while C P))); simpl.
  rewrite (DemonicComposition.extensionality (pred_opt P) (pred_opt P) (while C P) (old_while C (pred_opt P))); try reflexivity.
  { apply Predicative.while_fix. }
  { clear s s'.
    intros s s'; rewrite old_while_while; reflexivity.
  }
Qed.

Theorem while_ind : forall { T : Type } (C : @Predicate T) P X s s',
    while C P s s' -> (forall s s', ((C s /\ (pred_seq P X) s s') \/ (~ C s /\ s = s')) -> X s s') -> X s s'.
Proof.
  intros T C P X s s' HHwhile HH.
  eapply (f_lfp _ _ _ _ _ HHwhile).
  Unshelve.
  auto.
Qed.

Theorem ex_while_ind : forall { T : Type } (C : @Predicate T) P (X : Predicate) s,
    (exists s', while C P s s') -> (forall s, ((C s /\ (forall sx, (pred P s sx -> X sx)) \/ (~ C s)) -> X s)) -> X s.
Proof.
  intros T C P X s (s',HHwhile).
  pattern s,s'; apply HHwhile.
  intros.
  apply H0.
  destruct H.
  { destruct H. left; split; auto.
    rewrite (pred_opt_pred_seq
               P _ (Statement.Spec (fun s _ : T => (forall s1 : T, C s1 /\ (forall sx : T, pred P s1 sx -> X sx) \/ ~ C s1 -> X s1) -> X s))) in H1.
    destruct H1.
    intros.
    rewrite pred_pred_opt in H3.
    destruct (H2 _ H3).
    apply H4.
    auto.
  }
  { right; firstorder. }
Qed.

Theorem while_well_founded : forall { T : Type } (p : @Predicate T) C,
    well_founded (fun s s' => p s' /\ (pred C) s' s /\ (exists r, (while p C) s' r)).
Proof.
  intros T p C.
  constructor.
  intros y [HHp [HHpred HHwhile]].
  generalize y HHp HHpred; clear y HHp HHpred.
  pattern a; apply (ex_while_ind _ _ _ _ HHwhile).
  intros.
  destruct H; try contradiction.
  destruct H.
  constructor; intros.
  destruct H1.
  destruct H2.
  apply (H0 y); auto.
Qed.

Lemma wfd_prefix_while : forall { T : Type } (C : @Predicate T) P (K : Specification),
    well_founded (fun s s' => C s' /\ pred P s' s)
    -> (forall s s', K s s' -> ((C s /\ pred_seq P K s s') \/ (~ C s /\ s = s')))
    -> forall s s', K s s' -> while C P s s'.
Proof.
  intros T C P K HHwfd HHT1 s.
  pattern s; apply (well_founded_ind HHwfd).
  intros sx HH s' HHT.
  pose proof (HHT1 _ _ HHT).
  rewrite (pred_opt_pred_seq _ _ (Statement.Spec K)) in H.
  destruct H as [(HHc,((sy,(HH11,HH12)),HH13)) | HH2]; simpl in *.
  { apply while_construct; left; split; auto.
    rewrite (pred_opt_pred_seq _ _ (Statement.Spec (while C P))).
    split; simpl; auto.
    { exists sy; split; auto.
      apply HH; auto; split; auto.
      apply pred_pred_opt; auto.
    }
    { intros sz HHp2.
      pose proof (HH13 _ HHp2) as (sz',HHT2).
      exists sz'.
      apply HH; auto; split; auto.
      apply pred_pred_opt; auto.
    }
  }
  { apply while_construct; right; auto. }
Qed.

Theorem wfd_fix_while : forall { T : Type } (C : @Predicate T) P (K : Specification),
    well_founded (fun s s' => C s' /\ pred P s' s)
    -> (forall s s', K s s' <-> ((C s /\ pred_seq P K s s') \/ (~ C s /\ s = s')))
    -> forall s s', while C P s s' <-> K s s'.
Proof.
  intros T C P K HHwfd HHT s s'.
  split.
  { intros HHwhile.
    apply (while_ind _ _ _ _ _ HHwhile).
    apply HHT.
  }
  { apply wfd_prefix_while; auto.
    apply HHT.
  }
Qed.

Theorem while_extensionality :
  forall { T : Type } (C1 : @Predicate T) P1 C2 P2,
    (forall s, C1 s <-> C2 s) -> (forall s s', pred P1 s s' <-> pred P2 s s') -> forall s s', while C1 P1 s s' <-> while C2 P2 s s'.
Proof.
  intros T C1 P1 C2 P2 HHequiv1 HHequiv2 s s'.
  assert ( forall s s' : T, pred_opt P1 s s' <-> pred_opt P2 s s') as HHequiv2'.
  { clear HHequiv1 s s'.
    intros s s'.
    repeat rewrite <- pred_pred_opt.
    auto.
  }
  clear HHequiv2.
  unfold while.
  apply lfp_extensionality.
  clear s s'.
  unfold while_functional.
  intros X s s'.
  rewrite HHequiv1.
  repeat rewrite (pred_opt_pred_seq _ _ (Statement.Spec X)).
  rewrite (DemonicComposition.left_extensionality _ _ _ HHequiv2').
  reflexivity.
Qed.

Definition old_refines { T V : Type } := @refines T V.

Definition refines { T V : Type } (S1 S2 : @Stmt T V) :=
  forall s, (exists s', pred S2 s s') -> (forall s', pred S1 s s' -> pred S2 s s') /\ (exists s', pred S1 s s').

Lemma refines_old_refines : forall T V (C1 C2 : @Stmt T V), old_refines C1 C2 <-> refines C1 C2.
Proof.
  unfold old_refines, refines.
  intros S C1 C2.
  split; intros HHrefines.
  { intros s (t',HHc2).
    apply pred_old_pred in HHc2.
    destruct (HHrefines _ (ex_intro _ _ HHc2)) as (HHc1c2,(u',HHc1)).
    split.
    { intros s'; repeat rewrite pred_old_pred; apply HHc1c2. }
    { exists u'; rewrite pred_old_pred; exact HHc1. }
  }
  { intros s (t',HHc2).
    apply pred_old_pred in HHc2.
    destruct (HHrefines _ (ex_intro _ _ HHc2)) as (HHc1c2,(u',HHc1)).
    split.
    { intros s'; repeat rewrite <- pred_old_pred; apply HHc1c2. }
    { exists u'; rewrite <- pred_old_pred; exact HHc1. }
  }
Qed.

Notation "C1 ⊑ C2" := (refines C1 C2) (at level 60, format "C1  ⊑  C2").

Theorem if_extensionality :
  forall { T : Type } (C1 : @Predicate T) (P1 : @Stmt T T) C2 (P2 : @Stmt T T),
    (forall s, C1 s <-> C2 s) -> (forall s s', pred P1 s s' <-> pred P2 s s') -> forall s s', pred (IIf C1 Then P1 End) s s' <-> pred (IIf C2 Then P2 End) s s'.

Proof.
  intros T C1 P1 C2 P2 HHequiv1 HHequiv2 s s'.
  simpl. repeat rewrite <- pred_pred_opt.
  rewrite HHequiv1,HHequiv2.
  reflexivity.
Qed.

Theorem wfd_while_iff_if : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> forall s s', while C P s s' <-> pred (IIf C Then P End) s s' /\ ~ C s'.
Proof.
  intros T C P HHwfd HHrefines s s'.
  rewrite <- old_while_while.
  rewrite <- (Predicative.while_extensionality C (pred P) C (pred_opt P)); try reflexivity.
  { rewrite <- (if_extensionality C ⟨pred P⟩ C ); try reflexivity.
    apply Predicative.wfd_while_iff_if; auto.
  }
  { apply pred_pred_opt. }
Qed.

Theorem wfd_while_iff_if' : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (forall s s', C s /\ pred P s s' ->
               (forall sx, (C s' /\ pred P s' sx \/ ~ C s' /\ s' = sx) -> pred P s sx)
               /\ (C s' /\ (exists sx, pred P s' sx) \/ ~ C s'))
    -> forall s s', while C P s s' <-> pred (IIf C Then P End) s s' /\ ~ C s'.
Proof.
  intros T C P HHwfd HHrefines s s'.
  rewrite <- old_while_while.
  rewrite <- (Predicative.while_extensionality C (pred P) C (pred_opt P)); try reflexivity.
  { rewrite <- (if_extensionality C ⟨pred P⟩ C ); try reflexivity.
    apply Predicative.wfd_while_iff_if'; simpl; auto; apply HHrefines.
  }
  { apply pred_pred_opt. }
Qed.

Theorem wfd_while_refines_if : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> WWhile C Do P Done ⊑ IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    clear.
    firstorder.
  }
  { exists s''.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    destruct HHtrm.
    { firstorder. }
    { destruct H; subst s''; firstorder. }
  }
Qed.

Theorem wfd_while_refines_if' : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (forall s s', C s /\ pred P s s' ->
               (forall sx, (C s' /\ pred P s' sx \/ ~ C s' /\ s' = sx) -> pred P s sx)
               /\ (C s' /\ (exists sx, pred P s' sx) \/ ~ C s'))
    -> WWhile C Do P Done ⊑ IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if' _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    clear.
    firstorder.
  }
  { exists s''.
    rewrite (wfd_while_iff_if' _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    destruct HHtrm.
    { firstorder. }
    { destruct H; subst s''; firstorder. }
  }
Qed.

Theorem if_refines_wfd_while : forall { T : Type } (C : @Predicate T) P,
    well_founded (fun s s' => C s' /\ pred P s' s /\ C s)
    -> (⟨fun s s' => C s /\ pred P s s'⟩;⟨fun s s' => C s /\ pred P s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred P s s'⟩
    -> IIf C Then ⟨fun s s' => pred P s s' /\ ~ C s'⟩ End ⊑ WWhile C Do P Done.
Proof.
  intros * HHwfd HHrefines.
  unfold refines; simpl.
  intros * (s'',HHtrm).
  split.
  { intros s'.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines).
    simpl.
    rewrite <- pred_pred_opt.
    intros [HHpred | HHskip].
    { firstorder. }
    { destruct HHskip; subst s'.
      clear - H.
      firstorder.
    }
  }
  { exists s''.
    rewrite (wfd_while_iff_if _ _ HHwfd HHrefines) in HHtrm.
    simpl in HHtrm.
    rewrite <- pred_pred_opt in HHtrm.
    destruct HHtrm as ([ HHtrm | (HHc,HHeq) ], HHc').
    { firstorder. }
    { subst s''; firstorder. }
  }
Qed.

Require Import Wfd.

Theorem while_rule_sound_and_complete : forall { T : Type } (C : @Predicate T) P R,
    WWhile C Do P Done ⊑ R
    <-> exists K, P ⊑ K
           /\ well_founded (fun s s' => C s' /\ pred K s' s /\ C s)
           /\ (⟨fun s s' => C s /\ pred K s s'⟩;⟨fun s s' => C s /\ pred K s s' \/ ~ C s /\ s = s'⟩) ⊑ ⟨fun s s' => C s /\ pred K s s'⟩
           /\ IIf C Then ⟨fun s s' => pred K s s' /\ ~ C s'⟩ End ⊑ R.
Proof.
  intros *.
  repeat setoid_rewrite <- refines_old_refines.
  split; intros.
  { apply while_rule_sound_and_complete in H.
    unfold old_refines in *; simpl.
    destruct H as (K,(H1,(H2,(H3,H4)))).
    exists K.
    split.
    { auto. }
    { split.
      { apply (Wfd.by_inclusion _ _ _ H2).
        setoid_rewrite pred_old_pred; unfold old_pred; simpl.
        auto.
      }
      { unfold Predicative.refines in *; simpl in *.
        unfold DemonicComposition.fn in *.
        repeat setoid_rewrite (pred_old_pred K); unfold old_pred.
        auto.
      }
    }
  }
  { apply while_rule_sound_and_complete.
    unfold old_refines in *; simpl.
    destruct H as (K,(H1,(H2,H3))).
    exists K.
    split; auto.
    { split.
      { apply (Wfd.by_inclusion _ _ _ H2).
        setoid_rewrite pred_old_pred; unfold old_pred; simpl.
        auto.
      }
      { unfold Predicative.refines in *; simpl in *.
        unfold DemonicComposition.fn in *.
        repeat setoid_rewrite (pred_old_pred K) in H3; unfold old_pred.
        auto.
      }
    }
  }
Qed.

Theorem refines_reflexive : forall (T V : Type)  (P : @Stmt T V), refines P P.
Proof.
  intros T V P.
  rewrite <- refines_old_refines.
  apply refines_reflexive.
Qed.

Theorem refines_trans : forall (T V : Type)  (P Q R : @Stmt T V), refines P Q -> refines Q R -> refines P R.
Proof.
  intros T V P Q R.
  repeat rewrite <- refines_old_refines.
  apply refines_trans.
Qed.

Theorem Seq_left_monotonic_refines :
  forall (T U V : Type) (P1 P2 : @Stmt T U) (Q : @Stmt U V), refines P1 P2 -> refines (Seq P1 Q) (Seq P2 Q).
Proof.
  intros T U V P1 P2 Q.
  repeat rewrite <- refines_old_refines.
  apply Seq_left_monotonic_refines.
Qed.

Theorem Seq_right_monotonic_refines :
  forall (T U V : Type) (P : @Stmt T U) (Q1 Q2 : @Stmt U V), refines Q1 Q2 -> refines (Seq P Q1) (Seq P Q2).
Proof.
  intros T U V P Q1 Q2.
  repeat rewrite <- refines_old_refines.
  apply Seq_right_monotonic_refines.
Qed.

Theorem Seq_monotonic_refines :
  forall (T U V : Type) (P1 : @Stmt T U) (P2 : @Stmt U V) (Q1 : @Stmt T U) (Q2 : @Stmt U V),
    refines P1 Q1
    -> refines P2 Q2
    -> refines (Seq P1 P2) (Seq Q1 Q2).
Proof.
  intros T U V P1 P2 Q1 Q2.
  repeat rewrite <- refines_old_refines.
  apply Seq_monotonic_refines.
Qed.

Theorem If_monotonic_refines :
  forall (T V : Type) C (Pt Qt Pf Qf : @Stmt T V),
    refines Pt Qt
    -> refines Pf Qf
    -> refines (If C Pt Pf) (If C Qt Qf).
Proof.
  intros T V C Pt Pf Qt Qf.
  repeat rewrite <- refines_old_refines.
  apply If_monotonic_refines.
Qed.

Theorem When_monotonic_refines :
  forall (T V : Type) C (P Q : @Stmt T V),
    refines P Q
    -> refines (WWhen C Then P End) (WWhen C Then Q End).
Proof.
  intros T V C P Q.
  repeat rewrite <- refines_old_refines.
  apply When_monotonic_refines.
Qed.

Theorem Choice_left_monotonic_refines :
  forall (T V : Type) (P1 P2 : @Stmt T V) (Q : @Stmt T V), refines P1 P2 -> refines (P1 ⫾ Q) (P2 ⫾ Q).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_left_monotonic_refines.
Qed.

Theorem Choice_right_monotonic_refines :
  forall (T V : Type) (P : @Stmt T V) (Q1 Q2 : @Stmt T V), refines Q1 Q2 -> refines (P ⫾ Q1) (P ⫾ Q2).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_right_monotonic_refines.
Qed.

Theorem Choice_monotonic_refines :
  forall (T V : Type) (P1 Q1 : @Stmt T V) (P2 Q2 : @Stmt T V),
    refines P1 Q1
    -> refines P2 Q2
    -> refines (P1 ⫾ P2) (Q1 ⫾ Q2).
Proof.
  intros *; repeat rewrite <- refines_old_refines.
  apply Choice_monotonic_refines.
Qed.

Theorem While_monotonic_refines :
  forall (T : Type) C (P Q : @Stmt T T),
    refines P Q
    -> refines (While C P) (While C Q).
Proof.
  intros T C P Q.
  repeat rewrite <- refines_old_refines.
  apply While_monotonic_refines.
Qed.

Theorem refines_extensionality_left : forall T V (P1 P2 Q : @Stmt T V), (forall s s', (pred P1) s s' <-> (pred P2) s s') -> refines P1 Q <-> refines P2 Q.
Proof.
  intros T V P1 P2 Q HHequiv.
  unfold refines; split.
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite <- HHequiv; apply (HHsnd _ HHq). }
    { destruct (HHsnd _ HHq) as (_,(s',HHp1)); exists s'; rewrite <- HHequiv; exact HHp1. }
  }
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite HHequiv; apply (HHsnd _ HHq). }
    { destruct (HHsnd _ HHq) as (_,(s',HHp2)); exists s'; rewrite HHequiv; exact HHp2. }
  }
Qed.

Theorem refines_extensionality_right : forall T V (P Q1 Q2 : @Stmt T V), (forall s s', (pred Q1) s s' <-> (pred Q2) s s') -> refines P Q1 <-> refines P Q2.
Proof.
  intros T V P Q1 Q2 HHequiv.
  unfold refines; split.
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite <- HHequiv; apply HHsnd.
      setoid_rewrite HHequiv; auto.
    }
    { apply HHsnd.
      setoid_rewrite HHequiv; auto.
    }
  }
  { intros HHsnd s HHq.
    split.
    { intros s''; rewrite HHequiv; apply HHsnd.
      setoid_rewrite <- HHequiv; auto.
    }
    { apply HHsnd; setoid_rewrite <- HHequiv; exact HHq. }
  }
Qed.

Theorem refines_extensionality : forall T V (P1 P2 Q1 Q2 : @Stmt T V),
    (forall s s', (pred P1) s s' <-> (pred P2) s s')
    -> (forall s s', (pred Q1) s s' <-> (pred Q2) s s')
    -> refines P1 Q1 <-> refines P2 Q2.
Proof.
  intros.
  assert (refines P1 Q1 <-> refines P1 Q2).
  { apply refines_extensionality_right; auto. }
  rewrite H1.
  apply refines_extensionality_left; auto.
Qed.

Close Scope stmt_scope.


Require Import Bauer.
Require Import List.
Require Import MSets Arith.
Require Import Coq.omega.Omega.
Require Import synth.

Import ListNotations.

(* We can make a set out of an ordered type *)

Definition instance := Graph.
Definition solution := S.t.

Definition metric := nat.
Definition eval := S.cardinal.
Definition better (m1 m2 : metric) := negb (m1 <? m2).

Definition verifier (I : instance) (S : solution) :=
S.For_all (fun v1 => S.For_all (fun v2 => ~ is_some (I v1 v2)) S) S.

Definition checker (I : instance) (S : solution) :=
S.for_all (fun v1 => S.for_all (fun v2 => negb (is_someb (E I v1 v2))) S) S.

Definition gen_space := fun I => all_subset (V I).

Definition max_Is_brute_force := synthesize instance solution metric checker eval better gen_space.

Compute S.elements (match max_Is_brute_force (K 10) with | None => S.empty | Some s => s end).

Definition algorithm f := forall (I : instance) (Sol Cand : solution),
  (f I = Some Sol -> verifier I Sol /\ ((verifier I Cand) -> better Sol Cand))
/\
  (f I = None -> ~exists Cand', verifier I Cand').

Check SF.for_all_1.
Print Proper.

Lemma vc_reflect : forall I Sol, reflect (verifier I Sol) (checker I Sol).
Proof.
intros.
apply iff_reflect. split.
- intros. unfold verifier in H. unfold checker.
Admitted.

Search reflect.

Lemma list_max_aux : forall {X : Type} f l (d : X),  In (list_max f (d::l) d) (d::l).
Proof.
intros. induction l.
- simpl. left. destruct (f d d). reflexivity. reflexivity.
- simpl. inversion IHl. destruct (f d d) eqn:h.
  + destruct (f d a) eqn:e.
    * right. left. simpl in H. rewrite h in H.
Qed.

Lemma list_max_aux2 : forall {X : Type} f l (d a m : X), f d a = true -> list_max f l a = m ->
list_max f l d = m.
Proof.
induction l.
- intros. simpl. simpl in H0. rewrite <- H0.
Qed.

Check equivalence.

Search (Set -> Prop).

Definition f_refl {X : Type} f := forall x : X, f x x = true.
Definition f_trans {X : Type} f := forall x y z : X, f x y = true -> f y z = true -> f x z = true.

Definition f_preorder {X : Type} (f : X -> X -> bool) := (f_refl f) /\ (f_trans f).

Lemma list_max_In : forall {X : Type} f l (d : X),
In (list_max f l d) (d::l).
Proof.
intros. generalize dependent d. induction l.
- simpl. left. reflexivity.
- intros. simpl. destruct (f d a) eqn:e.
  + simpl in IHl. pose (IHl a). inversion o.
    * right. left. exact H.
    * right. right. exact H.
  + simpl in IHl. pose (IHl d). inversion o.
    * left. exact H.
    * right. right. exact H.
Qed.

Lemma list_max_max : forall {X : Type} f l (d a : X), In a (d::l) ->
f a (list_max f l d) = true.
Proof.
Admitted.

Lemma all_subset_In : forall (I : instance) (S : solution), verifier I S -> In S (all_subset I).
Proof.
Admitted.

Check Nat.ltb_lt.

Theorem correct : algorithm brute_force.
Proof.
unfold algorithm.
split.
- intros. split.
  + unfold brute_force in H.
    destruct (map (fun iset : S.t => (metric iset, iset))
           (filter (checker I)
              (all_subset I))) eqn:e.
    * inversion H.
    * inversion H. assert (forall rs, In rs
    (map (fun iset : S.t => (metric iset, iset))
      (filter (checker I )
         (all_subset I))) -> verifier I (snd rs)).
    { intros. apply in_map_iff in H0. inversion H0. inversion H2. inversion H3.
      apply filter_In in H4. inversion H4. destruct (vc_reflect I x).
      - simpl. exact v.
      - inversion H7.
    }
    pose (list_max
          (fun e1 e2 : nat * S.t =>
           let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p).
    apply (H0 p0). rewrite e. apply list_max_In.
  + unfold brute_force in H.
     destruct (map (fun iset : S.t => (metric iset, iset))
           (filter (checker I)
              (all_subset I))) eqn:e.
    * inversion H.
    * inversion H. unfold better. intros. remember (list_max
          (fun e1 e2 : nat * S.t =>
           let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p) as m.
      assert (In (metric Cand, Cand) (p::l)).
      { pose (all_subset_In I Cand H0). Check iff. pose (filter_In (checker I) Cand (all_subset I)).
        inversion i0. destruct (vc_reflect I Cand).
        + assert (In Cand (all_subset I) /\ true = true). { split. exact i. reflexivity. }
          apply H3 in H4. pose (in_map_iff (fun iset : S.t => (metric iset, iset)) (filter (checker I) (all_subset I)) (metric Cand, Cand)).
          inversion i1. rewrite e in H6. apply H6. exists Cand. split.
          - reflexivity.
          - exact H4.
        + exfalso. unfold not in n. apply n. apply H0. }
      pose (list_max_max (fun e1 e2 : nat * S.t =>
          let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p (metric Cand, Cand)).
      apply e0 in H2. rewrite <- Heqm in H2.
      destruct m. apply Nat.ltb_lt in H2.
      assert (n = metric t). { pose (list_max_In  (fun e1 e2 : nat * S.t =>
          let (s1, _) := e1 in let (s2, _) := e2 in s1 <? s2) l p). rewrite <- Heqm in i.
      pose (in_map_iff (fun iset : S.t => (metric iset, iset)) (filter (checker I) (all_subset I)) (n,t)). inversion i0.
      rewrite e in H3. apply H3 in i. inversion i. inversion H5. inversion H6. reflexivity. }
      simpl. rewrite <- H3. unfold ge. omega.
- admit.
Qed.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe UnivalenceImpliesFunext
               TruncType UnivalenceAxiom Types.Sigma
               FunextVarieties.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Import Rlow Cpo.

(** * Open Subspaces of a hset A *)

(** The continuous maps from A to
the Sierpinski space Sier forms a classifying topos for the opens
subsets of A. In Synthetic topology, continuous maps are the
definissible ones. *)

Definition OS (A : hSet) := A -> Sier.

Global Instance OS_isset {A} : IsHSet (OS A).
Proof.
apply _.
Qed.

(** Order relation on OS *)
Global Instance Osle {A} : Le (OS A) :=
           fun O1 O2 => forall x, SierLe (O1 x) (O2 x).

(** Osle is a partial order *)
Global Instance Osle_ord {A} : PartialOrder (@Osle A).
Proof.
split.
+ apply _.
+ intros x y.
  apply _.
+ split.
  - hnf.
    intros x s; reflexivity.
  - hnf.
    intros x y z Hxy Hyz s.
    transitivity (y s); auto.
+ hnf.
  intros x y H1 H2.
  apply path_forall.
  intros s.
  apply (antisymmetry le).
  apply H1.
  apply H2.
Defined.

(** Join of open subsets *)
Global Instance OS_join {A} : Join (OS A) :=
              fun U V => fun x => SierJoin (U x) (V x).

(** Meet of open subsets *)
Global Instance OS_meet {A} : Meet (OS A) :=
              fun U V => fun x => SierMeet (U x) (V x).

(** Empty space *)
Global Instance OS_empty {A} : Zero (OS A) := fun x : A => ⊥.

(** The entire space itself *)
Global Instance OS_full {A} : One (OS A) := fun x : A => ⊤.

(** OS A is has a cpo *)
Global Instance OS_cpo {A} : cpo (OS A).
Proof.
exists (OS_empty) (fun f : (nat -> OS A) => (fun x =>
                 CountableSup (fun n => f n x))).
+ intros f n a.
  apply (countable_sup_ub (fun n => f n a)).
+ intros f x H.
  assert (HL : forall n a, SierLe (f n a) (x a)).
  apply H.
  intros a.
  apply (countable_sup_least_ub (fun n => f n a)); trivial.
  intros n.
  apply HL.
+ intros x s; unfold OS_empty; simpl.
  apply bot_least.
Defined.

(** Notations *)
Notation "U ⋂ V" := (OS_meet U V) (at level 80).
Notation "U ∪ V" := (OS_join U V) (at level 80).
Notation "∅" := (OS_empty).
Notation "U ⊆ V" := (Osle U V) (at level 90).

(** Lattice properties of the order *)
Lemma os_lattice_order  {A} : LatticeOrder (@Osle A).
Proof.
split.
+ split.
  - apply Osle_ord.
  - intros x y s.
    apply SierMeet_is_meet.
  - intros x y s.
    apply SierMeet_is_meet.
  - intros x y z H1 H2 s.
    apply SierMeet_is_meet.
    apply H1. apply H2.
+ split.
  - apply Osle_ord.
  - intros x y s.
    apply SierJoin_is_join.
  - intros x y s.
    apply SierJoin_is_join.
  - intros x y z H1 H2 s.
    apply SierJoin_is_join.
    apply H1. apply H2.
Defined.

(** Semigroup structure of OS A with sg_op = join (OS A) :
     - associative sg_op
     - OS A is a hSet *)
Global Instance os_semi_group {A} : SemiGroup (OS A).
Proof.
split.
+ apply _.
+ hnf; intros x y z.
  apply path_forall.
  intros s.
  apply (antisymmetry le);
  apply SierJoin_is_join.
  transitivity ((x & y) s);
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  transitivity ((x & y) s);
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  apply SierJoin_is_join.
  transitivity ((y & z) s);
  apply SierJoin_is_join.
  transitivity ((y & z) s);
  apply SierJoin_is_join.
Defined.

(** Lattice structure on OS *)
Global Instance os_jslattice {A} : JoinSemiLattice (OS A).
Proof.
split.
+ split.
  - apply os_semi_group.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
    apply SierJoin_is_join.
+ intros x.
  apply path_forall; intro s.
  apply (antisymmetry le);
  apply SierJoin_is_join; reflexivity.
Defined.

Global Instance os_mslattice {A}: MeetSemiLattice (OS A).
Proof.
split.
+ split.
  - split.
    apply _.
    hnf; intros x y z.
    apply path_forall.
    intros s.
    apply (antisymmetry le).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((y ⋂  z) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((y ⋂ z) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((x ⋂ y) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    transitivity ((x ⋂ y) s).
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
    apply SierMeet_is_meet.
+ intros x.
  apply path_forall; intro s.
  apply (antisymmetry le);
  apply SierMeet_is_meet; reflexivity.
Defined.

Global Instance os_lattice {A} : Lattice (OS A).
Proof.
split.
  - apply os_jslattice.
  - apply os_mslattice.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierJoin_is_join.
    reflexivity.
    apply SierMeet_is_meet.
  - red. intros x y.
    apply path_forall; intro s.
    apply (antisymmetry le);
    apply SierMeet_is_meet.
    reflexivity.
    apply SierJoin_is_join.
Defined.

Global Instance os_dlattice {A}: DistributiveLattice (OS A).
Proof.
split.
+ exact os_lattice.
+ repeat red. intros a b c;
  apply path_forall ; intro s.
  generalize Sier_distributive_lattice.
  intros (_,HG).
  unfold LeftDistribute, LeftHeteroDistribute in *.
  specialize (HG (a s) (b s) (c s)).
  transitivity ((a s ⊔ b s) ⊓ (a s ⊔ c s)).
  apply HG.
  reflexivity.
Defined.


(*********************)
(*********************)
(****             ****)
(****   Objects   ****)
(****             ****)
(*********************)
(*********************)

Require Import Coq.Classes.Morphisms.
Require Import Main.CategoryTheory.Arrow.
Require Import Main.CategoryTheory.Category.
Require Import Main.Tactics.

#[local] Set Universe Polymorphism.

Definition isomorphic {C} (x y : object C) :=
  exists (f : arrow x y), isomorphism f.

Definition uniqueUpToIsomorphism {C} (P : object C -> Prop) :=
  forall x y, P x -> P y -> isomorphic x y.

Theorem isomorphicRefl C (x : object C) : isomorphic x x.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  eSearch.
Qed.

#[export] Hint Resolve isomorphicRefl : main.

Theorem isomorphicTrans C (x y z : object C) :
  isomorphic x y -> isomorphic y z -> isomorphic x z.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  clean.
  exists (compose x0 x2).
  exists (compose x3 x1).
  split.
  - rewrite cAssoc.
    rewrite <- (cAssoc x3).
    rewrite H.
    search.
  - rewrite cAssoc.
    rewrite <- (cAssoc x0).
    rewrite H1.
    search.
Qed.

(*
  We deliberately avoid adding a resolve hint for `isomorphicTrans` because
  doing so could lead to nonterminating searches.
*)

Theorem isomorphicSymm C (x y : object C) : isomorphic x y <-> isomorphic y x.
Proof.
  unfold isomorphic.
  unfold isomorphism.
  unfold inverse.
  eSearch.
Qed.

(*
  We deliberately avoid adding a resolve hint for `isomorphicSymm` because
  doing so could lead to nonterminating searches.
*)

Theorem opIsomorphic C x y :
  @isomorphic C x y <-> @isomorphic (oppositeCategory C) y x.
Proof.
  unfold isomorphic.
  split; clean; exists x0; [
    rewrite <- opIsomorphism | rewrite opIsomorphism
  ]; search.
Qed.

#[export] Hint Resolve opIsomorphic : main.


Require cem cbn expr db relations.
Require Import Unicode.Utf8 List NaryFunctions.
Require Import expr_db util CpdtTactics.
Require Import Basics.

Definition fresh (e : list nat) (h : cem.heap):= maximum (e ++ domain h).

(* Takes the closure from a configuration and converts it into the flattened
configuration, so its free variables are pointing directly to the correct
location*)
Definition closure_to_expr (c : cem.configuration) : option expr.tm
  := match c with | cem.conf h (cem.close t e') => let fix cte t e' e :=
    match t with
    | db.lam b => let f := fresh e h in
      match cte b e' (f :: e) with
      | Some b' => Some (expr.abs f b')
      | None => None
      end
    | db.var v => match nth_error e v with
      | Some l => Some (expr.var l)
      | None => match cem.clu v e' h with
        | Some (l', _) => Some (expr.var l')
        | None => None
        end
      end
    | db.app m n => match cte m e' e with
      | Some m' => match cte n e' e with
        | Some n' => Some (expr.app m' n')
        | None => None
        end
      | None => None
      end
    end
    in cte t e' nil
  end.

(*
Definition flatten (c: {c | cem.well_formed c}) : cbn.configuration := match c with
  | exist (cem.conf h c) p => cbn.st (map (fmap (closure_to_expr ∘ cem.conf h ∘ cem.clclose) h))
                         (closure_to_expr nil h c)
  end.

(* TODO : Proper relation *)
Inductive cem_cbn_rel : relation cem.configuration cbn.configuration :=
  | cc_rel : ∀ c1 c2, cem_cbn_rel c1 c2.

Lemma cem_cbn_bisim : strong_bisim cem.configuration cbn.configuration
                                   cem.step          cbn.step
                                   cem_cbn_rel.
Admitted.
Qed.

(*Well formed configurations can be collapsed into a closed deBruijn term*)
Theorem well_formed_cbn_closed_db : ∃ c, cbn.well_formed c ↔ ∃ e, db.closed e.
intros. destruct c. induction (expr.fvs t). destruct H.
induction h. destruct H. crush. assert (expr.closed t).
unfold expr.closed. apply util.subset_nil2. assumption. apply dbf. split with
(x:=t). assumption. destruct a. crush.

(* Relation idea: replace deBruijn variable with lookup location, which makes
them equal *)

Inductive state_rel : relation cem.configuration cbn.configuration :=
  | init : forall t e,
           deBruijn t e ->
           state_rel (cem.st nil (cem.close e 0)) (cbn.st nil t)
  | step : forall a b a' b',
           state_rel a b ->
           cem.step a a' ->
           cbn.step b b' ->
           state_rel a' b'.

Lemma ex1 : state_rel (cem.abs (0)

Fixpoint subst_cbn_config' vs e : expr.tm := match vs with
  | nil => e
  | (x,m)::hs => subst_cbn_config' hs (cbn.subst x m e)
  end.

Definition subst_cbn_config (st : cbn.configuration) : db.expr := match st with
  | cbn.st hs e => deBruijn (subst_cbn_config' hs e)
  end.

Theorem cem_cbn_bisim : bisim state_rel cem.step cbn.step.
unfold bisim.
intros. split.
  intros. induction H. destruct H. inversion H0. symmetry in H.
  apply app_cons_not_nil in H. inversion H.  apply ex_intro with (cbn.st nil
  (expr.abs v b)). assert (cbn.step (cbn.st nil (expr.abs v b)) (cbn.st nil
  (expr.abs v b))).  apply cbn.Abs. split. assumption.
    apply init. with (cem.st nil (cem.close (db.lam b') 0))
                    (cbn.st nil (expr.abs v b)).
                  *)


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal86.

Set Printing Depth 1000.
Definition lfind_eval  y:=
mult y Zero.

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero).


Set Implicit Arguments.

Require Import Tid.
Require Import Mid.

Section Defs.
  Inductive datum :=
  | d_task : tid -> datum
  | d_mem : mid -> datum
  | d_any : datum.

  Inductive mem_op :=
  | ALLOC: mem_op
  | READ: datum -> mem_op
  | WRITE: datum -> mem_op.

  Inductive op :=
  | INIT: op
  | MEM: mid -> mem_op -> op
  | FUTURE: tid -> op
  | FORCE: tid -> op.

  Definition event := (tid * op) % type.

  Definition trace := list event.

End Defs.


(*
 * Copyright (c) 2009-2012, Andrew Appel, Robert Dockins and Aquinas Hobor.
 * This presentation of Permission Algebras and Separation Algebras
 * includes ideas from a discussion with Jonas Jensen and also from
 * a paper by Francois Pottier.
 *)
Require Import VST.msl.Extensionality.

Set Implicit Arguments.

Class Join (t: Type) : Type := join: t -> t -> t -> Prop.

(* "Permission Algebra": commutative semigroup,
   such that if units exist, they must have certain properties. *)
Class Perm_alg (t: Type) {J: Join t} : Type :=
  mkPerm   {
   join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z';
   join_assoc: forall {a b c d e}, join a b d -> join d c e ->
                    {f : t & join b c f /\ join a f e};
   join_comm: forall {a b c}, join a b c -> join b a c;
   join_positivity: forall {a a' b b'}, join a a' b -> join b b' a -> a=b
}.
Arguments Perm_alg _ [J].

Definition unit_for {t}{J: Join t} (e a: t) := join e a a.
Definition identity {t} {J: Join t} (e: t) := forall a b, join e a b -> a=b.

Hint Extern 2 (@join _ _ _ _ _) =>
   (eapply join_comm; trivial;
     try eassumption;
     (* This next line looks superfluous, but it is not: it catches the
      case where H is join at a function type, where the goal is
      join at an applied function. *)
     match goal with H: @join _ _ _ _ _ |- _ => apply H end).
 (* Hint Immediate @join_comm. *)

Hint Unfold unit_for.

Lemma join_assoc_uniq:
  forall {t} {J: Join t} (PA1 PA2: @Perm_alg t J),
      forall a b c d e H H',
         (projT1 (@join_assoc _ _ PA1  a b c d e H H'))
        = (projT1 (@join_assoc _ _ PA2  a b c d e H H')).
Proof.
  intros.
  destruct (@join_assoc _ _ PA1  a b c d e H H') as [f [? ?]].
  destruct (@join_assoc _ _ PA2  a b c d e H H') as [g [? ?]].
  simpl. apply (join_eq j j1).
Qed.

  (* Sep_alg: additional properties that makes a Permission Algebra
     into a Separation Algebra. *)
  Class Sep_alg A {J: Join A} : Type :=
    mkSep {
      core: A -> A;
      core_unit: forall t, unit_for (core t) t;
      join_core: forall {a b c}, join a b c -> core a = core c
    }.
Arguments Sep_alg _ [J].

Lemma core_duplicable {A}{J: Join A}{SA: Sep_alg A}:
  forall a, join (core a) (core a) (core a).
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 generalize (core_unit (core a)); unfold unit_for; intro.
 generalize (join_core H); intro.
 rewrite H1 in H0; auto.
Qed.

Lemma core_self_join {A}{J: Join A}{SA: Sep_alg A}:
  forall a, a = core a -> join a a a.
Proof.
  intros.
  generalize (core_unit a); rewrite <- H; intro. apply H0.
Qed.

Lemma core_idem {A}{J: Join A}{SA: Sep_alg A}:
  forall a, core (core a) = core a.
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 apply (join_core H).
Qed.

Lemma core_hom {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall {a b c}, join a b c -> join (core a) (core b) (core c).
Proof.
 intros.
 generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
 rewrite H0; rewrite H1.
 apply core_duplicable.
Qed.

Lemma split_core' {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b (core c) -> a = core a.
Proof.
 intros.
 generalize (join_core H); rewrite core_idem; intro.
 rewrite <- H0 in H.
 clear dependent c.
 generalize (core_unit a); unfold unit_for; intro.
 eapply join_positivity; eauto.
Qed.

Lemma split_core{A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b (core c) -> unit_for a a.
Proof.
 intros.
 unfold unit_for.
 replace a with (core a).
 apply core_duplicable.
 symmetry; eapply split_core'; eauto.
Qed.

Lemma core_uniq {t} {J: Join t}{PA: Perm_alg t}:
   forall (SA1: @Sep_alg _ J)
          (SA2: @Sep_alg _ J),
     forall x, @core _ _ SA1 x = @core _ _ SA2 x.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 generalize  (@core_unit _ _ SA1 x); unfold unit_for; intro.
 generalize  (@core_unit _ _ SA2 x); unfold unit_for; intro.
 destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
 generalize (@core_unit _ _ SA2 (@core _ _ SA1 x)); unfold unit_for; intro.
 generalize (@core_unit _ _ SA1 (@core _ _ SA2 x)); unfold unit_for; intro.
 destruct (join_assoc ( H4) H2) as [g [? ?]].
 destruct (join_assoc H5 (join_comm H2)) as [h [? ?]].
 generalize (join_eq H6 (join_comm H8)); intro. rewrite <- H10 in *; clear dependent h.
 generalize (@join_core _ _ SA1 _ _ _ H4); intro.
 generalize (@join_core _ _ SA1 _ _ _ H0); intro.
 generalize (@join_core _ _ SA2 _ _ _ H0); intro.
 rewrite H11 in *. rewrite H12 in *. rewrite H10 in *.
 apply join_comm in H4.
 apply (join_eq H4 H5).
Qed.

Lemma join_core2 {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a b c, join a b c -> core a = core b.
Proof.
intros. generalize H; intro.
apply join_comm in H.
apply join_core in H0; apply join_core in H. congruence.
Qed.

(* Disj_alg: adds the property that no nonempty element can join with itself. *)
Class Disj_alg  (t: Type) {J: Join t} :=
   join_self: forall {a b}, join a a b -> identity a.
Arguments Disj_alg _ [J].

Lemma join_self' {A}{J: Join A}{DA: Disj_alg A} :
  forall {a b}, join a a b -> a = b.
Proof.
 intros.
 eapply join_self; eauto.
Qed.

Lemma   unit_identity {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
        forall {e} b, unit_for e b -> identity e.
Proof.
 intros.
 destruct (join_assoc (join_comm H) (join_comm H)) as [? []].
 eapply join_self; eauto.
Qed.

Lemma core_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a, identity (core a).
Proof.
  repeat intro.
  eapply join_eq; eauto.
  replace (core a) with (core a0); [apply core_unit|].
  symmetry; rewrite <- core_idem.
  eapply join_core2; eauto.
Qed.

Lemma join_ex_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall a, {e : A & prod (identity e) (unit_for e a) }.
Proof.
 intros.
 exists (core a).
 split.
 apply core_identity.
 apply core_unit.
Qed.

Lemma identity_core  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a, identity a -> a = core a.
Proof.
  intros.
  symmetry; apply H.
  apply join_comm, core_unit.
Qed.

  (* Sing_alg: adds the property that makes the Permission Algebra
     into a single-unit Separation Algebra.  (this is the "traditional"
     kind of Separation Algebra).   *)
Class Sing_alg A {J: Join A}{SA: Sep_alg A} :=
    mkSing {
      the_unit: A;
      the_unit_core: forall a, core a = the_unit
    }.
Arguments Sing_alg _ [J] [SA].
Arguments mkSing [A] [J] [SA] _ _.

  (* Positive Permission Algebra: there are no units, every element is nonempty *)
  Class Pos_alg  {A} {J: Join A} :=
    no_units: forall e a, ~unit_for e a.
Arguments Pos_alg _ [J].

(* Has the "cross-split" property described in Dockins et al,
    "A fresh look at separation algebras and share accounting", 2009 *)
Class Cross_alg (t: Type)  `{J: Join t} :=
   cross_split :
      forall a b c d z : t,
       join a b z ->
       join c d z ->
    { x:(t*t*t*t) &  match x with (ac,ad,bc,bd) =>
         join ac ad a /\ join bc bd b /\ join ac bc c /\ join ad bd d
       end
    }.
Arguments Cross_alg _ [J].

(* Has the "triple join" property  *)
Class Trip_alg {A} {J: Join A} :=
  triple_join_exists:
  forall (a b c ab bc ac : A), join a b ab -> join b c bc -> join a c ac ->
       {abc | join ab c abc}.
Arguments Trip_alg _ [J].

(* We do NOT yet introduce "emp" as a notation or synonym for "identity".
  This is because "emp" is a predicate of Separation Logic, but this file
  contains only Separation Algebras.  Some separation logics have
  predicates that are not just "t -> Prop", and therefore it is premature
  in this file to define "emp".
*)

(** * Lemmas about separation algebras. *)

Lemma  join_ex_units{A}{J: Join A}{SA: Sep_alg A}:
    forall a, {e : A & unit_for e a }.
Proof.
 intros. exists (core a). apply core_unit.
Qed.

Lemma same_identity {A}{J: Join A}{PA: Perm_alg A}:
  forall e e' a, identity e -> unit_for e a -> identity e' -> unit_for e' a -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 unfold unit_for in *.
 destruct (join_assoc (join_comm H1) (join_comm H3)) as [f [? ?]].
 generalize (H0 _ _ H4); intro.
 generalize (H2 _ _ (join_comm H4)); intro.
 rewrite H6; apply H7.
Qed.

Lemma same_unit {A}{J: Join A}{PA: Perm_alg A}{SA:Sep_alg A}{CA: Disj_alg A}:
       forall {e1 e2 a}, unit_for e1 a -> unit_for e2 a -> e1 = e2.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
intros.
generalize (unit_identity _ H0); intro.
unfold unit_for in *.
destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
generalize (H2 _ _ H3); intro.
rewrite <- H5 in *; clear f H5.
apply join_comm in H3.
apply (unit_identity _ H1 _ _ H3).
Qed.

  (** Elements [a] and [b] join. *)
  Definition joins {A} {J: Join A} (a b : A) : Prop :=
    exists c, join a b c.

  Definition overlap {A}{J: Join A} (a b: A) := ~(joins a b).

  Lemma join_joins {A} {J: Join A}: forall {a b c},
    join a b c -> joins a b.
  Proof. intros; econstructor; eauto.
  Qed.

  Lemma join_joins' {A} {J: Join A} {PA: Perm_alg A}: forall {a b c},
    join a b c -> joins b a.
  Proof.
    intros; econstructor. eauto.
  Qed.

  Lemma joins_sym {A}  {J: Join A} {PA: Perm_alg A}: forall a b,
    joins a b <-> joins b a.
  Proof.
    intros.
    split; intro; destruct H;
      exists x; apply join_comm; trivial.
  Qed.

  Lemma joins_sym': forall {A} `{Perm_alg A} {phi1 phi2}, joins phi1 phi2 -> joins phi2 phi1.
  Proof.
   intros.
   apply joins_sym. auto.
  Qed.

  (** Elememt [a] is a subelement of [c] .  This relation forms a partial order. *)
  Definition join_sub {A} `{Join A} (a c : A) : Prop :=
    exists b, join a b c.

  Lemma join_join_sub {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub a c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_join_sub' {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub b c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_sub_refl {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a,
    join_sub a a.
  Proof.
    intros.
    exists (core a). apply join_comm.
    apply core_unit.
  Qed.

  Hint Resolve @join_sub_refl.

  Lemma join_sub_trans {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a b c,
    join_sub a b ->
    join_sub b c ->
    join_sub a c.
  Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
    intros. destruct H0; destruct H1.
    destruct (join_assoc H0 H1) as [f [? ?]].
    econstructor; eauto.
  Qed.

  Lemma join_sub_unit_for {A} {J: Join A}{PA: Perm_alg A}:
    forall e a b, unit_for e a -> join_sub a b -> unit_for e b.
  Proof.
    unfold unit_for; intros ???? [].
    destruct (join_assoc H H0) as [b' []].
    assert (b' = b) by (eapply join_eq; eauto).
    subst; auto.
  Qed.

Lemma join_sub_same_identity {A} {J: Join A}{PA: Perm_alg A}:
   forall e e' a c,  identity e -> unit_for e a -> identity e' -> unit_for e' c ->
                  join_sub a c -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
  intros.
  destruct H4.
  unfold unit_for in *.
  destruct (join_assoc (join_comm H1) H4) as [f [? ?]].
   generalize (H0 _ _ H5); intro.
   rewrite <- H7 in *; clear dependent f.
   destruct (join_assoc H5 (join_comm H6)) as [g [? ?]].
   generalize (join_eq H4 (join_comm H7)); intro.
   rewrite <- H9 in *; clear dependent g.
   apply same_identity with c; auto.
Qed.

  Lemma join_sub_joins {A} `{HA: Perm_alg A}: forall {a b},
    join_sub a b -> joins a b -> joins a a.
  Proof.
    intros a b [? ?] [? ?].
    apply join_comm in H0.
    destruct (join_assoc H H0) as [? [? ?]].
    destruct (join_assoc H1 (join_comm H2)) as [? [? ?]].
    econstructor; eauto.
  Qed.
  (* Note: there are two other conceivable conclusions from the above
     premises: "joins b b" and "join_sub b a".  Neither must follow, since
     neither is true on the bools, but also neither is a contradiction
     since both are true on Z *)

  Lemma join_sub_joins_trans {A} `{HA: Perm_alg A}: forall {a b c},
    join_sub a c -> joins c b -> joins a b.
  Proof.
    intros.
    destruct H as [wx ?].
    destruct H0 as [wy ?].
    destruct (join_assoc (join_comm H) H0) as [wf [? ?]].
    econstructor; eauto.
  Qed.

  Lemma join_sub_joins'  {A} `{HA: Perm_alg A}:
    forall {a a' b b' : A},
      join_sub a a' -> join_sub b b' -> joins a' b' -> joins a b.
  Proof.
    intros.
    destruct H; destruct H0; destruct H1.
    destruct (join_assoc (join_comm H) H1) as [f [? ?]].
    destruct (join_assoc (join_comm H0) (join_comm H2)) as [g [? ?]].
    exists g; apply join_comm; auto.
  Qed.

  Definition sub_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c b -> joins c a.

  Definition same_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c a <-> joins c b.

  Lemma sub_silhouette_refl {A} `{Perm_alg A}: forall a, sub_silhouette a a.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma sub_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    sub_silhouette a b -> sub_silhouette b c -> sub_silhouette a c.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma same_silhouette_refl {A} `{Perm_alg A}: forall a, same_silhouette a a.
  Proof. unfold same_silhouette; intuition. Qed.

  Lemma same_silhouette_sym {A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> same_silhouette b a.
  Proof.  unfold same_silhouette; intros; split; apply H0; auto.
  Qed.

  Lemma same_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    same_silhouette a b -> same_silhouette b c -> same_silhouette a c.
 Proof. unfold same_silhouette; intros; split; intros;
             destruct (H0 c0); destruct (H1 c0);   auto. Qed.

  Lemma same_silhouette_sub1{A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> sub_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_sub2 {A} `{Perm_alg A}: forall a b,
     same_silhouette a b -> sub_silhouette b a.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma sub_same_silhouette {A} `{Perm_alg A}:
    forall a b, sub_silhouette a b -> sub_silhouette b a -> same_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_join {A} `{HA: Perm_alg A}:
    forall phi phi' phiy phiz phiz',
      same_silhouette phi phi' ->
      join phi phiy phiz ->
      join phi' phiy phiz' ->
      same_silhouette phiz phiz'.
  Proof.
    intros.
    intro phiu.
    split; intros [phix ?].
    destruct (join_assoc H0 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi phif phiz) by eauto.
    assert (joins phif phi) by (apply joins_sym;  auto).
    specialize (H H7).
    clear H5 H6 H7.
    destruct H as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H1 (join_comm H5)); intro.
    rewrite <- H7 in *. clear phig H7 H5.
    exists phix'.
    auto.
    destruct (join_assoc H1 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi' phif phiz) by eauto.
    assert (joins phif phi') by (apply joins_sym;  auto).
    specialize (H5 H7).
    clear H H6 H7.
    destruct H5 as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H0 (join_comm H5)); intro.
    rewrite <- H7 in *; clear phig H7 H5.
    exists phix'.
    auto.
  Qed.

Hint Resolve @join_joins @join_joins' @join_join_sub @join_join_sub'.

  Definition nonidentity {A} `{Perm_alg A} (a: A) := ~(identity a).

  (** If [a] is a subelement of [b], their units are equal. *)
  Lemma join_sub_units_eq {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
   forall {a b} ea eb,
    join_sub a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea = eb.
  Proof.
    unfold unit_for.
    intros.
    destruct H.
    destruct (join_assoc H0 H) as [f [? ?]].
    generalize (join_eq H H2); intro.
    rewrite <- H4 in *; clear f H4 H2.
    eapply same_unit; eauto.
  Qed.

  Lemma unit_core{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
      forall {a}, unit_for a a -> a = (core a).
  Proof.
   intros.
   eapply identity_core, unit_identity; eauto.
  Qed.

  (** A unit for an element is a unit for itself (is idempotent). *)
  Lemma unit_self_unit {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
   forall a ea,   unit_for ea a ->  unit_for ea ea.
  Proof.
    intros.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H) (join_comm H)) as [f [? _]].
    generalize (unit_identity _ H); intro.
    generalize (H1 _ _ H0); intro.
   rewrite <- H2 in H0; clear f H2.
   auto.
  Qed.

  (** If a joins with b, then their units are equal. *)
  Lemma joins_units_eq {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
   forall {a b} ea eb,
    joins a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea  = eb.
  Proof.
    intros.
    destruct H.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H0) H) as [f [? ?]].
    generalize (unit_identity _ H0 _ _ H2); intro.
    rewrite <- H4 in *; clear f H4.
    eapply same_unit; eauto.
  Qed.

  (** The existence of identity elements. *)
  Lemma join_ex_identities {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a,
    {e : A & identity e /\ joins e a}.
  Proof.
    intro x.
    destruct (join_ex_identity x) as [e [? ?]].
   exists e; split; auto.
   exists x; auto.
  Qed.

  (** If something is an identity and it joins with an element then it is a
     unit for that element. *)
  Lemma identity_unit {A} `{HA: Perm_alg A}: forall e a,
    identity e ->
    joins e a ->
    unit_for e a.
  Proof.
    intros. destruct H0.
    generalize (H a x H0); intro.
    rewrite <- H1 in *; clear x H1.
    trivial.
  Qed.

  Lemma identity_unit' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
    forall a,  identity a -> unit_for a a.
  Proof.
    repeat intro.
    apply identity_unit; trivial.
    exists a.
    destruct (join_ex_units a) as [ea H0].
    generalize (join_comm H0); intro.
    generalize (H ea a H1); intro.
    rewrite <- H2 in *; clear a H2.
    trivial.
  Qed.

  (** Identities are exactly units for themselves (are idempotent).*)
  Lemma identity_unit_equiv {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
    forall a,  identity a <-> unit_for a a.
  Proof.
    intros.
    split; [apply identity_unit' | apply unit_identity].
  Qed.

  (** Joinable identities are unique. *)
  Lemma identities_unique {A} `{HA: Perm_alg A} :
   forall e1 e2,  identity e1 ->  identity e2 ->  joins e1 e2 ->  e1 = e2.
  Proof.
    intros.
    destruct H1.
    assert (e2 = x) by auto.
    apply join_comm in H1.
    assert (e1 = x) by auto.
    rewrite H3; rewrite H2; reflexivity.
  Qed.

Lemma split_identity{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b c -> identity c -> identity a.
Proof.
 intros.
 apply identity_core in H0.
 rewrite H0 in H.
 erewrite split_core' by eauto.
 apply core_identity.
Qed.

  (* The contrapositive of split_identity *)
  Lemma join_nonidentity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a b c,
    nonidentity a -> join a b c -> nonidentity c.
  Proof.
    intros a b c H H0 H1.
    contradiction H.
    apply split_identity with b c; auto.
  Qed.

  Lemma join_sub_antisym {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall x y,
    join_sub x y ->
    join_sub y x ->
    x = y.
  Proof.
    intros ? ? [? ?] [? ?].
    eapply join_positivity; eauto.
  Qed.

  (** This lemma uses the full power of self_join and eliminates both N and Z. *)
  Lemma join_sub_joins_identity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> joins a b -> identity a.
  Proof.
    intros.
    generalize (join_sub_joins H H0); intro.
    destruct H1.
    eapply join_self; eauto.
  Qed.

  (** Sometimes it is useful to use a negative form of the previous lemma *)
  Lemma join_overlap {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> nonidentity a -> overlap a b.
  Proof.
    repeat intro.
    apply H0.
    eapply join_sub_joins_identity; eauto.
  Qed.

(** The opposite of identity is maximal or full *)

Definition full {A} {JA: Join A}(sigma : A) : Prop :=
   forall sigma', joins sigma sigma' -> identity sigma'.

Definition maximal {A} {JA: Join A} (sigma : A) : Prop :=
  forall sigma', join_sub sigma sigma' -> sigma = sigma'.

Lemma full_maximal {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
       forall a, full a <-> maximal a.
Proof with auto.
 pose proof I. (* hack: shift up auto-named hyps *)
  split; intro.
  intros a'' ?.
  destruct H1 as [a' ?].
  specialize (H0 a').
  apply H0. eauto. apply join_comm...
  intros a' ?.
  destruct H1 as [a'' ?].
  rewrite <- (H0 a'') in *; eauto; clear a'' H0.
  eapply unit_identity; eauto.
Qed.

(** The elements of a multi-unit separation algebra can be partitioned
    into equivalance classes, where two elements are in the class iff
    they have the same unit.
  *)

  Definition comparable {A} `{Sep_alg A}  (a b:A)
    := core a = core b.

  Lemma comparable_refl {A} `{Sep_alg A} : forall a, comparable a a.
  Proof. intros; red; auto. Qed.

  Lemma comparable_sym {A} `{Sep_alg A}: forall a b, comparable a b -> comparable b a.
  Proof. unfold comparable; intros; symmetry; auto. Qed.

  Lemma comparable_trans {A} `{Sep_alg A}: forall a b c, comparable a b -> comparable b c -> comparable a c.
  Proof. unfold comparable; intros; etransitivity; eauto. Qed.

  Lemma comparable_common_unit {A} `{Sep_alg A}: forall a b,
    comparable a b ->
    exists e, join e a a /\ join e b b.
  Proof.
    intros.
    red in H0.
    exists (core a); split.
    apply core_unit.
    rewrite H0; apply core_unit.
  Qed.

  Lemma common_unit_comparable {A} `{Sep_alg A} : forall a b,
    (exists e, join e a a /\ join e b b) ->
    comparable a b.
  Proof.
    intros.
    destruct H0 as [e [H1 H2]].
    unfold comparable.
    rewrite <- (join_core H1).  apply (join_core H2).
Qed.

Lemma join_comparable  {A} `{Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi3.
Proof.
  intros.
  unfold comparable.
  eapply join_core; eauto.
Qed.

Lemma join_comparable2  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi2.
Proof.
  intros.
  unfold comparable.
  generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
  rewrite H0; rewrite H1; reflexivity.
Qed.

Lemma join_sub_comparable  {A} `{Sep_alg A} : forall a c,
  join_sub a c -> comparable a c.
Proof.
  intros.
  destruct H0.
  eapply join_comparable; eauto.
Qed.

Lemma joins_comparable  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A} : forall a c,
  joins a c -> comparable a c.
Proof.
  intros a c H0.
  destruct H0.
  eapply join_comparable2; eauto.
Qed.

Lemma join_unit1 {A} `{Perm_alg A}:
  forall x y z, unit_for x z -> y = z -> join x y z.
Proof.
intros. rewrite H1 in *; auto.
Qed.

Lemma join_unit2 {A} `{Perm_alg A}:
  forall x y z, unit_for y z -> x = z -> join x y z.
Proof.
intros. rewrite  H1 in *;  clear x H1. apply join_comm; auto.
Qed.

Lemma join_unit1_e {A} `{Perm_alg A}:
  forall x y z, identity x -> join x y z -> y = z.
Proof.
intros.
eapply join_eq; eauto.
apply identity_unit; eauto.
Qed.

Lemma join_unit2_e {A} `{Perm_alg A}:
  forall x y z, identity y -> join x y z -> x = z.
Proof.
intros.
apply join_comm in H1.
eapply join_unit1_e; eauto.
Qed.

Lemma PermAlg_ext:
  forall (T: Type) (J: @Join T) (sa1 sa2: @Perm_alg T J), sa1=sa2.
Proof. intros.
destruct sa1, sa2.
f_equal; try apply proof_irr.
extensionality a b c d e H1 H2.
destruct (join_assoc1 a b c d e H1 H2) as [f [? ?]].
destruct (join_assoc0 a b c d e H1 H2) as [f0 [? ?]].
apply existT_ext.
eapply join_eq0; eauto.
Qed.

Lemma Sep_alg_ext {T} {J} {PA: @Perm_alg _ J}:
   forall (sa1 sa2: @Sep_alg T J), sa1=sa2.
Proof.
intros.
generalize (@core_uniq _ J _ sa1 sa2); intro.
destruct sa1; destruct sa2.
simpl in H.
assert (core0 = core1).
  extensionality; auto.
subst core1.
f_equal.
apply proof_irr.
apply proof_irr.
Qed.

Definition nonunit {A} `{Join A}  (a: A) := forall x, ~ unit_for a x.

Lemma nonidentity_nonunit {A} {JA: Join A} {PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
  forall {a}, nonidentity a -> nonunit a.
Proof.
 intros. intros ? H0; apply H. eapply unit_identity; apply H0.
Qed.

Lemma nonunit_nonidentity {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall x, nonunit x -> ~identity x.
Proof. intros. intro.
  apply identity_unit' in H0. apply (H _ H0).
Qed.

(* Canc_alg: makes a Permission Algebra into a cancellative Perm.Alg. *)
Class Canc_alg (t: Type) {J: Join t} :=
    join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1 = a2.
Arguments Canc_alg _ [J].


Require Import VST.floyd.proofauto.
Require Import VST.progs.bst.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := Z.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint pushdown_left (a: tree) (bc: tree) : tree :=
 match bc with
 | E => a
 | T b y vy c => T (pushdown_left a b) y vy c
 end.

Fixpoint delete (x: key) (s: tree) : tree :=
 match s with
 | E => E
 | T a y v' b => if  x <? y then T (delete x a) y v' b
                        else if y <? x then T a y v' (delete x b)
                        else pushdown_left a b
 end.

End TREES.
Arguments E {V}.
Arguments T {V} _ _ _ _.
Arguments insert {V} x v s.
Arguments lookup {V} default x t.
Arguments pushdown_left {V} a bc.
Arguments delete {V} x s.

Fixpoint tree_rep (t: tree val) (p: val) : mpred :=
 match t with
 | E => !!(p=nullval) && emp
 | T a x v b => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
    EX pa:val, EX pb:val,
    data_at Tsh t_struct_tree (Vint (Int.repr x),(v,(pa,pb))) p *
    tree_rep a pa * tree_rep b pb
 end.

Definition treebox_rep (t: tree val) (b: val) :=
 EX p: val, data_at Tsh (tptr t_struct_tree) p b * tree_rep t p.

(* TODO: seems not useful *)
Lemma treebox_rep_spec: forall (t: tree val) (b: val),
  treebox_rep t b =
  EX p: val,
  match t with
  | E => !!(p=nullval) && data_at Tsh (tptr t_struct_tree) p b
  | T l x v r => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
      data_at Tsh (tptr t_struct_tree) p b *
      spacer Tsh (sizeof tint) (sizeof size_t) p *
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p *
      field_at Tsh t_struct_tree [StructField _value] v p *
      treebox_rep l (field_address t_struct_tree [StructField _left] p) *
      treebox_rep r (field_address t_struct_tree [StructField _right] p)
  end.
Proof.
  intros.
  unfold treebox_rep at 1.
  f_equal.
  extensionality p.
  destruct t; simpl.
  + apply pred_ext; entailer!.
  + unfold treebox_rep.
    apply pred_ext; entailer!.
    - Intros pa pb.
      Exists pb pa.
      unfold_data_at (data_at _ _ _ p).
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
      cancel.
    - Intros pa pb.
      Exists pb pa.
      unfold_data_at (data_at _ _ _ p).
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
      cancel.
Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH n: Z
  PRE [ 1%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 1%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: val,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (memory_block Tsh n v).

Definition freeN_spec :=
 DECLARE _freeN
  WITH p : val , n : Z
  PRE [ 1%positive OF tptr tvoid , 2%positive OF tint]
     (* we should also require natural_align_compatible (eval_id 1) *)
      PROP() LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr n)))
      SEP (memory_block Tsh n p)
  POST [ tvoid ]
    PROP () LOCAL () SEP ().

Definition treebox_new_spec :=
 DECLARE _treebox_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ tptr (tptr t_struct_tree) ]
    EX v:val,
    PROP()
    LOCAL(temp ret_temp v)
    SEP (data_at Tsh (tptr t_struct_tree) nullval v).

Definition insert_spec :=
 DECLARE _insert
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint,
        _value OF (tptr Tvoid)   ]
    PROP( Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)); temp _value v)
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (insert x v t) b).

Definition lookup_spec :=
 DECLARE _lookup
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint  ]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ tptr Tvoid ]
    PROP()
    LOCAL(temp ret_temp (lookup nullval x t))
    SEP (treebox_rep t b).

Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, vx: val, tb: tree val, y: Z, vy: val, tc: tree val, b: val, l: val, pa: val, r: val
  PRE  [ __l OF (tptr (tptr (Tstruct _tree noattr))),
        _l OF (tptr (Tstruct _tree noattr)),
        _r OF (tptr (Tstruct _tree noattr))]
    PROP(Int.min_signed <= x <= Int.max_signed; is_pointer_or_null vx)
    LOCAL(temp __l b; temp _l l; temp _r r)
    SEP (data_at Tsh (tptr t_struct_tree) l b;
         data_at Tsh t_struct_tree (Vint (Int.repr x), (vx, (pa, r))) l;
         tree_rep ta pa;
         tree_rep (T tb y vy tc) r)
  POST [ Tvoid ]
    EX pc: val,
    PROP(Int.min_signed <= y <= Int.max_signed; is_pointer_or_null vy)
    LOCAL()
    SEP (data_at Tsh (tptr t_struct_tree) r b;
         data_at Tsh t_struct_tree (Vint (Int.repr y), (vy, (l, pc))) r;
         tree_rep (T ta x vx tb) l;
         tree_rep tc pc).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, v: val, tb: tree val, b: val, p: val
  PRE  [ _t OF (tptr (tptr (Tstruct _tree noattr)))]
    PROP(Int.min_signed <= x <= Int.max_signed; tc_val (tptr Tvoid) v)
    LOCAL(temp _t b)
    SEP (data_at Tsh (tptr t_struct_tree) p b;
         field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p;
         field_at Tsh t_struct_tree [StructField _value] v p;
         treebox_rep ta (field_address t_struct_tree [StructField _left] p);
         treebox_rep tb (field_address t_struct_tree [StructField _right] p))
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (pushdown_left ta tb) b).

Definition delete_spec :=
 DECLARE _delete
  WITH b: val, x: Z, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (delete x t) b).

Definition tree_free_spec :=
 DECLARE _tree_free
  WITH t: tree val, p: val
  PRE  [ _p OF (tptr t_struct_tree) ]
       PROP() LOCAL(temp _p p) SEP (tree_rep t p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition treebox_free_spec :=
 DECLARE _treebox_free
  WITH t: tree val, b: val
  PRE  [ _b OF (tptr (tptr t_struct_tree)) ]
       PROP() LOCAL(temp _b b) SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition Gprog : funspecs :=
    ltac:(with_library prog [
    mallocN_spec; freeN_spec; treebox_new_spec;
    tree_free_spec; treebox_free_spec;
    insert_spec; lookup_spec;
    turn_left_spec; pushdown_left_spec; delete_spec
  ]).

Lemma tree_rep_saturate_local:
   forall t p, tree_rep t p |-- !! is_pointer_or_null p.
Proof.
destruct t; simpl; intros.
entailer!.
Intros pa pb. entailer!.
Qed.

Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall t p, tree_rep t p |-- valid_pointer p.
Proof.
intros.
destruct t; simpl; normalize; auto with valid_pointer.
Qed.
Hint Resolve tree_rep_valid_pointer: valid_pointer.

Lemma treebox_rep_saturate_local:
   forall t b, treebox_rep t b |-- !! field_compatible (tptr t_struct_tree) [] b.
Proof.
intros.
unfold treebox_rep.
Intros p.
entailer!.
Qed.

Hint Resolve treebox_rep_saturate_local: saturate_local.

Definition insert_inv (b0: val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX b: val, EX t: tree val,
  PROP()
  LOCAL(temp _t b; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(treebox_rep t b;  (treebox_rep (insert x v t) b -* treebox_rep (insert x v t0) b0)).

Lemma ramify_PPQQ {A: Type} {NA: NatDed A} {SA: SepLog A} {CA: ClassicalSep A}: forall P Q,
  P |-- P * (Q -* Q).
Proof.
  intros.
  apply RAMIF_PLAIN.solve with emp.
  + rewrite sepcon_emp; auto.
  + rewrite emp_sepcon; auto.
Qed.

Lemma tree_rep_nullval: forall t,
  tree_rep t nullval |-- !! (t = E).
Proof.
  intros.
  destruct t; [entailer! |].
  simpl tree_rep.
  Intros pa pb. entailer!.
Qed.

Hint Resolve tree_rep_nullval: saturate_local.

Lemma treebox_rep_leaf: forall x p b (v: val),
  is_pointer_or_null v ->
  Int.min_signed <= x <= Int.max_signed ->
  data_at Tsh t_struct_tree (Vint (Int.repr x), (v, (nullval, nullval))) p * data_at Tsh (tptr t_struct_tree) p b |-- treebox_rep (T E x v E) b.
Proof.
  intros.
  unfold treebox_rep, tree_rep. Exists p nullval nullval. entailer!.
Qed.

Lemma bst_left_entail: forall (t1 t1' t2: tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t1 (field_address t_struct_tree [StructField _left] p) *
       (treebox_rep t1'
         (field_address t_struct_tree [StructField _left] p) -*
        treebox_rep (T t1' k v t2) b).
Proof.
  intros.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  unfold treebox_rep at 1. Exists p1. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p1.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p1.
  Exists p1 p2.
  entailer!.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  cancel.
Qed.

Lemma bst_right_entail: forall (t1 t2 t2': tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t2 (field_address t_struct_tree [StructField _right] p) *
       (treebox_rep t2'
         (field_address t_struct_tree [StructField _right] p) -*
        treebox_rep (T t1 k v t2') b).
Proof.
  intros.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  unfold treebox_rep at 1. Exists p2. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p2.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p2.
  Exists p1 p2.
  entailer!.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  cancel.
Qed.

Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A, P |-- Q -> P * (Q -* R) |-- R.
Proof.
  intros.
  eapply derives_trans; [| apply modus_ponens_wand].
  apply sepcon_derives; [| apply derives_refl].
  auto.
Qed.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb := first [ rewrite if_trueb by (apply Z.ltb_lt; omega)
                          | rewrite if_falseb by (apply Z.ltb_ge; omega)].

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (insert_inv b t x v) (insert_inv b t x v) )].
  * (* Precondition *)
    unfold insert_inv.
    Exists b t. entailer.
    apply ramify_PPQQ.
  * (* Loop body *)
    unfold insert_inv.
    Intros b1 t1.
    forward. (* Sskip *)
    unfold treebox_rep at 1. Intros p1.
    forward. (* p = *t; *)
    forward_if.
    + (* then clause *)
      subst p1.
      Time forward_call (sizeof t_struct_tree).
        1: simpl; rep_omega.
      Intros p'.
      rewrite memory_block_data_at_ by auto.
      forward. (* p->key=x; *)
      simpl.
      forward. (* p->value=value; *)
      forward. (* p->left=NULL; *)
      forward. (* p->right=NULL; *)
      assert_PROP (t1= (@E _)).
        1: entailer!.
      subst t1. simpl tree_rep. rewrite !prop_true_andp by auto.
      forward. (* *t = p; *)
      forward. (* return; *)
      apply modus_ponens_wand'.
      apply treebox_rep_leaf; auto.
    + (* else clause *)
      destruct t1.
        { simpl tree_rep. normalize. }
      simpl tree_rep.
      Intros pa pb. clear H1.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        unfold insert_inv.
        Exists (offset_val 8 p1) t1_1.
        entailer!. simpl.
        simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 8 p1)
          with (field_address t_struct_tree [StructField _left] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_left_entail; auto.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold insert_inv.
        Exists (offset_val 12 p1) t1_2.
        entailer!. simpl.
        simpl_compb; simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 p1)
          with (field_address t_struct_tree [StructField _right] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_right_entail; auto.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by omega.
        subst x.  clear H H1 H3.
        forward. (* p->value=value *)
        forward. (* return *) simpl.
        (* TODO: SIMPLY THIS LINE *)
        simpl_compb.
        simpl_compb.
        apply modus_ponens_wand'.
        unfold treebox_rep. Exists p1.
        simpl tree_rep. Exists pa pb. entailer!.
  * (* After the loop *)
    forward.
    unfold loop2_ret_assert. apply andp_left2. normalize.
Qed.

Definition lookup_inv (b0 p0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX p: val, EX t: tree val,
  PROP(lookup nullval x t = lookup nullval x t0)
  LOCAL(temp _p p; temp _x (Vint (Int.repr x)))
  SEP(tree_rep t p;  (tree_rep t p -* tree_rep t0 p0)).

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold treebox_rep. Intros p.
  forward. (* p=*t; *)
  apply (semax_post_ret1 nil
          (data_at Tsh (tptr t_struct_tree) p b :: tree_rep t p :: nil)).
  1: intro HH; inversion HH.
  1: unfold treebox_rep; Exists p; entailer!.
  apply semax_frame''.
  forward_while (lookup_inv b p t x).
  * (* precondition implies loop invariant *)
    Exists p t. entailer!.
    apply -> wand_sepcon_adjoint. cancel.
  * (* type-check loop condition *)
    entailer!.
  * (* loop body preserves invariant *)
    destruct t0; unfold tree_rep at 1; fold tree_rep. normalize.
    Intros pa pb.
    forward.
    forward_if; [ | forward_if ].
    + (* then clause: x<y *)
      forward. (* p=p<-left *)
      Exists (pa,t0_1). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        simpl. Exists pa pb; entailer!.
    + (* else-then clause: y<x *)
      forward. (* p=p<-right *)
      Exists (pb,t0_2). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        simpl. Exists pa pb; entailer!.
    + (* else-else clause: x=y *)
      assert (x=k) by omega. subst x. clear H H3 H4.
      forward. (* v=p->value *)
      forward. (* return v; *) simpl.
      unfold treebox_rep. unfold normal_ret_assert.
      entailer!.
      - rewrite <- H0. simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply modus_ponens_wand'.
        Exists pa pb; entailer!.
  * (* after the loop *)
    forward. (* return NULL; *)
    entailer!.
    apply modus_ponens_wand.
Qed.

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  simpl.
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  forward. (* r->left=l *)
  forward. (* _l = r *)
  Opaque tree_rep. forward. Transparent tree_rep. (* return *)
  (* TODO: simplify the following proof *)
  Exists pc.
  entailer!.
  simpl.
  Exists pa pb.
  entailer!.
Qed.

Definition pushdown_left_inv (b_res: val) (t_res: tree val): environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: Z, EX v: val, EX tb: tree val,
  PROP  ()
  LOCAL (temp _t b)
  SEP   (treebox_rep (T ta x v tb) b;
         (treebox_rep (pushdown_left ta tb) b -* treebox_rep t_res b_res)).

Lemma cancel_emp_spacer:
  forall sh x y p, x=y ->
    emp |-- spacer sh x y p.
Proof.
intros.
subst.
unfold spacer.
rewrite Z.sub_diag. simpl. auto.
Qed.

Lemma cancel_spacer_emp:
  forall sh x y p, x=y ->
    spacer sh x y p |-- emp.
Proof.
intros.
subst.
unfold spacer.
rewrite Z.sub_diag. simpl. auto.
Qed.

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (pushdown_left_inv b (pushdown_left ta tb))
                         (pushdown_left_inv b (pushdown_left ta tb)))].
  + (* Precondition *)
    unfold pushdown_left_inv.
    Exists b ta x v tb.
    entailer!.
    eapply derives_trans; [| apply ramify_PPQQ].
    rewrite (treebox_rep_spec (T ta x v tb)).
    Exists p.
    entailer!.
  + (* Loop body *)
    unfold pushdown_left_inv.
    clear x v H H0.
    Intros b0 ta0 x vx tbc0.
    unfold treebox_rep at 1.
    Intros p0.
    forward. (* skip *)
    forward. (* p = *t; *)
      (* TODO entailer: The following should be solve automatically. satuate local does not work *)
 (*     1: rewrite (add_andp _ _ (tree_rep_saturate_local _ _)); entailer!. *)
    simpl tree_rep.
    Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    - subst.
      assert_PROP (tbc0 = (@E _)).
        1: entailer!.
      subst.
      forward. (* q=p->left *)
      forward. (* *t=q *)
      Time forward_call (p0, sizeof t_struct_tree). (* freeN(p, sizeof ( *p )); *)
      {
        entailer!.
        rewrite memory_block_data_at_ by auto.
        cancel.
      }
      forward. (* return *)
      simpl.
      apply modus_ponens_wand'.
      Exists pa.
      entailer!.
    - destruct tbc0 as [| tb0 y vy tc0].
        { simpl tree_rep. normalize. }
      Time forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc). (* turn_left(t, p, q); *)
      Intros pc.
      forward. (* t = &q->left; *)
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0.
      (* TODO entailer: not to simply too much in entailer? *)
      Opaque tree_rep. entailer!. Transparent tree_rep.
        (* TODO: simplify this line *)
      apply RAMIF_PLAIN.trans'.
      apply bst_left_entail; auto.
  + forward. (* Sskip *)
    apply andp_left2; auto.
Qed.

Definition delete_inv (b0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX b: val, EX t: tree val,
  PROP()
  LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
  SEP(treebox_rep t b;  (treebox_rep (delete x t) b -* treebox_rep (delete x t0) b0)).

Lemma body_delete: semax_body Vprog Gprog f_delete delete_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (delete_inv b t x) (delete_inv b t x) )].
  * (* Precondition *)
    unfold delete_inv.
    Exists b t. entailer.
    apply ramify_PPQQ.
  * (* Loop body *)
    unfold delete_inv.
    Intros b1 t1.
    forward. (* Sskip *)
    unfold treebox_rep at 1. Intros p1.
    forward. (* p = *t; *)
    forward_if.
    + (* then clause *)
      subst p1.
      assert_PROP (t1= (@E _)).
        1: entailer!.
      subst t1. simpl tree_rep. rewrite !prop_true_andp by auto.
      forward. (* return; *)
      unfold treebox_rep at 1.
      apply modus_ponens_wand'.
      Exists nullval.
      simpl tree_rep.
      entailer!.
    + (* else clause *)
      destruct t1.
        { simpl tree_rep. normalize. }
      simpl tree_rep.
      Intros pa pb. clear H0.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        unfold delete_inv.
        Exists (offset_val 8 p1) t1_1.
        entailer!. simpl.
        simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 8 p1)
          with (field_address t_struct_tree [StructField _left] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_left_entail; auto.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold delete_inv.
        Exists (offset_val 12 p1) t1_2.
        entailer!. simpl.
        simpl_compb; simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 p1)
          with (field_address t_struct_tree [StructField _right] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_right_entail; auto.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by omega.
        subst x.
        unfold_data_at (data_at _ _ _ p1).
        gather_SEP 3 5.
        replace_SEP 0 (treebox_rep t1_1 (field_address t_struct_tree [StructField _left] p1)).
        {
          unfold treebox_rep; entailer!.
          Exists pa.
          rewrite field_at_data_at.
          entailer!.
        }
        gather_SEP 4 5.
        replace_SEP 0 (treebox_rep t1_2 (field_address t_struct_tree [StructField _right] p1)).
        {
          unfold treebox_rep; entailer!.
          Exists pb.
          rewrite field_at_data_at.
          entailer!.
        }
        Time forward_call (t1_1, k, v, t1_2, b1, p1).
        forward. (* return *)
        simpl.
        simpl_compb.
        simpl_compb.
        apply modus_ponens_wand'.
        auto.
  * (* After the loop *)
    forward. apply andp_left2; auto.
Qed.

Lemma body_treebox_new: semax_body Vprog Gprog f_treebox_new treebox_new_spec.
Proof.
  start_function.
  Time forward_call (sizeof (tptr t_struct_tree)).
  simpl sizeof; computable.
  Intros p.
  rewrite memory_block_data_at_ by auto.
  forward.
  forward.
  Exists p. entailer!.
Qed.

Lemma body_tree_free: semax_body Vprog Gprog f_tree_free tree_free_spec.
Proof.
  start_function.
  forward_if (PROP()LOCAL()SEP()).
  + destruct t; simpl tree_rep.
      1: Intros. contradiction.
    Intros pa pb.
    forward.
    forward.
    Time forward_call (p, sizeof t_struct_tree).
    {
      entailer!.
      rewrite memory_block_data_at_ by auto.
      cancel.
    }
    Time forward_call (t1,pa).
    Time forward_call (t2,pb).
    entailer!.
  + forward.
    subst.
    entailer!.
    simpl; normalize.
  + forward.
Qed.

Lemma body_treebox_free: semax_body Vprog Gprog f_treebox_free treebox_free_spec.
Proof.
  start_function.
  unfold treebox_rep.
  Intros p.
  forward.
  Time forward_call (t,p).
  Time forward_call (b, sizeof (tptr t_struct_tree)).
  entailer!.
  rewrite memory_block_data_at_ by auto.
  cancel.
  forward.
Qed.

Module Abstractions.
(* Demonstration of data abstraction via subsume_funspec. *)

(* Definitions of [combine] and [Abs] taken from
   Verified Functional Algorithms (Software Foundations Volume 3),
   chapter SearchTree *)
Section TREE_ABS.

Definition total_map (A:Type) := key -> A.
Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).
Definition t_update {A:Type} (m : total_map A)
                    (x : key) (v : A) :=
  fun x' => if x =? x' then v else m x'.

Definition combine {A} (pivot: key) (m1 m2: total_map A) : total_map A :=
  fun x : key => if zlt x pivot  then m1 x else m2 x.

Inductive Abs:  tree val -> total_map val -> Prop :=
| Abs_E: Abs E (t_empty nullval)
| Abs_T: forall a b l k v r,
      Abs l a ->
      Abs r b ->
      Abs (T l k v r)  (t_update (combine k a b) k v).

Theorem insert_relate:
 forall k v t cts,
    Abs t cts ->
    Abs (insert k v t) (t_update cts k v).
Admitted.  (* This is an exercise in Verified Functional Algorithms *)

Theorem lookup_relate:
  forall k t cts ,
    Abs t cts -> lookup nullval k t =  cts k.
Admitted.  (* This is an exercise in Verified Functional Algorithms *)

Definition tmap_rep (m: total_map val) (p: val) : mpred :=
   EX t: tree val, !! Abs t m && treebox_rep t p.

Definition abs_insert_spec :=
 DECLARE _insert
  WITH b: val, x: Z, v: val, m: total_map val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint,
        _value OF (tptr Tvoid)   ]
    PROP( Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)); temp _value v)
    SEP (tmap_rep m b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (tmap_rep (t_update m x v) b).

Definition abs_treebox_new_spec :=
 DECLARE _treebox_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ tptr (tptr t_struct_tree) ]
    EX v:val,
    PROP()
    LOCAL(temp ret_temp v)
    SEP (tmap_rep (t_empty nullval) v).

Definition abs_treebox_free_spec :=
 DECLARE _treebox_free
  WITH m: total_map val, p: val
  PRE  [ _b OF (tptr (tptr t_struct_tree)) ]
       PROP() LOCAL(temp _b p) SEP (tmap_rep m p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Lemma subsume_insert:
 subsume_funspec (snd insert_spec) (snd abs_insert_spec).
Proof.
apply NDsubsume_subsume.
split; reflexivity.
split3; auto.
intros [[[b x] v] m].
unfold tmap_rep.
Intros t.
Exists (b, x, v, t).
Exists emp.
change (`emp) with (@emp (environ->mpred) _ _); rewrite !emp_sepcon.
apply andp_right; auto.
entailer!.
apply prop_right.
simplify_Delta.
Exists (insert x v t).
entailer!.
apply insert_relate; auto.
Qed.

Lemma subsume_treebox_new:
 subsume_funspec (snd treebox_new_spec) (snd abs_treebox_new_spec).
Proof.
apply NDsubsume_subsume.
split; reflexivity.
split3; auto.
intros x. simpl in x.
Exists x.
Exists emp.
change (`emp) with (@emp (environ->mpred) _ _); rewrite !emp_sepcon.
apply andp_right; auto.
apply prop_right.
simplify_Delta.
Intros v.
Exists v.
unfold tmap_rep.
Exists (empty_tree val).
unfold treebox_rep.
Exists nullval.
entailer!.
constructor.
simpl. entailer!.
Qed.

Lemma subsume_treebox_free:
 subsume_funspec (snd treebox_free_spec) (snd abs_treebox_free_spec).
Proof.
apply NDsubsume_subsume.
split; reflexivity.
split3; auto.
intros [m p].
unfold tmap_rep.
Intros t.
Exists (t,p).
Exists emp.
change (`emp) with (@emp (environ->mpred) _ _); rewrite !emp_sepcon.
apply andp_right; auto.
apply prop_right.
simplify_Delta.
entailer!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
assert_PROP (isptr (gv ___stringlit_1)) by entailer!.
assert_PROP (isptr (gv ___stringlit_2)) by entailer!.
assert_PROP (isptr (gv ___stringlit_3)) by entailer!.
assert_PROP (isptr (gv ___stringlit_4)) by entailer!.
freeze [0;1;2;3] FR1.
forward_call subsume_treebox_new tt.
Intros p.
forward_call subsume_insert (p, 3, gv ___stringlit_1, t_empty nullval).
split. computable. auto.
forward_call subsume_insert (p, 1, gv ___stringlit_2, (t_update (t_empty nullval) 3 (gv ___stringlit_1))).
split. computable. auto.
forward_call subsume_insert (p, 4, gv ___stringlit_3, (t_update
             (t_update (t_empty nullval) 3
                (gv ___stringlit_1)) 1 (gv ___stringlit_2))).
split. computable. auto.
forward_call subsume_insert (p, 1, gv ___stringlit_4,
           (t_update
             (t_update
                (t_update (t_empty nullval) 3
                   (gv ___stringlit_1)) 1
                (gv ___stringlit_2)) 4 (gv ___stringlit_3))).
split. computable. auto.
forward_call subsume_treebox_free ((t_update
             (t_update
                (t_update
                   (t_update (t_empty nullval) 3
                      (gv ___stringlit_1)) 1
                   (gv ___stringlit_2)) 4
                (gv ___stringlit_3)) 1 (gv ___stringlit_4)), p).
forward.
Qed.

End TREE_ABS.

End Abstractions.