(*
 * 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  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 [? ?]].
(* Goal: @eq t (@projT1 t (fun f : t => and (@join t J b c f) (@join t J a f e)) (@existT t (fun f : t => and (@join t J b c f) (@join t J a f e)) f (@conj (@join t J b c f) (@join t J a f e) j j0))) (@projT1 t (fun f : t => and (@join t J b c f) (@join t J a f e)) (@existT t (fun f : t => and (@join t J b c f) (@join t J a f e)) g (@conj (@join t J b c g) (@join t J a g e) j1 j2))) *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @eq A a (@core A J SA a) *)
 generalize (core_unit a); unfold unit_for; intro.
(* Goal: @join A J (@core A J SA a) (@core A J SA a) (@core A J SA a) *)
 generalize (core_unit (core a)); unfold unit_for; intro.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
 generalize (join_core H); intro.
(* Goal: @join A J (@core A J SA a) (@core A J SA a) (@core A J SA a) *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @join A J a a a *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @eq A a (@core A J SA a) *)
 generalize (core_unit a); unfold unit_for; intro.
(* Goal: @eq A (@core A J SA (@core A J SA a)) (@core A J SA a) *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
 generalize (join_core H); intro.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
  generalize (join_core (join_comm H)); intro.
(* Goal: @join A J (@core A J SA a) (@core A J SA b) (@core A J SA c) *)
 rewrite H0; rewrite H1.
(* Goal: @join A J (@core A J SA a) (@core A J SA a) (@core A J SA a) *)
(* Goal: @eq A (@core A J SA a) a *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @eq A a (@core A J SA a) *)
 generalize (join_core H); rewrite core_idem; intro.
(* Goal: @eq A a (@core A J SA a) *)
 rewrite <- H0 in H.
(* Goal: @eq A a (@core A J SA a) *)
 clear dependent c.
(* Goal: @eq A a (@core A J SA a) *)
 generalize (core_unit a); unfold unit_for; intro.
(* Goal: @eq A x y *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: forall (a b ea eb : A) (_ : @join_sub A J a b) (_ : @unit_for A J ea a) (_ : @unit_for A J eb b), @eq A ea eb *)
 unfold unit_for.
(* Goal: @join A J a a a *)
 replace a with (core a).
(* Goal: @join A J (@core A J SA a) (@core A J SA a) (@core A J SA a) *)
(* Goal: @eq A (@core A J SA a) a *)
 apply core_duplicable.
(* Goal: @eq A (@core A J SA a) a *)
 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.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: not (@identity A JA x) *)
 generalize  (@core_unit _ _ SA1 x); unfold unit_for; intro.
(* Goal: not (@identity A JA x) *)
 generalize  (@core_unit _ _ SA2 x); unfold unit_for; intro.
(* Goal: @eq A e1 e2 *)
 destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (@core_unit _ _ SA2 (@core _ _ SA1 x)); unfold unit_for; intro.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (@core_unit _ _ SA1 (@core _ _ SA2 x)); unfold unit_for; intro.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 destruct (join_assoc ( H4) H2) as [g [? ?]].
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 destruct (join_assoc H5 (join_comm H2)) as [h [? ?]].
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (join_eq H6 (join_comm H8)); intro. rewrite <- H10 in *; clear dependent h.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (@join_core _ _ SA1 _ _ _ H4); intro.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (@join_core _ _ SA1 _ _ _ H0); intro.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 generalize (@join_core _ _ SA2 _ _ _ H0); intro.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 rewrite H11 in *. rewrite H12 in *. rewrite H10 in *.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 apply join_comm in H4.
(* Goal: @eq t (@core t J SA1 x) (@core t J SA2 x) *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
intros. generalize H; intro.
(* Goal: @eq A (@core A J SA a) (@core A J SA b) *)
apply join_comm in H.
(* Goal: @eq A (@core A J SA a) (@core A J SA b) *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @identity A JA a *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @identity A J e *)
 destruct (join_assoc (join_comm H) (join_comm H)) as [? []].
(* Goal: @identity A JA a *)
 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.
(* Goal: forall (a b : A) (_ : @join_sub A JA a b) (_ : @nonidentity A JA PA a), @overlap A JA a b *)
  repeat intro.
(* Goal: @eq A y z *)
  eapply join_eq; eauto.
(* Goal: @join A J (@core A J SA a) a0 a0 *)
  replace (core a) with (core a0); [apply core_unit|].
(* Goal: @eq A (@core A J SA a0) (@core A J SA a) *)
  symmetry; rewrite <- core_idem.
(* Goal: @eq A (@core A J SA (@core A J SA a)) (@core A J SA a0) *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @join_sub A J a a *)
 exists (core a).
(* Goal: prod (@identity A J (@core A J SA a)) (@unit_for A J (@core A J SA a) a) *)
 split.
(* Goal: @identity A JA (@core A JA SA a) *)
 apply core_identity.
(* Goal: @join A J (@core A J H a) a a *)
(* Goal: @join A J (@core A J H a) b b *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @eq A a (@core A J SA a) *)
  symmetry; apply H.
(* Goal: @join A J a (@core A J SA a) a *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 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.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @eq A ea eb *)
 unfold unit_for in *.
(* Goal: @eq A e e' *)
 destruct (join_assoc (join_comm H1) (join_comm H3)) as [f [? ?]].
(* Goal: @eq A e e' *)
 generalize (H0 _ _ H4); intro.
(* Goal: @eq A e e' *)
 generalize (H2 _ _ (join_comm H4)); intro.
(* Goal: @eq A e e' *)
 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.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
intros.
(* Goal: @eq A e1 e2 *)
generalize (unit_identity _ H0); intro.
(* Goal: @eq A ea eb *)
unfold unit_for in *.
(* Goal: @eq A e1 e2 *)
destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
(* Goal: @eq A e1 e2 *)
generalize (H2 _ _ H3); intro.
(* Goal: @eq A e1 e2 *)
rewrite <- H5 in *; clear f H5.
(* Goal: @eq A e1 e2 *)
apply join_comm in H3.
(* Goal: @eq A e1 e2 *)
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.
(* Goal: forall (a b c : A) (_ : @join A J a b c), @join_sub A J b c *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
    split; intro; destruct H;
(* Goal: @join A JA ea ea ea *)
      exists x; apply join_comm; trivial.
  Qed.

  Lemma joins_sym': forall {A} `{Perm_alg A} {phi1 phi2}, joins phi1 phi2 -> joins phi2 phi1.
  Proof.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
   intros.
(* Goal: @joins A J phi2 phi1 *)
   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.
(* Goal: forall (a b c : A) (_ : @join A J a b c), @join_sub A J b c *)
    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.
(* Goal: forall (a b c : A) (_ : @join A J a b c), @join_sub A J b c *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @join_sub A J a a *)
    exists (core a). apply join_comm.
(* Goal: @join A J (@core A J H a) a a *)
(* Goal: @join A J (@core A J H a) b b *)
    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.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros. destruct H0; destruct H1.
(* Goal: @join_sub A J a c *)
    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.
(* Goal: forall (e a b : A) (_ : @unit_for A J e a) (_ : @join_sub A J a b), @unit_for A J e b *)
    unfold unit_for; intros ???? [].
(* Goal: @join A J e b b *)
    destruct (join_assoc H H0) as [b' []].
(* Goal: @join A J e b b *)
    assert (b' = b) by (eapply join_eq; eauto).
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @eq A e e' *)
  destruct H4.
(* Goal: @eq A ea eb *)
  unfold unit_for in *.
(* Goal: @eq A e e' *)
  destruct (join_assoc (join_comm H1) H4) as [f [? ?]].
(* Goal: @eq A e e' *)
   generalize (H0 _ _ H5); intro.
(* Goal: @eq A e e' *)
   rewrite <- H7 in *; clear dependent f.
(* Goal: @eq A e e' *)
   destruct (join_assoc H5 (join_comm H6)) as [g [? ?]].
(* Goal: @eq A e e' *)
   generalize (join_eq H4 (join_comm H7)); intro.
(* Goal: @eq A e e' *)
   rewrite <- H9 in *; clear dependent g.
(* Goal: @join A JA ea ea ea *)
   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.
(* Goal: forall (a b : A) (_ : @join_sub A J a b) (_ : @joins A J a b), @joins A J a a *)
    intros a b [? ?] [? ?].
(* Goal: @joins A J a a *)
    apply join_comm in H0.
(* Goal: @joins A J a a *)
    destruct (join_assoc H H0) as [? [? ?]].
(* Goal: @joins A J a a *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @joins A J a b *)
    destruct H as [wx ?].
(* Goal: @joins A J a b *)
    destruct H0 as [wy ?].
(* Goal: @joins A J a b *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @join_sub A J a c *)
    destruct H; destruct H0; destruct H1.
(* Goal: @joins A J a b *)
    destruct (join_assoc (join_comm H) H1) as [f [? ?]].
(* Goal: @joins A J a b *)
    destruct (join_assoc (join_comm H0) (join_comm H2)) as [g [? ?]].
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: @join A JA ea ea ea *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @same_silhouette A J HA phiz phiz' *)
    intro phiu.
(* Goal: iff (@joins A J phiu phiz) (@joins A J phiu phiz') *)
    split; intros [phix ?].
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    destruct (join_assoc H0 (join_comm H2)) as [phif [? ?]].
(* Goal: @joins A J phiu phiz *)
    specialize (H phif).
(* Goal: @eq A ea eb *)
    destruct H.
    assert (exists phiz, join phi phif phiz) by eauto.
    assert (joins phif phi) by (apply joins_sym;  auto).
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    specialize (H H7).
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    clear H5 H6 H7.
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    destruct H as [phix' ?].
(* Goal: @joins A J phiu phiz *)
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    generalize (join_eq H1 (join_comm H5)); intro.
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    rewrite <- H7 in *. clear phig H7 H5.
(* Goal: @joins A J phiu phiz *)
    exists phix'.
(* Goal: @join A JA ea ea ea *)
    auto.
(* Goal: @joins A J phiu phiz *)
    destruct (join_assoc H1 (join_comm H2)) as [phif [? ?]].
(* Goal: @joins A J phiu phiz *)
    specialize (H phif).
(* Goal: @eq A ea eb *)
    destruct H.
    assert (exists phiz, join phi' phif phiz) by eauto.
    assert (joins phif phi') by (apply joins_sym;  auto).
(* Goal: @joins A J phiu phiz *)
    specialize (H5 H7).
(* Goal: @joins A J phiu phiz *)
    clear H H6 H7.
(* Goal: @joins A J phiu phiz *)
    destruct H5 as [phix' ?].
(* Goal: @joins A J phiu phiz *)
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
(* Goal: @joins A J phiu phiz *)
    generalize (join_eq H0 (join_comm H5)); intro.
(* Goal: @joins A J phiu phiz' *)
(* Goal: @joins A J phiu phiz *)
    rewrite <- H7 in *; clear phig H7 H5.
(* Goal: @joins A J phiu phiz *)
    exists phix'.
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: forall (a b ea eb : A) (_ : @join_sub A J a b) (_ : @unit_for A J ea a) (_ : @unit_for A J eb b), @eq A ea eb *)
    unfold unit_for.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @eq A ea eb *)
    destruct H.
(* Goal: @eq A ea eb *)
    destruct (join_assoc H0 H) as [f [? ?]].
(* Goal: @eq A ea eb *)
    generalize (join_eq H H2); intro.
(* Goal: @eq A ea eb *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
   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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @eq A ea eb *)
    unfold unit_for in *.
(* Goal: @join A JA ea ea ea *)
    destruct (join_assoc (join_comm H) (join_comm H)) as [f [? _]].
(* Goal: @join A JA ea ea ea *)
    generalize (unit_identity _ H); intro.
(* Goal: @join A JA ea ea ea *)
    generalize (H1 _ _ H0); intro.
(* Goal: @join A JA ea ea ea *)
   rewrite <- H2 in H0; clear f H2.
(* Goal: @join A JA ea ea ea *)
   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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @eq A ea eb *)
    destruct H.
(* Goal: @eq A ea eb *)
    unfold unit_for in *.
(* Goal: @eq A ea eb *)
    destruct (join_assoc (join_comm H0) H) as [f [? ?]].
(* Goal: @eq A ea eb *)
    generalize (unit_identity _ H0 _ _ H2); intro.
(* Goal: @eq A ea eb *)
    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.
(* Goal: forall a : A, @sigT A (fun e : A => and (@identity A JA e) (@joins A JA e a)) *)
    intro x.
(* Goal: @sigT A (fun e : A => and (@identity A JA e) (@joins A JA e x)) *)
    destruct (join_ex_identity x) as [e [? ?]].
(* Goal: @join A JA ea ea ea *)
   exists e; split; auto.
(* Goal: @join A JA ea ea ea *)
   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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros. destruct H0.
(* Goal: @unit_for A J e a *)
    generalize (H a x H0); intro.
(* Goal: @unit_for A J e a *)
    rewrite <- H1 in *; clear x H1.
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: forall (a b : A) (_ : @join_sub A JA a b) (_ : @nonidentity A JA PA a), @overlap A JA a b *)
    repeat intro.
(* Goal: @join A JA ea ea ea *)
    apply identity_unit; trivial.
(* Goal: @joins A JA a a *)
    exists a.
(* Goal: @join A JA a a a *)
    destruct (join_ex_units a) as [ea H0].
(* Goal: @join A JA a a a *)
    generalize (join_comm H0); intro.
(* Goal: @join A JA a a a *)
    generalize (H ea a H1); intro.
(* Goal: @join A JA a a a *)
    rewrite <- H2 in *; clear a H2.
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: iff (@identity A JA a) (@unit_for A JA a a) *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @identity A JA a *)
    destruct H1.
(* Goal: @join A JA ea ea ea *)
    assert (e2 = x) by auto.
(* Goal: @eq A x z *)
    apply join_comm in H1.
(* Goal: @join A JA ea ea ea *)
    assert (e1 = x) by auto.
(* Goal: @eq A e1 e2 *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 intros.
(* Goal: @identity A JA a *)
 apply identity_core in H0.
(* Goal: @identity A JA a *)
 rewrite H0 in H.
 erewrite split_core' by eauto.
(* Goal: @identity A JA (@core A JA SA a) *)
 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.
(* Goal: forall (a b c : A) (_ : @nonidentity A JA PA a) (_ : @join A JA a b c), @nonidentity A JA PA c *)
    intros a b c H H0 H1.
(* Goal: False *)
    contradiction H.
(* Goal: @join A JA ea ea ea *)
    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.
(* Goal: forall (x y : A) (_ : @join_sub A JA x y) (_ : @join_sub A JA y x), @eq A x y *)
    intros ? ? [? ?] [? ?].
(* Goal: @eq A x y *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @identity A JA a *)
    generalize (join_sub_joins H H0); intro.
(* Goal: @identity A JA a *)
    destruct H1.
(* Goal: @identity A JA a *)
    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.
(* Goal: forall (a b : A) (_ : @join_sub A JA a b) (_ : @nonidentity A JA PA a), @overlap A JA a b *)
    repeat intro.
(* Goal: False *)
    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.
(* Goal: @join A JA ea ea ea *)
Proof with auto.
(* Goal: forall (e e' a c : A) (_ : @identity A J e) (_ : @unit_for A J e a) (_ : @identity A J e') (_ : @unit_for A J e' c) (_ : @join_sub A J a c), @eq A e e' *)
 pose proof I. (* hack: shift up auto-named hyps *)
  split; intro.
  intros a'' ?.
  destruct H1 as [a' ?].
  specialize (H0 a').
(* Goal: False *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @ex A (fun e : A => and (@join A J e a a) (@join A J e b b)) *)
    red in H0.
(* Goal: prod (@identity A J (@core A J SA a)) (@unit_for A J (@core A J SA a) a) *)
    exists (core a); split.
(* Goal: @join A J (@core A J H a) a a *)
(* Goal: @join A J (@core A J H a) b b *)
    apply core_unit.
(* Goal: @join A J (@core A J H a) a a *)
(* Goal: @join A J (@core A J H a) b b *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
    intros.
(* Goal: @comparable A J H a b *)
    destruct H0 as [e [H1 H2]].
(* Goal: @comparable A J SA phi1 phi2 *)
    unfold comparable.
(* Goal: @eq A (@core A J H a) (@core A J H b) *)
    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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @comparable A J SA phi1 phi2 *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @comparable A J SA phi1 phi2 *)
  unfold comparable.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
  generalize (join_core H); intro.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
  generalize (join_core (join_comm H)); intro.
(* Goal: @eq A (@core A J SA phi1) (@core A J SA phi2) *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
  intros.
(* Goal: @comparable A J SA a c *)
  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.
(* Goal: forall (a c : A) (_ : @joins A J a c), @comparable A J SA a c *)
  intros a c H0.
(* Goal: @comparable A J SA a c *)
  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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
intros.
(* Goal: @eq A y z *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
intros.
(* Goal: @eq A x z *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
Proof. intros.
(* Goal: @eq (@Perm_alg T J) sa1 sa2 *)
destruct sa1, sa2.
(* Goal: @eq (@Perm_alg T J) (@mkPerm T J join_eq0 join_assoc0 join_comm0 join_positivity0) (@mkPerm T J join_eq1 join_assoc1 join_comm1 join_positivity1) *)
f_equal; try apply proof_irr.
(* Goal: @eq (forall (a b c d e : T) (_ : @join T J a b d) (_ : @join T J d c e), @sigT T (fun f : T => and (@join T J b c f) (@join T J a f e))) join_assoc0 join_assoc1 *)
extensionality a b c d e H1 H2.
(* Goal: @eq (@sigT T (fun f : T => and (@join T J b c f) (@join T J a f e))) (join_assoc0 a b c d e H1 H2) (join_assoc1 a b c d e H1 H2) *)
destruct (join_assoc1 a b c d e H1 H2) as [f [? ?]].
(* Goal: @eq (@sigT T (fun f : T => and (@join T J b c f) (@join T J a f e))) (join_assoc0 a b c d e H1 H2) (@existT T (fun f : T => and (@join T J b c f) (@join T J a f e)) f (@conj (@join T J b c f) (@join T J a f e) j j0)) *)
destruct (join_assoc0 a b c d e H1 H2) as [f0 [? ?]].
(* Goal: @eq (@sigT T (fun f : T => and (@join T J b c f) (@join T J a f e))) (@existT T (fun f : T => and (@join T J b c f) (@join T J a f e)) f0 (@conj (@join T J b c f0) (@join T J a f0 e) j1 j2)) (@existT T (fun f : T => and (@join T J b c f) (@join T J a f e)) f (@conj (@join T J b c f) (@join T J a f e) j j0)) *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
intros.
(* Goal: @eq (@Sep_alg T J) sa1 sa2 *)
generalize (@core_uniq _ J _ sa1 sa2); intro.
(* Goal: @eq (@Sep_alg T J) sa1 sa2 *)
destruct sa1; destruct sa2.
(* Goal: @eq (@Sep_alg T J) (@mkSep T J core0 core_unit0 join_core0) (@mkSep T J core1 core_unit1 join_core1) *)
simpl in H.
(* Goal: @eq (@Sep_alg T J) (@mkSep T J core0 core_unit0 join_core0) (@mkSep T J core1 core_unit1 join_core1) *)
assert (core0 = core1).
(* Goal: @join A JA ea ea ea *)
  extensionality; auto.
(* Goal: @eq (@Sep_alg T J) (@mkSep T J core0 core_unit0 join_core0) (@mkSep T J core1 core_unit1 join_core1) *)
subst core1.
(* Goal: @eq (@Sep_alg T J) (@mkSep T J core0 core_unit0 join_core0) (@mkSep T J core0 core_unit1 join_core1) *)
f_equal.
(* Goal: @eq (forall (a b c : T) (_ : @join T J a b c), @eq T (core0 a) (core0 c)) join_core0 join_core1 *)
apply proof_irr.
(* Goal: @eq (forall (a b c : T) (_ : @join T J a b c), @eq T (core0 a) (core0 c)) join_core0 join_core1 *)
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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
 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.
(* Goal: forall (x : A) (_ : @nonunit A JA x), not (@identity A JA x) *)
Proof. intros. intro.
(* Goal: False *)
  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].
