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
  | 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)
  | 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
  | 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.


Require Export Cfuzzi.Syntax.
Require Export Cfuzzi.IncExt.
Require Export Cfuzzi.DecExt.

Module KitchenSink(E : Embedding) (Lap: Laplace E) (LOGIC: APRHL E Lap).

  Module Inc := Increment E Lap LOGIC.
  Module Dec := Decrement E Lap LOGIC.
  Import Dec TSImpl APRHLImpl.
  Import Inc TSImpl APRHLImpl.

  Definition x := "x"%string.
  Definition y := "y"%string.

  Definition prog :=
    (x <- el 1%Z ;;
      y <- el 2%Z ;;
      inc_cmd x ;;
      dec_cmd x)%cmd.

  Goal forall ctx, VarMap.MapsTo x t_int ctx ->
                   VarMap.MapsTo y t_int ctx ->
                   welltyped ctx prog.
    intros ctx Hx Hy.
    repeat apply welltyped_seq; auto.
    apply welltyped_assign with (t := t_int); auto.
    apply welltyped_assign with (t := t_int); auto.
    apply Inc.typing_rule_type; auto.
    apply Dec.typing_rule_type; auto.
  Qed.

  Goal forall ctx sctx,
      welltyped ctx prog ->
      VarMap.MapsTo x 1%Z sctx ->
      (ctx ⊕ ctx |- prog ~_(0%R) prog : denote_env sctx ==> denote_env sctx)%triple.
    intros ctx sctx Htyped Hsens_typed.
    unfold prog; inversion Htyped; subst.
    inversion H2; subst.
    inversion H3; subst.
    inversion H7; subst.
    replace 0%R with (0 + 0)%R.
    apply aprhl_seq with (env := ctx) (env' := ctx) (Q := denote_env sctx); auto.
    Focus 2.
    replace 0%R with (0 + 0)%R.
    apply aprhl_seq with (env := ctx) (env' := ctx) (Q := denote_env sctx); auto.
    Focus 2.
    replace 0%R with (0 + 0)%R.
    apply aprhl_seq with (env := ctx) (env' := ctx) (Q := denote_env sctx); auto.
    apply Inc.typing_rule_sens with (tctx := ctx) (pre := sctx) (post := sctx); auto.
    - simpl.
      exists 1%Z; auto.
      apply VarMap.find_1; auto.
      Focus 2.
      apply Dec.typing_rule_sens with (tctx := ctx) (pre := sctx) (post := sctx); auto.
      exists 1%Z; auto.
      apply VarMap.find_1; auto.
    Admitted.

End KitchenSink.


Require Import Functor.

Class Monad (m : Type -> Type) : Type := {
  return_ : forall {A}, A -> m A
  ; bind : forall {A}, m A -> forall {B}, (A -> m B) -> m B
  (* monad laws *)
  ; right_unit : forall A (a : m A), a = bind a (@return_ A)
  ; left_unit : forall A (a : A) B (f : A -> m B),
      f a = bind (return_ a) f
  ; associativity : forall A (ma : m A) B f C (g : B -> m C),
      bind ma (fun x => bind (f x) g) = bind (bind ma f) g
}.

Notation "a >>= f" := (bind a f) (at level 50, left associativity).
Notation "a >> b" := (a >>= (fun _ => b)) (at level 50, left associativity).
Notation "'do' a <- e ; c" :=
  (e >>= (fun a => c)) (at level 60, right associativity).

Require Import List.
Fixpoint sequence {M : Type -> Type} {m : Monad M} {A : Type}
  (ms : list (M A)) : M (list A) :=
  match ms with
  | nil => return_ nil
  | m :: ms' => m >>= (fun x => sequence ms' >>= fun xs => return_ (x::xs))
  end.

Fixpoint sequence_ {M : Type -> Type} {m : Monad M} {A : Type}
  (ms : list (M A)) : M unit :=
  match ms with
  | nil => return_ tt
  | m :: ms' => m >> sequence_ ms' >> return_ tt
  end.

Definition mapM {M} {_ : Monad M}{A B:Type} (f:A->M B) xs :=
  sequence (fmap f xs).

Definition mapM_ {M} {_ : Monad M}{A B:Type} (f:A->M B) xs :=
  sequence_ (fmap f xs).

Instance OptionMonad : Monad option := {
  return_ := Some
  ; bind A m B f :=
      match m with
      | None => None
      | Some a => f a
      end
}.
Proof.
 destruct a; reflexivity.

 reflexivity.

 destruct ma.
  intros B f C g. destruct (f a); reflexivity.

  reflexivity.
Defined.


Require Import proof.

Lemma RA'_trans : forall ct' e lpt e' lpt' e'' lpt'',
    AVE_reduce' ct' e lpt e' lpt' ->
    AVE_reduce' ct' e' lpt' e'' lpt'' ->
    AVE_reduce' ct' e lpt e'' lpt''.
Proof.
  intros. induction H; eauto.
Qed.
Hint Resolve RA'_trans.

Lemma lemma8' : forall (ct' : class_table) (e e' : expr) (lpt lpt' : set expr),
    AVE_reduce' ct' e lpt e' lpt' -> subset lpt lpt'.
Proof.
  intros. induction H.
  - intros x H. assumption.
  - apply lemma8 in H. eapply subset_trans; eassumption.
Qed.
Hint Resolve lemma8'.

Lemma RAC'_Field : forall ct' e e' lpt lpt' fi,
    AVE_reduce' ct' e lpt e' lpt' -> AVE_reduce' ct' (E_Field e fi) lpt (E_Field e' fi) (lpt' U lpt).
Proof.
  intros.
  induction H.
  - rewrite union_same. apply RA'_refl.
  - eapply RA'_step; eauto.
    repeat erewrite <- union_include; eauto.
    erewrite <- union_include in IHAVE_reduce'; eauto.
    Unshelve. assumption. assumption. assumption. assumption. assumption. assumption.
Qed.
Hint Resolve RAC'_Field.

Lemma RAC'_Invk_Recv : forall {ct e e'} mi le {lpt lpt'},
    AVE_reduce' ct e lpt e' lpt' -> AVE_reduce' ct (E_Invk e mi le) lpt (E_Invk e' mi le) (lpt' U lpt).
Proof.
  intros. induction H; try (rewrite union_same; constructor).
  eapply RA'_step. eapply RAC_Invk_Recv. eassumption.
  repeat erewrite <- union_include; eauto.
  erewrite <- union_include in IHAVE_reduce'; eauto.
    Unshelve. assumption. assumption. assumption. assumption. assumption. assumption.
Qed.
Hint Resolve RAC'_Invk_Recv.

Inductive not_derived_by_rel_lpt {ct ct' gamma} : forall {e e' lpt}, alpha ct ct' gamma e e' lpt -> Prop :=
  N_Rel_Field : forall {e e' : expr} {f : field_id} {lpt : set expr} pf,
    not_derived_by_rel_lpt (Rel_Field ct ct' gamma e e' f lpt pf)
| N_Rel_Lib_Field : forall {e : expr} {c : class} {pfc : valid_class ct c} {di : class_id}
                    {f : field_id} {lpt : set expr} pf1 pf2 pf3 pf4,
    not_derived_by_rel_lpt (Rel_Lib_Field ct ct' gamma e c pfc di f lpt pf1 pf2 pf3 pf4)
| N_Rel_New : forall {ci : class_id} {le le' : list expr} {lpt : set expr} pf1 pf2 pf3,
    not_derived_by_rel_lpt (Rel_New ct ct' gamma ci le le' lpt pf1 pf2 pf3)
| N_Rel_Lib_New : forall {ci : class_id} {le : list expr} {lpt : set expr} pf1 pf2,
    not_derived_by_rel_lpt (Rel_Lib_New ct ct' gamma ci le lpt pf1 pf2)
| N_Rel_Invk : forall {e e' : expr} {le le' : list expr} {mi : method_id} {lpt : set expr} pf1 pf2 pf3,
    not_derived_by_rel_lpt (Rel_Invk ct ct' gamma e e' le le' mi lpt pf1 pf2 pf3)
| N_Rel_Lib_Invk : forall {e : expr} {le : list expr} {mi : method_id} {lpt : set expr} pf1 pf2 pf3,
    not_derived_by_rel_lpt (Rel_Lib_Invk ct ct' gamma e le mi lpt pf1 pf2 pf3)
| N_Rel_Cast : forall {e e' : expr} {c : class_id} {lpt : set expr} pf1,
    not_derived_by_rel_lpt (Rel_Cast ct ct' gamma e e' c lpt pf1)
| N_Rel_Lib_Cast : forall {e : expr} {ci : class_id} {lpt : set expr} pf1,
    not_derived_by_rel_lpt (Rel_Lib_Cast ct ct' gamma e ci lpt pf1).

Lemma lemma6 : forall {ct ct' gamma e eh lpt},
    alpha ct ct' gamma e eh lpt -> calP ct' gamma eh lpt -> exists yh,
        (exists rel : alpha ct ct' gamma e yh lpt, not_derived_by_rel_lpt rel) /\
        AVE_reduce' ct' eh lpt yh lpt.
Proof.
  intros ct ct' gamma e eh lpt H H0.
  induction H.
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Field H).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Lib_Field H H1 H2 H3).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_New H H1 H2).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Lib_New H H1).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Invk H H1 H2).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Lib_Invk H H1 H2).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Cast H).
  - eexists. split; try apply RA'_refl. eexists. apply (N_Rel_Lib_Cast H).
  - destruct H0 as [_ calPlpt]. apply calPlpt in H1 as calPe'.
    destruct (IHalpha (conj calPe' calPlpt)) as [dh [[rel not_lpt] red]].
    eexists. split. eexists. eassumption.
    eapply RA'_step; try eassumption.
    apply RA_Return. assumption.
Qed.

Lemma decl_in_lib_ct_decl_in_lib_ct'_h : forall {ct ct'} (rel : ave_rel ct ct') {c} pfc (pfc' : valid_class ct' c) fi di,
    declaring_class ct c pfc fi = Some di -> in_lib_id ct di -> pfc' = pfc' ->
    in_lib_id ct' di.
Proof.
  intros ct ct' rel c pfc pfc'.
  apply simul_induct with (ct := ct) (ct' := ct') (c := c) (pfc := pfc) (pfc' := pfc');
    try assumption; clear c pfc pfc'; intros; try solve [inversion H].
  inversion H0.
  destruct (@existsb field_id (beq_nat fi) (dfields c)) eqn:exstb;
    try (eapply H; try eassumption; reflexivity).
  inversion H4. subst. destruct ct' as (app', lib'). exists c.
  inversion rel as [val_ct _ keep_app _ _]. apply in_lib_id_in_lib in H1 as c_in_lib; try assumption.
  Focus 2. inversion sca as [[_ sol]|[_ sol]]; [ | apply in_app_in_table]; assumption.
  assert (pfc' := ValidParent (app', lib') c d pfd' ext' nla' sca').
  assert (in_table (app', lib') c) by (apply valid_in_table; assumption).
  destruct H3; try assumption.
  apply keep_app in H3. destruct nla; split; assumption.
Qed.

Lemma decl_in_lib_ct_decl_in_lib_ct' : forall {ct ct'} (rel : ave_rel ct ct') {c} pfc (pfc' : valid_class ct' c) fi di,
    declaring_class ct c pfc fi = Some di -> in_lib_id ct di ->
    in_lib_id ct' di.
Proof.
  intros. eapply decl_in_lib_ct_decl_in_lib_ct'_h with (pfc'0 := pfc'); try reflexivity; eassumption.
Qed.
Hint Resolve decl_in_lib_ct_decl_in_lib_ct'.

Lemma calPadd : forall ct' gamma e ea lpt,
    calP ct' gamma e lpt -> calPexpr ct' gamma ea -> calP ct' gamma e (add ea lpt).
Proof.
  intros. inversion H as [calPe calPlpt].
  split; try assumption.
  intros. destruct H1; auto.
  inversion H1. subst. assumption.
Qed.
Hint Resolve calPadd.

Lemma find_method_mresolve_h : forall l mi,
    existsb (fun a => beq_nat mi match a with Method _ id _ _ => id end) l =
    existsb (fun a => match a with Method _ id _ _ => beq_nat mi id end) l.
Proof.
  induction l; try reflexivity.
  intros. simpl. destruct a. rewrite IHl. reflexivity.
Qed.

Lemma find_method_mresolve : forall {ct c} pfc mi,
    (exists m, find_method mi pfc = Some m) <-> (exists p, mresolve ct mi c pfc = Some p).
Proof.
  induction pfc; (split; intros; [destruct H as [m Hm]; inversion Hm | destruct H as [p Hp]; inversion Hp]).
  - destruct (lookup_method c mi) eqn:find_method.
    + inversion H0; subst.
      exists c. simpl. unfold lookup_method in find_method. destruct c; try solve [inversion e].
      unfold dmethods_id. rewrite existsb_map.
      assert (existsb (fun a => PeanoNat.Nat.eqb mi (mid a)) (dmethods (C c c0 l c1 l0)) = true).
      { rewrite find_method_mresolve_h. apply existsb_find. eexists; eassumption. }
      rewrite H. reflexivity.
    + simpl. unfold lookup_method in find_method. destruct c; try solve [inversion e].
      assert (~ exists m, find (fun m : method => match m with
                                        | Method _ mi' _ _ => PeanoNat.Nat.eqb mi mi'
                                          end) l0 = Some m).
      { intro. destruct H. rewrite find_method in H. inversion H. }
      eapply not_iff in H. Focus 2. apply existsb_find.
      apply Bool.not_true_is_false in H.
      unfold dmethods_id. rewrite existsb_map. simpl. rewrite find_method_mresolve_h. rewrite H.
      apply IHpfc. simpl in Hm. rewrite find_method in Hm. eexists. eassumption.
  - destruct c; try solve [inversion e].
    destruct (existsb (beq_nat mi) (dmethods_id (C c c0 l c1 l0))) eqn:exstb; simpl in exstb;
      unfold dmethods_id in exstb; simpl; rewrite existsb_map, find_method_mresolve_h in exstb.
    + apply existsb_find in exstb. destruct exstb as [m Hm]. simpl in Hm. rewrite Hm. eexists. reflexivity.
    + rewrite <- Bool.not_true_iff_false in exstb. eapply not_iff in exstb. Focus 2. symmetry. apply existsb_find.
      apply not_exists_some_iff_none in exstb. simpl in exstb. rewrite exstb. apply IHpfc. eexists. eassumption.
Qed.
Hint Resolve find_method_mresolve.

Ltac try_invert :=
  try match goal with
      | [ H : _ |- _ ] => try solve [inversion H]
      end.

Lemma mresolve_valid : forall {ct c} pfc mi e,
    mresolve ct mi c pfc = Some e -> valid_class ct e.
Proof.
  induction pfc; intros; try_invert.
  simpl in H. destruct (existsb (beq_nat mi) (dmethods_id c)); inversion H; subst; eauto.
Qed.
Hint Resolve mresolve_valid.

Lemma find_method_ct_ct' : forall {ct ct'} (rel : ave_rel ct ct') {c}
                             (pfc : valid_class ct c) (pfc' : valid_class ct' c) mi,
    find_method mi pfc = find_method mi pfc'.
Proof.
  intros ct ct' rel c pfc pfc'.
  apply simul_induct with (ct := ct) (ct' := ct') (c := c) (pfc := pfc) (pfc' := pfc'); trivial.
  clear c pfc pfc'.
  intros. simpl. destruct (lookup_method c mi); auto.
Qed.
Hint Resolve find_method_ct_ct'.

Lemma combine_step : forall {A B} la lb (a : A) (b : B),
    (a, b) :: combine la lb = combine (a :: la) (b :: lb).
Proof. reflexivity. Qed.
Hint Resolve combine_step.

Lemma subtype_in_table : forall ct c d,
    subtype ct c d -> in_table ct c.
Proof. intros. induction H; eauto. Qed.
Hint Resolve subtype_in_table.

Lemma supertype_in_table : forall ct c d,
    valid_table ct -> subtype ct c d -> in_table ct d.
Proof. intros ct c d val_ct sub_c_d. inversion val_ct. induction sub_c_d; eauto. Qed.
Hint Resolve supertype_in_table.

Lemma subtype_ct_ct' : forall {ct ct'} c d,
    ave_rel ct ct' -> in_table ct' c -> subtype ct c d -> subtype ct' c d.
Proof with eauto.
  intros ct ct' c d rel_ct c_in_ct' c_sub_d. inversion rel_ct as [_ val_ct' _ keep_ext _].
  induction c_sub_d; eauto.
  - specialize (IHc_sub_d1 c_in_ct').
    assert (in_table ct' d)...
  - constructor; eauto. apply keep_ext; split; eauto.
Qed.
Hint Resolve subtype_ct_ct'.

Axiom preservation : forall ct gamma e e' ci,
    type_of ct gamma e ci -> FJ_reduce' ct e e' -> type_of ct gamma e' ci.
Hint Resolve preservation.

Lemma in_dmethods_mresolve : forall ct c pfc m,
    In m (dmethods c) -> mresolve ct (mid m) c pfc = Some c.
Proof with eauto.
  intros. destruct pfc; [inversion H|].
  simpl. unfold dmethods_id. rewrite existsb_map.
  replace (existsb (fun a : method => PeanoNat.Nat.eqb (mid m) (mid a)) (dmethods c)) with true...
  symmetry. eapply existsb_exists. split_rec 2; eauto. symmetry. apply beq_nat_refl.
Qed.
Hint Resolve in_dmethods_mresolve.

Lemma valid_calP : forall ct' gamma e,
    valid_expr ct' gamma e -> calPexpr ct' gamma e.
Proof.
  intros. induction H using valid_expr_ind_list; decomp; try inversion H; eauto.
Qed.
Hint Resolve valid_calP.

Lemma FJ_reduce_valid : forall ct gamma e e',
    valid_expr ct gamma e ->
    FJ_reduce ct e e' ->
    valid_expr ct gamma e'.
Proof.
  intros ct gamma e e' val_e H.
  induction H; inversion val_e; subst; eauto.
  - inversion H7; subst. eapply Forall_In; try eassumption; eauto.
  - inversion val_e; subst. inversion H9; subst. eauto.

Lemma calPrel : forall ct' gamma e e' lpt lpt',
    valid_table ct' ->
    AVE_reduce ct' e lpt e' lpt' ->
    valid_expr ct' gamma e ->
    calP ct' gamma e lpt ->
    calP ct' gamma e' lpt'.
Proof.
  intros ct' gamma e e' lpt lpt' val_ct' H val_e.
  induction H; eauto; intros; try solve [inverts 2; eauto].
  - split; eauto. inversion H2; inversion H3; inversion val_e; inversion H11; eauto. subst.
    apply In_set_from_list_In_list in H5. apply valid_calP. eapply Forall_In; swap 1 2; eassumption.
  - admit. (*inversion val_e. inversion H8. eauto. *)
  - eapply IHAVE_reduce; eauto.

Lemma lemma11 : forall ct ct' gamma e0 e e' eh lpt,
    ave_rel ct ct' -> FJ_reduce' ct e0 e -> FJ_reduce ct e e' ->
    alpha ct ct' gamma e eh lpt -> calP ct' gamma eh lpt ->
    type_checks ct gamma e0 -> fj_expr e0 -> valid_expr ct gamma e -> fj_expr e ->
    exists eh' lpt', AVE_reduce' ct' eh lpt eh' lpt' /\ alpha ct ct' gamma e' eh' lpt' /\ calP ct' gamma eh' lpt'.
Proof with eauto.
  intros ct ct' gamma e0 e e' eh lpt rel_ct red_e0_e red_e_e' rel_e_eh calPehlpt
         typ_chk_e0 fj_expr_e0 val_e fj_expr_e.
  generalize dependent eh. generalize dependent e0.
  inversion rel_ct as [val_ct val_ct' keep_app _ _].
  inversion val_ct as [ct0 in_table_valid _ one_cid id_in_one one_fid _]; subst ct0.
  inversion val_ct' as [ct0 in_table_valid' _ _ _ _ _]; subst ct0.
  induction red_e_e'; intros; dependent induction rel_e_eh;
    try solve [destruct calPehlpt; eapply IHrel_e_eh in rel_ct; try reflexivity; eauto;
               decomp; split_rec 4; try eassumption; eauto]; try clear IHrel_e_eh.

  (* Case R_Field *)

    (* Subcase Rel_Field *)
    - assert (In fi (field_ids ct c pfc)) as In_fields.
      { assert (forall fi', (beq_nat fi) fi' = true <-> fi = fi').
        { split; try apply beq_nat_true. intro. subst. symmetry. apply beq_nat_refl. }
        eapply index_of_In. eassumption. eexists; eassumption. }
      apply In_fields_decl_exists in In_fields. destruct In_fields as [chi declchi].
      apply valid_in_table in pfc as c_in_table. destruct c_in_table as [c_in_app | c_in_lib].

      (* if c is in CT_A *)
      + dependent induction rel_e_eh; intros.

        (* SubSubCase Rel_New *)
        * assert (exists ehi, nth_error le' n = Some ehi) as exeh.
           { apply nth_error_better_Some. rewrite <- H0. apply nth_error_better_Some. eexists; eauto. }
           destruct exeh as [ehi Hehi].
           exists ehi. exists lpt. split.
           -- eapply RA'_step with ehi lpt; try eapply RA'_refl. apply RA_FJ.
              assert (valid_class ct' c) as pfc'...
              eapply R_Field with (pfc := pfc'); eauto. rewrite <- (field_ids_same pfc); trivial.
           -- inversion calPehlpt as [calPeh calPlpt]. inversion calPeh. inversion H6.
              split; try split; try apply Forall_In with le'; try apply nth_error_In with n; try assumption.
              subst. apply Forall_In with (P := fun p => alpha ct ct' gamma (fst p) (snd p) lpt)
                                            (l := combine le le')
                                            (a := (ei, ehi)); try assumption.
              apply nth_error_In with n. apply nth_error_combine; assumption.

        (* SubSubCase Rel_Lib_New, CONTRADICTION  *)
        * destruct (not_lib_app ct c); trivial; split; trivial.
           apply in_lib_id_in_lib; trivial. apply in_app_in_table; trivial.

        (* SubSubCase Rel_Lpt, Induction  *)
        * eapply IHrel_e_eh in rel_ct as IHspec; try reflexivity; try eassumption.
           destruct IHspec as [eh' [lpt' [red_eh' [rel_eh' calP_eh']]]].
           exists eh'. exists lpt'. split; try split; try assumption.
           -- eapply RA'_trans; try eassumption.
              eapply RA'_step; try solve [econstructor].
              rewrite <- union_same. eapply RAC_Field.
              apply RA_Return. assumption.
           -- destruct calPehlpt as [_ calP_lpt].
              assert (valid_class ct' c) as pfc'.
              { apply in_table_valid', in_app_in_table, keep_app, c_in_app. }
              split; try assumption. eapply P_Field with (pfc' := pfc'); eauto.
              erewrite decl_ct'_decl_ct; eassumption.

      (* if c is in CT_L *)
      + dependent induction rel_e_eh; intros.

        (* SubSubCase Rel_New *)
        * assert (exists ehi, nth_error le' n = Some ehi) as exeh.
           { apply nth_error_better_Some. rewrite <- H0. apply nth_error_better_Some. exists ei. trivial. }
           destruct exeh as [ehi Hehi].
           exists ehi. exists lpt. split; try split.
           -- apply RA'_step with ehi lpt; try apply RA'_refl. apply RA_FJ.
              assert (valid_class ct' c) as pfc'.
              { apply in_table_valid', in_lib_in_table, keep_id_keep_class with ct; assumption. }
              apply R_Field with pfc' n; trivial. rewrite <- (field_ids_same pfc); trivial.
           -- remember (ei, ehi) as p.
              replace ei with (fst p); try replace ehi with (snd p); try (rewrite Heqp; reflexivity).
              eapply Forall_In with (P := fun p => alpha ct ct' gamma (fst p) (snd p) lpt).
              eassumption. eapply nth_error_In. erewrite nth_error_combine; eauto.
              rewrite Heqp. reflexivity.
           -- eapply calPsub; try eassumption.
              eapply SUB_Trans.
              ++ apply SUB_New. eapply nth_error_In. eassumption.
              ++ eapply SUB_Field.

        (* SubSubCase Rel_Lib_New *)
        * apply decl_of_in_lib_in_lib in declchi as chi_in_lib; try assumption.
           assert (ch_in_lib := chi_in_lib).
           unfold in_lib_id in ch_in_lib. destruct ct as [app lib].
           destruct ch_in_lib as [ch Hch].
           assert (chi = id_of ch).
           { apply one_cid. simpl. destruct (app chi) eqn:appchi; try assumption.
             destruct (id_in_one chi). split; try assumption. simpl. exists c0. assumption. }
           subst. assert (valid_class (app, lib) ch) as pfch.
           { apply in_table_valid. apply in_lib_in_table. assumption. }
           inversion calPehlpt as [calPeh calPlpt]. inversion calPeh. subst.
           rename pfc' into pfc0'.
           assert (valid_class (app, lib) c0) as pfc0 by (apply valid_ct'_valid_ct with ct'; assumption).
           assert (declaring_class (app, lib) c0 pfc0 fi = Some di) by
               (rewrite <- decl_ct'_decl_ct with (ct' := ct') (pfc' := pfc0'); assumption).
           assert (di = (id_of ch)) by (apply one_fid with c0 pfc0 c pfc fi; assumption). subst.
           assert (valid_class ct' ch) as pfch'.
           { apply in_table_valid'. apply in_table_in_table' with (app, lib); try assumption.
             - right. assumption.
             - apply decl_in_table with c0 pfc0' fi. assumption. }
           remember (E_New (id_of ch) (repeat E_Lib (length (fields ct' ch pfch')))) as ch_new.
           assert (in_lib ct' ch).
           { destruct (valid_in_table ct' ch pfch'); try assumption.
             destruct (not_lib_app (app, lib) ch pfch). split... apply keep_app; assumption. }
           exists E_Lib. exists (add ch_new lpt).
           split; try split.
           ++ apply RA'_step with (E_Field E_Lib fi) (add ch_new lpt).
              { rewrite Heqch_new. apply RA_New. assumption. }
              apply RA'_step with (E_Field ch_new fi) (add ch_new lpt).
              { rewrite <- union_same. apply RAC_Field. apply RA_Return. right. reflexivity. }
              apply RA'_step with E_Lib (add ch_new lpt); try apply RA'_refl.
              apply RA_FJ. rewrite Heqch_new.
              apply decld_class_same_decl with (pfe := pfch') in H6 as decl_ch'; try assumption.
              apply decl_index_of in decl_ch' as fi_in_ch; try assumption.
              destruct fi_in_ch as [m Hm].
              apply R_Field with pfch' m; try assumption.
              apply nth_error_repeat. rewrite fields_field_ids_length.
              apply index_of_length with (beq_nat fi). assumption.
           ++ apply lemma5. eapply Forall_In with (P := fun e  => alpha (app, lib) ct' gamma e E_Lib lpt);
                              try eapply nth_error_In; eassumption.
           ++ split. apply P_Lib. intros. destruct H7.
              apply calPlpt. apply H7. inversion H7. subst x. rewrite Heqch_new.
              apply P_New. apply Forall_repeat. apply P_Lib.
              apply decl_in_table with c0 pfc0' fi. assumption.

        (* SubSubCase Rel_Lpt, CONTRADICTION  *)
        * eapply IHrel_e_eh in rel_ct as IHspec; try reflexivity; try eassumption.
           destruct IHspec as [eh' [lpt' [red_eh' [rel_eh' calP_eh']]]].
           exists eh'. exists lpt'. split; try split; try assumption.
           -- eapply RA'_trans; try eassumption.
              eapply RA'_step; try solve [econstructor].
              rewrite <- union_same. eapply RAC_Field.
              apply RA_Return. assumption.
           -- destruct calPehlpt as [calPeh calP_lpt].
              split; try assumption. inversion calPeh. eapply P_Field; try eassumption; apply calP_lpt, H.

    (* Subcase Rel_Lib_Field *)
    - assert (In fi (field_ids ct c pfc)) as In_fields.
      { assert (forall fi', (beq_nat fi) fi' = true <-> fi = fi').
        { split; try apply beq_nat_true. intro. subst. symmetry. apply beq_nat_refl. }
        eapply index_of_In. eassumption. eexists; eassumption. }
      apply In_fields_decl_exists in In_fields. destruct In_fields as [chi declchi].
      assert (di = chi) by (eapply one_fid; eassumption). subst di.
      apply valid_in_table in pfc as c_in_table. destruct c_in_table as [c_in_app | c_in_lib].

      (* if c is in CT_A *)
      + dependent induction rel_e_eh; intros.

        (* SubSubCase Rel_Lib_New, CONTRADICTION *)
        * destruct (not_lib_app ct c pfc). split; try assumption.
           apply in_lib_id_in_lib; try apply rel_ct; try apply in_app_in_table; assumption.

        (* SubSubCase Rel_Lpt, INDUCTION  *)
        * destruct e'; inversion rel_e_eh; subst;
             try solve [eapply IHrel_e_eh in rel_ct as IHspec; try reflexivity; try eassumption].
           clear IHrel_e_eh.
           assert (exists ehi, nth_error l n = Some ehi) as exeh.
           { apply nth_error_better_Some. rewrite <- H11. apply nth_error_better_Some. exists ei. trivial. }
           destruct exeh as [ehi Hehi].
           assert (valid_class ct' c) as pfc'.
           { apply in_table_valid', in_app_in_table, keep_app. assumption. }
           eexists. eexists. split; try split.
           -- eapply RA'_step.
              { eapply RA_Field with (pfc := pfc'). erewrite decl_ct'_decl_ct. eapply declchi. assumption.
                eapply decl_in_lib_ct_decl_in_lib_ct' with (c1 := c); eassumption. }
              eapply RA'_step.
              { eapply RA_Return. right. reflexivity. }
              eapply RA'_step.
              { eapply RAC_Field. eapply RA_Return. left. eapply H. }
              rewrite union_same. eapply RA'_step.
              { eapply RA_FJ. eapply R_Field with (pfc := pfc'); try eassumption.
                erewrite <- field_ids_same; eassumption. }
              apply RA'_refl.
           -- remember (ei, ehi) as p.
              replace ei with (fst p); try replace ehi with (snd p); try (rewrite Heqp; reflexivity).
              apply lemma5. eapply Forall_In with (P := fun p => alpha ct ct' gamma (fst p) (snd p) lpt).
              eassumption. eapply nth_error_In. erewrite nth_error_combine; eauto.
              rewrite Heqp. reflexivity.
           -- inversion calPehlpt as [_ calPlpt].
              eapply calPsub.
              ++ apply calPadd. split. apply calPlpt. eassumption. assumption.
                 eapply P_Field with (pfc' := pfc'). constructor.
                 erewrite decl_ct'_decl_ct; eassumption.
              ++ eapply SUB_New, nth_error_In, Hehi.

      (* if c is in CT_L *)
      + dependent induction rel_e_eh; intros.

        (* SubSubCase Rel_Lib_New *)
        * eexists. eexists. split; try split; try eassumption. apply RA'_refl.
           eapply Forall_In with (P := fun e => alpha ct ct' gamma e E_Lib lpt); try eassumption.
           eapply nth_error_In; eassumption.

        (* SubSubCase Rel_Lpt, CONTRADICTION  *)
        * destruct e'; inversion rel_e_eh; subst;
             try solve [eapply IHrel_e_eh in rel_ct as IHspec; try reflexivity; try eassumption].
           clear IHrel_e_eh.
           assert (exists ehi, nth_error l n = Some ehi) as exeh.
           { apply nth_error_better_Some. rewrite <- H11. apply nth_error_better_Some. exists ei. trivial. }
           destruct exeh as [ehi Hehi].
           assert (valid_class ct' c) as pfc'.
           { apply in_table_valid'. apply in_lib_in_table. apply keep_id_keep_class with ct; assumption. }
           eexists. eexists. split; try split.
           -- eapply RA'_step.
              { eapply RA_Field with (pfc := pfc'). erewrite decl_ct'_decl_ct. eapply declchi. assumption.
                eapply decl_in_lib_ct_decl_in_lib_ct' with (c1 := c); eassumption. }
              eapply RA'_step.
              { eapply RA_Return. right. reflexivity. }
              eapply RA'_step.
              { eapply RAC_Field. eapply RA_Return. left. eapply H. }
              rewrite union_same. eapply RA'_step.
              { eapply RA_FJ. eapply R_Field with (pfc := pfc'); try eassumption.
                erewrite <- field_ids_same; eassumption. }
              apply RA'_refl.
           -- remember (ei, ehi) as p.
              replace ei with (fst p); try replace ehi with (snd p); try (rewrite Heqp; reflexivity).
              apply lemma5.
              eapply Forall_In with (P := fun p => alpha ct ct' gamma (fst p) (snd p) lpt).
              eassumption. eapply nth_error_In. erewrite nth_error_combine; eauto.
              rewrite Heqp. reflexivity.
           -- inversion calPehlpt as [_ calPlpt].
              eapply calPsub.
              ++ apply calPadd. split. apply calPlpt. eassumption. assumption.
                 eapply P_Field with (pfc' := pfc'). constructor.
                 erewrite decl_ct'_decl_ct; eassumption.
              ++ eapply SUB_New, nth_error_In, Hehi.

  (* Case R_Invk *)

    - assert (exists ch, mresolve ct mi c pfc = Some ch) as exst_ch.
      { apply find_method_mresolve. eexists; eassumption. }
      destruct exst_ch as [ch mres_ch].
      assert (valid_class ct ch) as pfch...
      destruct (valid_in_table ct ch pfch).

      (* Subcase Rel_Invk and mresolve(m, C) in CT_A *)
      + assert (in_app ct c) by (eapply lemma1; eassumption).
        assert (valid_class ct' c) as pfc'.
        { apply in_table_valid', in_app_in_table, keep_app. auto. }
        dependent induction rel_e_eh.

        * split_rec 4.
           -- eapply RA'_step; try solve [constructor].
              eapply RA_FJ. eapply R_Invk with (pfc := pfc'); try eassumption.
              erewrite <- find_method_ct_ct'; eassumption.
           -- repeat rewrite combine_step. admit. (* apply lemma3; eauto. *)
           -- inversion calPehlpt as [calPinvk calPlpt].
              split; eauto. admit.

        * destruct (not_lib_app ct c pfc). split; auto.

        * inversion calPehlpt as [calPeh calPlpt].
           inversion calPeh; subst.
           eapply IHrel_e_eh in rel_ct as IHspec; try reflexivity; eauto.
           destruct IHspec as [eh' [lpt' [red_eh' [rel_eh' calP_eh']]]].
           split_rec 4; try eassumption; eauto.
           -- eapply RA'_step.
              { eapply RAC_Invk_Recv. eapply RA_Return. eassumption. }
              rewrite union_same. eauto.

      (* Subcase Rel_Invk and mresolve(m, C) in CT_L *)
      + admit.

    - assert (exists ch, mresolve ct mi c pfc = Some ch) as exst_ch.
      { apply find_method_mresolve. eexists; eassumption. }
      destruct exst_ch as [ch mres_ch].
      assert (valid_class ct ch) as pfch...
      destruct (valid_in_table ct ch pfch).

      (* Subcase Rel_Lib_Invk and mresolve(m, C) in CT_A *)
      + admit.

      (* Subcase Rel_Lib_Invk and mresolve(m, C) in CT_L *)
      + admit.

  (* Case R_Cast *)

    (* Subcase Rel_Cast *)
    - assert (in_table ct c) as c_in_table by eauto.
      dependent induction rel_e_eh.

      (* SubSubCase Rel_New, direct proof *)
      + split_rec 4; try (eapply RA'_step; try apply RA'_refl; apply RA_FJ; apply R_Cast); eauto.

      (* SubSubCase Rel_Lib_New, case analysis *)
      + destruct c_in_table as [c_in_app | c_in_lib].

      (* SubSubSubCase C in CT_A, CONTRADICTION *)
        * assert (valid_class ct c) as pfc... destruct (not_lib_app ct c pfc). split; eauto.

      (* SubSubSubCase C in CT_L, direct proof *)
        * split_rec 4; try (eapply RA'_step; try apply RA'_refl; apply RA_Cast); eauto.

      (* SubSubCase Rel_Lpt, induction *)
      + inversion calPehlpt as [calPeh calPlpt]; inversion calPeh;
          eapply IHrel_e_eh in rel_ct; eauto; decomp; subst;
            split_rec 4; try (eapply RA'_step; try eassumption; rewrite <- union_same; eauto); eauto.

    (* Subcase Rel_Lib_Cast *)
    - split_rec 4; eauto.

  (* Case RC_Field *)

    (* Subcase Rel_Field *)
    - inversion val_e; inversion fj_expr_e; subst. eapply IHred_e_e' in rel_e_eh as IHspec; eauto.
      destruct IHspec as [eh'0 [lpt'' IHspec]]. decomp.
      exists (E_Field eh'0 f), lpt''. split_rec 2; try solve [erewrite union_include; eauto]; eauto.
      inversion calPehlpt as [calPeh calPlpt]. inversion calPeh; subst.
      inversion H3.
      split; eauto.

    (* Subcase Rel_Lib_Field *)
    - inversion val_e; inversion fj_expr_e; subst. eapply IHred_e_e' in rel_e_eh as IHspec; eauto.
      destruct IHspec as [eh'0 [lpt'' IHspec]]. decomp.
      destruct (E_Lib_dec eh'0); subst; try solve [split_rec 4; eauto].
      eapply lemma10 with (e0' := e') in rel_e_eh as lemma10spec; eauto.
      destruct lemma10spec as [lpt''' [rel_e'_lib red_lpt_lpt'']].
      exists E_Lib, lpt'''. split_rec 2; eauto.
      exists
      exists (E_Field eh'0 f), lpt''. split_rec 2; try solve [erewrite union_include; eauto]; eauto.
      inversion calPehlpt as [calPeh calPlpt]. inversion calPeh; subst.
      inversion H3.
      split; eauto.

  (* Case RC_Invk_Recv *)

    (* Subcase Rel_Invk *)
    - admit.

    (* Subcase Rel_Lib_Invk *)

    - admit.

  (* Case RC_Invk_Arg *)

    (* Subcase Rel_Invk *)
    - admit.

    (* Subcase Rel_Lib_Invk *)
    - admit.

  (* Case RC_New_Arg *)

    (* Subcase Rel_New *)
    - admit.

    (* Subcase Rel_Lib_New *)
    - admit.

  (* Case RC_Cast *)

    (* Subcase Rel_Cast *)
    - admit.

    (* Subcase Rel_Lib_Cast *)
    - admit.

Admitted.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-02-17

general lemmas and tactics
*)

Set Implicit Arguments.

From Coq Require Import Structures.Equalities.
From Coq Require Export EqdepFacts Eqdep_dec.
From Coq Require Setoid.

From CoLoR Require Import LogicUtil RelUtil BoolUtil.

(***********************************************************************)
(** Functor providing properties the basic properties of Leibniz
equality on some type. *)

Module LeibnizFacts (Import T : Typ).

  Definition eq : relation t := @Logic.eq t.

  Global Instance eq_refl : Reflexive eq.

  Proof. fo. Qed.

  Global Instance eq_sym : Symmetric eq.

  Proof. firstorder auto with crelations. Qed.

  Global Instance eq_trans : Transitive eq.

  Proof. unfold eq; class. Qed.

End LeibnizFacts.

(***********************************************************************)
(** Type equipped with a boolean equility. *)

Record Bool_eq_type : Type := mkBool_eq_type {
  bet_type :> Type;
  bet_eq : bet_type -> bet_type -> bool;
  bet_ok : forall x y, bet_eq x y = true <-> x = y }.

(***********************************************************************)
(** Properties of Leibniz equality on decidable types. *)

Section eq_dep.

  Variables (A : Type) (eq_dec : forall x y : A, {x=y}+{~x=y}).

  Lemma eq_rect_eq : forall (p : A) Q x h, x = eq_rect p Q x p h.

  Proof. exact (eq_rect_eq_dec eq_dec). Qed.

  Lemma eq_dep_eq : forall P (p : A) x y, eq_dep A P p x p y -> x = y.

  Proof. exact (eq_rect_eq__eq_dep_eq A eq_rect_eq). Qed.

  Lemma UIP : forall (x y : A) (p1 p2 : x = y), p1 = p2.

  Proof. exact (eq_dep_eq__UIP A eq_dep_eq). Qed.

  Lemma UIP_refl : forall (x : A) (p : x = x), p = eq_refl x.

  Proof. exact (UIP__UIP_refl A UIP). Qed.

  Lemma Streicher_K :
    forall (x : A) (P : x = x -> Prop), P (eq_refl x) -> forall p, P p.

  Proof. exact (K_dec_type eq_dec). Qed.

  Lemma inj_existT :
    forall P (x : A) (p q : P x), existT p = existT q -> p = q.

  Proof. exact (eq_dep_eq__inj_pairT2 A eq_dep_eq). Qed.

  Lemma inj_ex_intro :
    forall P (x : A) p q, ex_intro P x p = ex_intro P x q -> p = q.

  Proof.
    intros. apply inj_right_pair with (A:=A).
    intros x0 y0; case (eq_dec x0 y0); [left|right]; hyp.
    hyp.
  Qed.

End eq_dep.

Arguments UIP_refl [A] _ [x] p.

(***********************************************************************)
(** Properties of a boolean function testing Leibniz equality. *)

Section beq.

  Variable A : Type.
  Variable beq : A -> A -> bool.
  Variable beq_ok : forall x y, beq x y = true <-> x = y.

  Lemma beq_refl : forall x, beq x x = true.

  Proof. intro. ded (beq_ok x x). rewrite H. refl. Qed.

  Lemma beq_ko : forall x y, beq x y = false <-> x <> y.

  Proof.
    intros. destruct (beq_ok x y). case_eq (beq x y); intuition.
    rewrite H1 in H4. discr.
  Defined.

  Lemma dec_beq : forall x y : A, {x=y}+{~x=y}.

  Proof.
    intros. set (b := beq x y). case_eq b; intros.
    left. exact (proj1 (beq_ok x y) H).
    right. intro. unfold b in H. subst. rewrite beq_refl in H. discr.
  Defined.

  Lemma beq_com : forall x y, beq x y = beq y x.

  Proof.
    intros. case_eq (beq x y); intros; sym.
    rewrite beq_ok. sym. rewrite <- beq_ok. hyp.
    rewrite beq_ko. cut (x<>y). auto. rewrite <- beq_ko. hyp.
  Qed.

  Lemma beq_sym : forall x y, beq x y = true -> beq y x = true.

  Proof. intros. rewrite beq_com. exact H. Qed.

  Lemma beq_trans : forall x y z,
    beq x y = true -> beq y z = true -> beq x z = true.

  Proof.
    intros. rewrite beq_ok in H. rewrite beq_ok in H0.
    assert (x = z). apply eq_trans with y; hyp.
    rewrite beq_ok. exact H1.
  Qed.

End beq.

Arguments beq_refl [A beq] _ x.
Arguments dec_beq [A beq] _ x y.
Arguments beq_com [A beq] _ x y.
Arguments beq_ko [A beq] _ x y.

Ltac case_beq beq beq_ok x y := case_eq (beq x y);
  [let h := fresh in intro h; rewrite beq_ok in h;
    match type of h with ?x = ?y => subst y end
    | intro].

(***********************************************************************)
(** Boolean function testing Leibniz equality when it is decidable. *)

Section eq_dec.

  Variable A : Type.
  Variable eq_dec : forall x y : A, {x=y}+{~x=y}.

  Definition beq_dec x y :=
    match eq_dec x y with
      | left _ => true
      | right _ => false
    end.

  Lemma beq_dec_ok : forall x y, beq_dec x y = true <-> x = y.

  Proof. intros. unfold beq_dec. case (eq_dec x y); intuition. discr. Qed.

  Lemma beq_dec_refl : forall x, beq_dec x x = true.

  Proof. intro. unfold beq_dec. case (eq_dec x x); intros. refl. cong. Qed.

  Lemma beq_dec_sym : forall x y, beq_dec x y = beq_dec y x.

  Proof.
    intros. unfold beq_dec.
    case (eq_dec x y); case (eq_dec y x); intros; (refl || cong).
  Qed.

  Lemma beq_dec_trans : forall x y z,
    implb (beq_dec x y && beq_dec y z) (beq_dec x z) = true.

  Proof.
    intros. unfold beq_dec.
    case (eq_dec x y); case (eq_dec y z); case (eq_dec x z);
      intros; (refl || (cong || idtac)).
  Qed.

  Lemma beq_dec_ko : forall x y, beq_dec x y = false <-> x <> y.

  Proof.
    intros. case (eq_dec x y); case_eq (beq_dec x y); intuition.
    subst y. rewrite beq_dec_refl in H. discr.
    rewrite beq_dec_ok in H. contr.
  Qed.

End eq_dec.