Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.
Unset Printing Implicit Defensive.
Typeclasses eauto := 1.

Require Import ssreflect List Basic LAF LAFwE.

Section LAFwEL.

  Definition RenamingContexts `{QuantifyingStructureswE} w
    := ContextswE w.(PLab) w.(NLab) w.(QLab).

  Fixpoint ExtstL2Extst `{QSwE : QuantifyingStructureswE}
           w st st'
           (qnew: @Dec
                    (QLab (wextendsE st' w))
                    (PLab (wextendsE st' w))
                    (NLab (wextendsE st' w)) st)
  : @Dec (QLab (wextendsE st' w)) unit unit st
    :=
      match qnew with
        | leafP _ => leafP tt
        | leafN _ => leafN tt
        | dummy => dummy
        | node _ _ qnew1 qnew2 => node (ExtstL2Extst qnew1) (ExtstL2Extst qnew2)
        | qnode _ t qnew' => qnode t (ExtstL2Extst qnew')
      end.

  Definition QSTypeswEL2QSTypeswE_base `(QSwE : QuantifyingStructureswE)
             AtomV
             MoleculeV
             is_eqV
             (RC:forall w, RenamingContexts w)
             (ExtrenL : forall (w:World _) st, RC (wextendsE st w) w)
             (ExtstL : forall (w:World _) st, @Dec
                                           (QLab (wextendsE st w))
                                           (PLab (wextendsE st w))
                                           (NLab (wextendsE st w)) st)
             is_eq_renV
  : QSTypeswE (AtomV := AtomV) MoleculeV is_eqV
    :=
      {|
        Extren w st := readE (ExtrenL w st);
        Extst w st := ExtstL2Extst (ExtstL w st);
        is_eq_ren := is_eq_renV
      |}.

  Class QSTypeswEL `{QuantifyingStructureswE} AtomV MoleculeV is_eqV is_eq_renV
    :=
      {
        RC      : forall w, RenamingContexts w;
        ExtrenL : forall (w:World _) st, RC (wextendsE st w) w;
        ExtstL  : forall (w:World _) st, @Dec
                                      (QLab (wextendsE st w))
                                      (PLab (wextendsE st w))
                                      (NLab (wextendsE st w)) st;
        QSTwELasQSTwE := QSTypeswEL2QSTypeswE_base (AtomV := AtomV)
                                                  (MoleculeV:= MoleculeV)
                                                  (is_eqV := is_eqV)
                                                  (RC := RC)
                                                  ExtrenL ExtstL
                                                  is_eq_renV;
        RCrenProp w : renProp (RC w);
        RCstProp w : stProp (RC w)
      }.

  Coercion QSTwELasQSTwE: QSTypeswEL >-> QSTypeswE.
  (* Canonical QSTypeswEL2QSTypeswE `(QSTypeswEL) := QSTypeswEL2QSTypeswE_base MoleculeV is_eqV. *)

  Class LAFswEL `{QSTwEL: QSTypeswEL} {PatternsV PatDecV PatternsTypedV}
    := {
        asLAFwE :
        LAFswE (QSTV:=QSTwEL)
             (PatternsV := PatternsV) (PatDecV := PatDecV) (PatternsTypedV := PatternsTypedV);
        Renmap w0 w1 w2 : RC w0 w1 -> RC w1 w2 -> RC w0 w2;
        RenmapProp w0 w1 w2 (pi1:RC w0 w1) (pi2:RC w1 w2)
        : ContMap (H := asLAFwE) (readE pi1) (readp pi1) (readn pi1) pi2 (Renmap pi1 pi2);

        freeE {qLab : Type} : Terms qLab -> qLab -> Prop;

        mapdistrib (qLab qLab' : QWorld (asLAF (LAFswE := asLAFwE)))
                   (w: World (asLAF (LAFswE := asLAFwE)))
                   (f1: Inst Atom qLab -> Inst Atom qLab')
                   (f2: Inst Molecule qLab -> Inst Molecule qLab')
                   (Gamma: TCV qLab w)
                   st
                   (Delta: @Dec (Sorts (QSwE2QS asLAFwE))
                            (Inst Atom qLab')
                            (Inst Molecule qLab')
                            st)
                   (Delta': @Dec (Sorts (QSwE2QS asLAFwE))
                                 (Inst Atom qLab)
                                 (Inst Molecule qLab)
                                 st)
        : Declift (fun s1 s2 => s1 = s2)
                  (fun c c' => c = f1 c')
                  (fun c c' => c = f2 c')
                  Delta Delta'
          -> ContMap (H := asLAFwE) (fun i => i) (fun i => i) (fun i => i)
                    (TCmap f1 f2 (extends Delta' Gamma)) (extends Delta (TCmap f1 f2 Gamma))
      }.

  Coercion asLAFwE : LAFswEL >-> LAFswE.

  Context `(L:LAFswEL).

  Definition renaminglift {w wnew} st (rho: RC wnew w)
    := extends (ExtstL wnew st) (Renmap (ExtrenL wnew st) rho).

  Fixpoint liftP {w wnew : World asLAF} (rho:RC wnew w) (tp:Pos w) {struct tp}
  : Pos wnew
    := match tp with
          pos p v  => pos p (liftTree rho v)
      end
  with liftTree {w wnew : World asLAF}{st} (rho:RC wnew w) (v: @TermDec asLAF w st) {struct v}
       : TermDec wnew st
       := match v with
           | tleafP xp => tleafP (readp rho xp)
           | tleafN tn => tleafN (liftN rho tn)
           | tdummy => tdummy wnew
           | tnode _ _ v1 v2 => tnode (liftTree rho v1) (liftTree rho v2)
           | tqnode _ t v' => tqnode
                               (LAF := asLAF (LAFswE := L))
                               (lift2Terms (readE rho) t) (liftTree rho v')
         end
  with liftN {w wnew} (rho:RC wnew w) (tn:@Neg asLAF w) {struct tn}
       : Neg wnew
       := match tn with
             rei f => rei (fun p => liftOC (renaminglift (PatDec p) rho) (f p))
         end
  with liftOC {w wnew: World asLAF} (rho:RC wnew w) (oc:OptionCommand w) {struct oc}
       : OptionCommand wnew
       := match oc with
           | none => none wnew
           | some c => some(liftC rho c)
         end
  with liftC {w wnew: World asLAF} (rho:RC wnew w) (c:Command w)  {struct c}
       : Command wnew
       := match c with
           | cut tn tp => cut (liftN rho tn) (liftP rho tp)
           | select xn tp => select (readn rho xn) (liftP rho tp)
         end
  .

  Fixpoint freeP
           {w : World (asLAF (LAFswE := L))}
           {A:World asLAF -> Type}
           (leafPf: forall w, w.(PLab) -> A w -> Prop)
           (leafNf: forall w, w.(NLab) -> A w -> Prop)
           (qnodef: forall w, Terms (q:= asLAF) w.(QLab) -> A w -> Prop)
           (read: forall wnew w, RC wnew w -> A w -> A wnew)
           (tp:Pos w) (xp: A w) {struct tp}
  : Prop
    := match tp with
          pos p v  => freeDec leafPf leafNf qnodef read v xp
      end
  with freeDec {w : World asLAF}
               {A:World asLAF -> Type}
               (leafPf: forall w, w.(PLab) -> A w -> Prop)
               (leafNf: forall w, w.(NLab) -> A w -> Prop)
               (qnodef: forall w, Terms (q:= asLAF) w.(QLab) -> A w -> Prop)
               (read: forall wnew w, RC wnew w -> A w -> A wnew)
               {st} (v: @TermDec asLAF w st) (xp:A w) {struct v}
       : Prop
       := match v with
           | tleafP xp' => leafPf w xp' xp
           | tleafN tn => freeN leafPf leafNf qnodef read tn xp
           | tdummy => False
           | tnode _ _ v1 v2 => (freeDec leafPf leafNf qnodef read v1 xp)
                               \/(freeDec leafPf leafNf qnodef read v2 xp)
           | tqnode _ t v' => (qnodef w t xp)
                             \/(freeDec leafPf leafNf qnodef read v' xp)
         end
  with freeN {w: World asLAF}
              {A:World asLAF -> Type}
              (leafPf: forall w, w.(PLab) -> A w -> Prop)
              (leafNf: forall w, w.(NLab) -> A w -> Prop)
              (qnodef: forall w, Terms (q:= asLAF) w.(QLab) -> A w -> Prop)
              (read: forall wnew w, RC wnew w -> A w -> A wnew)
              (tn:@Neg asLAF w) (xp:A w) {struct tn}
       : Prop
       := match tn with
             rei f => exists p, freeOC (w:=wextends (PatDec p) w) leafPf leafNf qnodef read
                                 (f p) (read _ _ (ExtrenL w (PatDec p)) xp)
         end
  with freeOC {w: World asLAF}
               {A:World asLAF -> Type}
               (leafPf: forall w, w.(PLab) -> A w -> Prop)
               (leafNf: forall w, w.(NLab) -> A w -> Prop)
               (qnodef: forall w, Terms (q:= asLAF) w.(QLab) -> A w -> Prop)
               (read: forall wnew w, RC wnew w -> A w -> A wnew)
               (oc:OptionCommand w) (xp:A w) {struct oc}
       : Prop
       := match oc with
           | none => False
           | some c => freeC leafPf leafNf qnodef read c xp
         end
  with freeC {w: World asLAF}
              {A:World asLAF -> Type}
              (leafPf: forall w, w.(PLab) -> A w -> Prop)
              (leafNf: forall w, w.(NLab) -> A w -> Prop)
              (qnodef: forall w, Terms (q:= asLAF) w.(QLab) -> A w -> Prop)
              (read: forall wnew w, RC wnew w -> A w -> A wnew)
              (c:Command w) (xp:A w) {struct c}
       : Prop
       := match c with
           | cut tn tp => (freeN leafPf leafNf qnodef read tn xp)
                         \/(freeP leafPf leafNf qnodef read tp xp)
           | select xn tp => (leafNf w xn xp)
                            \/(freeP leafPf leafNf qnodef read tp xp)
         end
  .

  Definition freepP w := freeP (w:=w) (fun w xp' xp => xp=xp') (fun _ _ _ => False) (fun _ _ _ => False) (fun wnew w rho xp => readp rho xp).
  Definition freepN w := freeN (w:=w) (fun w xp' xp => xp=xp') (fun _ _ _ => False) (fun _ _ _ => False) (fun wnew w rho xp => readp rho xp).
  Definition freepDec w st := freeDec (w:=w) (st:=st) (fun w xp' xp => xp=xp') (fun _ _ _ => False) (fun _ _ _ => False) (fun wnew w rho xp => readp rho xp).
  Definition freepOC w := freeOC (w:=w) (fun w xp' xp => xp=xp') (fun _ _ _ => False) (fun _ _ _ => False) (fun wnew w rho xp => readp rho xp).
  Definition freepC w := freeC (w:=w) (fun w xp' xp => xp=xp') (fun _ _ _ => False) (fun _ _ _ => False) (fun wnew w rho xp => readp rho xp).

  Definition freenP w := freeP (w:=w) (fun _ _ _ => False) (fun w xn' xn => xn=xn') (fun _ _ _ => False) (fun wnew w rho xn => readn rho xn).
  Definition freenN w := freeN (w:=w) (fun _ _ _ => False) (fun w xn' xn => xn=xn') (fun _ _ _ => False) (fun wnew w rho xn => readn rho xn).
  Definition freenDec w st := freeDec (w:=w) (st:=st) (fun _ _ _ => False) (fun w xn' xn => xn=xn') (fun _ _ _ => False) (fun wnew w rho xn => readn rho xn).
  Definition freenOC w := freeOC (w:=w) (fun _ _ _ => False) (fun w xn' xn => xn=xn') (fun _ _ _ => False) (fun wnew w rho xn => readn rho xn).
  Definition freenC w := freeC (w:=w) (fun _ _ _ => False) (fun w xn' xn => xn=xn') (fun _ _ _ => False) (fun wnew w rho xn => readn rho xn).

  Definition freeEP w := freeP (w:=w) (fun _ _ _ => False) (fun _ _ _ => False) (fun w t xq => freeE t xq) (fun wnew w rho xq => readE rho xq).
  Definition freeEN w := freeN (w:=w) (fun _ _ _ => False) (fun _ _ _ => False) (fun w t xq => freeE t xq) (fun wnew w rho xq => readE rho xq).
  Definition freeEDec w st := freeDec (w:=w) (st:=st) (fun _ _ _ => False) (fun _ _ _ => False) (fun w t xq => freeE t xq) (fun wnew w rho xq => readE rho xq).
  Definition freeEOC w := freeOC (w:=w) (fun _ _ _ => False) (fun _ _ _ => False) (fun w t xq => freeE t xq) (fun wnew w rho xq => readE rho xq).
  Definition freeEC w := freeC (w:=w) (fun _ _ _ => False) (fun _ _ _ => False) (fun w t xq => freeE t xq) (fun wnew w rho xq => readE rho xq).

  Definition embeds {qLab w1 w2}
             (Gamma1: TCV (LAFswE := L) qLab w1)
             (Gamma2: TCV qLab w2)
             (rho: RC w2 w1) :=
    (forall xq:w1.(QLab), Gamma2.(readE) (rho.(readE) xq) = Gamma1.(readE) xq)
    /\
    (forall xp:w1.(PLab), Gamma2.(readp) (rho.(readp) xp) = (Gamma1.(readp) xp))
    /\
    (forall xn:w1.(NLab), Gamma2.(readn) (rho.(readn) xn) = (Gamma1.(readn) xn))
  .

  Remark Rem1 (w wnew : World (asLAF (LAFswE:= L))) st (rho: RC wnew w)
  : forall xq: w.(QLab),
      (readE (renaminglift st rho) (readE (ExtrenL w st) xq))
      =
      (readE (ExtrenL wnew st)) (readE rho xq)
  .
  Proof.
    move => xq.
    rewrite RCrenProp.
    refine ((fun H => _ )(RenmapProp (ExtrenL wnew st) rho)).
    elim: H0 => H0 _.
    rewrite H0 => //.
  Qed.

  Remark Rem2
         (qLab1 qLab2: QWorld (asLAF (LAFswE:= L)))
         (w1 w2 : World (asLAF (LAFswE:= L)))
         (Gamma1: TCV qLab1 w1)
         (Gamma2: TCV qLab2 w2)
         st
         (rho: RC w2 (wextendsE st w1))
         (Delta: @Dec (Sorts (QSwE2QS L))
                       (Inst Atom qLab2)
                       (Inst Molecule qLab2)
                       st)
         (Delta': @Dec (Sorts (QSwE2QS L))
                  (Inst Atom qLab1)
                  (Inst Molecule qLab1)
                  st)
         (f1: Inst Atom qLab1 -> Inst Atom qLab2)
         (f2: Inst Molecule qLab1 -> Inst Molecule qLab2)
  :
    Declift (fun s1 s2 => s1 = s2)
            (fun c c' => c = f1 c')
            (fun c c' => c = f2 c')
            Delta Delta'
    -> embeds (extends Delta (TCmap f1 f2 Gamma1)) Gamma2 rho
    -> embeds (TCmap f1 f2 (extends Delta' Gamma1)) Gamma2 rho.
  Proof.
    move => H0 [H1 [H2 H3]].
    move: (mapdistrib Gamma1 H0) => [H4 [H5 H6]].
    by split;
    [ move => xq; rewrite H1 H4
    | split ;
      [move => xp; rewrite H2 H5
      | move => xn; rewrite H3 H6]
    ].
  Qed.

  Hypothesis RenamingCorrelation
  : forall (qLab: QWorld (asLAF (LAFswE:= L)))
      (w1 w2 : World (asLAF (LAFswE:= L)))
      (Gamma1: TCV qLab w1)
      (Gamma2: TCV qLab w2)
      (rho: RC w2 w1)
      st
      (Delta: @Dec (Sorts (QSwE2QS L))
               (Inst Atom qLab)
               (Inst Molecule qLab)
               st),
      embeds Gamma1 Gamma2 rho
      -> embeds (extends Delta Gamma1) (extends Delta Gamma2) (renaminglift st rho).

  Lemma Lem55:
    forall (w wnew: World (asLAF (LAFswE:= L)))
      (rho: RC wnew w)
      st st' ls delta delta'
      (Delta:TypingDec st ls),
      Declift (st := st)
              (fun s s' => s = readE(renaminglift st' rho) s')
              (fun c c' => True)
              (fun c c' => True)
              delta
              delta'
      ->
      forall (tl: TList (wextends st' w).(QLab) ls),
      Declift (st := st)
              (fun s s' => s = s')
              (fun c c' => c = renInst (readE(renaminglift st' rho)) c')
              (fun c c' => c = renInst (readE(renaminglift st' rho)) c')
              (InstTypingDec delta (renTList (readE(renaminglift st' rho)) tl) Delta)
              (InstTypingDec delta' tl Delta).
  Proof.
    move => w wnew rho st st' l delta delta' Delta.
    induction Delta => H0 tl //.

    move: H0.
    move: (Decstruct (snode s1 s2) delta) => [v1 [v2 Hdelta]].
    rewrite Hdelta.
    move: (Decstruct (snode s1 s2) delta') => [v1' [v2' Hdelta']].
    rewrite Hdelta'.
    simpl.
    move => [H1 H2].
    by split; [apply (IHDelta1 v1 v1') | apply (IHDelta2 v2 v2')].

    move: H0.
    move: (Decstruct (sqnode s) delta) => [v0 [t Hdelta]].
    rewrite Hdelta.
    move: (Decstruct (sqnode s) delta') => [v0' [t' Hdelta']].
    rewrite Hdelta'.
    simpl.
    move => [H0 H1].
    split =>//.
    rewrite H0.
    move:(IHDelta v0 v0' H1 (TermCons so (asT t') tl)).
    simpl.
    by rewrite lift2Terms_asT.
  Qed.

  Lemma Lem55bis
        (w wnew: World (asLAF (LAFswE:= L)))
        (rho: RC wnew w)
        st st' ls delta delta'
        (Delta:TypingDec st ls)
  : Declift (st := st)
            (fun s s' => s = readE(renaminglift st' rho) s')
            (fun c c' => True)
            (fun c c' => True)
            delta
            delta'
    ->
    forall (tl: TList w.(QLab) ls),
      Declift (st := st)
              (fun s1 s2 => s1 = s2)
              (fun c c' => c = renInst (readE(renaminglift st' rho)) c')
              (fun c c' => c = renInst (readE(renaminglift st' rho)) c')
              (InstTypingDec delta
                             (renTList (readE (ExtrenL wnew st')) (renTList (readE rho) tl))
                             Delta)
              (InstTypingDec delta'
                             (renTList (readE (ExtrenL w st')) tl)
                             Delta).
  Proof.
    move => H0 tl.
    refine (_ (_ :renTList (readE (ExtrenL wnew st')) (renTList (readE rho) tl)
               = renTList (readE(renaminglift st' rho)) (renTList (readE (ExtrenL w st')) tl))).
    move => H1.
    rewrite H1.
    apply Lem55 => //.
    rewrite -(renTList_comp (f3 := comp (readE (ExtrenL wnew _)) (readE rho))).
    rewrite (renTList_comp (f3 := comp (readE (ExtrenL wnew _)) (readE rho))
                           (f2 := readE (renaminglift _ rho))
                           (f1 := readE (ExtrenL w _))
            ) => //.
    by move => xq; rewrite /comp -Rem1.
    by move => xq; rewrite /comp.
  Qed.

  Remark Rem3 (w wnew: World (asLAF (LAFswE:= L))) st0 st delta delta'
      (rho: RC wnew w)
  :
    Declift (st := st)
      (fun (s : QLab (wextendsE st0 wnew)) (xq : QLab (wextendsE st0 w)) =>
         s = readE (extends (ExtstL wnew st0) (Renmap (ExtrenL wnew st0) rho)) xq)
      (fun (_ : PLab (wextendsE st0 wnew)) (_ : unit) => True)
      (fun (_ : NLab (wextendsE st0 wnew)) (_ : unit) => True)
      delta delta' ->
    Declift
      (fun (s : QLab (wextendsE st0 wnew)) (s' : QLab (wextendsE st0 w)) =>
         s = readE (extends (ExtstL wnew st0) (Renmap (ExtrenL wnew st0) rho)) s')
      (fun _ _ : unit => True) (fun _ _ : unit => True)
      (ExtstL2Extst delta) delta'.
  Proof.
    induction st.
    move: (Decstruct sleafP delta) => [a H0]; rewrite H0 => //.
    move: (Decstruct sleafN delta) => [a H0]; rewrite H0 => //.
    move: (Decstruct sdummy delta) => H0; rewrite H0 => //.
    move: (Decstruct (snode st1 st2) delta) => [delta1 [delta2 H0]]; rewrite H0 => //.
    move: (Decstruct (snode st1 st2) delta') => [delta1' [delta2' H0']]; rewrite H0'; simpl;
     move => [H1 H2].
    split;[apply IHst1 | apply IHst2] => //.
    move: (Decstruct (sqnode st) delta) => [delta0 [t H0]]; rewrite H0.
    move: (Decstruct (sqnode st) delta') => [delta0' [t' H0']]; rewrite H0'; simpl.
    move => [H1 H2]; split =>//.
    apply IHst => //.
  Qed.

  Lemma Lem55ter:
    forall (w wnew: World (asLAF (LAFswE:= L)))
      (rho: RC wnew w)
      st ls
      (Delta:TypingDec st ls)
      (tl: TList w.(QLab) ls),
      Declift (st := st)
              (fun s1 s2 => s1 = s2)
              (fun c c' => c = renInst (readE(renaminglift st rho)) c')
              (fun c c' => c = renInst (readE(renaminglift st rho)) c')
              (InstTypingDec (ExtstL2Extst (ExtstL wnew st))
                             (renTList (readE (ExtrenL wnew st)) (renTList (readE rho) tl))
                             Delta)
              (InstTypingDec (ExtstL2Extst (ExtstL w st))
                             (renTList (readE (ExtrenL w st)) tl)
                             Delta).
  Proof.
    intros.
    apply Lem55bis.
    rewrite /renaminglift.
    refine ((fun H =>_) (RCstProp)).
    refine (_ (H0 (wextendsE st wnew))).
    clear H0.
    rewrite /stProp => H0.
    refine (_ (H0 w st (Renmap (ExtrenL wnew st) rho) (ExtstL wnew st))).
    clear H0.
    rewrite /Extst.
    simpl.
    apply Rem3.
  Qed.

  Definition Tembeds {w1 w2 : World (asLAF (LAFswE:= L))}
             (Gamma1: TCV w1.(QLab) w1)
             (Gamma2: TCV w2.(QLab) w2)
             (rho: RC w2 w1) :=
    embeds (TCmap (renInst (readE rho)) (renInst (readE rho)) Gamma1) Gamma2 rho.

  Lemma Lem56 :
    forall (w wnew : World (asLAF (LAFswE:= L)))
      (Gamma1: TCV w.(QLab) w)
      (Gamma2: TCV wnew.(QLab) wnew)
      (rho: RC wnew w)
      st ls
      (Delta:TypingDec st ls)
      (tl: TList w.(QLab) ls),
      Tembeds Gamma1 Gamma2 rho
      ->
      Tembeds
        (extends
           (InstTypingDec (ExtstL2Extst (ExtstL w st))
                          (renTList (readE (ExtrenL w st)) tl) Delta)
           (TCmap (renInst (readE (ExtrenL w st)))
                  (renInst (readE (ExtrenL w st))) Gamma1))
        (extends
           (InstTypingDec (ExtstL2Extst (ExtstL wnew st))
                          (renTList (readE (ExtrenL wnew st))
                                    (renTList (readE rho) tl)) Delta)
           (TCmap (renInst (readE (ExtrenL wnew st)))
                  (renInst (readE (ExtrenL wnew st))) Gamma2))
        (renaminglift st rho).
  Proof.
    move => w wnew Gamma1 Gamma2 rho st ls Delta tl.
    rewrite /Tembeds.
    rewrite{1}/embeds.
    elim  => H0 [H1 H2].
    apply: (Rem2 (Delta := (InstTypingDec (ExtstL2Extst (ExtstL wnew st))
           (renTList (readE (ExtrenL wnew st)) (renTList (readE rho) tl))
           Delta))).
    apply: Lem55ter.
    apply: RenamingCorrelation.
    refine (_ (TCmapProp (renInst (readE (ExtrenL wnew st)))
                         (renInst (readE (ExtrenL wnew st))) Gamma2));
      move => [H3 [H4 H5]].
    refine (_ (TCmapProp  (renInst (readE (renaminglift st rho)))
                          (renInst (readE (renaminglift st rho)))
                          (TCmap (renInst (readE (ExtrenL w st)))
                                 (renInst (readE (ExtrenL w st))) Gamma1)));
      move => [H6 [H7 H8]].
    refine (_ (TCmapProp (renInst (readE (ExtrenL w st)))
                         (renInst (readE (ExtrenL w st)))
                         Gamma1));
      move => [H9 [H10 H11]].
    refine (_ (TCmapProp (renInst (readE rho))
                         (renInst (readE rho))
                         Gamma1)); move => [H12 [H13 H14]].
    split.
    move => xq.
    rewrite H3 H6 H9 H0 H12 => //.
    split;
      [
        move => xp;
        rewrite H4 H7 H10 H1 H13
      | move => xn;
        rewrite H5 H8 H11 H2 H14
      ];
    (rewrite -(renInst_comp (f3 := comp (readE (ExtrenL wnew st)) (readE rho)));
    [ apply (renInst_comp (f3 := comp (readE (ExtrenL wnew st)) (readE rho)));
    by move => xq; rewrite /comp -Rem1
    | by move => xq; rewrite /comp]).
  Qed.

  Theorem RenamingTyping:
    forall (w:World (asLAF (LAFswE := L))) (Gamma1: TContext w),
      (forall pt A,
         PosTyping Gamma1 pt A
         -> forall wnew (Gamma2: TContext wnew) (rho: RC wnew w),
             Tembeds Gamma1 Gamma2 rho
             -> PosTyping Gamma2 (liftP rho pt) (renInst (readE rho) A))
      /\ (forall l st (v:TermDec w st) Delta tl,
           DecTyping (l:=l) Gamma1 v Delta tl
           -> forall wnew (Gamma2: TContext wnew) (rho: RC wnew w),
               Tembeds Gamma1 Gamma2 rho
               -> DecTyping Gamma2 (liftTree rho v) Delta (renTList (readE rho) tl))
      /\ (forall nt A,
           NegTyping Gamma1 nt A
           -> forall wnew (Gamma2: TContext wnew) (rho: RC wnew w),
               Tembeds Gamma1 Gamma2 rho
               -> NegTyping Gamma2 (liftN rho nt) (renInst (readE rho) A))
      /\ (forall c,
           OptionCommandTyping Gamma1 c
           -> forall wnew (Gamma2: TContext wnew) (rho: RC wnew w),
               Tembeds Gamma1 Gamma2 rho
               -> OptionCommandTyping Gamma2 (liftOC rho c))
      /\ (forall c,
           CommandTyping Gamma1 c
           -> forall wnew (Gamma2: TContext wnew) (rho: RC wnew w),
               Tembeds Gamma1 Gamma2 rho
               -> CommandTyping Gamma2 (liftC rho c)).
  Proof.
    apply typing_ind;intros;
    [
      apply: (typingpos p0) => //; apply: H0 => //
    | by elim: H0 => H1 [H3 _]; apply: typingsub_leafl;
                 rewrite /Treadp;
                 simpl;
                 rewrite (H3 xp);
                 move: (TCmapProp (renInst (readE rho))(renInst (readE rho)) Gamma) => [_ [H4 _]];
                 rewrite H4;
                 apply (is_eq_ren i)
    | by apply: typingsub_leafr; apply H0 => //;
      move => xq; move :(H1 xq);
      move: (TCmapProp (renInst (readE rho))(renInst (readE rho)) Gamma) => [H2 _];
      rewrite H2
    | by apply: typingsub_dummy
    | by apply: typingsub_node; [apply H0| apply H1] => //
    | by apply: typingsub_qnode;
      [ apply: (renSorting _ s0); elim: H1 => H1 _ ;
          move => xq; move :(H1 xq);
          move: (TCmapProp (renInst (readE rho))(renInst (readE rho)) Gamma) => [H2 _];
          rewrite H2
      | apply H0 => // ]
    | apply typingneg
    | by apply: typingoption; apply: H0
    | by apply: (typingcut (A:= (renInst (readE rho) A))); [ apply H0 | apply H1]
    |
    ].

    move => p c H2;
           remember (f p) as d;
           move: Heqd (e p);
           elim: (f p);
           [ move => c0 _; by apply
           | move => H3; move: c H2; rewrite H3 => c Hc; inversion Hc
           ].

    move => p Delta H2; apply : (H0 p Delta) => //.
    simpl.
    rewrite /getA/getTerms; simpl.
    apply Lem56 => //.

    by elim: (H1) => _ [_ H2] /=;
    move: (H2 xn); clear H2;
    move : (rho.(readn) xn) => b H2; apply: typingselect;
    rewrite /Treadn;
    simpl;
    rewrite H2;
    move: (TCmapProp (renInst (readE rho))(renInst (readE rho)) Gamma) => [_ [_ H3]];
    rewrite H3;
    apply H0.
  Qed.

End LAFwEL.


Require Import VST.msl.msl_standard.
Require Import VST.msl.ghost.
Require Import VST.msl.Coqlib2.
Require Import VST.veric.shares.

Module Type ADR_VAL.
Parameter address : Type.
Parameter some_address:address.

(* Validity of traces.  The "valid" predicate ensures that related addresses don't get
    split apart from each other.  *)
Parameter kind: Type.
End ADR_VAL.

Inductive TypeTree: Type :=
  | ConstType: Type -> TypeTree
  | Mpred: TypeTree
  | DependentType: nat -> TypeTree
  | ProdType: TypeTree -> TypeTree -> TypeTree
  | ArrowType: TypeTree -> TypeTree -> TypeTree
  | SigType: forall (I : Type), (I -> TypeTree) -> TypeTree
  | PiType: forall (I : Type), (I -> TypeTree) -> TypeTree
  | ListType: TypeTree -> TypeTree.

Definition dependent_type_functor_rec (ts: list Type): TypeTree -> functor :=
  fix dtfr (T: TypeTree): functor :=
  match T with
  | ConstType A => fconst A
  | Mpred => fidentity
  | DependentType n => fconst (nth n ts unit)
  | ProdType T1 T2 => fpair (dtfr T1) (dtfr T2)
  | ArrowType T1 T2 => ffunc (dtfr T1) (dtfr T2)
  | SigType _ f => fsig (fun i => dtfr (f i))
  | PiType _ f => fpi (fun i => dtfr (f i))
  | ListType T => flist (dtfr T)
  end.
Opaque dependent_type_functor_rec.

Definition dependent_type_function_rec (ts: list Type) (mpred': Type): TypeTree -> Type :=
  fix dtfr (T: TypeTree): Type :=
  match T with
  | ConstType A => A
  | Mpred => mpred'
  | DependentType n => nth n ts unit
  | ProdType T1 T2 => (dtfr T1 * dtfr T2)%type
  | ArrowType T1 T2 => dtfr T1 -> dtfr T2
  | SigType A f => sigT (fun a => dtfr (f a))
  | PiType A f => forall a, dtfr (f a)
  | ListType T => list (dtfr T)
  end.

Definition fpreds: functor :=
  fsig (fun T: TypeTree =>
    fpi (fun ts: list Type => dependent_type_functor_rec ts T)).

Lemma realize_eq: forall {A} (a b: A) P, (exists H: a = b, P H) -> {H: a = b & P H}.
Proof.
  intros ???? []; subst; exists eq_refl; auto.
Qed.

Lemma lower_join_inv : forall {A} {J: Join A} a b c, lower_join J a b c <->
  match a, b, c with
  | Some a, Some b, Some c => join a b c
  | Some a, None, Some c | None, Some a, Some c => a = c
  | None, None, None => True
  | _, _, _ => False
  end.
Proof.
  split.
  - inversion 1; subst; auto; destruct c; auto.
  - destruct a, b, c; intros; subst; try contradiction; try constructor; auto.
Qed.

Module Type STRAT_MODEL.
  Declare Module AV : ADR_VAL.
  Import AV.

  Inductive res (PRED : Type) : Type :=
    | NO':  forall sh: Share.t, ~(readable_share sh) -> res PRED
    | YES': forall sh: Share.t, readable_share sh -> kind -> fpreds PRED -> res PRED
    | PURE': kind -> fpreds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (g:B->A)(x:res A) : res B :=
    match x with
      | NO' rsh nsh => NO' B rsh nsh
      | YES' sh rsh k pds => YES' B sh rsh k (fmap fpreds f g pds)
      | PURE' k pds => PURE' B k (fmap fpreds f g pds)
    end.
  Axiom ff_res : functorFacts res res_fmap.
  Definition f_res : functor := Functor ff_res.

  Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
    | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
                                     (NO' PRED sh3 nsh3)
    | res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
                              join sh1 sh2 sh3 ->
              res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).
  Axiom pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Proof. intros.
            apply mkSep
             with (fun x => match x
                             with NO' _ _ => NO' _ Share.bot bot_unreadable
                               | YES' _ _ _ _ => NO' _ Share.bot bot_unreadable
                               | PURE' k pds => PURE' _ k pds end).
            intro. destruct t; constructor; try apply join_unit1; auto.
            intros. inversion H; auto.
  Defined.

  Axiom paf_res : @pafunctor f_res res_join.

  Definition res_option (PRED : Type) (r: res PRED) : option (rshare * kind):=
    match r with
      | NO' _ _ => None
      | YES' sh rsh k _ => Some (readable_part rsh,k)
      | PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
    end.

  Definition ghost (PRED : Type) : Type :=
    list (option ({g: Ghost & {a: @G g | ghost.valid a}} * fpreds PRED)%type).

  Definition ghost_fmap (A B:Type) (f:A->B) (g:B->A)(x:ghost A) : ghost B :=
    fmap (flist (foption (fpair (fconst _) fpreds))) f g x.

  Axiom ff_ghost : functorFacts ghost ghost_fmap.
  Definition f_ghost : functor := Functor ff_ghost.

  Instance preds_join PRED : Join _ := Join_equiv (fpreds PRED).

  Inductive ghost_elem_join : Join {g: Ghost & {a: @G g | ghost.valid a}} :=
  | elem_join_I g a b c va vb vc: join a b c ->
    ghost_elem_join (existT _ g (exist _ a va)) (existT _ g (exist _ b vb))
                    (existT _ g (exist _ c vc)).
  Existing Instance ghost_elem_join.

  Inductive ghost_join PRED : Join (ghost PRED) :=
  | ghost_join_nil_l m: ghost_join PRED nil m m
  | ghost_join_nil_r m: ghost_join PRED m nil m
  | ghost_join_cons a1 a2 m1 m2 a3 m3: join a1 a2 a3 -> ghost_join PRED m1 m2 m3 ->
      ghost_join PRED (a1 :: m1) (a2 :: m2) (a3 :: m3).
  Existing Instance ghost_join.

  Axiom pa_gj : forall PRED, @Perm_alg _ (ghost_join PRED).

  Instance sa_gj : forall PRED, @Sep_alg _ (ghost_join PRED).
  Proof.
    intros; exists (fun _ => nil); auto; constructor.
  Defined.
  Axiom paf_ghost : @pafunctor f_ghost ghost_join.

  Definition f_pre_rmap : functor :=
    fpair (ffunc (fconst address) f_res) f_ghost.

  Instance Join_pre_rmap (A: Type) : Join (f_pre_rmap A) :=
            Join_prod _ (Join_fun address (res A) (res_join A)) _ (ghost_join A).

  Declare Instance Perm_pre_rmap: forall (A: Type), Perm_alg (f_pre_rmap A).
  Declare Instance Sep_pre_rmap: forall (A: Type), Sep_alg (f_pre_rmap A).
  Parameter paf_pre_rmap : @pafunctor f_pre_rmap Join_pre_rmap.

  Existing Instance ghost_join.
  Instance Join_res A : Join (f_res A) := res_join A.

Axiom pre_rmap_core:
forall (A : Type) (m : f_pre_rmap A),
  @core (f_pre_rmap A) (Join_pre_rmap A) (Sep_pre_rmap A) m =
 (@core ((fpair (ffunc (fconst address) f_res) f_ghost) A)
           (Join_prod ((ffunc (fconst address) f_res) A)
              (Join_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A))
              (f_ghost A) (ghost_join A))
           (@Sep_prod ((ffunc (fconst address) f_res) A)
              (Join_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A))
              (f_ghost A) (ghost_join A)
              (Sep_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A)
                 (fun _ : (fconst address) A => sa_rj A))
              (sa_gj A)) m).

End STRAT_MODEL.

Module StratModel (AV' : ADR_VAL) : STRAT_MODEL with Module AV:=AV'.
  Module AV := AV'.
  Import AV.

  Definition preds: functor :=
    fsig (fun T: TypeTree =>
      fpi (fun ts: list Type => dependent_type_functor_rec ts T)).

  Inductive res (PRED : Type) : Type :=
    | NO':  forall sh: Share.t, ~(readable_share sh) -> res PRED
    | YES': forall sh: Share.t, readable_share sh -> kind -> preds PRED -> res PRED
    | PURE': kind -> preds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (g:B->A)(x:res A) : res B :=
    match x with
      | NO' rsh nsh => NO' B rsh nsh
      | YES' sh rsh k pds => YES' B sh rsh k (fmap preds f g pds)
      | PURE' k pds => PURE' B k (fmap preds f g pds)
    end.

  Lemma ff_res : functorFacts res res_fmap.
  Proof with auto.
    constructor; intros; extensionality rs; icase rs; unfold res_fmap.
    rewrite fmap_id... rewrite fmap_id...
    rewrite <- fmap_comp... rewrite <- fmap_comp...
  Qed.

  Definition f_res : functor := Functor ff_res.

  Inductive res_join (PRED : Type) : f_res PRED -> f_res PRED -> f_res PRED -> Prop :=
    | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (NO' PRED sh2 nsh2)
                                     (NO' PRED sh3 nsh3)
    | res_join_NO2 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (NO' PRED sh1 nsh1) (YES' PRED sh2 rsh2 k p)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_NO3 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p,
                               join sh1 sh2 sh3 ->
                               res_join PRED (YES' PRED sh1 rsh1 k p) (NO' PRED sh2 nsh2)
                                   (YES' PRED sh3 rsh3 k p)
    | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p,
                              join sh1 sh2 sh3 ->
              res_join PRED (YES' PRED sh1 rsh1 k p) (YES' PRED sh2 rsh2 k p) (YES' PRED sh3 rsh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).

  Instance Join_res (PRED: Type) : Join (res PRED) := res_join PRED.

  Instance pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Proof. intros. constructor.
*      (* saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2;
      repeat match goal with H: join ?A ?B _, H': join ?A ?B ?C |- _ => pose proof (join_eq H H'); subst C end;
      repeat proof_irr; auto.
*     (* saf_assoc *)
      intros a b c d e H1 H2.
      destruct d as [rd | rd sd kd pd | kd pd].
      destruct a as [ra | | ]; try solve [elimtype False; inv H1].
      destruct b as [rb| | ]; try solve [elimtype False; inv H1].
      assert (join ra rb rd) by (inv H1; auto).
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO' _ rf (join_unreadable_shares H3 n1 n2)); split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable2 H3 sc) kc pc).
      inv H2. split; constructor; auto.
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      destruct b as [ | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kd pd).  inv H1; inv H2; split; constructor; auto.
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO' _ rf (join_unreadable_shares H3 n0 n)).  inv H1; inv H2; split; constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable2 H3 sc) kc pc).  inv H1; inv H2; split; constructor; auto.
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES' _ rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      exists (PURE' _ kd pd). inv H1; inv H2; split; constructor.

*      (* saf_com *)
      intros a b c H; inv H; econstructor;  apply join_comm; auto.

*     (* saf_positivity *)
     intros; inv H; inv H0;
      repeat match goal with H: join ?A ?B ?C, H': join ?C ?D ?A |- _ =>
                    pose proof (join_positivity H H'); subst C
      end;
      repeat proof_irr; auto.
 Qed.

  Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Proof. intros.
            apply mkSep
             with (fun x => match x
                             with NO' _ _ => NO' _ Share.bot bot_unreadable
                               | YES' _ _ _ _ => NO' _ Share.bot bot_unreadable
                               | PURE' k pds => PURE' _ k pds end).
            intro. destruct t; constructor; try apply join_unit1; auto.
            intros. inversion H; auto.
  Defined.

  Definition paf_res : @pafunctor f_res res_join.
  Proof. constructor; repeat intro.
  (* This is a little painful because of the way res_join is defined, but
      whatever... *)
   inv H; simpl; constructor; trivial.
   destruct z as [ rz | rz sz kz pz | kz pz ].
   destruct x' as [ rx' | rx' sx' kx' px' | kx' px' ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (NO' _ rx' n0); exists (NO' _ ry n1); inv H; split; constructor; tauto.
   destruct x' as [ rx' | rx' sx' kx' px' | kx' px' ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (NO' _ rx' n); exists (YES' _ ry sy kz pz); inv H; split; constructor; auto. simpl in *; f_equal; auto.
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   exists (YES' _ rx' sx' kx' pz); exists (NO' _ ry n); inv H; split; constructor; auto.
   exists (YES' _ rx' sx' kx' pz); exists (YES' _ ry sy ky pz); inv H; split; constructor; auto; simpl; f_equal; auto.
   exists (PURE' _ kz pz); exists (PURE' _ kz pz); simpl in *; inv H; split; [constructor | tauto].

   destruct x as [ rx | rx sx kx px | kx px ]; try solve [elimtype False; inv H].
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (NO' _ ry n0); exists (NO' _ rz n1); inv H; split; constructor; auto.
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (YES' _ ry sy ky py); exists (YES' _ rz sz ky py); inv H; split; constructor; auto.
   destruct y as [ ry | ry sy ky py | ky py ]; try solve [elimtype False; inv H].
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (NO' _ ry n); exists (YES' _ rz sz kx px); inv H; split; constructor; auto.
   destruct z' as [ rz | rz sz kz pz | kz pz ]; try solve [elimtype False; inv H].
   exists (YES' _ ry sy kx px); exists (YES' _ rz sz kx px); inv H; split; constructor; auto. simpl; f_equal; auto.
   exists (PURE' _ kx px); exists (PURE' _ kx px); inv H; split; constructor; auto.
  Qed.

  Definition res_option (PRED : Type) (r: res PRED) : option (rshare * kind):=
    match r with
      | NO' _ _ => None
      | YES' sh rsh k _ => Some (readable_part rsh,k)
      | PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
    end.

  Definition ghost (PRED : Type) : Type :=
    list (option ({g: Ghost & {a: @G g | ghost.valid a}} * fpreds PRED)%type).

  Definition ghost_fmap (A B:Type) (f:A->B) (g:B->A)(x:ghost A) : ghost B :=
    fmap (flist (foption (fpair (fconst _) fpreds))) f g x.

  Lemma ff_ghost : functorFacts ghost ghost_fmap.
  Proof.
    constructor; intros; extensionality x; unfold ghost_fmap.
    - rewrite fmap_id; auto.
    - rewrite <- fmap_comp; auto.
  Qed.

  Definition f_ghost : functor := Functor ff_ghost.

  Instance preds_join PRED : Join _ := Join_equiv (fpreds PRED).

  Inductive ghost_elem_join : Join {g: Ghost & {a: @G g | ghost.valid a}} :=
  | elem_join_I g a b c va vb vc: join a b c ->
    ghost_elem_join (existT _ g (exist _ a va)) (existT _ g (exist _ b vb))
                    (existT _ g (exist _ c vc)).
  Existing Instance ghost_elem_join.

  Inductive ghost_join PRED : Join (ghost PRED) :=
  | ghost_join_nil_l m: ghost_join PRED nil m m
  | ghost_join_nil_r m: ghost_join PRED m nil m
  | ghost_join_cons a1 a2 m1 m2 a3 m3: join a1 a2 a3 -> ghost_join PRED m1 m2 m3 ->
      ghost_join PRED (a1 :: m1) (a2 :: m2) (a3 :: m3).
  Hint Constructors ghost_join.
  Existing Instance ghost_join.

  Lemma elem_join_inv: forall a1 a2 a3, ghost_elem_join a1 a2 a3 ->
  match a1, a2, a3 with
  | existT g1 (exist x1 _), existT g2 (exist x2 _), existT g3 (exist x3 _) =>
      exists H: g2 = g1, exists H': g3 = g1, join x1 (eq_rect _ _ x2 _ H) (eq_rect _ _ x3 _ H')
  end.
  Proof.
    inversion 1; subst.
    exists eq_refl, eq_refl; auto.
  Qed.

  Lemma ghost_join_inv: forall PRED m1 m2 m3, ghost_join PRED m1 m2 m3 ->
  match m1, m2 with
  | nil, _ => m3 = m2
  | _, nil => m3 = m1
  | a1 :: m1, a2 :: m2 => match m3 with nil => False
                          | a3 :: m3 => join a1 a2 a3 /\ ghost_join PRED m1 m2 m3 end
  end.
  Proof.
    induction 1; simpl; auto.
    destruct m; simpl; auto.
  Qed.

  Instance pa_gej : @Perm_alg _ ghost_elem_join.
  Proof.
    constructor.
    - inversion 1; inversion 1; subst.
      inv H.
      repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
          subst).
      f_equal; eapply exist_ext, join_eq; eauto.
    - intros ????? J1%elem_join_inv J2%elem_join_inv.
      destruct a as (ga & a & ?), b as (gb & b & ?), c as (gc & c & ?), d as (gd & d & ?),
        e as (ge & e & ?).
      repeat (apply realize_eq in J1; destruct J1 as [? J1]).
      repeat (apply realize_eq in J2; destruct J2 as [? J2]); subst.
      destruct (join_assoc J1 J2) as (f & ? & J).
      exists (existT _ ga (exist _ f (join_valid _ _ _ (join_comm J) v3))).
      split; constructor; auto.
    - inversion 1; constructor; auto.
    - inversion 1; subst; inversion 1; subst; auto.
      inv H.
      repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
          subst).
      f_equal; eapply exist_ext, join_positivity; eauto.
  Qed.

  Instance pa_gj : forall PRED, @Perm_alg _ (ghost_join PRED).
  Proof.
    constructor.
    - intros until 1; revert z'; induction H; inversion 1; subst; auto.
      f_equal; auto.
      eapply join_eq; eauto.
    - induction a; intros ???? J1 J2; apply ghost_join_inv in J1; subst.
      { exists e; split; auto; constructor. }
      destruct b; subst; [eexists; split; eauto; constructor|].
      destruct d; [contradiction|].
      destruct J1 as [Jc1 J1].
      apply ghost_join_inv in J2.
      destruct c; subst; [eexists; split; eauto; constructor; auto|].
      destruct e; [contradiction|].
      destruct J2 as [Jc2 J2].
      destruct (join_assoc Jc1 Jc2) as (f & ? & ?).
      destruct (IHa _ _ _ _ J1 J2) as (f' & ? & ?).
      exists (f :: f'); split; constructor; auto.
    - induction 1; constructor; auto.
    - intros until 1; revert b'; induction H; inversion 1; subst; auto.
      f_equal; eauto.
      eapply join_positivity; eauto.
  Qed.

  Instance sa_gj : forall PRED, @Sep_alg _ (ghost_join PRED).
  Proof.
    intros; exists (fun _ => nil); auto; constructor.
  Defined.

  Opaque fpreds.

  Definition paf_ghost : @pafunctor f_ghost ghost_join.
  Proof.
    constructor; repeat intro.
    - induction H; constructor; auto.
      inv H; constructor; auto.
      inv H1; constructor; auto.
      inv H2; constructor; auto; simpl; congruence.
    - revert dependent z; revert y; induction x'; intros; apply ghost_join_inv in H.
      { exists nil, z; split; auto; constructor. }
      destruct y; simpl in *.
      { exists z, nil; split; auto; constructor. }
      destruct z; [contradiction | simpl in *].
      destruct H as [J1 J2].
      destruct (IHx' _ _ J2) as (x & y' & ? & ? & ?); subst.
      apply lower_join_inv in J1.
      destruct a as [[[? []]]|].
      + destruct o as [[[? []]]|].
        * destruct o0 as [[[? []]]|]; [|contradiction].
          destruct J1 as [J1%elem_join_inv J1']; simpl in *.
          repeat (apply realize_eq in J1 as [? J1]); subst; simpl in *.
          exists (Some (existT _ x0 (exist _ _ v), _f1) :: x),
            (Some (existT _ x0 (exist _ _ v0), _f1) :: y').
          split; [repeat constructor; auto|].
          unfold ghost_fmap in *; simpl in *.
          inv J1'.
          rewrite <- H1, <- H2; auto.
        * destruct o0 as [[[? []]]|]; [|contradiction].
          inv J1.
          match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
            subst.
          exists (Some (existT _ x2 (exist _ _ v0), _f0) :: x), (None :: y').
          split; [repeat constructor; auto|].
          unfold ghost_fmap in *; simpl in *.
          rewrite <- H1; split; f_equal; f_equal; f_equal; f_equal.
          apply exist_ext; auto.
      + exists (None :: x), (o0 :: y').
        split; [repeat constructor; auto|].
        split; auto.
        unfold ghost_fmap in *; simpl in *.
        rewrite <- H1; f_equal.
        destruct o, o0; inv J1; auto.
    - revert dependent z'; revert y; induction x; intros; apply ghost_join_inv in H; simpl in H.
      { exists y, y; split; auto; constructor. }
      destruct y; simpl in *.
      { exists nil, (a :: x); split; auto; constructor. }
      destruct z'; [contradiction | simpl in *].
      destruct H as [J1 J2].
      destruct (IHx _ _ J2) as (y' & z & ? & ? & ?); subst.
      apply lower_join_inv in J1.
      destruct a as [[[? []]]|].
      + destruct o as [[[? []]]|].
        * destruct o0 as [[[? []]]|]; [|contradiction].
          destruct J1 as [J1%elem_join_inv J1']; simpl in *.
          repeat (apply realize_eq in J1 as [? J1]); subst; simpl in *.
          exists (Some (existT _ x0 (exist _ _ v0), _f) :: y'),
            (Some (existT _ x0 (exist _ _ v1), _f) :: z).
          split; [repeat constructor; auto|].
          unfold ghost_fmap in *; simpl in *.
          inv J1'.
          rewrite <- H0, <- H1; auto.
        * destruct o0 as [[[? []]]|]; [|contradiction].
          inv J1.
          match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
            subst.
          exists (None :: y'), (Some (existT _ x2 (exist _ _ v), _f) :: z).
          split; [repeat constructor; auto|].
          unfold ghost_fmap in *; simpl in *.
          rewrite <- H0; split; f_equal; f_equal; f_equal; f_equal.
          apply exist_ext; auto.
      + exists (o :: y'), (o :: z).
        split; [repeat constructor; auto|].
        unfold ghost_fmap in *; simpl in *; rewrite <- H0; split; f_equal.
        destruct o, o0; auto; contradiction.
  Qed.

  Definition pre_rmap (A:Type) := ((address -> res A) * ghost A)%type.
  Definition f_pre_rmap : functor :=
    fpair (ffunc (fconst address) f_res) f_ghost.

  Notation Join_obj A := (Join_prod _ (Join_fun address (res A) (res_join A)) _ (ghost_join A)).

  Instance Join_pre_rmap (A: Type) : Join (pre_rmap A) :=
    Join_obj A.

  Definition paf_pre_rmap : @pafunctor f_pre_rmap Join_pre_rmap :=
    paf_pair (paf_fun address paf_res) paf_ghost.

  Definition Perm_pre_rmap (A: Type): Perm_alg (pre_rmap A) :=
    Perm_prod (Perm_fun address _ _ _) (pa_gj A).

  Definition Sep_pre_rmap (A: Type): Sep_alg (pre_rmap A) :=
    Sep_prod (Sep_fun address _ _ _) (sa_gj A).

Lemma pre_rmap_core:
forall (A : Type) (m : f_pre_rmap A),
  @core (f_pre_rmap A) (Join_pre_rmap A) (Sep_pre_rmap A) m =
 (@core ((fpair (ffunc (fconst address) f_res) f_ghost) A)
           (Join_prod ((ffunc (fconst address) f_res) A)
              (Join_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A))
              (f_ghost A) (ghost_join A))
           (@Sep_prod ((ffunc (fconst address) f_res) A)
              (Join_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A))
              (f_ghost A) (ghost_join A)
              (Sep_pi ((fconst address) A)
                 (fun _ : (fconst address) A => f_res A)
                 (fun _ : (fconst address) A => Join_res A)
                 (fun _ : (fconst address) A => sa_rj A))
              (sa_gj A)) m).
Proof.
intros. reflexivity.
Qed.

End StratModel.

Local Open Scope nat_scope.

Module Type RMAPS.
  Declare Module AV:ADR_VAL.
  Import AV.

  Parameter rmap : Type.
  Axiom Join_rmap: Join rmap. Existing Instance Join_rmap.
  Axiom Perm_rmap: Perm_alg rmap. Existing Instance Perm_rmap.
  Axiom Sep_rmap: Sep_alg rmap. Existing Instance Sep_rmap.
  Axiom ag_rmap: ageable rmap.  Existing Instance ag_rmap.
  Axiom Age_rmap: Age_alg rmap.  Existing Instance Age_rmap.

  Inductive preds : Type :=
    SomeP : forall A : TypeTree,
      (forall ts: list Type, dependent_type_functor_rec ts A (pred rmap)) -> preds.

  Definition NoneP := SomeP (ConstType unit) (fun _ => tt).

  Inductive resource : Type :=
    | NO: forall sh: Share.t, ~(readable_share sh) -> resource
    | YES: forall sh: Share.t, readable_share sh -> kind -> preds -> resource
    | PURE: kind -> preds -> resource.

  Definition res_option (r:resource) : option (rshare * kind) :=
    match r with
      | NO _ _ => None
      | YES sh rsh k _ => Some (readable_part rsh,k)
      | PURE k _ => None
    end.

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (NO sh2 nsh2) (NO sh3 nsh3)
   | res_join_NO2 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (YES sh1 rsh1 k p) (NO sh2 nsh2) (YES sh3 rsh3 k p)
   | res_join_NO3 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
        res_join (YES sh1 rsh1 k p) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Axiom Perm_resource: Perm_alg resource. Existing Instance Perm_resource.
  Axiom Sep_resource: Sep_alg resource. Existing Instance Sep_resource.

  Definition preds_fmap (f g: pred rmap -> pred rmap) (x:preds) : preds :=
    match x with SomeP A Q => SomeP A (fmap (fpi _) f g Q)
    end.
  (* Check whether the following two can be erased. *)
  Axiom preds_fmap_id : preds_fmap (id _) (id _) = id preds.
  Axiom preds_fmap_comp : forall f1 f2 g1 g2,
    preds_fmap g1 g2 oo preds_fmap f1 f2 = preds_fmap (g1 oo f1) (f2 oo g2).

  Definition resource_fmap (f g:pred rmap -> pred rmap) (x:resource) : resource :=
    match x with
    | NO sh nsh => NO sh nsh
    | YES sh rsh k p => YES sh rsh k (preds_fmap f g p)
    | PURE k p => PURE k (preds_fmap f g p)
    end.
  Axiom resource_fmap_id : resource_fmap (id _) (id _) = id resource.
  Axiom resource_fmap_comp : forall f1 f2 g1 g2,
    resource_fmap g1 g2 oo resource_fmap f1 f2 = resource_fmap (g1 oo f1) (f2 oo g2).

  Definition ghost : Type := list (option ({g: Ghost & {a: @G g | ghost.valid a}} * preds)%type).

  Instance preds_join : Join _ := Join_equiv preds.

  Inductive ghost_elem_join : Join {g: Ghost & {a: @G g | ghost.valid a}} :=
  | elem_join_I g a b c va vb vc: join a b c ->
    ghost_elem_join (existT _ g (exist _ a va)) (existT _ g (exist _ b vb))
                    (existT _ g (exist _ c vc)).
  Existing Instance ghost_elem_join.

  Inductive ghost_join : Join ghost :=
  | ghost_join_nil_l m: ghost_join nil m m
  | ghost_join_nil_r m: ghost_join m nil m
  | ghost_join_cons a1 a2 m1 m2 a3 m3: join a1 a2 a3 -> ghost_join m1 m2 m3 ->
      ghost_join (a1 :: m1) (a2 :: m2) (a3 :: m3).
  Existing Instance ghost_join.

  Axiom Perm_ghost: Perm_alg ghost. Existing Instance Perm_ghost.
  Axiom Sep_ghost: Sep_alg ghost. Existing Instance Sep_ghost.
  Axiom ghost_core: forall (g: ghost), core g = nil.

  Definition ghost_fmap (f g:pred rmap -> pred rmap)(x:ghost) : ghost :=
    map (option_map (fun '(a, b) => (a, preds_fmap f g b))) x.

  Axiom ghost_fmap_id : ghost_fmap (id _) (id _) = id ghost.
  Axiom ghost_fmap_comp : forall f1 f2 g1 g2,
    ghost_fmap g1 g2 oo ghost_fmap f1 f2 = ghost_fmap (g1 oo f1) (f2 oo g2).

  Definition rmap' := ((address -> resource) * ghost)%type.

  Definition rmap_fmap (f g: pred rmap -> pred rmap) (x:rmap') : rmap' :=
    (resource_fmap f g oo fst x, ghost_fmap f g (snd x)).

  Axiom rmap_fmap_id : rmap_fmap (id _) (id _) = id rmap'.
  Axiom rmap_fmap_comp : forall f1 f2 g1 g2,
   rmap_fmap g1 g2 oo rmap_fmap f1 f2 = rmap_fmap (g1 oo f1) (f2 oo g2).

  Parameter squash : (nat * rmap') -> rmap.
  Parameter unsquash : rmap -> (nat * rmap').

  Axiom rmap_level_eq: @level rmap _ = fun x => fst (unsquash x).
  Axiom rmap_age1_eq: @age1 _ _ =
     fun k => match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition resource_at (phi:rmap) : address -> resource := fst (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).
  Definition ghost_of (phi:rmap) : ghost := snd (snd (unsquash phi)).

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.

  Axiom join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).

  Definition rmap_unage (k:rmap) : rmap :=
    match unsquash k with
    | (n,x) => squash (S n, x)
    end.

  Program Definition approx (n:nat) (p: pred rmap) : pred rmap :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Axiom squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Axiom unsquash_squash : forall n rm, unsquash (squash (n,rm)) = (n,rmap_fmap (approx n) (approx n) rm).
  Axiom ghost_of_core : forall phi, ghost_of (core phi) = core (ghost_of phi).

End RMAPS.

Module Rmaps (AV':ADR_VAL): RMAPS with Module AV:=AV'.
  Module AV:=AV'.
  Import AV.

  Module SM := StratModel(AV).
  Import SM.

  Module TyF. (* <: TY_FUNCTOR_PROP. *)
    Definition F := f_pre_rmap.
  End TyF.

  Module TyFSA <: KNOT_FULL_SA_INPUT with Module KI:=TyF.
    Module KI := TyF.
    Import KI.

    Instance Join_F: forall A, Join (F A) := _.
    Definition Perm_F : forall A, Perm_alg (F A) := Perm_pre_rmap.
    Definition Sep_F := Sep_pre_rmap.
    Definition paf_F := paf_pre_rmap.
  End TyFSA.

  Module K := Knot_MixVariantHeredProp(TyF).
  Module KL := KnotLemmas_MixVariantHeredProp(K).
  Module KSa := KnotFullSa(TyFSA)(K)(KL).

  Definition rmap := K.knot.
  Instance Join_rmap: Join rmap := KSa.Join_knot.
  Instance Perm_rmap : Perm_alg rmap:= KSa.Perm_knot.
  Instance Sep_rmap : Sep_alg rmap:= KSa.Sep_knot.
  Instance ag_rmap : ageable rmap := K.ageable_knot.
  Instance Age_rmap: Age_alg rmap := KSa.asa_knot.

  Inductive preds : Type :=
    SomeP : forall A : TypeTree,
    (forall ts: list Type, dependent_type_functor_rec ts A (pred rmap)) -> preds.

  Definition NoneP := SomeP (ConstType unit) (fun _ => tt).

  Inductive resource : Type :=
    | NO: forall sh: Share.t, ~ readable_share sh -> resource
    | YES: forall sh: Share.t, readable_share sh -> kind -> preds -> resource
    | PURE: kind -> preds -> resource.

  Definition resource2res (r: resource): res (pred rmap) :=
    match r with
      | NO sh nsh => NO' (pred rmap) sh nsh
      | YES sh rsh k (SomeP A l) => YES' (pred rmap) sh rsh k (existT _ A l)
      | PURE k (SomeP A l) => PURE' (pred rmap) k (existT _ A l)
    end.

  Definition res2resource (r: res (pred rmap)) : resource :=
    match r with
      | NO' sh nsh => NO sh nsh
      | YES' sh rsh k (existT A l) => YES sh rsh k (SomeP A l)
      | PURE' k (existT A l) => PURE k (SomeP A l)
    end.

  Lemma res2resource2res: forall x, resource2res (res2resource x) = x.
  Proof. unfold resource2res, res2resource; destruct x as [? | ? ? ? [? ?] | ? [? ?]]; auto. Qed.

  Lemma resource2res2resource: forall x, res2resource (resource2res x) = x.
  Proof. unfold resource2res, res2resource; destruct x; try destruct p0; try destruct p; auto. Qed.

  Definition res_option (r:resource) : option (rshare * kind) :=
    match r with
      | NO _ _ => None
      | YES sh rsh k _ => Some (readable_part rsh,k)
      | PURE k _ => None
    end.

  Lemma res_option_rewrite: res_option = SM.res_option (pred rmap) oo resource2res.
  Proof.
    unfold SM.res_option, res_option, compose.
    extensionality r; destruct r; simpl; auto; destruct p; auto.
  Qed.

  Definition ghost : Type := list (option ({g: Ghost & {a: @G g | ghost.valid a}} * preds)%type).

  Definition pred2p (p: preds) : fpreds (pred rmap) :=
    match p with SomeP A P => existT _ A P end.

  Definition p2pred (p: fpreds (pred rmap)) : preds :=
    match p with existT A P => SomeP A P end.

  Definition ghost2g (r: ghost): SM.ghost (pred rmap) :=
    map (option_map (fun '(a, b) => (a, pred2p b))) r.

  Definition g2ghost (r: SM.ghost (pred rmap)) : ghost :=
    map (option_map (fun '(a, b) => (a, p2pred b))) r.

  Lemma g2ghost2g: forall x, ghost2g (g2ghost x) = x.
  Proof.
    induction x; auto; simpl.
    rewrite IHx; destruct a as [[]|]; auto; simpl.
    destruct _f; auto.
  Qed.

  Lemma ghost2g2ghost: forall x, g2ghost (ghost2g x) = x.
  Proof.
    induction x; auto; simpl.
    rewrite IHx; destruct a as [[]|]; auto; simpl.
    destruct p; auto.
  Qed.

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : forall sh1 nsh1 sh2 nsh2 sh3 nsh3
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (NO sh2 nsh2) (NO sh3 nsh3)
   | res_join_NO2 : forall sh1 rsh1 sh2 nsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (YES sh1 rsh1 k p) (NO sh2 nsh2) (YES sh3 rsh3 k p)
   | res_join_NO3 : forall sh1 nsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
                 res_join (NO sh1 nsh1) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_YES : forall sh1 rsh1 sh2 rsh2 sh3 rsh3 k p
                 (RJ: join sh1 sh2 sh3),
        res_join (YES sh1 rsh1 k p) (YES sh2 rsh2 k p) (YES sh3 rsh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Instance Perm_resource: Perm_alg resource.
  Proof. constructor.
  * (*saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2;
      repeat match goal with H: join ?A ?B _, H': join ?A ?B ?C |- _ => pose proof (join_eq H H'); subst C end;
      repeat proof_irr; auto.
  * (* saf_assoc *)
      intros a b c d e H1 H2.
      destruct d as [rd | rd sd kd pd | kd pd].
      destruct a as [ra | | ]; try solve [elimtype False; inv H1].
      destruct b as [rb| | ]; try solve [elimtype False; inv H1].
      assert (join ra rb rd) by (inv H1; auto).
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO rf (join_unreadable_shares H3 n1 n2)); split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (join rd rc re) by (inv H2; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable2 H3 sc) kc pc).
      inv H2. split; constructor; auto.
      destruct c as [rc | rc sc kc pc | kc pc]; try solve [elimtype False; inv H2].
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      destruct b as [ | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kd pd).  inv H1; inv H2; split; constructor; auto.
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (NO rf (join_unreadable_shares H3 n0 n)).  inv H1; inv H2; split; constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; constructor; auto.
      destruct e as [re | re se ke pe | ke pe]; try solve [elimtype False; inv H2].
      assert (H0: join rd rc re) by (inv H2; auto).
      destruct b as [ rb | rb sb kb pb | ]; try solve [elimtype False; inv H1].
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable2 H3 sc) kc pc).  inv H1; inv H2; split; constructor; auto.
      destruct a as [ra | ra sa ka pa | ka pa ]; try solve [elimtype False; inv H1].
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      assert (H: join ra rb rd) by (inv H1; auto).
      destruct (join_assoc H H0) as [rf [? ?]].
      exists (YES rf (join_readable1 H3 sb) kb pb).  inv H1; inv H2; split; try constructor; auto.
      exists (PURE kd pd). inv H1; inv H2; split; constructor.

*      (* saf_com *)
      intros a b c H; inv H; econstructor;  apply join_comm; auto.

*     (* saf_positivity *)
     intros; inv H; inv H0;
      repeat match goal with H: join ?A ?B ?C, H': join ?C ?D ?A |- _ =>
                    pose proof (join_positivity H H'); subst C
      end;
      repeat proof_irr; auto.
 Qed.

  Instance Sep_resource: Sep_alg resource.
  Proof.
  apply mkSep
    with (fun x => match x
                   with NO _ _ => NO Share.bot bot_unreadable
                      | YES _ _ _ _ => NO Share.bot bot_unreadable
                      | PURE k pds => PURE k pds end).
  intro. destruct t; constructor; try apply join_unit1; auto.
  intros. inversion H; auto.
  Defined.

  (* Will this give us the higher-order ghost state we want? *)
  Instance preds_join : Join _ := Join_equiv preds.

  Inductive ghost_elem_join : Join {g: Ghost & {a: @G g | ghost.valid a}} :=
  | elem_join_I g a b c va vb vc: join a b c ->
    ghost_elem_join (existT _ g (exist _ a va)) (existT _ g (exist _ b vb))
                    (existT _ g (exist _ c vc)).
  Existing Instance ghost_elem_join.

  Inductive ghost_join : Join ghost :=
  | ghost_join_nil_l m: ghost_join nil m m
  | ghost_join_nil_r m: ghost_join m nil m
  | ghost_join_cons a1 a2 m1 m2 a3 m3: join a1 a2 a3 -> ghost_join m1 m2 m3 ->
      ghost_join (a1 :: m1) (a2 :: m2) (a3 :: m3).
  Existing Instance ghost_join.

  Lemma elem_join_inv: forall a1 a2 a3, ghost_elem_join a1 a2 a3 ->
  match a1, a2, a3 with
  | existT g1 (exist x1 _), existT g2 (exist x2 _), existT g3 (exist x3 _) =>
      exists H: g2 = g1, exists H': g3 = g1, join x1 (eq_rect _ _ x2 _ H) (eq_rect _ _ x3 _ H')
  end.
  Proof.
    inversion 1; subst.
    exists eq_refl, eq_refl; auto.
  Qed.

  Lemma ghost_join_inv: forall m1 m2 m3, ghost_join m1 m2 m3 ->
  match m1, m2 with
  | nil, _ => m3 = m2
  | _, nil => m3 = m1
  | a1 :: m1, a2 :: m2 => match m3 with nil => False
                          | a3 :: m3 => join a1 a2 a3 /\ ghost_join m1 m2 m3 end
  end.
  Proof.
    induction 1; simpl; auto.
    destruct m; simpl; auto.
  Qed.

  Instance pa_gej : @Perm_alg _ ghost_elem_join.
  Proof.
    constructor.
    - inversion 1; inversion 1; subst.
      inv H.
      repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
          subst).
      f_equal; eapply exist_ext, join_eq; eauto.
    - intros ????? J1%elem_join_inv J2%elem_join_inv.
      destruct a as (ga & a & ?), b as (gb & b & ?), c as (gc & c & ?), d as (gd & d & ?),
        e as (ge & e & ?).
      repeat (apply realize_eq in J1; destruct J1 as [? J1]).
      repeat (apply realize_eq in J2; destruct J2 as [? J2]); subst.
      destruct (join_assoc J1 J2) as (f & ? & J).
      exists (existT _ ga (exist _ f (join_valid _ _ _ (join_comm J) v3))).
      split; constructor; auto.
    - inversion 1; constructor; auto.
    - inversion 1; subst; inversion 1; subst; auto.
      inv H.
      repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
          subst).
      f_equal; eapply exist_ext, join_positivity; eauto.
  Qed.

  Instance Perm_ghost : Perm_alg ghost.
  Proof.
    constructor.
    - intros until 1; revert z'; induction H; inversion 1; subst; auto.
      f_equal; auto.
      eapply join_eq; eauto.
    - induction a; intros ???? J1 J2; apply ghost_join_inv in J1; subst.
      { exists e; split; auto; constructor. }
      destruct b; subst; [eexists; split; eauto; constructor|].
      destruct d; [contradiction|].
      destruct J1 as [Jc1 J1].
      apply ghost_join_inv in J2.
      destruct c; subst; [eexists; split; eauto; constructor; auto|].
      destruct e; [contradiction|].
      destruct J2 as [Jc2 J2].
      destruct (join_assoc Jc1 Jc2) as (f & ? & ?).
      destruct (IHa _ _ _ _ J1 J2) as (f' & ? & ?).
      exists (f :: f'); split; constructor; auto.
    - induction 1; constructor; auto.
    - intros until 1; revert b'; induction H; inversion 1; subst; auto.
      f_equal; eauto.
      eapply join_positivity; eauto.
  Qed.

  Instance Sep_ghost : Sep_alg ghost.
  Proof.
    intros; exists (fun _ => nil); auto; constructor.
  Defined.

  Lemma ghost_core : forall (g: ghost), core g = nil.
  Proof.
    auto.
  Qed.

  Definition rmap' := ((address->resource) * ghost)%type.
  Definition preds_fmap (f g:(pred rmap)->(pred rmap)) (x:preds) : preds :=
    match x with SomeP A ls => SomeP A (fmap (fpi _) f g ls) end.

  Lemma preds_fmap_id : preds_fmap (id (pred rmap)) (id (pred rmap)) = id preds.
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl; auto.
    unfold id at 3.
    f_equal.
    extensionality i.
    rewrite fmap_id; auto.
  Qed.

  Lemma preds_fmap_comp : forall f1 f2 g1 g2,
    preds_fmap g1 g2 oo preds_fmap f1 f2 = preds_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl.
    unfold preds_fmap, compose at 1; simpl.
    f_equal.
    extensionality i.
    rewrite <- fmap_comp; auto.
  Qed.

  Definition resource_fmap (f g:pred rmap -> pred rmap) (x:resource) : resource :=
    match x with
    | NO sh nsh => NO sh nsh
    | YES sh rsh k p => YES sh rsh k (preds_fmap f g p)
    | PURE k p => PURE k (preds_fmap f g p)
    end.

  Definition ghost_fmap (f g:pred rmap -> pred rmap)(x:ghost) : ghost :=
    map (option_map (fun '(a, b) => (a, preds_fmap f g b))) x.

  Lemma resource_fmap_id :
    resource_fmap (id (pred rmap)) (id (pred rmap)) = id resource.
  Proof.
    intros; apply extensionality; intro x.
    unfold resource_fmap.
    destruct x; simpl; auto.
    rewrite preds_fmap_id; auto.
    rewrite preds_fmap_id; auto.
  Qed.

  Lemma ghost_fmap_id : ghost_fmap (id (pred rmap)) (id (pred rmap)) = id ghost.
  Proof.
    extensionality x; induction x; auto; simpl.
    rewrite IHx; destruct a as [[]|]; auto; simpl.
    rewrite preds_fmap_id; auto.
  Qed.

  Lemma resource_fmap_comp : forall f1 f2 g1 g2,
    resource_fmap g1 g2 oo resource_fmap f1 f2 = resource_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros f1 f2 g1 g2.
    apply extensionality; intro x; destruct x; simpl; auto.
    unfold compose at 1; simpl.
    rewrite <- preds_fmap_comp; auto.
    rewrite <- preds_fmap_comp; auto.
  Qed.

  Lemma ghost_fmap_comp : forall f1 f2 g1 g2,
    ghost_fmap g1 g2 oo ghost_fmap f1 f2 = ghost_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros; extensionality x; induction x; auto; simpl.
    rewrite <- IHx; destruct a as [[]|]; auto; simpl.
    rewrite <- preds_fmap_comp; auto.
  Qed.

  Definition rmap_fmap (f g:(pred rmap)->(pred rmap)) (x:rmap') : rmap' :=
              (resource_fmap f g oo fst x, ghost_fmap f g (snd x)).

  Lemma rmap_fmap_id : rmap_fmap (id (pred rmap)) (id (pred rmap)) = id rmap'.
  Proof.
    intros; apply extensionality; intro x.
    unfold rmap_fmap; destruct x.
    simpl.
    rewrite resource_fmap_id, ghost_fmap_id.
    rewrite (id_unit2 _ (resource) r).
    f_equal; auto.
  Qed.

  Lemma rmap_fmap_comp : forall f1 f2 g1 g2,
    rmap_fmap g1 g2 oo rmap_fmap f1 f2 = rmap_fmap (g1 oo f1) (f2 oo g2).
  Proof.
    intros f1 f2 g1 g2.
    unfold rmap_fmap.
    apply extensionality; intro x.
    unfold compose at 1.
    destruct x as (r,g). simpl.
    rewrite <- compose_assoc.
    rewrite resource_fmap_comp; auto.
    f_equal; auto.
    pose proof ghost_fmap_comp as HG.
    unfold compose in HG at 1; rewrite <- HG.
    intros.
    f_equal; proof_irr; auto.
  Qed.

  Definition rmap'2pre_rmap (f: rmap') : f_pre_rmap (pred rmap) :=
      (fun x : address => resource2res (fst f x), ghost2g (snd f)).

  Definition pre_rmap2rmap' (f: f_pre_rmap (pred rmap)) : rmap' :=
      (fun l : address => res2resource (fst f l), g2ghost (snd f)).

  Lemma rmap'2pre_rmap2rmap' :
    forall x, rmap'2pre_rmap (pre_rmap2rmap' x) = x.
  Proof.
    intro. unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    destruct x; simpl; f_equal.
    extensionality x; rewrite res2resource2res; auto.
    rewrite g2ghost2g; auto.
  Qed.

  Lemma pre_rmap2rmap'2pre_rmap :
    forall x,  pre_rmap2rmap' (rmap'2pre_rmap x) = x.
  Proof.
    intro.
    unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    destruct x; simpl; f_equal.
    extensionality x; rewrite resource2res2resource; auto.
    rewrite ghost2g2ghost; auto.
  Qed.

  Definition squash (n_rm:nat * rmap') : rmap :=
    match n_rm with (n,rm) => K.squash (n, rmap'2pre_rmap rm) end.

  Definition unsquash (phi:rmap) : (nat * rmap') :=
    match K.unsquash phi with (n,rm) => (n, pre_rmap2rmap' rm) end.

  Definition rmap_level (phi:rmap) : nat := fst (unsquash phi).
  Definition resource_at (phi:rmap) : address -> resource := fst (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).
  Definition ghost_of (phi:rmap) : ghost := snd (snd (unsquash phi)).

  Lemma pred_ext': forall {A} `{agA: ageable A} P Q,
                (forall x, app_pred P x <-> app_pred Q x) -> P = Q.
  Proof. intros; apply pred_ext; intro; apply H; auto. Qed.

  Lemma squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Proof.
    intros.
    unfold squash, unsquash; simpl.
    destruct (K.unsquash phi) eqn:?H; simpl; intros.
    rewrite rmap'2pre_rmap2rmap'.
    unfold K.KI.F in *.
    unfold f_pre_rmap in H.
    match goal with
    | |- K.squash ?A = _ => replace A with (K.unsquash phi)
    end.
    rewrite K.squash_unsquash; auto.
  Qed.

  Program Definition approx (n:nat) (p: (pred rmap)) : (pred rmap) :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H.
  simpl in *. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Lemma approx_K_approx: approx = K.approx.
  Proof.
    extensionality n p.
    apply pred_ext'; intros w.
    unfold approx, compose; simpl.
    rewrite K.approx_spec.
    unfold rmap_level, unsquash; simpl;
    repeat rewrite K.knot_level;
    repeat rewrite setset, setget;     intuition.
  Qed.

  Lemma unsquash_squash : forall n rm, (unsquash (squash (n,rm))) = (n,rmap_fmap (approx n) (approx n) rm).
  Proof.
    intros.
    unfold unsquash, squash.
    rewrite K.unsquash_squash. unfold K.KI.F, f_pre_rmap.
    match goal with [|- (_,?X) = (_,?Y) ] =>
      replace Y with X; auto
    end.
    match goal with [|- pre_rmap2rmap' ?X = _ ] =>
      replace X with
        (fmap f_pre_rmap (K.approx n) (K.approx n) (rmap'2pre_rmap rm))
    end.
    2: repeat rewrite <- fmap_comp.
    2: unfold compose; auto.
    destruct rm; simpl. unfold pre_rmap2rmap', rmap_fmap. simpl; f_equal.
    extensionality l.
    unfold compose.
    destruct (r l); simpl; auto.
    (* YES *)
    destruct p; simpl.
    rewrite approx_K_approx; auto.
    (* PURE *)
    destruct p; simpl.
    rewrite approx_K_approx; auto.
    (* ghost *)
    induction g; auto; simpl.
    setoid_rewrite IHg; destruct a as [[]|]; auto; simpl.
    repeat f_equal.
    rewrite approx_K_approx; destruct p; auto.
  Qed.

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.
(*
Lemma fmap_p2p'_inj:
  forall p q,
        fmap SM.preds K.predicate K.predicate (@pred rmap ag_rmap) p =
        fmap SM.preds K.predicate K.predicate (@pred rmap ag_rmap) q ->
        p=q.
Proof.
  intros.
  destruct p as [p Vp]. destruct q as [q Vq].
  unfold fmap in *. unfold f_preds in *. simpl in *.
  inv H.
  f_equal.
  apply inj_pair2 in H2. unfold ffun_fmap, f_identity in *.
  unfold fmap, compose in H2.
  extensionality w.
 apply equal_f with w in H2. unfold fidentity_fmap in *.
  unfold p2p' in *. inv H2.
  unfold K.predicate in *.
  apply pred_ext'. intros [k o]. destruct o.
  apply equal_f with k in H0. rewrite H0; intuition.
Qed.
*)
  Lemma g2ghost_inv: forall g1 g2, g2ghost g1 = g2ghost g2 -> g1 = g2.
  Proof.
    induction g1; destruct g2; inversion 1; auto.
    f_equal; auto.
    destruct a as [[]|], o as [[]|]; inv H1; auto.
    destruct _f, _f0; inv H4; auto.
  Qed.

  Lemma join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).
  Proof.
    intros.
    unfold unsquash.
    rewrite KSa.join_unsquash.
    destruct (K.unsquash phi1) as [n f].
    destruct (K.unsquash phi2) as [n0 f0].
    destruct (K.unsquash phi3) as [n1 f1].
    simpl; intuition.
    destruct H; simpl in *; split; simpl; auto.
    inversion H0.
    constructor.
    intro l; specialize ( H1 l).
    simpl in *.
    unfold compose.
    destruct f, f0, f1; simpl in *.
    inv H1; simpl.
    constructor; auto.
    destruct p. simpl in *. constructor; auto. destruct p. simpl in *. constructor; auto.
    destruct p; simpl in *.
    constructor; auto.
    destruct p; simpl in *.
    constructor; auto.

    destruct f, f0, f1; simpl in *.
    clear - H2; induction H2; constructor; auto.
    inv H; constructor; auto.
    destruct a0, a4, a5; inv H0; simpl in *.
    inv H; inv H1; constructor; constructor; auto.

    destruct H; simpl in *; split; simpl; auto.
    inversion H0.
    hnf in H1. simpl proj1_sig in H1.
    constructor; auto.
    intro l; specialize ( H1 l).
    simpl proj1_sig.
    clear - H1.
    destruct f, f0, f1; simpl in *.
    forget (r l) as a; forget (r0 l) as b; forget (r1 l) as c.
    clear - H1.
    unfold res2resource in *. unfold res_fmap in *.
    destruct a as [ra | ra sha ka pa| ka pa]; try destruct pa as [? ?p];
    destruct b as [rb | rb shb kb pb|kb pb]; try destruct pb as [? ?p];
    destruct c as [rc | rc shc kc pc|kc pc]; try destruct pc as [? ?p];
    inv H1.
    + constructor; auto.
    + apply inj_pair2 in H8. subst p0. constructor; auto.
    + apply inj_pair2 in H8. subst p0. constructor; auto.
    + subst. apply inj_pair2 in H11. subst p1. apply inj_pair2 in H7; subst p0.
      constructor; auto.
    + subst ; apply inj_pair2 in H8. subst p1. apply inj_pair2 in H5. subst p0.
      constructor; auto.
    + simpl in *.
      destruct f, f0, f1; simpl in *.
      clear - H2.
      remember (g2ghost g) as a; remember (g2ghost g0) as b; remember (g2ghost g1) as c.
      revert dependent g1; revert dependent g0; revert dependent g; induction H2; intros; subst.
      * apply g2ghost_inv in Heqc; subst; destruct g; [constructor | discriminate].
      * apply g2ghost_inv in Heqc; subst; destruct g0; [constructor | discriminate].
      * destruct g, g0, g1; inv Heqa; inv Heqb; inv Heqc.
        constructor; [|apply IHghost_join; auto].
        destruct o as [[]|], o0 as [[]|], o1 as [[]|]; inv H; try constructor.
        -- destruct _f, _f0, _f1; inv H4; simpl in *.
           inv H; inv H0.
           inv H; inv H3.
           repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
             subst); constructor; constructor; auto.
        -- destruct _f, _f0; inv H4.
           repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
             subst); constructor; auto.
        -- destruct _f, _f0; inv H4.
           repeat (match goal with H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H end;
             subst); constructor; auto.
  Qed.

  Lemma ghost_of_core : forall phi, ghost_of (core phi) = core (ghost_of phi).
  Proof.
    intro; rewrite KSa.core_unsquash.
    unfold ghost_of, KSa.K.unsquash, KSa.K.squash, unsquash, squash.
    destruct (K.unsquash phi); simpl.
    rewrite K.unsquash_squash; simpl.
    setoid_rewrite (pre_rmap_core _ _f). auto.
Qed.

  Definition rmap_age1 (k:rmap) : option rmap :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition rmap_unage (k:rmap) : rmap :=
    match unsquash k with
    | (n,x) => squash (S n, x)
    end.

  Lemma rmap_age1_knot_age1 :
    rmap_age1 = @age1 _ K.ageable_knot.
  Proof.
    extensionality x.
    unfold rmap_age1.
    rewrite  K.knot_age1.
    unfold unsquash, squash.
    case (K.unsquash x); simpl; intros.
    destruct n; auto.
    rewrite rmap'2pre_rmap2rmap'.
    f_equal.
  Qed.

  Lemma rmap_age1_eq: @age1 _ ag_rmap = rmap_age1.
  Proof.
   unfold age1. unfold ag_rmap; simpl; auto.
   rewrite rmap_age1_knot_age1; reflexivity.
  Qed.

  Lemma rmap_level_eq: @level rmap ag_rmap = fun x => fst (unsquash x).
  Proof.
    intros.
   extensionality x.  unfold level.  unfold ag_rmap.
   unfold KSa.K.ageable_knot. unfold unsquash.
   rewrite K.knot_level. destruct (K.unsquash x); simpl. auto.
  Qed.

(*  Lemma unevolve_identity_rmap :
   (* REMARK:  This may not be needed for anything, so for now it's removed
     from the Module Type *)
    forall w w':rmap, necR w w' -> identity w' -> identity w.
  Proof.
    intros.
    induction H; eauto.
    rewrite identity_unit_equiv in H0.
    rewrite identity_unit_equiv.
    red in H0. red.
    rewrite join_unsquash in H0.
    rewrite join_unsquash.
    hnf in H. unfold rmap, ag_rmap in H. rewrite <- rmap_age1_knot_age1 in H.
    unfold rmap_age1 in H.
   destruct (unsquash x).
   destruct n. inv H.
    assert (y = squash (n,r)).
    inv H; auto.
    subst y.
    rewrite unsquash_squash in H0.
    destruct H0.
    destruct H1.
    split; auto.
    split.
    intro l; specialize ( H1 l).
    destruct r.
    simpl in *.
    unfold compose in *.
    destruct (fst x0 l); simpl in *.
    constructor; auto.
    inv H1; auto.
    inv H1. constructor; auto.
    constructor.
    simpl in *.
  Qed.*)

End Rmaps.
Local Close Scope nat_scope.


(** * Syntax of MMLL
This file defines the syntax of formulas in MMLL
(type [oo]). Predicate [isFormula] determines when a term is a valid
MMLL formula (ruling out exotic terms). Proofs usually proceed by
induction on the fact that a term satisfies this property.
 *)

Require Export MMLL.Misc.UtilsTactics.
Require Export MMLL.Misc.Permutations.
Require Export MMLL.Misc.Hybrid.
Require Export MMLL.Misc.Database.
Require Export MMLL.SL.Signature.

Require Import Coq.Logic.FunctionalExtensionality.

Export ListNotations.
Set Implicit Arguments.

(** ** External definitions for the Object Logic (OL)
The class [OLSig] specifies the external definitions for terms and
atomic propositions of the object logic. The syntax is parametric on:

 - [atm] : type for atomic propositions (judgments at the Object Logic level)
 - [con] : type for syntactic constructors at the OL level
 - [uniform_atm] : predicate ruling out exotic terms at the OL level
 *)

Class OLSig :=
  {
    (* Signature for atoms (judgments at the OL level) *)
    atm:Set;
    (* Type for constants (constructors for OL syntax) *)
    con:Set;
    (* predicate ruling out exotic terms for atoms *)
    uniform_atm : (expr con -> atm) -> Prop
  }.

Section LLSyntax.

  Context `{OLS: OLSig}.
  Context `{SI: Signature}.

  (** Connectives of the logic *)
  Inductive oo : Set :=
  | atom : atm -> oo
  | perp : atm -> oo
  | Top : oo
  | One : oo
  | Zero : oo
  | Bot : oo
  | AAnd : oo -> oo -> oo
  | MAnd : oo -> oo -> oo
  | AOr : oo -> oo -> oo
  | MOr : oo -> oo -> oo
  | Bang : subexp -> oo -> oo
  | Quest : subexp -> oo -> oo
  | All : (expr con -> oo) -> oo
  | Some : (expr con -> oo) -> oo.

  (** Complexity of formulas *)
  Fixpoint complexity (X:oo) :=
    match X with
    | atom A   => 1
    | perp A   => 1
    | One => 1
    | Bot => 1
    | Zero => 1
    | Top => 1
    | MAnd F G => 1+ complexity F + complexity G
    | AAnd F G => 1+ complexity F + complexity G
    | MOr F G => 1+ complexity F + complexity G
    | AOr F G => 1+ complexity F + complexity G
    | Bang a F   => 1+ complexity F
    | Quest a F  => 1+ complexity F
    | Some FX => 1+ complexity (FX (VAR con 0))
    | All FX => 1+ complexity (FX (VAR con 0))
    end.

     (** Complexity on list of formulas *)
  Fixpoint complexityL (L: list oo) :=
    match L with
    | nil => 0
    | a :: L' => complexity a + complexityL L'
    end.

  Lemma Complexity0 : forall F, complexity F > 0.
    induction F;simpl;lia.
  Qed.

  Lemma ComplexityL0 : forall L, complexityL L =0 -> L = [].
    intros;destruct L;simpl;auto.
    simpl in H.
    generalize (Complexity0 o);intros.
    lia.
  Qed.

  (** Classical linear logic dualities *)
  Fixpoint dual (X: oo) :=
    match X with
    | atom A   => perp A
    | perp A   => atom A
    | One => Bot
    | Bot => One
    | Zero => Top
    | Top => Zero
    | MAnd F G => MOr (dual  F) (dual G)
    | AAnd F G => AOr (dual  F) (dual G)
    | MOr F G => MAnd (dual  F) (dual G)
    | AOr F G => AAnd (dual  F) (dual G)
    | Bang a F   => Quest a (dual F)
    | Quest a F  => Bang a (dual   F)
    | Some X => All (fun x => dual  (X x))
    | All X => Some (fun x => dual (X x))
    end.

  (** Negation is involutive *)
  Theorem ng_involutive: forall F: oo, F = dual (dual F).
  Proof.
    intro.
    induction F; simpl; auto;
      try( try(rewrite <- IHF1); try(rewrite <- IHF2); try(rewrite <- IHF);auto);
      try(assert (o = fun x =>  dual (dual (o x))) by
             (extensionality e; apply H); rewrite <- H0; auto).
  Qed.

  Lemma DualComplexity : forall F, complexity F = complexity (dual F) .
    intros.
    induction F;intros;auto;
      try solve
          [simpl; try rewrite IHF; try rewrite IHF1; try rewrite IHF2;auto].
  Qed.

  (**  Linear Implication *)
  Definition Limp (F G : oo) : oo := MOr (dual F) G .
  Definition TypedFormula : Type := subexp * oo.

  (** Uniform Predicate (ruling out exotic terms) *)
  Inductive uniform_oo: (expr con -> oo) -> Prop :=
  | uniform_atom: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (atom (a x)))
  | uniform_perp: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (perp (a x)))
  | uniform_Top: uniform_oo (fun x => Top)
  | uniform_One: uniform_oo (fun x => One)
  | uniform_Bot: uniform_oo (fun x => Bot)
  | uniform_Zero: uniform_oo (fun x => Zero)
  | uniform_AAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AAnd (A x) (B x)))
  | uniform_MAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MAnd (A x) (B x)))
  | uniform_AOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AOr (A x) (B x)))
  | uniform_MOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MOr (A x) (B x)))
  | uniform_Bang: forall (A: expr con -> oo) a,
      uniform_oo A -> uniform_oo (fun x => (Bang a (A x)))
  | uniform_Quest: forall (A: expr con -> oo) a,
      uniform_oo A -> uniform_oo (fun x => (Quest a (A x)))
  | uniform_All: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (All (fun y => (A y x))))
  | uniform_Some: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (Some (fun y => (A y x)))).

  (** Well formedness condition  *)
  Inductive isFormula: oo -> Prop  :=
  | wf_atm : forall (P1:atm), isFormula (atom P1)
  | wf_perp : forall (P1:atm), isFormula (perp P1)
  | wf_Top : isFormula Top
  | wf_One : isFormula One
  | wf_Zero : isFormula Zero
  | wf_Bot : isFormula Bot
  | wf_AAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AAnd A1 A2)
  | wf_MAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MAnd A1 A2)
  | wf_AOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AOr A1 A2)
  | wf_MOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MOr A1 A2)
  | wf_Bang : forall (A1 :oo) a, isFormula A1 -> isFormula (Bang a A1)
  | wf_Quest : forall (A1 :oo) a, isFormula A1 -> isFormula (Quest a A1)
  | wf_All : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (All A)
  | wf_Some : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (Some A).

  Hint Constructors isFormula : core.

  Lemma ComplexityUniformEq : forall FX x y , uniform_oo FX ->
                                            proper x -> proper y ->
                                            complexity (FX x) =  complexity (FX y).
    intros.
    induction H;subst;simpl;firstorder.
  Qed.

   Lemma ComplexityPerm: forall M N, Permutation M N ->
                                        complexityL M =  complexityL N.
    intros.
    induction H;subst;simpl;lia.
  Qed.

    Global Instance permComplexity   :
   Proper ((@Permutation oo) ==> eq) (complexityL).
    Proof.
    unfold Proper; unfold respectful.
      intros.
      apply ComplexityPerm;auto.
  Qed.

  (** Well formendness conditions for lists and arrows *)
  Definition isFormulaL  (L:list oo)  := Forall isFormula L.
  Definition multiset := list.

  Global Instance perm_isFormulaL :
      Proper (@Permutation oo ==> Basics.impl)
             (isFormulaL  ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl .
      intros.
      unfold isFormulaL.
      rewrite <- H;auto.
    Qed.

  Lemma isFormulaIn : forall F L,
      isFormulaL L -> In F L -> isFormula F.
  Proof.
    intros. eapply @ForallIn with (F:=F) in H;auto.
  Qed.

  (** Arrows for the focused system
      - [UP] : negative phase
      - [DW] : positive phase
   *)
  Inductive Arrow  :=
  | UP (l : list oo) (* negative phase *)
  | DW (F : oo). (* positive phase *)

  (** Transforming arrows into lists of formulas *)
  Definition Arrow2LL (A: Arrow) : list oo :=
    match A  with
    | UP l => l
    | DW F => [F]
    end.

  (** Checking when a formulas has to lose focusing *)
  Inductive negativeFormula : oo -> Prop :=
  | RelNA1 : forall A,  negativeFormula (atom A)
  | RelTop : negativeFormula Top
  | RelBot : negativeFormula Bot
  | RelPar : forall F G, negativeFormula (MOr F G)
  | RelWith : forall F G, negativeFormula (AAnd F G)
  | RelQuest : forall F a, negativeFormula (Quest a F)
  | RelForall : forall FX, negativeFormula (All FX).

  (** Positive formulas (focusing persists *)
  Inductive positiveFormula : oo -> Prop :=
  | PosAt : forall A,  positiveFormula (perp A)
  | PosOne : positiveFormula One
  | PosZero : positiveFormula Zero
  | PosTensor : forall F G, positiveFormula (MAnd F G)
  | PosPlus : forall F G, positiveFormula (AOr F G)
  | PosBang : forall F a, positiveFormula (Bang a F)
  | PosEx : forall FX, positiveFormula (Some FX).

  (** Checking when a formulas has to be stored *)
  Inductive positiveLFormula : oo -> Prop :=
  | PosLAt : forall A,  positiveLFormula (atom A)
  | PosLPe : forall A,  positiveLFormula (perp A)
  | PosLOne : positiveLFormula One
  | PosLZero : positiveLFormula Zero
  | PosLTensor : forall F G, positiveLFormula (MAnd F G)
  | PosLPlus : forall F G, positiveLFormula (AOr F G)
  | PosLBang : forall F a, positiveLFormula (Bang a F)
  | PosLEx : forall FX, positiveLFormula (Some FX).

Theorem PositiveToLPositive : forall F,
      positiveFormula F -> positiveLFormula F.
    intros.
    inversion H;constructor.
  Qed.

  (** Every formula is either  a positive formula, or it must be released *)
  Theorem PositiveOrNegative : forall F,
      positiveFormula F \/ negativeFormula F.
    intros.
    destruct F;try (left;constructor);try(right;constructor).
  Qed.

Theorem PositiveNegativeSplit : forall M, exists M1 M2,
    Forall positiveFormula M1 /\ Forall negativeFormula M2 /\ Permutation M (M1++M2).
  Proof with sauto.
    induction M; intros...
    - exists nil.
      exists nil...
    - destruct (PositiveOrNegative a)...
      { exists (a::x).
        exists x0...
        rewrite H3... }
      { exists x.
        exists (a::x0)...
        rewrite H3... }
  Qed.

  (** Positive formulas cannot be released *)
   Theorem PositiveNotNegative: forall F,
      positiveFormula F -> ~ negativeFormula F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

 Theorem NegativeNotPositive : forall F,
      negativeFormula F -> ~ positiveFormula F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

  (** The dual of a positive formula is a release formula *)
Theorem PositiveDualNegative : forall F,
      positiveFormula F -> negativeFormula (dual F).
    intros F Hpos.
    inversion Hpos;subst;constructor.
  Qed.

  Theorem NegativeDualPositive : forall F, negativeFormula F -> positiveFormula (dual F).
    intros F Hrel.
    inversion Hrel;subst;constructor.
  Qed.

  (** Postive atoms *)
  Inductive IsPositiveAtom : oo -> Prop :=
  | IsPAP : forall A, IsPositiveAtom (atom A).

  (** Negative atoms *)
  Inductive IsNegativeAtom : oo -> Prop :=
  | IsNAP : forall A, IsNegativeAtom (perp A).

Local Hint Constructors IsPositiveAtom IsNegativeAtom : core.

  Theorem NegativeAtomDec : forall F,
      IsNegativeAtom F \/ ~ IsNegativeAtom F.
    induction F;auto; try solve[right;intro H'; inversion H'].
  Qed.

  Theorem PositiveAtomDec : forall F,
      IsPositiveAtom F \/ ~ IsPositiveAtom F.
    destruct F;auto;right;intro H';inversion H'.
  Qed.

  (** List of positive atoms *)
  Definition IsPositiveAtomL  L : Prop := Forall IsPositiveAtom L.

 Lemma NotAsynchronousPosAtoms :
    forall F, positiveLFormula F -> positiveFormula F \/ IsPositiveAtom F.
    intros.
    inversion H;auto; first [left;constructor
                             | right;constructor ].
  Qed.

Theorem PositiveAtomToNegativeFormula : forall F,
      IsPositiveAtom F -> negativeFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem NetagiveAtomToPositiveFormula : forall F,
      IsNegativeAtom F -> positiveFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem PositiveAtomToPositiveLFormula : forall F,
      IsPositiveAtom F -> positiveLFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem positiveNotAtom F: positiveFormula F -> IsPositiveAtom F -> False.
Proof.
  intros.
  inversion H0;subst.
  inversion H.
 Qed.

  End LLSyntax.

Global Hint Constructors uniform_oo : core.
Global Hint Resolve Complexity0
                    DualComplexity: core.

Module LLNotations .
  Notation "'⊥'" := Bot.
  Notation "'⊤'" := Top.
  Notation "'1'" := One.
  Notation "'0'" := Zero.
  Notation "A ⊗ B" := (MAnd A B ) (at level 50) .
  Notation "A ⅋ B" := (MOr A B) (at level 50) .
  Notation "A ⊕ B" := (AOr A B) (at level 50) .
  Notation "A & B" := (AAnd A B) (at level 50) .
  Notation "! A" := (Bang A) (at level 50) .
  Notation "? A" := (Quest A) (at level 50) .
  Notation " A ^ " := (dual A) (at level 10) .
  Notation "'∀{' FX '}'" := (All FX) (at level 10) .
  Notation "'∃{' FX '}'" := (Some FX) (at level 10) .
End LLNotations .

Global Hint Constructors IsPositiveAtom : core.

Global Hint Constructors
    negativeFormula
    positiveFormula
    positiveLFormula
    uniform_oo isFormula IsPositiveAtom
    IsNegativeAtom: core.

Global Hint Resolve
     PositiveToLPositive
     PositiveAtomToNegativeFormula
     PositiveAtomToPositiveLFormula
     NetagiveAtomToPositiveFormula
     positiveNotAtom: core.

Global Hint Unfold isFormulaL :core.