(*
 * 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.


     (* Time-stamp: <Mon 2/9/15 16:19 Dan Dougherty Strands.v> *)

(* TO FIX:

 - better name for "path", "is_path", ...

 - can we avoid the default-value trick in the "ith" function?

*)
(* Things to learn how to do:

 1) once you prove "exists x, blah(x)"
    how to introduce, in a Section, a named Variable
    satifying blah, to use>

 2) How to extract minimum elements for a predicate?  Ie. would like a
    function from inhabited predicates to nodes, rturning minimal
    nodes.
*)

(* Add LoadPath "./". *)
(* Add LoadPath "./Classical_Wf". *)
Require Import Classical.
Require Import Message_Algebra.
Require Import Lists.ListSet.
Require Import Lists.List.
Require Import Omega ZArith.

Open Scope list_scope.
Import ListNotations.
Open Scope ma_scope.

(** * The signature (vocabulary) for the models *)
(*  *************************************** *)

Variable node : Set.
(* Variable strand : Set. *)
Definition strand : Type := list smsg.
Variable role : Set.
(* Predicate for positive and negative nodes *)
Variable xmit : node -> Prop.
Variable recv : node -> Prop.

Variable smsg_of : node -> smsg.
Definition msg_of : node -> msg :=
  fun (n:node) => smsg_2_msg (smsg_of n).
Hint Resolve msg_of.

Variable msg_deliver : node -> node -> Prop.
Variable ssucc : node ->  node -> Prop.
Definition path : Type := list (prod node msg).
(* Variable regular_strand : set strand. *)
(* Variable penetrable_strand : set strand.*)
Variable strand_of: node -> strand.
(* Predicates for regular nodes and penetrable nodes *)
Variable p_node : node -> Prop.
Variable r_node : node -> Prop.

(* not needed here...do it in protocol specs *)
(* Variable role_of: strand -> role.   (** maybe should be a relation *) *)

(** * Some defined notions *)
(*  ************************ *)

(** *** Predecessor along a strand *)
Definition spred : node -> node -> Prop := fun x y => ssucc y x.

(** *** Strand-predecessor or message-deliver *)
Definition prec_generator : node -> node -> Prop  :=
  fun n m => ssucc n m \/ msg_deliver n m.

(** *** Transitive closures *)
(*  ------------------- *)

(* Transitive closure of strand-successor *)
Inductive ssuccs (x z: node) : Prop :=
| ssuccs_step : ssucc x z -> ssuccs x z
| ssuccs_trans (y': node) : ssucc x y'-> ssuccs y' z  -> ssuccs x z.

(* Transitive closure of strand-predecessor *)
Inductive spreds (x z: node) : Prop :=
| spreds_step : spred x z -> spreds x z
| spreds_trans (y': node) : spred x y'-> spreds y' z  -> spreds x z.

(* Transitive closure of (ssucc \/ msg_deliver) *)
Inductive prec (x z: node) : Prop :=
| prec_ssucc_step : ssucc x z -> prec x z
| prec_msg_step :  msg_deliver x z -> prec x z
| prec_ssucc_trans (y': node) : ssucc x y'-> prec y' z  -> prec x z
| prec_msg_trans (y': node) : msg_deliver x y'-> prec y' z  -> prec x z.

(** *** Reflexive-Transitive closures *)
(*  ---------------------------- *)

(* Reflexive_Transitive closure of strand-successor *)
Inductive ssuccseq (x z: node) : Prop :=
| ssuccseq_refl : x = z -> ssuccseq x z
| ssuccseq_trans : ssuccs x z -> ssuccseq x z.

(* Reflexive_Transitive closure of strand-predecessor *)
Inductive spredseq  (x z: node) : Prop :=
| spredseq_refl : x = z -> spredseq x z
| spredseq_trans : spreds x z -> spredseq x z.

(* Reflexive_Transitive closure of (ssucc \/ msg_deliver) *)
Inductive preceq  (x z: node) : Prop :=
| preceq_refl : x = z -> preceq x z
| preceq_trans : prec x z -> preceq x z.

(** Minimal nodes *)

Definition is_minimal: (node -> Prop) -> node -> Prop :=
  fun P x => (P x) /\ forall y, (prec y x) -> ~( P y).

Definition has_min_elt: (node -> Prop) -> Prop :=
  fun P  =>   exists x:node, is_minimal P x.

(** *** Origination *)

Definition orig_at : node -> msg -> Prop :=
  fun (n:node) (m:msg) =>
    xmit(n) /\  (ingred m (msg_of n)) /\
    (forall (n':node), ( (ssuccs n' n) ->
      (ingred m (msg_of n')) ->
      False)).

Definition non_orig : msg -> Prop :=
  fun (m:msg) =>
    forall (n:node), ~orig_at n m.

Definition unique : msg -> Prop :=
  fun (m:msg) =>
    (exists (n:node), orig_at n m) /\
    (forall  (n n':node),
      (orig_at n m) /\ (orig_at n' m) ->
      n=n').

(* (*  Need this? *) *)

(* Definition sent_by : node -> msg -> Prop :=  *)
(*   fun (n: node) (m: msg) => *)
(*     exists (n' :node) , (preceq n' n) /\ (msg_of n') = m. *)

(** ** Decidable equality *)
(*  ---------------------------  *)

(** Q: what's the difference between Variable and Axiom here? %\\%
*)
Variable eq_msg_dec : forall x y : msg, {x = y} + {x <> y}.
Hint Resolve eq_msg_dec.
Variable eq_node_dec : forall x y : node, {x = y} + {x <> y}.
Hint Resolve eq_node_dec.
(* Variable eq_strand_dec : forall x y : strand, {x = y} + {x <> y}.
Hint Resolve eq_strand_dec.
*)

(** * Axioms *)
(*  ******** *)

(** ** xmit and recv *)

(** no node is both transmit and receive %\\% *)
Axiom xmit_vs_recv: forall (n:node),  xmit(n) /\ recv(n) -> False.

(** every  node is either transmit or receive %\\% *)
Axiom xmit_or_recv: forall (n: node), xmit n \/ recv n.

(** strand-successor is irreflexive %\\% *)
Axiom ssucc_not_ref: forall (n:node),  ssucc n n -> False.

(** strand-successors are unique %\\% *)
Axiom ssucc_partial_fun:
  forall (n n1 n2: node),  ssucc n n1 /\ ssucc n n2  -> n1 = n2.

(** Every node and its successor are on the same strand *)
Axiom ssucc_same_strand :
  forall (n1 n2 : node), ssucc n1 n2 -> strand_of n1 = strand_of n2.
Hint Resolve ssucc_same_strand.

(** Every sign message of a node must belong to node's strand *)
Axiom smsg_on_strand :
  forall n l, strand_of n = l -> set_In (smsg_of n) l.

(** If a sign message of a node is possitive, then it is a positive node *)
Axiom positive_smsg :
  forall (n:node) (m:msg), smsg_of n = + m -> xmit n.

(** If a sign message of a node is negative, then it is a negative node *)
Axiom negative_smsg :
  forall (n:node) (m:msg), smsg_of n = - m -> recv n.

(** Every regular node lies on a regular strand *)

(** Every penetrator node lies on a penetrator strand *)

(** Lemma for strand_of *)
Lemma ssuccs_same_strand :
  forall (n1 n2 : node), ssuccs n1 n2 -> strand_of n1 = strand_of n2.
Proof.
  intros n1 n2 Hs.
  induction Hs.
  auto.
  assert (Hs' : strand_of x = strand_of y'). auto.
  rewrite IHHs in Hs'. auto.
Qed.

(** ** Message-delivery relation *)
(*  ---------------------------  *)

(** *** Messages match *)
Axiom msg_deliver_ax :
  forall x y : node, (msg_deliver x y) ->
    (xmit x /\ recv y /\ msg_of x = msg_of y).

(** *** The bundle axiom: every received  message was sent  *)
Axiom was_sent : forall x : node, (recv x) ->
  (exists y : node,  msg_deliver y x).

(** ** Well-foundedness *)

(* Better would be to just postulate well_founded for (ssucc \/ msg-deliver)
*)
Axiom wf_prec: well_founded prec.

(** * Theorems *)
(*  ********** *)

(** ** Baby results about xmit and recv *)

Lemma xmit_not_recv: forall n, xmit n -> ~(recv n).
Proof.
  intros.
  unfold not.
  intros.
  apply xmit_vs_recv with (n:=n).
  tauto.
Qed.

Lemma recv_not_xmit: forall n, recv n -> ~(xmit n).
Proof.
  intros n0 H0 H.
  apply xmit_vs_recv with (n:=n0).
  tauto.
Qed.

Lemma not_xmit_recv: forall n,  ~(xmit n) -> (recv n).
Proof.
  unfold not.
  intro.
  assert (a1: (xmit n \/ recv n)).
  exact (xmit_or_recv n).
  tauto.
Qed.

Lemma not_recv_xmit: forall n,  ~(recv n) -> (xmit n).
Proof.
  unfold not.
  intro.
  assert (a1: (xmit n \/ recv n)).
  exact (xmit_or_recv n).
  tauto.
Qed.

(** ** Baby results about prec *)

Theorem prec_transitive:
  forall x y z, (prec x y) -> (prec y z) -> (prec x z).
Proof.
  intros.
  induction H.
  eapply (prec_ssucc_trans). apply H.
  auto.

  eapply (prec_msg_trans). apply H.
  auto.

  eapply (prec_ssucc_trans).
  apply H.
  auto.
  eapply (prec_msg_trans).
  apply H.
  auto.
Qed.

Lemma deliver_prec:
  forall n0 n1, (msg_deliver n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_msg_step; auto.
Qed.

Lemma ssucc_prec:
  forall n0 n1, (ssucc n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_ssucc_step; auto.
Qed.

Lemma ssuccs_prec:
  forall n0 n1, (ssuccs n0 n1) -> (prec n0 n1).
Proof.
  intros.
  induction H.
  apply ssucc_prec; auto.
  assert (prec x y').
  apply ssucc_prec; auto.
  apply prec_transitive with (y:=y'); auto.
Qed.

(** ** Baby results about origination
   Some of these would be axioms, in a first-order axiomatization
*)

(* (these are ugly proofs, I'm just flailing around) :*)

Lemma
  orig_is_sent :
  forall (n : node) (m : msg), orig_at n m ->  (ingred m (msg_of n)).

Proof.
  unfold orig_at.
  tauto.
Qed.

Lemma
  non_not_originate :
  forall (n : node) (m : msg), non_orig m -> orig_at n m -> False.
Proof.
  intros n0 m0 H0.
  unfold non_orig in H0.
  intros H1.
  unfold orig_at in H1.
  destruct H1.
  destruct H1.
  assert (a0: orig_at n0 m0).
  unfold orig_at.
  auto.
  assert (na0: ~ (orig_at n0 m0)).
  apply H0.
  tauto.
Qed.

Lemma
  unique_only_once :
  forall (m : msg) (n n' : node),
    unique m -> orig_at n m -> orig_at n' m -> n = n'.
Proof.
  intros.
  unfold unique in  H.
  destruct H.
  apply H2.
  tauto.
Qed.

Lemma
  orig_not_sent_earlier :
  forall (n n' : node) (m : msg),
    (orig_at n m) ->  (ssucc n' n) ->  (ingred m (msg_of n')) -> False.
Proof.
  intros n0 n'0 m0 H0.
  intros H1.
  intros H2.
  unfold orig_at in H0.
  destruct H0.
  destruct H0.
  apply (H3 n'0).
  apply (ssuccs_step); auto.
  auto.
Qed.

Lemma
  unique_does_originate :
  forall m : msg, unique m -> exists n : node, orig_at n m.
Proof.
  intros.
  unfold unique in H.
  destruct H.
  destruct H.
  exists x. auto.
Qed.

Lemma msg_deliver_prec:
  forall n0 n1, (msg_deliver n0 n1) -> (prec n0 n1).
Proof.
  intros.
  apply prec_msg_step; auto.
Qed.

(** ** Every inhabited predicate has a prec-minimal element *)
Theorem always_min_elt :  forall P: node-> Prop,
  (exists (x:node), (P x)) -> has_min_elt P.
Proof.
  intros.
  destruct H.
  revert x H.
  unfold has_min_elt.
  unfold is_minimal.
  apply (@well_founded_ind node prec (wf_prec)
    (fun x:node =>
      P x -> exists y:node, P y /\ (forall z:node, prec z y  ->   ~ (P z) ))).
  intros.
  case (classic (forall y:node, P y -> ~ prec y x)).
  intros.
  exists x.
  split.
  auto.
  intros.
  assert (a2: P z -> ~ prec z x).
  apply H1.
  tauto.
  intros.
  apply not_all_ex_not in H1.
  destruct H1.
  apply imply_to_and in H1.
  destruct H1.
  apply NNPP in H2.
  apply H with (y:=x0).
  assumption.
  assumption.
Qed.

(** ** prec is acyclic *)

Theorem prec_is_acyclic: forall (x:node), (prec x x) -> False.
Proof.
  intros x H.
  assert (has_min_elt (fun x => prec x x )).
  apply always_min_elt.
  exists x;  auto.
  unfold has_min_elt in H0.
  destruct H0.
  destruct H0.
  assert (prec x0 x0 -> ~ prec x0 x0 ).
  apply H1.
  tauto.
Qed.

(** * Ingredients must originate *)

Section IngredientsOriginate.

  Variable the_m: msg.
  Definition m_ingred (n: node): Prop := ingred the_m (msg_of n).

(** If m is an ingredient somewhere then there is a minimal such place *)

  Lemma
    ingred_min:
    (exists n:node,  (m_ingred n)) ->
    (exists n:node, (is_minimal m_ingred n)).
  Proof.
    intros H.
    apply always_min_elt; auto.
  Qed.

(** A minimal node can't be a reception *)

  Lemma
    minimal_not_recv:
    forall (n:node), (is_minimal m_ingred n) ->
      ~ (recv n).
  Proof.
    unfold not.
    intros.
    unfold is_minimal in H.
    destruct H.
    assert (a1: exists n1, msg_deliver n1 n).
    apply was_sent; auto.

    destruct a1.
    assert (a2: prec x n).
    apply deliver_prec; auto.

    assert (a3: ~(m_ingred x)).
    apply H1; auto.
    assert (a4: m_ingred x).

    assert (a5: msg_of x = msg_of n).
    apply msg_deliver_ax; auto.
    unfold m_ingred.
    unfold m_ingred in H.
    rewrite a5; auto.
    tauto.
  Qed.

(** So, a minimal node must be a transmission *)

  Lemma minimal_is_xmit:   forall (n:node), (is_minimal m_ingred n) ->
    (xmit n).
  Proof.
    intros.
    apply not_recv_xmit.
    apply minimal_not_recv; auto.
  Qed.

(** Main result of this section: an ingredient must originate *)

  Theorem
    ingred_originates_2:
    (exists n:node, (ingred the_m (msg_of n))) ->
    (exists n:node, (orig_at n the_m)).
  Proof.
    intros.
    assert (a1: has_min_elt m_ingred).
    apply always_min_elt.
    unfold m_ingred; auto.
    unfold orig_at.
    unfold has_min_elt in a1.
    destruct a1.
    assert (a0: xmit x).
    apply minimal_is_xmit; auto.

    unfold m_ingred in H0.
    unfold is_minimal in H0.
    destruct H0.
    exists x.
    split.
    auto.
    split.
    auto.
    intros.
    assert (a1: prec n' x).
    apply ssuccs_prec; auto.
    revert H3.
    unfold not in H1.
    apply H1; auto.
  Qed.

End IngredientsOriginate.

(*********************************************************************)

(** * Penetrator Strands *)
Section PenetratorStrand.
  Parameter K_p : set Key.

  Inductive MStrand (s : strand) : Prop :=
  | P_M : forall t : Text, s = [+ (T t)] -> MStrand s.
  Hint Constructors MStrand.

  Inductive KStrand (s : strand) : Prop :=
  | P_K : forall k : Key, set_In k K_p -> s = [+ (K k)] -> KStrand s.
  Hint Constructors KStrand.

  Inductive CStrand (s : strand) : Prop :=
  | P_C : forall (g h : msg), s = [- g; - h; + (P g h)] -> CStrand s.
  Hint Constructors CStrand.

  Inductive SStrand (s : strand) : Prop :=
  | P_S : forall (g h : msg), s = [- (P g h); + g ; + h] -> SStrand s.
  Hint Constructors SStrand.

  Inductive EStrand (s : strand) : Prop :=
  | P_E : forall (k : Key) (h :msg), s = [- (K k); - h; + (E h k)] -> EStrand s.
  Hint Constructors EStrand.

  Inductive DStrand (s : strand) : Prop :=
  | P_D : forall (k k' : Key) (h :msg),
    inv k k' -> s = [- ( K k'); - (E h k); + h] -> DStrand s.
  Hint Constructors DStrand.

  (*Definition PenetratorStrand (s : strand) : Prop :=
    MStrand s \/ KStrand s \/ CStrand s \/ SStrand s \/ EStrand s \/ DStrand s.*)
  Inductive PenetratorStrand (s:strand) :Prop :=
  | PM : MStrand s -> PenetratorStrand s
  | PK : KStrand s -> PenetratorStrand s
  | PC : CStrand s -> PenetratorStrand s
  | PS : SStrand s -> PenetratorStrand s
  | PE : EStrand s -> PenetratorStrand s
  | PD : DStrand s -> PenetratorStrand s.

(* Inductive PenetratorStrand (s : strand) : Prop :=
  | P_M : forall t : Text, s = [+ (T t)] -> PenetratorStrand s
  | P_K : forall k : Key, set_In k K_p -> s = [+ (K k)] -> PenetratorStrand s
  | P_C : forall (g h : msg), s = [- g; - h; + (P g h)] -> PenetratorStrand s
  | P_S : forall (g h : msg), s = [- (P g h); + g ; + h] -> PenetratorStrand s
  | P_E : forall (k : Key) (h :msg), s = [- (K k); - h; + (E h k)] -> PenetratorStrand s
  | P_D : forall (k k' : Key) (h :msg),
          inv k k' -> s = [- ( K k'); - (E h k); + h] -> PenetratorStrand s.
Hint Constructors PenetratorStrand.
*)

(** ** Axiom about penetrator strands and penetrator nodes *)
  Axiom P_node_strand :
    forall (n:node), p_node n -> PenetratorStrand (strand_of n).

(** ** Basic Results for Penetrator Strands *)
(* If n is a node of a MStrand or KStrand, then n is a positive node *)
  Lemma MStrand_xmit_node :
    forall (n:node), MStrand (strand_of n) -> xmit n.
  Proof.
    intros n Hm.
    inversion Hm.
    assert (Hl : set_In (smsg_of n) [+ T t]).
    apply smsg_on_strand. auto.
    elim Hl.
    intros Hp. apply positive_smsg with (m:= T t). auto.
    intros He. elim He.
  Qed.

  Lemma KStrand_xmit_node :
    forall (n:node), KStrand (strand_of n) -> xmit n.
  Proof.
    intros n Hm.
    inversion Hm.
    assert (Hl : set_In (smsg_of n) [+ K k]).
    apply smsg_on_strand. auto.
    elim Hl.
    intros Hp. apply positive_smsg with (m:= K k). auto.
    intros He. elim He.
  Qed.

(** TODO : move to right place *)
  Lemma pair_not_ingred_comp_l :
    forall x y, ~(P x y) <st x.
  Proof.
    intros x y Hst.
    assert (Hlt : size (P x y ) <= size x).
    apply ingred_lt. auto.
    assert (Hgt : size (P x y) > size x).
    simpl. apply size_lt_plus_l. omega.
  Qed.

  Lemma pair_not_ingred_comp_r :
    forall x y, ~(P x y) <st y.
  Proof.
    intros x y Hst.
    assert (Hlt : size (P x y ) <= size y).
    apply ingred_lt. auto.
    assert (Hgt : size (P x y) > size y).
    simpl.
  Admitted.

  Lemma CStrand_not_falling :
    forall (s:strand), CStrand s ->
      ~ exists (n1 n2 : node), recv n1 /\ xmit n2 /\
        strand_of n1 = s /\ strand_of n2 = s /\
        ingred (msg_of n2) (msg_of n1).
  Proof.
    intros s Hcs Hc.
    destruct Hc as (n1,(n2,(Hre, (Hxmit,(Hs1,(Hs2,Hingred)))))).
    assert (Hin1 : set_In (smsg_of n1) s).
    apply smsg_on_strand. auto.
    inversion Hcs.
    assert (Hin2 : set_In (smsg_of n2) s).
    apply smsg_on_strand. auto.
    rewrite H in Hin2. elim Hin2.
    intros. apply xmit_vs_recv with (n:=n2).
    split. auto. apply negative_smsg with (m:= g). auto.
    intros Hin21. elim Hin21.
    intros. apply xmit_vs_recv with (n:=n2).
    split. auto. apply negative_smsg with (m:= h). auto.
    intros Hin22. elim Hin22.
    intros. assert (Hmsg : msg_of n2 = P g h).
    unfold msg_of. symmetry in H0. rewrite H0. unfold smsg_2_msg. auto.
    rewrite H in Hin1. inversion Hin1.
    symmetry in H1. assert (Hmsg1 : msg_of n1 = g).
    unfold msg_of. rewrite H1. unfold smsg_2_msg. auto.
    rewrite Hmsg, Hmsg1 in Hingred. apply (pair_not_ingred_comp_l g h). auto.
    elim H1. intros. symmetry in H2. assert (Hmsg1 : msg_of n1 = h).
    unfold msg_of. rewrite H2. unfold smsg_2_msg. auto.
    rewrite Hmsg, Hmsg1 in Hingred. apply (pair_not_ingred_comp_r g h). auto.
    intros Hin12. elim Hin12. intros. apply xmit_vs_recv with (n:=n1).
    split. auto. apply positive_smsg with (m:=P g h). auto. auto.
    auto. auto.
  Qed.

  Axiom EStrand_not_falling :
    forall (s:strand), EStrand s ->
      ~ exists (n1 n2 : node), n1 <> n2 /\
        strand_of n1 = s /\ strand_of n2 = s /\
        ingred (msg_of n2) (msg_of n1).

End PenetratorStrand.

(*********************************************************************)

(** * New Component *)
(** ** Component of a node *)
(** A message is a component of a node if it is a component
of the message at that node *)
Definition comp_of_node : msg -> node -> Prop :=
  fun (m:msg) (n:node) => comp m (msg_of n).
Notation "x <[node] y" := (comp_of_node x y) (at level 50) : ss_scope.

Lemma msg_deliver_comp :
  forall (n1 n2:node) (m:msg),
    msg_deliver n1 n2 /\
    comp_of_node m n2 -> comp_of_node m n1.
Proof.
  intros.
  destruct H as (H1,H2).
  unfold comp_of_node.
  assert (msg_of n1 = msg_of n2).
  apply msg_deliver_ax. auto.
  rewrite H.
  unfold comp_of_node in H2. auto.
Qed.
Hint Resolve msg_deliver_comp.

Lemma comp_of_node_imp_ingred :
  forall (m:msg) (n:node), m <[node] n -> m <st (msg_of n).
Proof.
  intros.
  unfold comp_of_node in H.
  apply comp_imp_ingred.
  assumption.
Qed.

(** ** New at *)
(** A message is new at a node if it is a component of that node
and the message is not a component of any ealier node in the same
strand with the node *)
Definition new_at : msg -> node -> Prop :=
  fun (m : msg) (n : node) =>
    m <[node] n /\
    forall (n' : node) , ssuccs n' n -> m <[node] n'-> False.

Lemma new_at_imp_comp : forall m n, new_at m n -> m <[node] n.
Proof.
  intros m n H.
  unfold new_at in H.
  apply H.
Qed.

Lemma not_new_exists :
  forall n L, L <[node] n -> ~ new_at L n ->
    exists n', ssuccs n' n /\ L <[node] n'.
Proof.
  unfold not.
  intros n L Hcom Hnnew.
  apply Peirce. intros.
  apply False_ind. apply Hnnew.
  unfold new_at. split.
  assumption.
  intros n' Hssucc Hcomn'.
  apply H. exists n'.
  split; auto.
Qed.

(** ** Basic results about penetrator strands related to components *)
(* A MStrand or KStrand cannot have an edge *)
Lemma MStrand_not_edge :
  forall (s:strand), MStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\ ssuccs n1 n2.
Proof.
intros s Hm Hex.
destruct Hex as (n1, (n2, (Hs1, (Hs2, Hss)))).
inversion Hm.
assert (Hin1 : set_In (smsg_of n1) s). apply smsg_on_strand. auto.
assert (Hin2 : set_In (smsg_of n2) s). apply smsg_on_strand. auto.
rewrite H in Hin1, Hin2. elim Hin1.
intro. elim Hin2.
Admitted.
Axiom KStrand_not_edge :
  forall (s:strand), KStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\ ssuccs n1 n2.

Axiom CStrand_not :
  forall (s:strand), CStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\
    recv n1 /\ xmit n2 /\ ssuccs n1 n2 /\
    exists L1 L2, L1 <[node] n1 /\ L2 <[node] n2 /\ L1 <> L2.

Axiom SStrand_not :
  forall (s:strand), SStrand s -> ~ exists (n1 n2 : node),
    strand_of n1 = s /\ strand_of n2 = s /\
    recv n1 /\ xmit n2 /\ ssuccs n1 n2 /\
    exists L1 L2, L1 <[node] n1 /\ L2 <[node] n2 /\ L1 <> L2.

(*********************************************************************)

(** * Penetrable Keys and Safe Keys *)
(* Penetrable key is already penetrated (K_p) or some regular strand
puts it in a form that could allow it to be penetrated, because for each key
protecting it, the matching key decryption key is already pentrable *)
Section Penetrable_Keys.
  Parameter Kp : Set.
  Parameter Pk : nat -> Key -> Prop.
  Axiom init_pkeys : sig (Pk 0) = Kp.
  Axiom next_pkeys : forall (i:nat) (k:Key), (exists (n:node) (t:msg),
    r_node n /\ xmit n /\ new_at t n /\
    k_ingred (sig (Pk i)) (K k) t) -> Pk (i+1) k.

  Inductive PKeys (k:Key) : Prop :=
  | pkey_step : (exists (i:nat), Pk i k) -> PKeys k.

End Penetrable_Keys.

(*********************************************************************)

(** * Paths *)
Section Path.
(** ** Path condition *)
  Inductive path_cond (m n : node) : Prop :=
  | path_cond_single :  msg_deliver m n -> path_cond m n
  | path_cond_double : ssuccs m n /\ recv(m) /\ xmit(n) -> path_cond m n.
  Hint Constructors path_cond.
  Notation "m |--> n" := (path_cond m n) (at level 30) : ss_scope.

(** ** Path condition implies prec *)
  Lemma path_imp_prec :
    forall (m n:node), m |--> n -> prec m n.
  Proof.
    intros.
    apply path_cond_ind with (m:=m) (n:=n).
    apply deliver_prec.
    intros.
    apply ssuccs_prec. apply H0.
    auto.
  Qed.

(** MAYBE WE CAN AVOID THIS?? *)
  Variable default_n : node.

(** ** ith node of a path *)
  Definition nth_node : nat -> list node -> node :=
    fun (n:nat) (p:list node) => nth n p default_n.
  Hint Resolve nth_node.

(** ** Definitions for paths *)
  Definition is_path : list node -> Prop :=
    fun  (p: list node) => forall (n : nat),
      n < length(p) - 1 ->
      path_cond (nth_node n p ) (nth_node (n+1) p).

(** ** Axiom for paths *)
(** All paths begin on a positive node and end on a negative node *)
  Axiom path_begin_pos_end_neg : forall (p : list node),
    is_path p -> xmit(nth_node 0 p) /\ recv(nth_node (length p - 1)  p).

(** ** Penetrator Paths *)
  Definition p_path : list node -> Prop :=
    fun (p:list node) => is_path p ->
      forall (i:nat), (i > 0 /\ i < length p - 1) ->
        p_node (nth i p default_n).

(** ** Falling paths *)
  Definition falling_path :=
    fun (p:list node) => p_path p -> forall (i:nat), i < length p -1 ->
      ingred (msg_of (nth (i+1) p default_n)) (msg_of (nth i p default_n)).

(** ** Rising paths *)
  Definition rising_path :=
    fun (p:list node) => p_path p -> forall (i:nat), i < length p -1 ->
      ingred (msg_of (nth i p default_n)) (msg_of (nth (i+1) p default_n)).

(** ** Basic results for falling and rising paths *)
  Lemma falling_imp_D_or_S :
    forall (p:list node), falling_path p ->
      forall (i:nat), 0 < i /\ i < length p - 1 /\ recv (nth i p default_n) ->
        DStrand (strand_of (nth i p default_n)) \/
        SStrand (strand_of (nth i p default_n)).
Admitted.

Lemma rising_imp_E_or_C :
  forall (p:list node), rising_path p ->
    forall (i:nat), 0 < i /\ i < length p - 1 /\ recv (nth i p default_n) ->
      EStrand (strand_of (nth i p default_n)) \/
      CStrand (strand_of (nth i p default_n)).
Admitted.

(*********************************************************************)

(** * Edges *)
(** ** Transformed edges *)
(** ** Transforming edges *)

(*********************************************************************)

(* I want to define some constant of type msg here but we don't know any constant
of this type, so I just say it is some variable *)
Variable default_msg : msg.

(** * Transformation paths *)
Section Trans_path.
  Variable p : path.
  Definition ln := fst (split p).
  Hint Resolve ln.
  Definition lm := snd (split p).
  Hint Resolve lm.

  Definition nth_msg : nat -> list msg -> msg :=
    fun (n:nat) (p:list msg) => nth n p default_msg.
  Hint Resolve nth_msg.

  Definition L (n:nat) := nth_msg n lm.
  Hint Resolve L.
  Definition nd (n:nat) := nth_node n ln.
  Hint Resolve nd.

  Definition is_trans_path : Prop :=
    (is_path ln /\
      (True \/
        (ssuccs (nd 0) (nd 1) /\  xmit (nd 0) /\ xmit (nd 1)))) /\
    forall (n:nat), (n < length p -> (L n) <[node] (nd n)) /\
      (n < length p - 1 -> (L n = L (n+1) \/ (L n <> L (n+1) ->
        recv (nd n) /\ xmit (nd (n+1)) /\ ssuccs (nd n) (nd (n+1)) /\
        (exists m, xmit m /\ new_at (L (n+1)) m  /\
          ssuccs (nd n) m /\ ssuccseq m (nd (n+1)))))).

End Trans_path.

(* Baby result : a single pair (n, L) is a trans-foramtion path *)
Open Scope list_scope.
Check [1].
Lemma anode_trans_path :
  forall (n:node) (t:msg),
    t <[node] n -> is_trans_path [(n,t)].
Proof.
  intros n t Hcom.
  unfold is_trans_path.
  simpl. split.
  split. constructor. simpl in H.
  apply False_ind; omega.
  left; auto.
  intros n1; split.
  intro Hn1_lt. assert (n1=0). omega. subst. apply Hcom.
  intros Hn1_lt. apply False_ind. omega.
Qed.

(*********************************************************************)
(** * Proposition 7 *)
Section P7_1.
  Variable pl : path.
  Variable i : nat.
  Let p := fst (split pl).
  Let l := snd (split pl).
  Let p_i := nth_node i p.
  Let p_i1 := nth_node (i+1) p.
  Hypothesis Hc : 0 < i /\ i < length pl - 1.
  Hypothesis Hfp : falling_path p.
  Hypothesis Hrec : recv p_i.
  Hypothesis Hpn : p_node p_i.
  Let s := strand_of p_i.

  Lemma P7_1_aux : DStrand (strand_of p_i) \/ SStrand (strand_of p_i).
  Admitted.

  Lemma P7_1 :
    enc (msg_of p_i) \/ pair (msg_of p_i).

  Admitted.
Section P7_1_a.
  Variable h : msg.
  Variable k : Key.
  Hypothesis Heq : msg_of p_i = E h k.
  Lemma P7_1a :
    EStrand s /\ msg_of p_i1 = h.
Admitted.
End P7_1_a.

Section P7_1_b.
  Variable g h : msg.
  Lemma P7_1_b :
    SStrand s /\ (msg_of p_i1 = h \/ msg_of p_i1 = g).
Admitted.
End P7_1_b.
End P7_1.

(*********************************************************************)

(** * Proposition 10 *)
Section Proposition_10.
  Variable p : path.
  Variable n : nat.
  Hypothesis Htp : is_trans_path p.
  Hypothesis Hn : n < length p - 1.
  Hypothesis Hcom : L p n <> L p (n+1).

(* TODO : move to right place *)
  Lemma ssuccs_trans' :
    forall x y z, ssuccs x y -> ssuccs y z -> ssuccs x z.
  Proof.
    intros x y z Hxy. induction Hxy.
    intros. apply ssuccs_trans with (y':= z0).
    auto. auto.
    intros. apply ssuccs_trans with (y':= y').
    auto.
    apply IHHxy. auto.
  Qed.

  Lemma ssuccs_eq :
    forall x y z, ssuccs x y -> ssuccseq y z -> ssuccs x z.
  Proof.
    intros x y z Hxy Hyz.
    inversion Hyz.
    rewrite H in Hxy. auto.
    apply ssuccs_trans' with (y:=y); auto.
  Qed.

  Lemma trans_path_ssuccs :
      ssuccs (nd p n) (nd p (n+1)) /\ recv (nd p n) /\ xmit (nd p (n+1)).
  Proof.
    unfold is_trans_path in Htp.
    destruct Htp as ((H3,H4),H5).
    remember (H5 n) as H6.
    destruct H6 as (H61, H62).
    remember (H62 Hn) as H7.
    case H7.
    intros. apply False_ind. apply Hcom. auto.
    intros. remember (H Hcom) as H8.
    destruct H8 as (Hrec, (Hxmit, (Hss, (m, (H9, (H10, (H11, H12))))))).
    repeat split.
    apply ssuccs_eq with (y:= m); auto.
    auto.
    auto.
  Qed.

  Lemma Proposition_10 : p_node (nd p n) ->
    ssuccs (nd p n) (nd p (n+1)) /\
    (DStrand (strand_of (nd p n)) \/ EStrand (strand_of (nd p n))).
  Proof.
    intro Hpn.
    assert (Hs : ssuccs (nd p n) (nd p (n + 1)) /\ recv (nd p n) /\ xmit (nd p (n+1))).
    apply trans_path_ssuccs; auto.
    unfold is_trans_path in Htp.
    destruct Htp as (Ha, Hb).
    split.
    apply Hs.

    assert (Hp : PenetratorStrand (strand_of (nd p n))).
    apply (P_node_strand (nd p n)); auto.
    elim Hp.
    intro. apply False_ind. apply (MStrand_not_edge (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    apply Hs.

    intro. apply False_ind. apply (KStrand_not_edge (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand; apply Hs.
    apply Hs.

    intro. apply False_ind. apply (CStrand_not (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    repeat split. apply Hs. apply Hs. apply Hs.
    exists (L p n). exists (L p (n+1)).
    split. apply Hb. omega.
    split. apply Hb with (n:= n+1). omega.
    auto.

    intro. apply False_ind. apply (SStrand_not (strand_of (nd p n))).
    auto.
    exists (nd p n).
    exists (nd p (n+1)).
    split. auto.
    split. symmetry. apply ssuccs_same_strand. apply Hs.
    repeat split. apply Hs. apply Hs. apply Hs.
    exists (L p n). exists (L p (n+1)).
    split. apply Hb. omega.
    split. apply Hb with (n:= n+1). omega.
    auto.

    auto.
    auto.
  Qed.

End Proposition_10.

(*********************************************************************)

(** * Proposition 11 *)
(** For every atomic ingredient of a message, there exists
a component of the message so that the atomic value is
an ingredient of that component *)
Lemma ingred_exists_comp:
  forall m a, atomic a -> a <st m -> exists L, a <st L /\ comp L m.
Proof.
  intros m a Hatom Hingred.
  induction m.
  exists a; split.
  constructor.
  assert (a = T t). apply atomic_ingred_eq; auto.
  subst. apply comp_atomic_cyclic; assumption.

  exists a; split.
  constructor.
  assert (a = K k). apply atomic_ingred_eq; auto.
  subst. apply comp_atomic_cyclic; assumption.

  assert (Hor : ingred a m1 \/ ingred a m2).
  apply ingred_pair. inversion Hatom; discriminate.
  assumption.
  case Hor.
  intro Hst.
  assert (Hex : exists L : msg, ingred a L /\ comp L m1).
  exact (IHm1 Hst). destruct Hex as (L, (HaL, Hcom)).
  exists L; split.
  assumption.
  apply preserve_comp_l; assumption.

  intros Hst.
  assert (Hex : exists L : msg, ingred a L /\ comp L m2).
  exact (IHm2 Hst). destruct Hex as (L, (HaL, Hcom)).
  exists L; split.
  assumption.
  apply preserve_comp_r; assumption.

  assert (Hex : exists L : msg, a <st L /\ L <com m).
  apply IHm. apply ingred_enc with (k:=k).
  inversion Hatom; discriminate.
  assumption.
  destruct Hex as (L, (HaL, Hcom)).
  exists (E m k); split.
  assumption.
  apply comp_simple_cyclic.
  apply simple_step. unfold not. intros Hpair.
  inversion Hpair.
Qed.

Lemma ingred_exists_comp_of_node:
  forall (n:node) (a:msg), atomic a -> a <st (msg_of n)
    -> exists L, a <st L /\ L <[node] n.
Proof.
  intros.
  apply ingred_exists_comp; assumption.
Qed.

Section Proposition11.
  Variable a : msg.
  Variable n : node.
  Definition P_ingred : node -> Prop:=
    fun (n':node) => ssuccs n' n /\ ingred a (msg_of n').

(* Since ssuccs implies prec, if a element x is prec-accessible
then it is ssuccs-accessible *)
  Lemma acc_prec_ssuccs : forall x, Acc prec x -> Acc ssuccs x.
  Proof.
    intros x Hprec.
    induction Hprec. constructor.
    intros. apply H0.
    apply ssuccs_prec; auto.
  Qed.

(* Ssuccs is a well-founded relation *)
(* Notice that every sub-relation of a well-founded relation is
also well-founded *)
  Lemma wf_ssuccs : well_founded ssuccs.
  Proof.
    unfold well_founded. intros x.
    apply acc_prec_ssuccs.
    apply wf_prec.
  Qed.

  Lemma ingred_of_earlier :
    forall (n':node),
      a <st (msg_of n) -> xmit n -> ~ orig_at n a -> exists n', P_ingred n'.
  Proof.
    intros n' Hst Hxmit Hnorig.
    apply Peirce.
    intros.
    apply False_ind.
    apply Hnorig. unfold orig_at.
    repeat split.
    auto.
    auto.
    intros n1 Hssuc Hastn1. apply H.
    exists n1. split; auto.
  Qed.

  Lemma not_orig_exists :
    a <st (msg_of n) -> xmit n -> ~ orig_at n a -> has_min_elt P_ingred.
  Proof.
    intros Hxmit Hst Hnorig.
    apply always_min_elt.
    apply ingred_of_earlier; assumption.
  Qed.

End Proposition11.

(** Backward construction *)
Lemma backward_construction :
  forall (n:node) (a L:msg),
    atomic a -> L <[node] n -> ~ orig_at n a -> a <st L ->
    exists (n':node) (L':msg),
      (msg_deliver n' n \/ ssuccs n' n) /\ a <st L' /\ L' <[node] n' /\
      (L' = L \/ (ssuccs n' n /\ new_at L n)).
Proof.
  intros n a L Hatom Hcom Hnorig Hst.
  assert (Hx_r : xmit n \/ recv n). apply xmit_or_recv.
  case Hx_r.
  Focus 2. intros Hrecv.
  assert (Hex : exists (n':node), msg_deliver n' n).
  apply was_sent. auto.
  destruct Hex as (n', Hmsg_deli).
  exists n'; exists L.
  split. left; auto.
  split. exact Hst.
  split. apply msg_deliver_comp with (n1:=n') (n2:=n).
  split; assumption.
  left. trivial.

  intros Hxmit.
  assert (Hdec : new_at L n \/ ~(new_at L n)). tauto.
  case Hdec.
  intros Hnew.
  assert (Hex2 :exists n1, ssuccs n1 n /\ ingred a (msg_of n1)).
  apply ingred_of_earlier. repeat split; auto.
  apply ingred_trans with (y:=L).
  assumption.
  apply comp_of_node_imp_ingred; assumption.
  assumption.
  assumption.
  destruct Hex2 as (n1, (Hssucc, Hastn1)).
  assert (HexL1 : exists L1, ingred a L1 /\ comp_of_node L1 n1).
  apply ingred_exists_comp_of_node; assumption.
  destruct HexL1 as (L1, (H1, H2)).
  exists n1; exists L1.
  split. right. assumption.
  split. assumption.
  split. assumption.
  right. split; auto.

  intros Hnnew.
  assert (Hex : exists n', ssuccs n' n /\ L <[node] n').
  apply not_new_exists; auto.
  destruct Hex as (n', (Hssucc, Hn)).
  exists n'; exists L.
  split. right. auto.
  split. auto.
  split. assumption.
  left; trivial.
Qed.

Definition Proposition_11_aux : node -> Prop :=
  fun (n':node) =>
    forall (a t:msg),
      atomic a -> a <st t /\ t <[node] n' ->
      exists p, let ln := fst (split p) in
        let lm := snd (split p) in
          is_trans_path p /\
          orig_at (nth_node 0 ln) a /\
          nth_node (length p - 1) ln = n' /\
          nth_msg (length p -1) lm = t /\
          forall (i:nat), i < length p -> a <st (nth_msg i lm).

(* The main result *)
Lemma proposition11 :
  forall (n':node), Proposition_11_aux n'.
Proof.
  apply well_founded_ind with (R:=prec).
  exact wf_prec.
  intros.
  unfold Proposition_11_aux.
  unfold Proposition_11_aux in H.
  intros.
  destruct H1 as (H1, H2).
  assert (orig_at x a \/ ~ orig_at x a). tauto.
  case H3.
  intros.
  exists (cons (x, t) nil).
  simpl. split.
  apply anode_trans_path with (n:=x) (t:=t). exact H2.
  split; auto; split; auto; split; auto.
  intros.
  assert (i=0). omega.
  rewrite H6;auto.

  intros.
  assert (Hex : exists (n':node) (L':msg),
    (msg_deliver n' x \/ ssuccs n' x) /\ a <st L' /\ L' <[node] n' /\
    (L' = t \/ (ssuccs n' x /\ new_at t x))).
  apply backward_construction; assumption.
  destruct Hex as (n', (L', (Hor, (Hst, (Hcom, Hlast))))).
  assert (IH : forall a t : msg,
    atomic a ->
    a <st t /\ t<[node]n' ->
    exists p : list (node * msg),
      is_trans_path p /\
      orig_at (nth_node 0 (fst (split p))) a /\
      nth_node (length p - 1) (fst (split p)) = n' /\
      nth_msg (length p - 1) (snd (split p)) = t /\
      (forall i : nat, i < length p -> a <st nth_msg i (snd (split p)))).
  apply H with (y:= n'). case Hor.
  apply msg_deliver_prec.
  apply ssuccs_prec.
  assert (Hex2 : exists p : list (node * msg),
    is_trans_path p /\
    orig_at (nth_node 0 (fst (split p))) a /\
    nth_node (length p - 1) (fst (split p)) = n' /\
    nth_msg (length p - 1) (snd (split p)) = L' /\
    (forall i : nat, i < length p -> a <st nth_msg i (snd (split p)))).
  apply IH. assumption. split; assumption.
  destruct Hex2 as (p0, (Hex2, (Hex3, (Hex4, (Hex5, Hex6))))).
  assert (orig_at n' a \/ ~orig_at n' a). tauto.
  case H5.
  intro Horign'.
  exists ((n', L')::(x,t)::nil). simpl.
  split. admit.
  split. auto.
  split. auto.
  split. auto.
  intros. assert (i=0 \/ i=1). omega.
  case H7.
  intro. subst; auto.
  intro; subst; auto.
  intro Hnorig.
  exists (p0++(n',L')::nil).
Admitted.

(*********************************************************************)

(** * Proposition 13 *)
Section P13.
  Variable pl : path.
  Let p := fst (split pl).
  Let l := snd (split pl).
  Hypothesis Hpp : p_path p.
  Hypothesis Hp1 : simple (msg_of (nth_node 0 p)).
  Definition P13_1_aux (n:nat) : Prop :=
    msg_of (nth_node n p) = (nth_msg (length p - 1) l) /\
    forall (i:nat), i >= n -> i <= length p - 1 ->
      nth_msg i l = nth_msg (length p - 1) l.
  Lemma P13_1 :
    exists (n:nat), P13_1_aux n /\
      (forall m, m > n -> ~ P13_1_aux m) /\
      exists i, i < length p - 1 -> nth_msg i l <> nth_msg (i+1) l ->
        xmit (nth_node n p) /\ EStrand (strand_of (nth_node n p)).
Admitted.
End P13.
End Path.


Inductive tp : Set :=
  | tp_nat: tp
  | tp_exp: tp -> tp -> tp.
Hint Constructors tp.

Notation "t -o t0" := (tp_exp t t0) (at level 51, right associativity).

Inductive term : tp -> Set :=
  | ap: forall {a b : tp}, term (a -o b) -> term a -> term b
  | sub: forall {a b c : tp}, term ((a -o b -o c) -o (a -o b) -o a -o c)
  | const: forall {a b : tp}, term (a -o b -o a)
  | zero: term tp_nat
  | succ: term (tp_exp tp_nat tp_nat)
  | rec: forall {a : tp}, term (tp_nat -o (tp_nat -o a -o a) -o a -o a).
Hint Constructors term.

Notation "x * y" := (ap x y) (at level 40, left associativity).

Fixpoint eval_tp (a : tp) : Set :=
  match a with
    | tp_nat => nat
    | a -o a0 => (eval_tp a) -> (eval_tp a0)
  end.

Inductive step : forall {a}, term a -> term a -> Set :=
  | step_ap_1: forall {a b} (f f0 : term (b -o a)) (x : term b),
    step f f0 -> step (f*x) (f0*x)
  | step_ap_2: forall {a b} (f : term (b -o a)) (x x0 : term b),
    step x x0 -> step (f*x) (f*x0)
  | step_const: forall {a b} x y, step ((@const a b)*x*y) x
  | step_subs: forall {a b c} x y z, step ((@sub b c a)*x*y*z) (x*z*(y*z))
  | step_zero: forall {a} f x, step ((@rec a)*zero*f*x) x
  | step_succ: forall {a} f x n, step ((@rec a)*(succ*n)*f*x) (f*n*(rec*n*f*x)).
Hint Constructors step.

Inductive terminates {a} (x : term a) : Prop :=
  terminates_intro: (forall y, step x y -> terminates y) -> terminates x.
Hint Constructors terminates.

Ltac value :=
  match goal with
  | [  |- terminates ?X ] => apply terminates_intro; intros y H; inversion H
  end.

Lemma const_val {a b}: terminates (@const a b).
Proof.  value.  Qed.

Lemma const_x_val {a b}:
  forall x, terminates x -> terminates ((@const a b) * x).
Proof.
  intros.
  apply terminates_intro.
  intros.
  inversion H0.
  (* TODO *)
Admitted.

(* Tait's hereditary termination predicate *)
Fixpoint ht a (x : term a) : Prop :=
  match a, x with
  | tp_nat, x => terminates x
  | tp_exp b c, x => terminates x /\ forall y, ht b y -> ht c (x * y)
  end.

Lemma ht_terminates a (x : term a) : ht a x -> terminates x.
Proof.
  intros H; unfold ht in H; induction a; compute; apply H.
Qed.

Lemma ht_ap:
  forall {a b} (x : term (a -o b)) (y : term a),
  ht _ x -> ht _ y -> ht _ (x * y).
Proof.
  intros.
  inversion H.
  apply H2.
  apply H0.
Qed.
Hint Resolve ht_ap.

Theorem hereditary_termination: forall a (x : term a), ht a x.
Proof.
  induction x.
            inversion IHx1; apply ht_ap; assumption.
          admit.
        unfold ht; fold ht; split.
          apply const_val.
        fold ht; intros y H; split.
          apply const_x_val.
          apply ht_terminates; assumption.
        intros z IH.
        induction a; compute; fold ht.
        apply terminates_intro; intros y' Hs; inversion Hs.
        (* TODO *)
Admitted.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Set Transparent Obligations.

Program Instance Cat : Category := {
obj     := Category;
hom     := @Functor;
homset  := @Functor_Setoid;
id      := @Id;
compose := @Compose;

compose_respects := @Compose_respects
}.

Record Isomorphism_FullyFaithful `(iso : C ≅ D) := {
to_full       : Full (to iso);
to_faithful   : Faithful (to iso);
from_full     : Full (from iso);
from_faithful : Faithful (from iso)
}.

Theorem Cat_Iso_FullyFaithful `(iso : C ≅ D) :
let φ := to iso in
let ψ := from iso in
let η x := to (`1 (iso_from_to iso) x) in
let μ x := to (`1 (iso_to_from iso) x) in

(∀ x, fmap[φ] (η x) ≈ μ (φ x)) ->
(∀ x, fmap[ψ] (μ x) ≈ η (ψ x)) ->
Isomorphism_FullyFaithful iso.
Proof. hammer_hook "Cat" "Cat.Cat_Iso_FullyFaithful".
construct.
- construct.
+ exact (to (`1 (iso_from_to iso) y)
∘ fmap[from iso] g
∘ from (`1 (iso_from_to iso) x)).
+ abstract
(proper;
now rewrite X1).
+ abstract
(simpl;
rewrite fmap_id, id_right;
now apply iso_to_from).
+ abstract
(simpl;
comp_left;
comp_right;
rewrite <- !comp_assoc;
rewrite (comp_assoc (`1 (iso_from_to iso) y)⁻¹);
rewrite (iso_from_to (`1 (iso_from_to iso) y)), id_left;
now apply fmap_comp).
+ abstract
(simpl;
rewrite !fmap_comp;
srewrite X;
srewrite (`2 (iso_to_from iso));
rewrite !comp_assoc;
rewrite iso_to_from, id_left;
srewrite_r X;
rewrite <- comp_assoc;
rewrite <- fmap_comp;
rewrite iso_to_from, fmap_id, id_right;
reflexivity).
- construct.
abstract
(rewrite <- id_left;
rewrite <- id_right;
symmetry;
rewrite <- id_left;
rewrite <- id_right;
symmetry;
spose (`2 (iso_from_to iso)) as X2;
rewrite <- (iso_to_from (`1 (iso_from_to iso) y));
rewrite <- (iso_to_from (`1 (iso_from_to iso) x));
rewrite <- !comp_assoc;
rewrite (comp_assoc _ f _);
rewrite (comp_assoc _ g _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite <- (X2 x y f);
rewrite <- (X2 x y g);
comp_left;
comp_right;
now apply (@fmap_respects D C iso⁻¹)).
- construct.
+ exact (to (`1 (iso_to_from iso) y)
∘ fmap[to iso] g
∘ from (`1 (iso_to_from iso) x)).
+ abstract
(proper;
now rewrite X1).
+ abstract
(simpl;
rewrite fmap_id, id_right;
now apply iso_to_from).
+ abstract
(simpl;
comp_left;
comp_right;
rewrite <- !comp_assoc;
rewrite (comp_assoc (`1 (iso_to_from iso) y)⁻¹);
rewrite (iso_from_to (`1 (iso_to_from iso) y)), id_left;
now apply fmap_comp).
+ abstract
(simpl;
rewrite !fmap_comp;
srewrite X0;
srewrite (`2 (iso_from_to iso));
rewrite !comp_assoc;
rewrite iso_to_from, id_left;
srewrite_r X0;
rewrite <- comp_assoc;
rewrite <- fmap_comp;
rewrite iso_to_from, fmap_id, id_right;
reflexivity).
- construct.
abstract
(rewrite <- id_left;
rewrite <- id_right;
symmetry;
rewrite <- id_left;
rewrite <- id_right;
symmetry;
spose (`2 (iso_to_from iso)) as X2;
rewrite <- (iso_to_from (`1 (iso_to_from iso) y));
rewrite <- (iso_to_from (`1 (iso_to_from iso) x));
rewrite <- !comp_assoc;
rewrite (comp_assoc _ f _);
rewrite (comp_assoc _ g _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite (comp_assoc (_ ∘ _) _ _);
rewrite <- (X2 x y f);
rewrite <- (X2 x y g);
comp_left;
comp_right;
now apply (@fmap_respects C D (to iso))).
Defined.