Require Import VST.msl.msl_standard.
Require Import VST.msl.cjoins.
Require Import VST.msl.rmaps.
Require Import VST.msl.Coqlib2.
Require Import VST.msl.sepalg_list.

Module Rmaps_Lemmas (R: RMAPS).
Module R := R.
Import R.

Hint Resolve (@subp_sepcon _ Join_rmap Perm_rmap Sep_rmap): contractive.

 Lemma approx_p  : forall (p:pred rmap) n w, approx n p w -> p w.
 Proof. unfold approx; simpl; intuition. Qed.

 Lemma approx_lt : forall (p:pred rmap) n w, lt (level w) n -> p w -> approx n p w.
 Proof. unfold approx; simpl; intuition. Qed.

 Lemma approx_ge : forall p n w, ge (level w) n -> approx n p w -> False.
 Proof. unfold approx; intros. destruct H0; auto. omega. Qed.

  Definition identity_rmap' : R.rmap' := exist valid (fun _: AV.address => R.NO) AV.valid_empty.
  Definition identity_rmap (n:nat) : rmap := R.squash (n, identity_rmap').

  Lemma identity_level : forall n, level (identity_rmap n) = n.
  Proof.
    intro n; unfold identity_rmap.
    rewrite rmap_level_eq. rewrite unsquash_squash. auto.
  Qed.

  Lemma snd_identity_map : forall n, proj1_sig (snd (R.unsquash (identity_rmap n))) = fun _ => R.NO .
    unfold identity_rmap; intros.
    rewrite R.unsquash_squash.
    simpl.
    apply extensionality; intro l.
    unfold compose; simpl; auto.
  Qed.

  Lemma comparable_level : forall phi1 phi2 : rmap ,
         comparable phi1 phi2 -> level phi1 = level phi2.
  Proof.
   intros.
   apply comparable_fashionR.
   trivial.
  Qed.

  Lemma ageN_level : forall n (phi1 phi2 : rmap),
    ageN n phi1 = Some phi2 -> level phi1 = (n + (level phi2))%nat.
  Proof.
    unfold ageN; induction n; simpl; intros.
    injection H; intros; subst; auto.
    revert H.
    repeat rewrite rmap_level_eq in *.
    intros. invSome.
    specialize (IHn _ _ H2).
    apply  age_level in H.  rewrite rmap_level_eq in *. omega.
  Qed.

Lemma NO_identity: identity NO.
Proof.
  unfold identity; intros.
  inv H; auto.
Qed.

Lemma PURE_identity: forall k pds, identity (PURE k pds).
Proof.
  unfold identity; intros.
  inv H; auto.
Qed.

Lemma identity_NO:
  forall r, identity  r -> r = NO \/ exists k, exists pds, r = PURE k pds.
Proof.
  destruct r; auto; intros.
  left. symmetry; apply H.
  apply res_join_NO2.
  right. exists k. exists p. trivial.
Qed.

Lemma age1_resource_at_identity:
  forall phi phi' loc, age1 phi = Some phi' ->
               identity (phi@loc) ->
               identity (phi'@loc).
Proof.
  intros.
  generalize (identity_NO _ H0); clear H0; intro.
  unfold resource_at in *.
  rewrite rmap_age1_eq in *.
  revert H H0; case_eq (unsquash phi); simpl; intros.
  destruct n; inv H0.
  rewrite unsquash_squash.
  simpl.
  destruct r. simpl in *.
  unfold compose; simpl. destruct H1 as [H1 | [k [pds H1]]]; rewrite H1; simpl; auto.
  apply NO_identity.
  apply PURE_identity.
Qed.

Lemma unage1_resource_at_identity:
  forall phi phi' loc, age1 phi = Some phi' ->
               identity (phi'@loc) ->
               identity (phi@loc).
Proof.
  intros.
  generalize (identity_NO _ H0); clear H0; intro.
  unfold resource_at in *. simpl in H.
  rewrite rmap_age1_eq in H.
  revert H H0; case_eq (unsquash phi); simpl; intros.
  destruct n; inv H0.
  rewrite unsquash_squash in H1. destruct r. simpl in *.
  unfold compose in H1; simpl in H1.
  unfold resource_fmap in H1.
  destruct (x loc).
  apply NO_identity.
  destruct H1 as [H1 | [k' [pds' H1]]]; inv H1.
  apply PURE_identity.
Qed.

Lemma necR_resource_at_identity:
  forall phi phi' loc, necR phi phi' ->
         identity (phi@loc) ->
         identity (phi'@loc).
Proof.
  induction 1; auto.
  intro; eapply age1_resource_at_identity; eauto.
Qed.

Lemma make_rmap': forall f, AV.valid (fun l => res_option (f l)) ->
          exists phi: rmap', proj1_sig phi = f.
Proof.
  intros.
  unfold rmap'.
  exists (exist valid f H).
  auto.
Qed.

Lemma make_rmap (f: AV.address -> resource) (V: AV.valid (res_option oo f))
    (n: nat) (H: resource_fmap (approx n) oo f = f) :
  {phi: rmap | level phi = n /\ resource_at phi = f}.
Proof.
intros.
apply (exist _ (squash (n, @exist (AV.address -> resource) R.valid f V))).
simpl level; rewrite rmap_level_eq in *; unfold resource_at. rewrite unsquash_squash.
simpl; auto.
Qed.

Lemma make_rmap'':
    forall n (f: AV.address -> resource) ,
      AV.valid (fun l => res_option (f l)) ->
      exists phi:rmap, level phi = n /\ resource_at phi = resource_fmap (approx n) oo f.
  Proof.
    intros.
    exists (squash (n, exist valid f H)).
    rewrite rmap_level_eq.
      unfold resource_at; rewrite unsquash_squash; simpl; split; auto.
Qed.

(*
Lemma make_simple_rmap:
    forall n (f: AV.address -> resource) ,
      AV.valid (fun l => res_option (f l)) ->
      (forall l, match f l with YES _ _ (SomeP _ _) => False | _ => True end) ->
      exists phi:rmap, level phi = n /\ resource_at phi = f.
Proof.
  intros; destruct (make_rmap'' n f H) as [phi [? ?]]; exists phi; split; auto.
  rewrite H2.
  extensionality l; unfold compose; simpl;  generalize (H0 l); destruct (f l); auto.
  destruct p0; intros; try contradiction.
Qed.
*)

Lemma approx_oo_approx':
  forall n n', (n' >= n)%nat -> approx n oo approx n' = approx n.
Proof.
unfold compose; intros.
extensionality P.
 apply pred_ext; intros w ?; unfold approx; simpl in *; intuition.
Qed.

Lemma approx_oo_approx: forall n, approx n oo approx n = approx n.
Proof.
intros; apply approx_oo_approx'; omega.
Qed.

Lemma approx_approx' n n' x :
  (n' >= n)%nat -> approx n (approx n' x) = approx n x.
Proof.
  intro H.
  change ((approx n oo approx n') x = approx n x).
  apply equal_f, approx_oo_approx', H.
Qed.

Lemma resources_same_level:
   forall f phi,
     (forall l : AV.address, join_sub (f l) (phi @ l)) ->
        resource_fmap (approx (level phi)) oo f = f.
Proof.
  intros.
  rewrite rmap_level_eq.
  unfold resource_fmap, resource_at in *.
  unfold compose; extensionality l. spec H l.
  destruct H as [g ?].
  revert H; case_eq (unsquash phi); intros n ? ?.
  generalize H; rewrite <- (squash_unsquash phi).
  rewrite H. rewrite unsquash_squash.
  simpl; intros.
  injection H0. clear H0. intro.
  clear phi H.
  rewrite <- H0 in H1.
  clear H0.
  unfold rmap_fmap in *.
  destruct r.
  simpl in *.
  revert H1.
  unfold resource_fmap, compose.
  destruct (f l); destruct g; destruct (x l); simpl; intro; auto; inv H1.
  change (preds_fmap (approx n) (preds_fmap (approx n) p2))
  with ((preds_fmap (approx n) oo preds_fmap (approx n)) p2).
  rewrite preds_fmap_comp.
  rewrite approx_oo_approx; auto.
  change (preds_fmap (approx n) (preds_fmap (approx n) p4))
  with ((preds_fmap (approx n) oo preds_fmap (approx n)) p4).
  rewrite preds_fmap_comp.
  rewrite approx_oo_approx; auto.
  change (preds_fmap (approx n) (preds_fmap (approx n) p1))
  with ((preds_fmap (approx n) oo preds_fmap (approx n)) p1).
  rewrite preds_fmap_comp.
  rewrite approx_oo_approx; auto.
Qed.

Lemma deallocate:
  forall (phi: rmap) (f g : AV.address -> resource),
  AV.valid (res_option oo f) -> AV.valid (res_option oo g) ->
  (forall l, join  (f l) (g l) (phi@l)) ->
   exists phi1, exists phi2,
     join phi1 phi2 phi /\ resource_at phi1 = f.
Proof.
  intros until g. intros Hf Hg H0.
  generalize (resources_same_level f phi); intro.
  spec H. intro; econstructor; apply H0.
  generalize (resources_same_level g phi); intro.
  spec H1.
  intro. econstructor; eapply join_comm; eauto.
  generalize (make_rmap'' (level phi) f Hf); intros [phif [? Gf]].
  generalize (make_rmap'' (level phi) g Hg); intros [phig [? Gg]].
  exists phif; exists phig.
  split.
  rewrite rmap_level_eq in *.
  unfold resource_at in *.
  revert H0 H Gf H1 Gg H2 H3;
  case_eq (unsquash phif); intros nf phif' ?.
  case_eq (unsquash phig); intros ng phig' ?.
  case_eq (unsquash phi); intros n phi' ?.
  simpl.
  intros; subst nf ng.
  rewrite join_unsquash.
  rewrite H; rewrite H0; rewrite H1.
  rewrite <- H1.
  revert H1; case_eq (unsquash phi); intros n' phi'' ?.
  intros.
  inversion H5.
  simpl.
  split.
  simpl; constructor; auto.
  subst n' phi''.
  intro l; spec H2 l.
  simpl.
  rewrite Gf; rewrite Gg; clear Gf Gg.
  rewrite H3; rewrite H4.
  auto.
  rewrite Gf.
  auto.
Qed.

Lemma allocate:
     forall (phi : rmap) (f : AV.address -> resource),
     AV.valid (res_option oo f) ->
        resource_fmap (approx (level phi)) oo f = f ->
       (forall l, {r' | join (phi@l) (f l) r'}) ->
       exists phi1 : rmap,
         exists phi2 : rmap,
           join phi phi1 phi2 /\ resource_at phi1 = f.
Proof.
 intros. rename X into H1.
 generalize (make_rmap'' (level phi) f H); intros [phif [? Gf]].
 pose (g loc := proj1_sig (H1 loc)).
 assert (H3: forall l, join (phi @ l) (f l) (g l))
   by (unfold g; intro; destruct (H1 l); simpl in *; auto).
 clearbody g.
 generalize (make_rmap'' (level phi) g); intro.
 spec H4.
   assert (AV.valid (fun l => res_option (phi @ l))).
     clear.
     unfold resource_at.
     case_eq (unsquash phi); intros.
     simpl.
     destruct r. simpl.
     apply v.
   eapply AV.valid_join. 2: apply H5. 2: apply H.
   clear - H3.
   intro l; spec H3 l.
   destruct (phi @ l); simpl in *.
   apply join_unit1_e in H3. unfold compose. rewrite H3. constructor. apply NO_identity.
   unfold compose at 1. unfold res_option.
   destruct (f l). apply join_unit2_e in H3; [ | apply NO_identity]. rewrite <- H3. constructor.
   destruct (g l). inv H3. inv H3.
   constructor; split; auto.
   inv H3. inv H3. inv H3. unfold compose, res_option. rewrite <- H. constructor.
 destruct H4 as [phig [? ?]].
 exists phif; exists phig.
 split.
 2: congruence.
 rewrite join_unsquash.
 unfold resource_at in *.
 rewrite rmap_level_eq in *.
 revert H0 H1 H2 H3 H4 H5 Gf.
 case_eq (unsquash phif); intros nf phif' ?.
 case_eq (unsquash phig); intros ng phig' ?.
 case_eq (unsquash phi); intros n phi' ?.
 simpl.
 intros; subst nf ng.
 split. split; trivial.
 simpl.
 intro l.
 spec H6 l.
 assert (proj1_sig phig' l = g l).
   generalize (f_equal squash H2); intro.
   rewrite squash_unsquash in H5.
   subst phi.
   rewrite unsquash_squash in H2.
   injection H2; clear H2; intro.
   rewrite <- H2 in H6.
   rewrite <- H3 in H6.
   rewrite H8.
   clear - H6.
   revert H6.
   unfold rmap_fmap, compose, resource_fmap.
   destruct phi'; simpl.
   destruct (x l); destruct (f l); destruct (g l); simpl; intros; auto; try inv H6;
              try change (preds_fmap (approx n) (preds_fmap (approx n) p0)) with
                ((preds_fmap (approx n) oo preds_fmap (approx n)) p0);
              try change (preds_fmap (approx n) (preds_fmap (approx n) p)) with
                ((preds_fmap (approx n) oo preds_fmap (approx n)) p);
                rewrite preds_fmap_comp; rewrite approx_oo_approx; auto.
 rewrite H5.
 rewrite Gf.
 rewrite H3.
 auto.
Qed.

  Lemma unsquash_inj : forall x y,
      unsquash x = unsquash y -> x = y.
  Proof.
    intros.
    rewrite <- (squash_unsquash x).
    rewrite <- (squash_unsquash y).
    rewrite H; auto.
  Qed.

  Lemma rmap_ext: forall phi1 phi2,
    level phi1 = level phi2 ->
    (forall l, phi1@l = phi2@l) ->
    phi1=phi2.
  Proof.
    intros.
    apply unsquash_inj.
    rewrite rmap_level_eq in *.
    unfold resource_at in *.
    rewrite <- (squash_unsquash phi1).
    rewrite <- (squash_unsquash phi2).
    destruct (unsquash phi1).
    destruct (unsquash phi2).
    simpl in H.
    rewrite H.
    rewrite unsquash_squash.
    rewrite unsquash_squash.
    simpl in H0.
    replace (rmap_fmap (approx n0) r) with (rmap_fmap (approx n0) r0); auto.
    destruct r; destruct r0.
    simpl in *.
    generalize (valid_res_map (approx n0) x0 v0).
    generalize (valid_res_map (approx n0) x v).
    replace (resource_fmap (approx n0) oo x0)
      with (resource_fmap (approx n0) oo x).
    intros v1 v2; replace v2 with v1 by apply proof_irr; auto.
    extensionality l.
    unfold compose.
    spec H0 l.
    subst n0.
    rewrite H0; auto.
  Qed.

  Lemma resource_at_join:
    forall phi1 phi2 phi3 loc,
      join phi1 phi2 phi3 ->
      join (phi1@loc) (phi2@loc) (phi3@loc).
  Proof.
    intros.
    revert H; rewrite join_unsquash; unfold resource_at.
    intros [? ?].
    apply H0.
  Qed.

  Lemma resource_at_join2:
    forall phi1 phi2 phi3,
      level phi1 = level phi3 -> level phi2 = level phi3 ->
      (forall loc, join (phi1@loc) (phi2@loc) (phi3@loc)) ->
      join phi1 phi2 phi3.
  Proof.
    intros ? ? ?.
    rewrite join_unsquash.
    rewrite rmap_level_eq in *.
    unfold resource_at.
    case_eq (unsquash phi1); case_eq (unsquash phi2); case_eq (unsquash phi3); simpl; intros.
    subst.
    split; auto.
  Qed.

Lemma all_resource_at_identity:
  forall w, (forall l, identity (w@l)) ->
         identity w.
Proof.
  intros.
  rewrite identity_unit_equiv.
  apply join_unsquash.
  split. split; auto.
  revert H. unfold resource_at.
  case_eq (unsquash w); simpl; intros.
  intro a. spec H0 a.
  rewrite identity_unit_equiv in H0.
  trivial.
Qed.

  Lemma ageN_squash : forall d n rm, le d n ->
    ageN d (squash (n, rm)) = Some (squash ((n - d)%nat, rm)).
  Proof.
    induction d; simpl; intros.
    unfold ageN; simpl.
    replace (n-0)%nat with n by omega; auto.
    unfold ageN; simpl.
    rewrite rmap_age1_eq in *.
    rewrite unsquash_squash.
    destruct n.
    inv H.
    replace (S n - S d)%nat with (n - d)%nat by omega.
    unfold ageN in IHd. rewrite rmap_age1_eq in IHd.
    rewrite IHd.
    2: omega.
    replace (squash ((n - d)%nat, rmap_fmap (approx (S n)) rm))
       with (squash ((n - d)%nat, rm)); auto.
    apply unsquash_inj.
    rewrite unsquash_squash.
    rewrite unsquash_squash.
    replace (rmap_fmap (approx (n - d)) rm)
       with (rmap_fmap (approx (n - d) oo approx (S n)) rm); auto.
    rewrite <- rmap_fmap_comp.
    unfold compose; auto.
    replace (approx (n-d) oo approx (S n)) with (approx (n-d)).
    auto.
    clear.
    assert (n-d <= (S n))%nat by omega.
    revert H; generalize (n-d)%nat (S n).
    clear.
    intros.
    extensionality p.
    apply pred_ext'.  extensionality w.
    unfold compose, approx.
    apply prop_ext; simpl; intuition.
  Qed.

  Lemma unageN: forall n (phi': rmap),   exists phi, ageN n phi = Some phi'.
  Proof.
    intros n phi'.
    rewrite <- (squash_unsquash phi').
    destruct (unsquash phi'); clear phi'.
    exists (squash ((n+n0)%nat,r)).
    rewrite ageN_squash.
    replace (n + n0 - n)%nat with n0 by omega; auto.
    omega.
  Qed.

Lemma YES_join_full:
   forall n P r2 r3,
       join (R.YES pfullshare n P) r2 r3 ->
       r2 = NO.
Proof.
  intros.
  simpl in H.
  inv H. trivial.
  pfullshare_join.
Qed.

Lemma YES_not_identity:
  forall sh k Q, ~ identity (YES sh k Q).
Proof.
intros. intro.
rewrite identity_unit_equiv in H.
simpl in * |-.
unfold unit_for in H.
inv H.
apply no_units in H1; auto.
Qed.

Lemma YES_overlap:
forall (phi0 phi1: rmap) loc (sh : pshare) k k' p p',
  joins phi0 phi1 -> phi1@loc = R.YES pfullshare k p ->
               phi0@loc = R.YES sh k' p' -> False.
Proof.
  intros.
  destruct H as [phi3 ?].
  generalize (resource_at_join _ _ _ loc H); intro.
  rewrite H1 in H2.
  rewrite H0 in H2.
  contradiction (YES_not_identity sh k' p').
  apply join_comm in H2. apply YES_join_full in H2. discriminate.
Qed.

Lemma necR_NOx:
   forall phi phi' l, necR phi phi' -> phi@l = NO -> phi'@l = NO.
Proof.
induction 1; eauto.
unfold age in H; simpl in H.
revert H; rewrite rmap_age1_eq; unfold resource_at.
destruct (unsquash x).
intros; destruct n; inv H.
rewrite unsquash_squash; simpl in *; auto.
destruct r; simpl in *.
unfold compose.
rewrite H0.
auto.
Qed.

Ltac do_map_arg :=
match goal with |- ?a = ?b =>
  match a with context [map ?x _] =>
    match b with context [map ?y _] => replace y with x; auto end end end.

Lemma preds_fmap_fmap:
  forall f g pp, preds_fmap f (preds_fmap g pp) = preds_fmap (f oo g) pp.
Proof.
destruct pp; simpl; auto.
Qed.

Lemma resource_fmap_fmap:  forall f g r, resource_fmap f (resource_fmap g r) =
                                                                      resource_fmap (f oo g) r.
Proof.
destruct r; simpl; auto.
rewrite preds_fmap_fmap; auto.
rewrite preds_fmap_fmap; auto.
Qed.

Lemma resource_at_approx:
  forall phi l,
      phi @ l = resource_fmap (approx (level phi)) (phi @ l).
Proof.
intros. rewrite rmap_level_eq. unfold resource_at.
case_eq (unsquash phi); intros.
simpl.
destruct r; simpl in *.
assert (R.valid (resource_fmap (approx n) oo x)).
apply valid_res_map; auto.
set (phi' := (squash (n, exist (fun m : AV.address -> resource => R.valid m) _ H0))).
generalize (unsquash_inj phi phi'); intro.
spec H1.
replace (unsquash phi) with (unsquash (squash (unsquash phi))).
2: rewrite squash_unsquash; auto.
rewrite H.
unfold phi'.
repeat rewrite unsquash_squash.
simpl.
replace (exist (fun m : AV.address -> resource => valid m)
  (resource_fmap (approx n) oo x) (valid_res_map (approx n) x v)) with
(exist (fun m : AV.address -> resource => valid m)
  (resource_fmap (approx n) oo resource_fmap (approx n) oo x)
  (valid_res_map (approx n) (resource_fmap (approx n) oo x) H0)); auto.
assert (Hex: forall A (F: A -> Prop) (x x': A) y y', x=x' -> exist F x y = exist F x' y') by auto with extensionality.
apply Hex.
unfold compose.
extensionality y.
rewrite resource_fmap_fmap.
rewrite approx_oo_approx; auto.
unfold phi' in *; clear phi'.
subst.
rewrite unsquash_squash in H.
injection H; clear H; intro.
pattern x at 1; rewrite <- H.
unfold compose.
rewrite resource_fmap_fmap.
rewrite approx_oo_approx; auto.
Qed.

Lemma necR_resource_at:
  forall phi phi' loc r,
        necR phi phi' ->
         phi @ loc = resource_fmap (approx (level phi)) r ->
         phi' @ loc = resource_fmap (approx (level phi')) r.
Proof.
intros.
revert r loc H0; induction H; intros; auto.
unfold age in H.
simpl in H.
revert H H0; rewrite rmap_level_eq, rmap_age1_eq; unfold resource_at.
 case_eq (unsquash x); intros.
destruct n; inv H0.
simpl in *.
rewrite unsquash_squash; simpl.
destruct r0; simpl in *.
unfold compose in *.
rewrite H1; clear H1.
rewrite resource_fmap_fmap.
rewrite approx_oo_approx'; auto.
Qed.

Lemma necR_YES:
  forall phi phi' loc sh k pp,
        necR phi phi' ->
         phi @ loc = YES sh k pp ->
         phi' @ loc = YES sh k (preds_fmap (approx (level phi')) pp).
Proof.
intros.
generalize (resource_at_approx phi loc);
pattern (phi @ loc) at 2; rewrite H0; intro.
apply (necR_resource_at _ _ _ _ H H1).
Qed.

Lemma necR_PURE:
  forall phi phi' loc k pp,
        necR phi phi' ->
         phi @ loc = PURE k pp ->
         phi' @ loc = PURE k (preds_fmap (approx (level phi')) pp).
Proof.
  intros.
  generalize (resource_at_approx phi loc);
  pattern (phi @ loc) at 2; rewrite H0; intro.
  apply (necR_resource_at _ _ _ _ H H1).
Qed.

Lemma necR_NO:
   forall phi phi' l, necR phi phi' ->
   (phi@l = NO <-> phi'@l = NO).
Proof.
  intros; split.
  apply necR_NOx; auto.
  intros.
  case_eq (phi @ l); intros; auto.
  destruct p0.
  generalize (necR_YES _ _ _ _ _ _ H H1); rewrite H0; congruence.
  generalize (necR_PURE _ _ _ _ _ H H1); rewrite H0; congruence.
Qed.

Lemma resource_at_empty: forall phi, identity phi -> forall l, (phi @ l = NO \/ exists k, exists pds, phi @ l = PURE k pds).
Proof.
  intros.
  rewrite identity_unit_equiv in H.
  unfold unit_for in H.
  generalize (resource_at_join _ _ _ l H); intro.
  remember (phi @ l) as r.
  destruct r; inv H0; auto.
  apply no_units in H2; contradiction.
  right. exists k. exists p. trivial.
Qed.
Implicit Arguments resource_at_empty.

Lemma rmap_valid: forall r, AV.valid (res_option oo resource_at r).
Proof.
unfold compose, resource_at; intros.
destruct (unsquash r).
destruct r0.
simpl.
apply v.
Qed.

Ltac inj_pair_tac :=
 match goal with H: (@existT ?U ?P ?p ?x = @existT _ _ _ ?y) |- _ =>
   generalize (@inj_pair2 U P p x y H); clear H; intro; try (subst x || subst y)
 end.

Lemma preds_fmap_NoneP:
  forall f, preds_fmap f NoneP = NoneP.
Proof.
intros.
unfold NoneP.
simpl.
f_equal. extensionality x; destruct  x.
destruct v.
Qed.

Lemma necR_YES':
   forall phi phi' loc sh k,
         necR phi phi' -> (phi@loc = YES sh k NoneP <-> phi'@loc = YES sh k NoneP).
Proof.
intros.
induction H.
rename x into phi; rename y into phi'.
unfold age in H; simpl in H.
(* revert H; case_eq (age1 phi); intros; try discriminate. *)
inv H.
split; intros.
rewrite (necR_YES phi phi' loc sh k NoneP); auto; [ | constructor 1; auto].
f_equal.
apply preds_fmap_NoneP.
rewrite rmap_age1_eq in *.
unfold resource_at in *.
revert H1; case_eq (unsquash phi); simpl; intros.
destruct n; inv H1.
rewrite unsquash_squash in H. simpl in H. destruct r; simpl in *.
unfold compose in H.
revert H; destruct (x loc); simpl; intros; auto.
destruct p0; inv H.
inj_pair_tac. f_equal.
unfold NoneP; f_equal.
extensionality x'; destruct x'.
destruct v0.
inv H.
intuition.
intuition.
Qed.

Lemma necR_YES'':
   forall phi phi' loc sh k,
         necR phi phi' ->
    ((exists pp, phi@loc = YES sh k pp) <->
    (exists pp, phi'@loc = YES sh k pp)).
Proof.
intros.
induction H; try solve [intuition].
rename x into phi; rename y into phi'.
revert H; unfold age; case_eq (age1 phi); intros; try discriminate.
inv H0.
simpl in *.
split; intros [pp ?].
econstructor;
apply (necR_YES phi phi' loc sh k pp).
constructor 1; auto. auto.
rename phi' into r.
rewrite rmap_age1_eq in *.
unfold resource_at in *.
revert H; case_eq (unsquash phi); simpl; intros.
destruct n; inv H1.
rewrite unsquash_squash in H0. simpl in H0. destruct r0; simpl in *.
unfold compose in H0.
revert H0; destruct (x loc); simpl; intros; auto.
inv H0.
inv H0.
econstructor; eauto.
inv H0.
Qed.

Lemma resource_at_join_sub:
  forall phi1 phi2 l,
       join_sub phi1 phi2 -> join_sub (phi1@l) (phi2@l).
Proof.
intros.
destruct H as [phi ?].
generalize (resource_at_join _ _ _ l H); intro.
econstructor; eauto.
Qed.

Lemma age1_res_option: forall phi phi' loc,
     age1 phi = Some phi' -> res_option (phi @ loc) = res_option (phi' @ loc).
  Proof.
    unfold res_option, resource_at; simpl.
   rewrite rmap_age1_eq; intros phi1 phi2 l.
 case_eq (unsquash phi1); intros. destruct n; inv H0.
 rewrite unsquash_squash.
   destruct r;
    simpl.
   unfold compose. destruct (x l); simpl; auto.
Qed.

Lemma necR_res_option:
  forall (phi phi' : rmap) (loc : AV.address),
  necR phi phi' -> res_option (phi @ loc) = res_option (phi' @ loc).
Proof.
  intros.
  case_eq (phi @ loc); intros.
  rewrite (necR_NO _ _ _ H) in H0. congruence.
  destruct p0.
  rewrite (necR_YES phi phi' loc _ _ _ H H0); auto.
  rewrite (necR_PURE phi phi' loc _ _ H H0); auto.
Qed.

Lemma age1_resource_at:
     forall phi phi',
          age1 phi = Some phi' ->
         forall loc r,
          phi @ loc = resource_fmap (approx (level phi)) r ->
          phi' @ loc = resource_fmap (approx (level phi')) r.
Proof.
   unfold resource_at; rewrite rmap_age1_eq, rmap_level_eq.
intros until phi'; case_eq (unsquash phi); intros.
simpl in *.
destruct n; inv H0.
rewrite unsquash_squash.
destruct r; simpl in *.
unfold compose; rewrite H1.
rewrite resource_fmap_fmap.
rewrite approx_oo_approx'; auto.
Qed.

Lemma age1_YES: forall phi phi' l sh k ,
  age1 phi = Some phi' -> (phi @ l = YES sh k NoneP <-> phi' @ l = YES sh k NoneP).
Proof.
intros.
apply necR_YES'.
constructor 1; auto.
Qed.

Lemma empty_NO: forall r, identity r -> r = NO \/ exists k, exists pds, r = PURE k pds.
Proof.
intros.
destruct r; auto.
unfold identity in H.
spec H NO (YES p k p0).
spec H.
apply res_join_NO2.
auto.
right. exists k. exists p. trivial.
Qed.

Lemma YES_join_full':
  forall loc k P m1 m2 m3, join m1 m2 m3 -> m1@loc = YES pfullshare k P ->
                   m3 @ loc = YES pfullshare k P.
Proof.
  intros.
  generalize (resource_at_join _ _ _ loc H); rewrite H0; intro.
  generalize (YES_join_full _ _ _ _ H1); intro. rewrite H2 in H1.
  inv H1.
  trivial.
Qed.

Lemma level_age_fash:
  forall m m': rmap, level m = S (level m') -> exists m1, age m m1. (* /\ comparable m1 m'. *)
Proof.
  intros.
  case_eq (age1 m); intros.
  exists r. auto.
  elimtype False.
  eapply age1None_levelS_absurd in H0; eauto.
Qed.

Lemma level_later_fash:
 forall m m': rmap, (level m > level m')%nat  -> exists m1, laterR m m1 /\ level m1 = level m'.
Proof.
  intros.
  assert (exists k, level m = S k + level m')%nat.
    exists (level m - S (level m'))%nat.
    omega.
  clear H; destruct H0 as [k ?].
  revert m H; induction k; intros.
  simpl in H.
  destruct (level_age_fash _ _ H) as [m1 ?].
  exists m1; split; auto.
  constructor 1; auto.
  apply age_level in H0. rewrite H in H0. inv H0. trivial.
  case_eq (age1 m); intros.
  spec IHk r.
  rewrite <- ageN1 in H0.
  generalize (ageN_level _ _ _ H0); intro.
  spec IHk; try omega.
  destruct IHk as [m1 [? ?]].
  exists m1; split; auto.
  econstructor 2; eauto.
  rewrite ageN1 in H0.
  constructor 1.
  auto.
  elimtype False.
  eapply age1None_levelS_absurd in H0; eauto.
Qed.

Lemma resource_at_constructive_joins2:
  forall phi1 phi2,
       level phi1 = level phi2 ->
       (forall loc, constructive_joins (phi1 @ loc) (phi2 @ loc)) ->
         constructive_joins phi1 phi2.
Proof.
intros ? ? ? H0.
assert (AV.valid (res_option oo (fun loc => proj1_sig (H0 loc)))).
apply AV.valid_join with (res_option oo (resource_at phi1)) (res_option oo (resource_at phi2));
 try apply rmap_valid.
intro l.
unfold compose in *.
destruct (H0 l); simpl in *.
destruct (phi1 @ l). inv j; constructor.
inv j; constructor. split; auto.
inv j; constructor.
(** End of CompCert_AV.valid proof **)
destruct (make_rmap _ H1 (level phi1)) as [phi' [? ?]].
clear H1.
unfold compose; extensionality loc.
spec H0 loc.
destruct H0 as [? H1].
simpl.
symmetry.
revert H1; case_eq (phi1 @ loc); intros.
inv H1. reflexivity.
rewrite H2.
rewrite H; apply resource_at_approx.
inv H1. rewrite <- H0. apply resource_at_approx.
generalize (resource_at_approx phi1 loc); intro.
rewrite H0 in H1. simpl in H1.
simpl. f_equal. injection H1; auto.
inv H1.
generalize (resource_at_approx phi1 loc); intro.
rewrite H0 in H1. simpl in H1.
simpl. f_equal. injection H1; auto.
(*  End of make_rmap proof *)
exists phi'.
apply resource_at_join2; auto.
congruence.
intros.
rewrite H3.
destruct (H0 loc).
simpl; auto.
Qed.

Lemma resource_at_joins2:
  forall phi1 phi2,
       level phi1 = level phi2 ->
       (forall loc, constructive_joins (phi1 @ loc) (phi2 @ loc)) ->
         joins phi1 phi2.
Proof.
  intros.
  apply cjoins_joins.
  apply resource_at_constructive_joins2; trivial.
Qed.

Definition no_preds (r: resource) :=
   match r with NO => True | YES _ _ pp => pp=NoneP | PURE _ pp => pp=NoneP end.

Lemma remake_rmap:
  forall (f: AV.address -> resource),
       AV.valid (res_option oo f) ->
       forall n,
       (forall l, (exists m, level m = n /\ f l = m @ l) \/ no_preds (f l)) ->
       {phi: rmap | level phi = n /\ resource_at phi = f}.
Proof.
  intros.
  apply make_rmap; auto.
  extensionality l.
  unfold compose.
  destruct (H0 l); clear H0.
  destruct H1 as [m [?  ?]].
  rewrite H1.
  subst.
  symmetry; apply resource_at_approx.
  destruct (f l); simpl in *; auto;
  [destruct p0 | destruct p];
  rewrite H1;
  apply f_equal;
  apply preds_fmap_NoneP.
Qed.

Lemma rmap_unage_age:
  forall r, age (rmap_unage r) r.
Proof.
intros; unfold age, rmap_unage; simpl.
case_eq (unsquash r); intros.
rewrite rmap_age1_eq.
rewrite unsquash_squash.
f_equal.
apply unsquash_inj.
rewrite H.
rewrite unsquash_squash.
f_equal.
generalize (equal_f (rmap_fmap_comp (approx (S n)) (approx n)) r0); intro.
unfold compose at 1 in H0.
rewrite H0.
rewrite approx_oo_approx'; auto.
clear - H.
generalize (unsquash_squash n r0); intros.
rewrite <- H in H0.
rewrite squash_unsquash in H0.
congruence.
Qed.

Lemma ageN_resource_at_eq:
  forall phi1 phi2 loc n phi1' phi2',
          level phi1 = level phi2 ->
          phi1 @ loc = phi2 @ loc ->
         ageN n phi1 = Some phi1' ->
         ageN n phi2 = Some phi2' ->
         phi1' @ loc = phi2' @ loc.
Proof.
intros ? ? ? ? ? ? Hcomp ? ? ?; revert phi1 phi2 phi1' phi2' Hcomp H H0 H1; induction n; intros.
inv H0; inv H1; auto.
unfold ageN in H0, H1.
simpl in *.
revert H0 H1; case_eq (age1 phi1); case_eq (age1 phi2); intros; try discriminate.
assert (level r = level r0) by (apply age_level in H0; apply age_level in H1; omega).
apply (IHn r0 r); auto.
rewrite (age1_resource_at _ _ H0 loc _ (resource_at_approx _ _)).
rewrite (age1_resource_at _ _ H1 loc _ (resource_at_approx _ _)).
rewrite H. rewrite H4; auto.
Qed.

Lemma join_YES_pfullshare1:
    forall pp k p x y, join (YES (mk_lifted Share.top pp) k p) x y -> (NO, YES pfullshare k p) = (x,y).
Proof.
intros. inv H; try pfullshare_join; f_equal; auto.
  f_equal. unfold pfullshare. f_equal. apply proof_irr.
Qed.

Lemma join_YES_pfullshare2:
    forall pp k p x y, join x (YES  (mk_lifted Share.top pp) k p) y -> (NO, YES pfullshare k p) = (x,y).
Proof.
intros. inv H; try pfullshare_join; f_equal; auto.
  f_equal. unfold pfullshare. f_equal. apply proof_irr.
Qed.

Ltac inv H := (apply join_YES_pfullshare1 in H || apply join_YES_pfullshare2 in H || idtac);
                  (inversion H; clear H; subst).

  Definition empty_rmap' : rmap'.
    set (f:= fun _: AV.address => NO).
    assert (R.valid f).
    red; unfold f; simpl.
    apply AV.valid_empty.
    exact (exist _ f H).
  Defined.

  Definition empty_rmap (n:nat) : rmap := R.squash (n, empty_rmap').

Lemma emp_empty_rmap: forall n, emp (empty_rmap n).
Proof.
intros.
intro; intros.
apply rmap_ext.
Comp.
intros.
apply (resource_at_join _ _ _ l) in H.
unfold empty_rmap, empty_rmap', resource_at in *.
destruct (unsquash a); destruct (unsquash b).
simpl in *.
destruct r; destruct r0; simpl in *.
rewrite unsquash_squash in H.
simpl in *.
unfold compose in H.
inv H; auto.
Qed.

Lemma empty_rmap_level:
  forall lev, level (empty_rmap lev) = lev.
Proof.
intros.
simpl.
rewrite rmap_level_eq.
unfold  empty_rmap.
rewrite unsquash_squash; auto.
Qed.

Lemma approx_FF: forall n, approx n FF = FF.
Proof.
intros.
apply pred_ext; auto.
unfold approx; intros ? ?.
hnf in H. destruct H; auto.
Qed.

Lemma resource_at_make_rmap: forall f V lev H, resource_at (proj1_sig (make_rmap f V lev H)) = f.
refine (fun f V lev H => match proj2_sig (make_rmap f V lev H) with
                           | conj _ RESOURCE_AT => RESOURCE_AT
                         end).
Qed.

Lemma level_make_rmap: forall f V lev H, @level rmap _ (proj1_sig (make_rmap f V lev H)) = lev.
refine (fun f V lev H => match proj2_sig (make_rmap f V lev H) with
                           | conj LEVEL _ => LEVEL
                         end).
Qed.

Instance Join_trace : Join (AV.address -> option (pshare * AV.kind)) :=
     (Join_fun AV.address (option (pshare * AV.kind))
                   (Join_lower (Join_prod pshare Join_pshare AV.kind (Join_equiv AV.kind)))).

 Lemma res_option_join:
    forall x y z, join x y z -> @join _ (@Join_lower (pshare * AV.kind)
     (Join_prod pshare Join_pshare AV.kind (Join_equiv AV.kind))) (res_option x) (res_option y) (res_option  z).
 Proof.
   intros.
  inv H; constructor.  split; auto.
 Qed.

Definition fixup_trace (trace: AV.address -> option (pshare * AV.kind))
                                    (f: AV.address -> resource) : AV.address -> resource :=
   fun x => match trace x, f x with
                   | None, PURE k pp => PURE k pp
                   | Some(sh,k), PURE _ pp => YES sh k pp
                   | Some (sh,k), YES _ _ pp => YES sh k pp
                   | Some (sh, k), NO => YES sh k NoneP
                   | None, _ => NO
                   end.

Lemma fixup_trace_valid: forall tr f, AV.valid tr -> AV.valid (res_option oo (fixup_trace tr f)).
 Proof. intros.
  replace (res_option oo fixup_trace tr f) with tr. auto.
  extensionality l. unfold compose. unfold fixup_trace.
  destruct (tr l); simpl; auto.
  destruct p. destruct (f l); simpl; auto.
  destruct (f l); reflexivity.
Qed.

Lemma fixup_trace_rmap:
    forall (tr: sig AV.valid) (f: rmap),
        {phi: rmap | level phi = level f /\ resource_at phi = fixup_trace (proj1_sig tr) (resource_at f)}.
Proof.
 intros.
 apply make_rmap. apply fixup_trace_valid. destruct tr; simpl; auto.
 extensionality l.
 unfold compose, fixup_trace.
 destruct tr. simpl.
 destruct (x l); simpl; auto. destruct p.
 case_eq (f @ l); intros.
 unfold resource_fmap. rewrite preds_fmap_NoneP; auto.
 generalize (resource_at_approx f l); intro.
 rewrite H in H0. symmetry in H0.
  simpl in H0. simpl.
   f_equal. injection H0; auto.
 generalize (resource_at_approx f l); intro.
 rewrite H in H0. symmetry in H0.
  simpl in H0. simpl.
   f_equal. injection H0; auto.
 case_eq (f @ l); intros; auto.
 generalize (resource_at_approx f l); intro.
 rewrite H in H0. symmetry in H0.
  simpl in H0. simpl.
   f_equal. injection H0; auto.
Qed.

Ltac crtac :=
 repeat  (solve [constructor; auto] ||
   match goal with
 | H: None = res_option ?A |- _ => destruct A; inv H
 | H: Some _ = res_option ?A |- _ => destruct A; inv H
 | H: join NO _ _ |- _ => inv H
 | H: join _ NO _ |- _ => inv H
 | H: join (YES _ _ _) _ _ |- _ => inv H
 | H: join _ (YES _ _ _) _ |- _ => inv H
 | H: join (PURE _ _) _ _ |- _ => inv H
 | H: join _ (PURE _ _) _ |- _ => inv H
 | H: @join _ _ (Some _) _ _ |- _ => inv H
 | H: @join _ _ _ (Some _) _ |- _ => inv H
 | H: @join _ _ None _ _ |- _ =>
                apply join_unit1_e in H; [| apply None_identity]
 | H: @join _ _ _ None _ |- _ =>
                apply join_unit2_e in H; [| apply None_identity]
 | H:  prod pshare AV.kind |- _ => destruct H
 | H: @join _ (Join_equiv _) ?a ?b ?c |- _ => destruct H; try subst a; try subst b; try subst c
 | H: @join _ (Join_prod _ _ _ _) (_,_) (_,_) (_,_) |- _ => destruct H; simpl fst in *; simpl snd in *
 end; auto).

Lemma Cross_resource: Cross_alg resource.
Proof.
intro; intros.
destruct a as [|a|a].
assert (b=z) by (inv H; auto). subst.
exists (NO,NO,c,d); split; simpl; auto; try constructor; auto.
inv H. inv H0; split; constructor. inv H0; split; constructor.
destruct b as [|b|b].
assert (z=YES a k p) by (inv H; auto). clear H; subst.
exists (c,d,NO,NO); split; simpl; auto.
inv H0; split3; constructor.
assert (Hz: k0=k /\ p0=p) by (inv H; auto). destruct Hz; subst.
destruct c as [|c|c].
assert (z=d) by (inv H0; auto). clear H0; subst.
exists (NO,(YES a k p),NO,(YES b k p)); simpl; split; auto.
constructor.
inv H; split3; constructor; auto.
destruct d as [|d|d].
assert (z=YES c k0 p0) by (inv H0; auto). clear H0; subst.
assert (Hz: k0=k /\ p0=p) by (inv H; auto); destruct Hz; subst.
exists (YES a k p, NO, YES b k p, NO); simpl; split; auto.
constructor. inv H; split3; constructor; auto.
destruct z as [|z|z].  elimtype False; inv H0.
assert (Hx: k=k2 /\ k0=k2 /\ k1=k2 /\ p=p2 /\ p0=p2 /\ p1=p2) by  (inv H0; inv H; auto 50).
destruct Hx as [? [? [? [? [? ?]]]]]; subst.
assert (join c d z) by (inv H0; auto).
assert (join a b z) by (inv H; auto).
clear H H0.
destruct (share_cross_split _ _ _ _ _ H2 H1) as [[[[ac ad] bc] bd] [Ha [Hb [Hc Hd]]]].
destruct (dec_share_identity ac).
apply i in Ha; apply i in Hc. subst.
destruct (dec_share_identity bd).
apply join_comm in Hb; apply join_comm in Hd; apply i0 in Hb; apply i0 in Hd; subst.
apply lifted_eq in Hb. apply lifted_eq in Hd; subst b d.
rename k2 into k; rename p2 into p.
exists (NO, YES a k p, YES c k p, NO); simpl; split; auto. constructor.
split3; constructor; auto.
rename k2 into k; rename p2 into p.
apply nonidentity_nonunit in n.
exists (NO, YES a k p, YES c k p, YES (mk_lifted _ n) k p); simpl; split; auto.
constructor. split3; constructor; auto.
destruct (dec_share_identity ad).
apply join_comm in Ha; apply i in Ha; apply i in Hd; subst bd ac.
clear n.
destruct (dec_share_identity bc).
apply join_comm in Hc; apply i0 in Hb; apply i0 in Hc.  apply lifted_eq in Hb; apply lifted_eq in Hc; subst d c.
rename k2 into k; rename p2 into p.
exists (YES a k p, NO, NO, YES b k p); simpl; split; auto.
constructor. split3; constructor; auto.
rename k2 into k; rename p2 into p.
exists (YES a k p, NO, YES (mk_lifted _ (nonidentity_nonunit n)) k p, YES d k p); simpl; split; auto.
constructor. split3; constructor; auto.
destruct (dec_share_identity bc).
apply join_comm in Hc; apply i in Hb; apply i in Hc.  subst ac bd.
rename k2 into k; rename p2 into p.
exists (YES c k p, YES (mk_lifted _ (nonidentity_nonunit n0)) k p, NO, YES b k p); simpl; split; auto.
constructor. auto. split3; constructor; auto.
destruct (dec_share_identity bd).
apply join_comm in Hb; apply join_comm in Hd;
 apply i in Hb; apply i in Hd. subst bc ad.
rename k2 into k; rename p2 into p.
exists (YES (mk_lifted _ (nonidentity_nonunit n)) k p,  YES d k p, YES b k p, NO); split; simpl; auto.
constructor; auto. split3; constructor; auto.
rename k2 into k; rename p2 into p.
exists (YES (mk_lifted _ (nonidentity_nonunit n)) k p, YES (mk_lifted _ (nonidentity_nonunit n0)) k p,
       YES (mk_lifted _ (nonidentity_nonunit n1)) k p,  YES (mk_lifted _ (nonidentity_nonunit n2)) k p); split; simpl; auto.
constructor; auto.  split3; constructor; auto.
elimtype False; inv H0.
elimtype False; inv H0.
elimtype False; inv H0; inv H.
elimtype False; inv H.
exists (PURE a p, PURE a p, PURE a p, PURE a p).
inv H. inv H0.
repeat split; constructor; auto.
Qed.

Instance Cross_rmap:
      @Cross_alg _ (Join_prop _ Join_trace AV.valid) ->
      Cross_alg rmap.
Proof.
  intro CAV.
  repeat intro.
  assert (Hz : valid (resource_at z)).
  unfold resource_at.
  case_eq (unsquash z); intros.
  simpl.
  destruct r; simpl; auto.
  specialize (CAV
          (exist AV.valid _ (rmap_valid a))
          (exist AV.valid _ (rmap_valid b))
          (exist AV.valid _ (rmap_valid c))
          (exist AV.valid _ (rmap_valid d))
          (exist AV.valid _ Hz)).
  destruct CAV as [[[[Vac Vad] Vbc] Vbd] [Va [Vb [Vc Vd]]]].
  intro l.  unfold compose. simpl.
  apply res_option_join. apply resource_at_join. auto.
  intro l.  simpl. unfold compose.
  apply res_option_join. apply resource_at_join. auto.
  destruct (fixup_trace_rmap Vac z) as [Mac [? ?]].
  destruct (fixup_trace_rmap Vad z) as [Mad [? ?]].
  destruct (fixup_trace_rmap Vbc z) as [Mbc [? ?]].
  destruct (fixup_trace_rmap Vbd z) as [Mbd [? ?]].
  exists (Mac,Mad,Mbc,Mbd).
  destruct Vac as [ac ?]; destruct Vad as [ad ?]; destruct Vbc as [bc ?];
  destruct Vbd as [bd ?]; simpl in *.
  assert (LEVa: level a = level z) by (apply join_level in H; destruct H; auto).
  assert (LEVb: level b = level z) by (apply join_level in H; destruct H; auto).
  assert (LEVc: level c = level z) by (apply join_level in H0; destruct H0; auto).
  assert (LEVd: level d = level z) by (apply join_level in H0; destruct H0; auto).
  do 2 red in Va,Vb,Vc,Vd; simpl in *.
  unfold compose in *. clear Hz.
  split; [|split3];   apply resource_at_join2; try congruence; intro l;
  spec Va l; spec Vb l; spec Vc l; spec Vd l;
  apply (resource_at_join _ _ _ l) in H;
  apply (resource_at_join _ _ _ l) in H0;
  try rewrite H2; try rewrite H4; try rewrite H6; try rewrite H8;
  unfold fixup_trace; simpl in *.
  forget (a @ l) as al; forget (b @ l) as bl; forget (c @ l ) as cl;
  forget (d @ l) as dl; forget (z @ l) as zl;
   clear - Va Vb Vc Vd H H0.
  (* case 1 *)
  destruct (ac l); crtac. destruct (ad l); crtac.
  (* case 2 *)
  destruct (bc l); crtac. destruct (bd l); crtac.
  (* case 3 *)
  destruct (ac l); crtac. destruct (bc l); crtac.
  (* case 4 *)
  destruct (ad l); crtac. destruct (bd l); crtac.
Qed.

Lemma Cross_rmap_simple: (forall f, AV.valid f) -> Cross_alg rmap.
Proof.
  intro V.
   apply Cross_rmap.
   intros [a Ha] [b Hb] [c Hc] [d Hd] [e He] ? ?.
   do 2 red in H,H0. simpl in *.
   assert (Cross_alg (AV.address -> option (pshare * AV.kind))).
     apply (cross_split_fun  (option (pshare * AV.kind))).
   eapply (Cross_bij' _ _ _ _ (opposite_bij (option_bij (lift_prod_bij _ _)))).
   apply Cross_smash; auto with typeclass_instances.
   clear; intro. destruct x. destruct (dec_share_identity t); [left|right].
    apply identity_unit_equiv in i. apply identity_unit_equiv. split; auto.
    contradict n.
    apply identity_unit_equiv in n. apply identity_unit_equiv. destruct n; auto.
   clear. extensionality a b c. apply prop_ext.
   destruct a as [[[? ?] ?] | ]; destruct b  as [[[? ?] ?] | ]; destruct c as [[[? ?] ?] | ];
   split; simpl; intro H; inv H; simpl in *; try constructor; auto; hnf in  *; simpl in *;
   try proof_irr; try constructor;
     destruct H3; constructor; simpl; auto. (* this line for compatibility with Coq 8.3 *)
   destruct (X a b c d e H H0) as [[[[ac ad] bc] bd] [? [? [? ?]]]].
   exists (exist AV.valid ac (V _), exist AV.valid ad (V _),
              exist AV.valid bc (V _), exist AV.valid bd (V _)).
   split; [ |split3]; simpl; auto.
Qed.

Lemma identity_resource: forall r: resource, identity r <->
    match r with YES _ _ _ => False | _ => True end.
Proof.
 intros. destruct r; intuition.
 apply NO_identity.
 specialize (H NO (YES p k p0)).
 spec H. constructor. inv H.
 intros  ? ? ?. inv H0. auto.
Qed.

Lemma resource_at_core_identity:  forall m i, identity (core m @ i).
Proof.
  intros.
  generalize (core_duplicable m); intro Hdup. apply (resource_at_join _ _ _ i) in Hdup.
  apply identity_resource.
  case_eq (core m @ i); intros; auto.
  rewrite H in Hdup. inv Hdup.
   apply pshare_nonunit in H1. auto.
Qed.

Lemma YES_inj: forall sh k pp sh' k' pp',
           YES sh k pp = YES sh' k' pp' ->
          sh=sh' /\ k=k' /\ pp=pp'.
Proof. intros. inv H. auto. Qed.

Lemma SomeP_inj1: forall t t' a a', SomeP t a = SomeP t' a' -> t=t'.
  Proof. intros. inv H; auto. Qed.
Lemma SomeP_inj2: forall t a a', SomeP t a = SomeP t a' -> a=a'.
  Proof. intros. inv H. apply inj_pair2 in H1. auto. Qed.
Lemma SomeP_inj:
   forall T a b, SomeP T a = SomeP T b -> a=b.
Proof. intros. inv H. apply inj_pair2 in H1. auto.
Qed.

Lemma PURE_inj: forall T x x' y y', PURE x (SomeP T y) = PURE x' (SomeP T y') -> x=x' /\ y=y'.
 Proof. intros. inv H. apply inj_pair2 in H2. subst; auto.
 Qed.

Lemma core_resource_at: forall w i, core (w @ i) = core w @ i.
Proof.
 intros.
 generalize (core_unit w); intros.
 apply (resource_at_join _ _ _ i) in H.
 generalize (core_unit (w @ i)); unfold unit_for; intros.
 eapply join_canc; eauto.
Qed.

End Rmaps_Lemmas.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 227 to 230, whose indices in         *)
(* the_configs range over segment [226, 230).                                 *)
(******************************************************************************)

Lemma red226to230 : reducible_in_range 226 230 the_configs.
Proof. CheckReducible. Qed.


(* This Program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Typed LambdaFactor Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus  from Project Coq                               *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   type_derivation.v                                *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import General.
Require Import Max.
Require Import Test.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import LamSF_Substitution_term.
Require Import Components.
Require Import Compounds.
Require Import LamSF_reduction.
Require Import LamSF_Closed.

(* Types of System F *)

(* Typing will be implicit, with rules for instantiating and
generalising type variables that do not change the term.  Further, the
presence of the operators requires that there be rules for pushing type
variables to the right of arrows after generalising when the bound
variable does not appear in the argument type.

The main goal is to prove subject reduction. This is challenging since
there may be many derivations of the same typing. The strategy will be
to define derivation in a natural manner, and then reduce the variety
of derivation strategies allowed, without losing any typings. This is
done by first limiting instantiation to variables and operators, and
then requiring instantiation to produce a well-formed type,
i.e. without abstractions to the right of an arrow.

*)

(* the terms are also used to represent types *)

Definition varty := Ref .
Definition funty ty1 ty2 := App (App s_op ty1) ty2.

Fixpoint quant (k:nat) ty :=
match k with
| 0 => ty
| S k1 => Abs (quant k1 ty)
end.

Lemma quant_quant: forall j n ty, quant j (quant n ty) = quant (j+n) ty.
Proof. induction j; split_all. Qed.

Lemma lift_rec_preserves_quant :
forall n ty n0 k,
lift_rec (quant n ty) n0 k = quant n (lift_rec ty (n+n0) k).
Proof.
induction n; split_all. unfold quant; fold quant; simpl. rewrite IHn.
replace(n + S n0) with (S (n+n0)) by omega. auto.
Qed.

Lemma subst_rec_preserves_quant :
forall n ty1 ty2 k,
subst_rec (quant n ty1) ty2 k =
quant n (subst_rec ty1 ty2 (n+k)) .
Proof.
induction n; unfold lift; split_all.
(* 2 *)
repeat (rewrite lift_rec_null). auto.
(* 1 *)
rewrite IHn; unfold lift.
replace (n + S k) with (S (n+k)) by omega; auto.
Qed.

Lemma quant_monotonic :
forall n ty1 ty2,
 quant n ty1 = quant n ty2 -> ty1 = ty2.
Proof. induction n; split_all.  inversion H. auto. Qed.

(* the well-formed type schemes are characterised as follows *)

Inductive wfs : lamSF -> Prop :=
| wfs_var : forall i, wfs (varty i)
| wfs_funty : forall ty1 ty2, wfs ty1 -> wfs ty2 -> wfs (funty ty1 ty2)
| wfs_abs : forall ty, wfs ty -> wfs (Abs ty)
.

Hint Constructors wfs.

(* the well-formed types are a sub-set of the well-formed schemes *)

Inductive wf : lamSF -> Prop :=
| wf_var : forall i, wf (varty i)
| wf_funty : forall ty1 ty2, wfs ty1 -> wf ty2 -> wf (funty ty1 ty2)
.

Hint Constructors wf.

Lemma lift_rec_preserves_wfs: forall ty, wfs ty -> forall n k, wfs(lift_rec ty n k).
Proof.
rank_tac. induction ty; split_all; inv1 wfs; subst; simpl in *.
eapply2 wfs_abs.
eapply2 IHty. omega.
eapply2 wfs_funty.  eapply2 IHp; omega. eapply2 IHty2; omega.
Qed.

Lemma lift_rec_reflects_wfs : forall ty n k, wfs (lift_rec ty n k) -> wfs ty.
Proof.
rank_tac.
induction ty; split_all.
inversion H0; subst. eapply2 wfs_abs. eapply2 IHp. omega.
inversion H0; subst.
gen3_case H H0 H1 ty1.
inversion H1; subst.
gen3_case H H0 H5 l; try discriminate.
rewrite <- H5.
eapply2 wfs_funty.
eapply2 IHp. omega.
eapply2 IHp. omega.
Qed.

Lemma subst_rec_preserves_wfs: forall ty1 ty k, wfs ty1 -> wfs ty -> wfs (subst_rec ty1 ty k).
Proof.
rank_tac.
induction ty1; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all.
unfold lift; eapply2 lift_rec_preserves_wfs.
eapply2 wfs_abs. eapply2 IHty1. simpl in *; omega. inversion H0; auto.
inversion H0; subst.
simpl. eapply2 wfs_funty.
eapply2 IHp. simpl in *; omega.
eapply2 IHp. simpl in *; omega.
Qed.

Lemma lift_rec_preserves_wf: forall ty, wf ty -> forall n k, wf(lift_rec ty n k).
Proof. induction ty; split_all; inv1 wf. eapply2 wf_funty.  eapply2 lift_rec_preserves_wfs. Qed.

Hint Resolve lift_rec_preserves_wfs lift_rec_preserves_wf.

Lemma wf_implies_wfs : forall ty, wf ty -> wfs ty.
Proof. induction ty; split_all; inv1 wf; subst. eapply2 wfs_funty. Qed.

Lemma quant_preserves_wfs: forall j ty, wfs ty -> wfs (quant j ty).
Proof. induction j; split_all. Qed.

(* operator types *)

Definition op_abs o :=
match o with
| Sop => 3
| Aop => 2
| Kop => 2
| Eop => 3
| Gop => 2
| Qop => 2
| Uop => 1
| _ => 1
end.

Definition  opty_core0 (o: operator) :=
match o with
  | Sop => funty (funty (varty 2) (funty (varty 1) (varty 0)))
                 (funty (funty (varty 2) (varty 1))
                        (funty (varty 2) (varty 0))
                 )
  | Aop => funty (funty (varty 0) (varty 1)) (funty (varty 0) (varty 1))
  | Kop => funty (varty 1) (funty (varty 0) (varty 1))
  | Eop => funty (varty 2) (funty (varty 1) (funty (varty 0) (funty (varty 0) (varty 0))))
  | Gop => funty (Abs (funty (funty (varty 0) (varty 2)) (funty (varty 0) (varty 1))))
                        (funty (varty 1) (varty 0))
  | Qop => funty (Abs (funty (varty 0) (varty 1)))
                 (funty (funty (varty 0) (funty (varty 0) (varty 0)))
                        (funty (varty 1) (varty 0)))
  | Uop => funty (Abs (Abs (funty (varty 1)
                                         (funty (funty (varty 0) (varty 1))
                                                (funty (varty 0) (varty 1))))))
                        (funty (varty 0) (varty 0))
  | Yop => funty (funty (varty 0) (varty 0)) (varty 0)
| _ => Op o (* dummy value *)
end.

Definition  case_op_type o :=
  funty (quant (op_abs o) (opty_core0 o))
        (funty (funty (varty 0) (varty 0))
               (funty (varty 0) (varty 0))) .

Definition opty_core o :=
match o with
| DSop => case_op_type Sop
| DAop => case_op_type Aop
| DKop => case_op_type Kop
| DEop => case_op_type Eop
| DGop => case_op_type Gop
| DQop => case_op_type Qop
| DUop => case_op_type Uop
| DYop => case_op_type Yop
| _ => opty_core0 o
end.

Definition opty (o: operator) := quant (op_abs o) (opty_core o).

Ltac unfold_opty := unfold opty, opty_core, opty_core0, case_op_type, op_abs, quant.

(* instance *)

Inductive instance1 : lamSF -> lamSF -> Prop :=
| instance_rule : forall ty ty1, wfs ty -> wfs ty1 -> instance1 (Abs ty1) (subst ty ty1)
| instance_abs : forall ty1 ty2, instance1 ty1 ty2 -> instance1 (Abs ty1) (Abs ty2)
| instance_funty : forall ty1 ty2 ty3, wfs ty1 -> instance1 ty2 ty3 ->
                                     instance1 (funty ty1 ty2) (funty ty1 ty3)
| instance_contra : forall ty0 ty1 ty2, instance1 ty0 ty1 -> wfs ty2 ->
                                     instance1 (funty ty1 ty2) (funty ty0 ty2)
.

Hint Constructors instance1.

Definition instance := multi_step instance1.

Lemma lift_rec_preserves_instance1 : lift_rec_preserves instance1.
Proof.
intros ty1 ty2 p; induction p; split_all.
unfold subst; replace n with (0+n) by omega;
rewrite lift_rec_subst_rec; try omega.
eapply2 instance_rule.
eapply2 instance_funty.
eapply2 instance_contra.
Qed.

Lemma lift_rec_preserves_instance :
forall ty1 ty2, instance ty1 ty2 ->
forall n k, instance (lift_rec ty1 n k) (lift_rec ty2 n k).
Proof.
eapply2 lift_rec_preserves_multi_step.
red; split_all. eapply2 lift_rec_preserves_instance1.
Qed.

Lemma subst_rec_preserves_instance1 :
forall ty1 ty2, instance1 ty1 ty2 ->
forall ty k, wfs ty -> instance1(subst_rec ty1 ty k) (subst_rec ty2 ty k).
Proof.
intros ty1 ty2 p; induction p; split_all.
(* 3 *)
unfold subst. replace k with (0+k) by auto.
rewrite subst_rec_subst_rec. simpl.
replace(subst_rec (subst_rec ty1 ty0 (S k)) (subst_rec ty ty0 k) 0)
with (subst (subst_rec ty ty0 k) (subst_rec ty1 ty0 (S k))) by auto.
eapply2 instance_rule; eapply2 subst_rec_preserves_wfs.
(* 2 *)
eapply2 instance_funty.  eapply2 subst_rec_preserves_wfs.
eapply2 instance_contra. eapply2 subst_rec_preserves_wfs.
Qed.

Lemma subst_rec_preserves_instance :
forall ty1 ty2, instance ty1 ty2 ->
forall ty k, wfs ty -> instance(subst_rec ty1 ty k) (subst_rec ty2 ty k).
Proof.
cut(forall red ty1 ty2, multi_step red ty1 ty2 -> red = instance1 ->
forall ty k, wfs ty -> instance(subst_rec ty1 ty k) (subst_rec ty2 ty k)).
intro c; split_all; eapply2 c.
intros red ty1 ty2 m; induction m; split_all; subst.
eapply2 zero_red.
apply transitive_red with (subst_rec N ty k); auto.
one_step. eapply2 subst_rec_preserves_instance1.
eapply2 IHm.
Qed.

Lemma preserves_abs_instance : forall ty1 ty2, instance ty1 ty2 -> instance (Abs ty1) (Abs ty2).
Proof.
cut(forall red ty1 ty2, multi_step red ty1 ty2 -> red = instance1 ->
instance (Abs ty1) (Abs ty2)).
intro aux; split_all; eapply2 aux.
intros red ty1 ty2 m; induction m; split_all; subst. eapply2 zero_red.
eapply succ_red. 2: eapply2 IHm. auto.
Qed.

Lemma preserves_funty_r_instance :
forall ty1 ty2 ty3, wfs ty1 -> instance ty2 ty3 -> instance(funty ty1 ty2) (funty ty1 ty3).
Proof.
cut(forall red ty1 ty2 ty3, wfs ty1 -> multi_step red ty2 ty3 -> red = instance1 ->
instance(funty ty1 ty2) (funty ty1 ty3)).
intro aux; split_all; eapply2 aux.
intros red ty1 ty2 ty3 w m; induction m; split_all; subst.
eapply2 zero_red.
eapply transitive_red. one_step. eapply instance_funty; auto.
eexact H. eapply2 IHm.
Qed.

Lemma preserves_contra_instance :
forall ty1 ty2 ty3, wfs ty1 -> instance ty2 ty3 -> instance(funty ty3 ty1) (funty ty2 ty1).
Proof.
cut(forall red ty1 ty2 ty3, wfs ty1 -> multi_step red ty2 ty3 -> red = instance1 ->
instance(funty ty3 ty1) (funty ty2 ty1)).
intro aux; split_all; eapply2 aux.
intros red ty1 ty2 ty3 w m; induction m; split_all; subst.
eapply2 zero_red.
eapply transitive_red. eapply2 IHm. one_step.
Qed.

Lemma instance1_implies_wfs: forall ty1 ty2, instance1 ty1 ty2 -> wfs ty1 /\ wfs ty2.
Proof.
intros ty1 ty2 inst; induction inst; split_all.
unfold subst; eapply2 subst_rec_preserves_wfs.
Qed.

Lemma instance_implies_wfs:
forall ty1 ty2, instance ty1 ty2 -> (wfs ty1 -> wfs ty2) /\ (wfs ty2 -> wfs ty1).
Proof.
cut(forall red ty1 ty2, multi_step red ty1 ty2 -> red = instance1 ->
 (wfs ty1 -> wfs ty2) /\ (wfs ty2 -> wfs ty1)).
intro aux; intros;
assert((wfs ty1 -> wfs ty2) /\ (wfs ty2 -> wfs ty1)) by eapply2 aux; split_all.

intros red ty1 ty2 m; induction m; split_all; subst.
eapply2 IHm; eapply2 instance1_implies_wfs.
assert(wfs M /\ wfs N) by eapply2 instance1_implies_wfs. split_all.
Qed.

Lemma preserves_funty_instance :
forall ty0 ty1 ty2 ty3, wfs ty1 -> wfs ty2 -> instance ty0 ty1 -> instance ty2 ty3 ->
instance(funty ty1 ty2) (funty ty0 ty3).
Proof.
split_all. eapply transitive_red. eapply2 preserves_funty_r_instance.
eapply2 preserves_contra_instance.
assert((wfs ty2 -> wfs ty3) /\ (wfs ty3 -> wfs ty2)) by eapply2 instance_implies_wfs.
split_all.
Qed.

Lemma preserves_varty_instance :
forall red ty1 ty2, multi_step red ty1 ty2 -> red = instance1 -> forall i, ty1 = varty i -> ty2 = ty1.
Proof. intros red ty1 y2 m; induction m; split_all; subst. inversion H. Qed.

(* push *)

Inductive push1 : lamSF -> lamSF -> Prop :=
| push_lift : forall ty1 ty2, wfs ty1 -> wfs ty2 ->
                push1 (Abs (funty (lift 1 ty1) ty2)) (funty ty1 (Abs ty2))
| push_abs : forall ty1 ty2, push1 ty1 ty2 -> push1 (Abs ty1) (Abs ty2)
                                    (* for pushing after generalizing *)
| push_funty : forall ty1 ty2 ty3,
                push1 ty2 ty3 -> wfs ty1 ->
                push1 (funty ty1 ty2) (funty ty1 ty3)
.

Definition push := multi_step push1.

Hint Resolve push_lift push_abs push_funty.

Lemma lift_rec_preserves_push1 :
forall ty1 ty2, push1 ty1 ty2 ->
forall n k, push1 (lift_rec ty1 n k) (lift_rec ty2 n k).
Proof.
intros ty1 ty2 p; induction p; split_all.
unfold lift, funty; rewrite lift_lift_rec; try omega. eapply2 push_lift.
eapply2 push_funty.
Qed.

Lemma subst_rec_preserves_push1 :
forall ty1 ty2, push1 ty1 ty2 ->
forall ty k, wfs ty ->  push1 (subst_rec ty1 ty k) (subst_rec ty2 ty k).
Proof.
intros ty1 ty2 p; induction p; split_all.
unfold lift; rewrite subst_rec_lift_rec1; try omega.
eapply2 push_lift; eapply2 subst_rec_preserves_wfs.
eapply2 push_funty; eapply2 subst_rec_preserves_wfs.

Qed.

Lemma subst_rec_preserves_push :
forall red ty1 ty2, multi_step red ty1 ty2 -> red = push1 ->
forall ty k, wfs ty -> push (subst_rec ty1 ty k) (subst_rec ty2 ty k).
Proof.
intros red ty1 ty2 p; induction p; split_all; subst.
eapply2 zero_red.
apply succ_red with (subst_rec N ty k); auto.
eapply2 subst_rec_preserves_push1.
eapply2 IHp.
Qed.

Lemma preserves_funty_r_push :
forall ty1 ty2 ty3, wfs ty1 -> push ty2 ty3 -> push(funty ty1 ty2) (funty ty1 ty3).
Proof.
cut(forall red ty1 ty2 ty3, wfs ty1 -> multi_step red ty2 ty3 -> red = push1 ->
push(funty ty1 ty2) (funty ty1 ty3)).
intro aux; split_all; eapply2 aux.
intros red ty1 ty2 ty3 w m; induction m; split_all; subst.
eapply2 zero_red.
eapply transitive_red. one_step. eapply push_funty; auto.
eexact H. eapply2 IHm.
Qed.

Lemma push1_quant :
forall j ty1 ty2, push1 ty1 ty2 -> push1 (quant j ty1) (quant j ty2).
Proof. induction j; split_all; rewrite IHj; auto. Qed.

Lemma push_quant :
forall j ty1 ty2, wfs ty1 -> wfs ty2 -> push (quant j (funty (lift j ty1) ty2))
                       (funty ty1 (quant j ty2)).
Proof.
induction j; split_all.
(* 2 *)
unfold lift; rewrite lift_rec_null. eapply2 zero_red.
(* 1 *)
apply transitive_red  with (Abs (funty (lift 1 ty1) (quant j ty2))); auto.
eapply2 preserves_abs_multi_step. red; split_all.
replace(lift (S j) ty1) with (lift j (lift 1 ty1)).
eapply2 IHj.
unfold lift; eapply2 lift_rec_preserves_wfs.
unfold lift; rewrite lift_rec_lift_rec; try omega.
replace (j+1) with (S j) by omega; auto.
one_step.
eapply2 push_lift.
clear - H0.
induction j; split_all.
Qed.

Lemma push_preserves_abs :
forall ty1 ty2, push ty1 ty2 -> push (Abs ty1) (Abs ty2).
Proof.
cut(forall red ty1 ty2, multi_step red ty1 ty2 -> red = push1 ->
                        push (Abs ty1) (Abs ty2)).
intro aux; split_all; eapply2 aux.
intros red ty1 ty2 m; induction m; split_all; subst.
eapply2 zero_red.
eapply succ_red.
eapply2 push_abs.
eapply2 IHm.
Qed.

Lemma push_preserves_funty :
forall ty0 ty1 ty2, push ty1 ty2 -> wfs ty0 -> push (funty ty0 ty1) (funty ty0 ty2).
Proof.
cut(forall red ty0 ty1 ty2, multi_step red ty1 ty2 -> red = push1 -> wfs ty0 ->
                        push (funty ty0 ty1) (funty ty0 ty2)).
intro aux; split_all; eapply2 aux.
intros red ty0 ty1 ty2 m; induction m; split_all; subst.
eapply2 zero_red.
eapply succ_red.
eapply2 push_funty.
eapply2 IHm.
Qed.

Lemma preserves_abs_push : preserves_abs push.
Proof.  eapply2 preserves_abs_multi_step. red; split_all. Qed.

Lemma push_implies_wfs: forall ty1 ty2, push1 ty1 ty2 -> wfs ty1 /\ wfs ty2.
Proof.
intros ty1 ty2 p; induction p; split_all.
eapply2 wfs_abs. eapply2 wfs_funty. unfold lift; eapply2 lift_rec_preserves_wfs.
Qed.

Lemma push1_instance1:
forall ty1 ty2, push1 ty1 ty2 -> forall ty3, instance1 ty2 ty3 ->
exists ty4, instance1 ty1 ty4 /\ push ty4 ty3.
Proof.
intros ty1 ty2 p; induction p; split_all.
(* 3 *)
inversion H1; subst. inversion H6; subst.
(* 5 *)
exist (subst ty (funty (lift 1 ty1) ty2)).
eapply2 instance_rule.  unfold lift; simpl. eapply2 wfs_funty.
unfold subst, lift; simpl.
rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null.
eapply2 zero_red.
(* 4 *)
exist (Abs (funty (lift 1 ty1) ty3)) .
unfold lift; simpl. eapply2 instance_abs.
red; one_step. eapply2 push_lift.  eapply2 instance1_implies_wfs.
(* 3 *)
unfold lift; simpl.
exist  (Abs (App (App (Op Sop) (lift_rec ty0 0 1)) ty2)) .
eapply2 instance_abs. eapply2 instance_contra. eapply2 lift_rec_preserves_instance1.
red; one_step.
replace  (App (Op Sop) (lift_rec ty0 0 1)) with (lift 1 (App s_op ty0)) by auto.
eapply2 push_lift.
assert(wfs ty0 /\ wfs ty1) by eapply2 instance1_implies_wfs. split_all.
(* 2 *)
inversion H; subst.
(* 3 *)
exist(subst ty ty1). eapply2 instance_rule.
assert(wfs ty1 /\ wfs ty2) by eapply2 push_implies_wfs. split_all.
unfold subst; simpl. red; one_step. eapply2 subst_rec_preserves_push1.
(* 2 *)
assert(exists ty5 : lamSF, instance1 ty1 ty5 /\ push ty5 ty4) by eapply2 IHp.
split_all.
exist(Abs x).
eapply2 preserves_abs_push.
(* 1 *)
inversion H0; subst.
assert(exists ty5 : lamSF, instance1 ty2 ty5 /\ push ty5 ty6) by eapply2 IHp.
split_all.
exist(funty ty1 x).
eapply2 preserves_funty_r_push.
(* 1 *)
exist(funty ty4 ty2). eapply2 instance_contra.
assert(wfs ty2 /\ wfs ty3) by eapply2 push_implies_wfs. split_all.
red; one_step.
eapply2 push_funty.
assert(wfs ty4 /\ wfs ty1) by eapply2 instance1_implies_wfs. split_all.
Qed.

(* contexts *)

Definition context := list lamSF.

Inductive wfc : context -> Prop :=
| wfc_nil : wfc nil
| wfc_cons : forall ty gamma, wfs ty -> wfc gamma -> wfc (cons ty gamma).

Hint Resolve wfc_nil wfc_cons.

Lemma lift_rec_preserves_wfc :
forall gamma, wfc gamma -> forall n k, wfc (map (fun M => lift_rec M n k) gamma).
Proof. induction gamma; split_all. inversion H; subst. eapply2 wfc_cons. Qed.

Lemma subst_rec_preserves_wfc :
forall gamma, wfc gamma -> forall sch k, wfs sch -> wfc (map (fun M => subst_rec M sch k) gamma).
Proof.
induction gamma; split_all.
inversion H; subst. eapply2 wfc_cons. eapply2 subst_rec_preserves_wfs.
Qed.

Hint Resolve lift_rec_preserves_wfc subst_rec_preserves_wfc.

Lemma lift0_context : forall gamma : context, List.map (lift 0) gamma = gamma.
Proof. induction gamma; split_all. rewrite IHgamma. unfold lift; rewrite lift_rec_null. auto. Qed.

Definition insertn k (gamma: context) sch := app (firstn k gamma) (cons sch (skipn k gamma)).
Definition removen k (gamma: context) := app (firstn k gamma) (tl (skipn k gamma)).

Lemma append_preserves_wfc :
forall gamma1 gamma2, wfc gamma1 -> wfc gamma2 -> wfc (gamma1 ++ gamma2).
Proof. induction gamma1; split_all. inversion H. eapply2 wfc_cons. Qed.

Lemma tl_preserves_wfc :
forall gamma, wfc gamma -> wfc (tl gamma).
Proof. induction gamma; split_all. inversion H; auto. Qed.

Lemma firstn_preserves_wfc: forall k gamma, wfc gamma -> wfc (firstn k gamma).
Proof.
induction k; split_all. induction gamma; split_all. inversion H; subst. eapply2 wfc_cons.
Qed.

Lemma skipn_preserves_wfc: forall k gamma, wfc gamma -> wfc (skipn k gamma).
Proof.
induction k; split_all. induction gamma; split_all. inversion H; subst. eapply2 IHk.
Qed.

Lemma insertn_preserves_wfc:
forall k gamma sch, wfc gamma -> wfs sch -> wfc (insertn k gamma sch).
Proof.
split_all. unfold insertn. eapply2 append_preserves_wfc.
eapply2 firstn_preserves_wfc.
eapply2 wfc_cons. eapply2 skipn_preserves_wfc.
Qed.

Lemma removen_preserves_wfc: forall k gamma, wfc gamma -> wfc (removen k gamma).
Proof.
split_all. unfold removen. eapply2 append_preserves_wfc.
eapply2 firstn_preserves_wfc.
assert (wfc (skipn k gamma)) by eapply2 skipn_preserves_wfc.
gen_case H0 (skipn k gamma).
inversion H0; auto.
Qed.

Hint Resolve insertn_preserves_wfc removen_preserves_wfc.

Ltac wfcs_tac := unfold lift; simpl; relocate_lt; repeat eapply2 wfc_cons;
repeat (repeat eapply2 wfs_abs; repeat eapply2 wfs_funty); simpl; auto.

Lemma insertn_cons :
forall k sch gamma sch0, insertn (S k) (cons sch gamma) sch0 = cons sch (insertn k gamma sch0).
Proof. auto. Qed.

Lemma removen_cons :
forall k sch gamma , removen (S k) (cons sch gamma) = cons sch (removen k gamma).
Proof. auto. Qed.

Lemma map_skipn:
forall gamma k (f:lamSF -> lamSF), map f (skipn k gamma) = skipn k (map f gamma).
Proof. induction gamma; split_all; induction k; split_all. Qed.

Lemma map_insertn : forall k sch gamma f, map f (insertn k gamma sch) = insertn k (map f gamma) (f sch).
Proof.
induction k; split_all.
case gamma.
split_all.
intros.
replace (map f (l :: l0)) with (f l :: map f l0) by auto.
replace (insertn (S k) (l :: l0) sch) with (l :: insertn k l0 sch) by auto.
replace (insertn (S k) (f l :: map f l0) (f sch))
with (f l :: insertn k (map f l0) (f sch)) by auto.
replace (map f (l :: insertn k l0 sch)) with (f l :: map f (insertn k l0 sch))
by auto.
rewrite IHk. auto.
Qed.

Lemma map_removen : forall k gamma f, map f (removen k gamma) = removen k (map f gamma).
Proof.
induction k; split_all.
unfold removen, firstn; simpl.  case gamma; split_all.
case gamma; intros.
split_all.
replace (map f (l::l0)) with (f l :: map f l0) by auto.
rewrite removen_cons.
rewrite removen_cons.
replace (map f (l::removen k l0)) with (f l :: map f (removen k l0)) by auto.
rewrite IHk.  auto.
Qed.

Lemma lift_rec_reflects_wfc :
forall gamma n k, wfc (map (fun ty => lift_rec ty n k) gamma) -> wfc gamma.
Proof.
induction gamma; split_all. inversion H. eapply2 wfc_cons.
eapply2 lift_rec_reflects_wfs.
Qed.

(* type derivation *)

Inductive derivation : context -> lamSF -> lamSF -> Prop :=
| derive_op : forall gamma o,  wfc gamma -> derivation gamma (Op o) (opty o)
| derive_var : forall gamma ty,  wfc gamma -> wfs ty -> derivation (cons ty gamma) (Ref 0) ty
| derive_weak : forall gamma i ty1 ty,  derivation gamma (Ref i) ty -> wfs ty1 ->
                                       derivation (cons ty1 gamma) (Ref (S i)) ty
| derive_abs : forall gamma ty1 ty2 t,
                 derivation (cons ty1 gamma) t ty2 ->
                 derivation gamma (Abs t) (funty ty1 ty2)
| derive_app: forall gamma t ty1 ty2 u,
                derivation gamma t (funty ty1 ty2) ->
                derivation gamma u ty1 ->
                derivation gamma (App t u) ty2
| derive_inst : forall gamma t ty1 ty2, derivation gamma t ty1 ->
                                         instance1 ty1 ty2 ->
                                   derivation gamma t ty2
| derive_gen1: forall gamma t ty, derivation (map (lift 1) gamma) t ty ->
                                  derivation gamma t (Abs ty)
| derive_push1 : forall gamma t ty, derivation gamma t ty ->
                forall ty2, push1 ty ty2 -> derivation gamma t ty2
 .

Hint Constructors derivation.

Lemma lift_rec_ty_preserves_derive : forall gamma t ty, derivation gamma t ty -> forall n k ,
derivation (map (fun ty0 => lift_rec ty0 n k) gamma) t (lift_rec ty n k).
Proof.
intros gamma t ty d; induction d; split_all.
(* 6 *)
replace (lift_rec (opty o) n k) with (opty o) by (case o; split_all); auto.
(* 5 *)
eapply2 derive_abs; eapply2 IHd.
(* 4 *)
simpl in *; eapply2 derive_app.
(* 3 *)
eapply2 derive_inst. eapply2 lift_rec_preserves_instance1.
(* 2 *)
eapply2 derive_gen1.
replace(map (lift 1)  (map (fun ty0 : lamSF => lift_rec ty0 n k) gamma))
with (map (fun ty0 : lamSF => lift_rec ty0 (S n) k) (map (lift 1) gamma)).
auto.
clear; induction gamma; split_all.
rewrite IHgamma; unfold lift; rewrite lift_lift_rec; try omega; auto.
(* 1 *)
eapply2 derive_push1. eapply2 lift_rec_preserves_push1.
Qed.

Lemma derive_implies_wfcs: forall gamma t ty, derivation gamma t ty -> wfc gamma /\  wfs ty.
Proof.
intros gamma t ty d; induction d; split_all.
(* 7 *)
case o; split_all; unfold opty, funty; split_all; unfold funty; wfcs_tac.
(* 6 *)
inversion H; auto.
(* 5 *)
inversion H; subst. wfcs_tac.
(* 4 *)
inversion H2; subst. auto.
(* 3 *)
eapply2 instance1_implies_wfs.
assert(wfc(map (subst ty) (map (lift 1) gamma)))
by eapply2 subst_rec_preserves_wfc.
replace gamma with (map (subst ty) (map (lift 1) gamma)); auto.
clear; induction gamma; split_all. rewrite IHgamma.
unfold lift, subst; rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
eapply2 push_implies_wfs.
Qed.

(* general form of derive_weak *)

Lemma derive_weak_general_k:
forall gamma t ty, derivation gamma t ty ->
forall k sch, wfs sch -> derivation (insertn k gamma sch) (lift_rec t k 1) ty.
Proof.
intros gamma t ty d; induction d; split_all.
(* 7 *)
unfold relocate. elim(test k 0); split_all; try noway.
assert(k=0) by omega; subst k. unfold insertn; simpl. eapply2 derive_weak.
replace k with (S (pred k)) by omega.
rewrite insertn_cons. eapply2 derive_var.
(* 6 *)
unfold relocate. elim(test k (S i)); split_all.
gen_case a k. unfold insertn; simpl. eapply2 derive_weak.
rewrite insertn_cons. eapply2 derive_weak.
replace (Ref (S i)) with (lift_rec (Ref i) n 1) by (simpl; relocate_lt; auto).
eapply2 IHd.
replace k with (S (pred k)) by omega.
rewrite insertn_cons. eapply2 derive_weak.
replace (Ref i) with (lift_rec (Ref i) (pred k) 1) by (simpl; relocate_lt; auto).
eapply2 IHd.
(* 5 *)
eapply2 derive_abs. rewrite <- insertn_cons. eapply2 IHd.
(* 4 *)
eapply2 derive_app.
(* 3 *)
eapply2 derive_inst.
(* 2 *)
assert(derivation (insertn k (map (lift 1) gamma) (lift 1 sch)) (lift_rec t k 1) ty).
eapply2 IHd. unfold lift; auto.
rewrite <- map_insertn in H0.
auto.
(* 1 *)
eapply2 derive_push1.
Qed.

Proposition derive_weak_general :
forall gamma t ty, derivation gamma t ty ->
forall sch, wfs sch -> derivation (sch :: gamma) (lift 1 t) ty.
Proof.
split_all.
replace (sch :: gamma) with (insertn 0 gamma sch) by auto.
replace (lift 1 t) with (lift_rec t 0 1) by auto.
eapply2 derive_weak_general_k.
Qed.

(* subst_rec_ty_preserves_derive *)

Lemma weak_aux : forall gamma t sch, derivation gamma t sch -> forall i, t = Ref i -> gamma <> nil.
Proof. intros gamma t sch d; induction d; split_all;
intro; subst; split_all; unfold map in *; auto; eapply2 IHd.
Qed.

Lemma weak_aux1:
forall gamma t ty, derivation gamma t ty -> forall i, t = Ref (S i) ->
forall k, k < S i -> derivation (removen k gamma) (Ref i) ty.
Proof.
intros gamma t ty d; induction d; split_all.
(* 4 *)
inversion H0; subst.
gen_case H1 k.
rewrite removen_cons.
replace i0 with (S (pred i0)) by omega.
eapply2 derive_weak.
eapply2 IHd.
assert(i0 = S (pred i0)) by omega; congruence.
omega.
(* 3 *)
subst. eapply2 derive_inst.
(* 2 *)
subst.
assert(derivation (removen k (map (lift 1) gamma)) (Ref i) ty) by eapply2 IHd.
rewrite <- map_removen in H. auto.
(* 1 *)
eapply2 derive_push1.
Qed.

Lemma weak_aux2:
forall gamma t ty, derivation gamma t ty -> forall i, t = Ref i ->
forall k, k > i -> derivation (removen k gamma) (Ref i) ty.
Proof.
intros gamma t ty d; induction d; split_all.
(* 5 *)
inversion H1; subst.
gen_case H2 k; try noway.
rewrite removen_cons.
eapply2 derive_var.
(* 4 *)
inversion H0; subst.
replace k with (S (pred k)) by omega.
rewrite removen_cons.
eapply2 derive_weak.
eapply2 IHd. omega.
(* 3 *)
eapply2 derive_inst.
(* 2 *)
assert(derivation (removen k (map (lift 1) gamma)) (Ref i) ty) by eapply2 IHd.
rewrite <- map_removen in H1; auto.
(* 1 *)
eapply2 derive_push1.
Qed.

Lemma derive_push0:
forall red gamma t ty, derivation gamma t ty ->
forall ty2, multi_step red ty ty2 -> red = push1 -> derivation gamma t ty2.
Proof.
intros red gamma t ty d ty2 m; induction m; split_all; subst; eapply2 IHm.
Qed.
Lemma derive_push:
forall gamma t ty, derivation gamma t ty ->
forall ty2, push ty ty2 -> derivation gamma t ty2.
Proof. split_all; eapply2 derive_push0. Qed.

Lemma derive_instance:
forall gamma t ty, derivation gamma t ty ->
forall ty2,  instance ty ty2 -> derivation gamma t ty2.
Proof.
cut(forall gamma t ty, derivation gamma t ty ->
forall red ty2,  multi_step red ty ty2 -> red = instance1 ->
derivation gamma t ty2); [ intro c; split_all; eapply2 c |].
intros gamma t ty d red ty2 m; induction m; split_all; subst. eapply2 IHm.
Qed.

Lemma derive_gen:
forall j gamma t ty, derivation (map (lift j) gamma) t ty ->
                                  derivation gamma t (quant j ty).
Proof.
induction j; split_all.
(* 2 *)
rewrite lift0_context in *; auto.
(* 1 *)
replace(map (lift (S j)) gamma)
with (map (lift j) (map (lift 1) gamma)) in H.
assert(derivation (map (lift 1) gamma) t (quant j ty)) by eapply2 IHj.
eapply2 derive_gen1.
clear; induction gamma; split_all; rewrite IHgamma.
unfold lift; rewrite lift_rec_lift_rec; try omega.
replace(j+1) with (S j) by omega; auto.
Qed.

Lemma subst_rec_ty_preserves_derive :
forall gamma t ty, wfs ty -> derivation gamma t ty ->
forall ty1 k, wfs ty1 ->
derivation (map (fun ty0 => subst_rec ty0 ty1 k) gamma) t
           (subst_rec ty ty1 k).
Proof.
intros gamma t ty w d; induction d; split_all.
(* 8 *)
replace(subst_rec (opty o) ty1 k) with (opty o) by (case o; split_all).
eapply2 derive_op.
(* 7 *)
eapply2 derive_var.  eapply2 subst_rec_preserves_wfs.
(* 6 *)
eapply2 derive_weak.  eapply2 subst_rec_preserves_wfs.
(* 5 *)
eapply2 derive_abs. eapply2 IHd. inversion w. auto.
(* 4 *)
eapply2 derive_app. eapply2 IHd1. eapply2 derive_implies_wfcs.
eapply2 IHd2. assert(wfs (funty ty1 ty2)) by eapply2 derive_implies_wfcs.
inversion H0. auto.
(* 3 *)
eapply2 derive_inst. eapply2 IHd.  eapply2 derive_implies_wfcs.
eapply2 subst_rec_preserves_instance1.
(* 2 *)
assert(derivation
          (map (fun ty0 : lamSF => subst_rec ty0 ty1 (S k)) (map (lift 1) gamma))
          t (subst_rec ty ty1 (S k))).  eapply2 IHd.
inversion w; auto.
replace (map (fun ty0 : lamSF => subst_rec ty0 ty1 (S k)) (map (lift 1) gamma))
with (map (lift 1) (map (fun ty0 : lamSF => subst_rec ty0 ty1 k) gamma)) in H0.
auto.
clear; induction gamma; split_all; rewrite IHgamma.
unfold lift; rewrite subst_rec_lift_rec1; auto; omega.
(* 1 *)
eapply2 derive_push1. eapply2 IHd. eapply2 derive_implies_wfcs.
eapply2 subst_rec_preserves_push1.
Qed.

Ltac subst_out :=
unfold subst; simpl; insert_Ref_out;
repeat (rewrite subst_rec_lift_rec; [| omega| omega]);
repeat (rewrite lift_rec_null); auto.

(* subst_rec_preserves_derive *)

Proposition subst_rec_preserves_derive :
forall gamma M ty, derivation gamma M ty ->
forall k u, k < length gamma ->
derivation (skipn (S k) gamma) u (nth k gamma s_op) ->
derivation (removen k gamma) (subst_rec M u k) ty.
Proof.
intros gamma M ty d; induction d; intros.
(* 8 *)
split_all.
(* 7 *)
generalize H0; clear H0; induction k; split_all; simpl.
(* 6 *)
unfold removen; simpl. insert_Ref_out. rewrite lift_rec_null. auto.
(* 5 *)
rewrite removen_cons. insert_Ref_out. auto.
(* 4 *)
 simpl in *.
unfold insert_Ref. elim(compare k (S i)); split_all. elim a; split_all.
(* 8 *)
apply weak_aux1 with (Ref (S i)); auto.
(* 7 *)
subst. rewrite removen_cons.
replace (lift (S i) u) with (lift 1 (lift i u)).
eapply2 derive_weak_general.
cut(derivation (removen i gamma) (subst_rec (Ref i) u i) ty).
simpl; insert_Ref_out. auto.
 eapply2 IHd. omega.
unfold lift. rewrite lift_rec_lift_rec; try omega. auto.
(* 6 *)
apply weak_aux2 with (Ref (S i)); auto.
(* 5 *)
simpl. eapply2 derive_abs.
assert(derivation (removen (S k) (ty1 :: gamma)) (subst_rec t u (S k)) ty2) by (eapply2 IHd; simpl; omega).
replace(removen (S k) (ty1 :: gamma)) with (ty1::removen k gamma) in H1 by auto.
auto.
(* 4 *)
simpl.  eapply2 derive_app. simpl in *; auto.
(* 3 *)
eapply2 derive_inst.
(* 2 *)
assert( derivation (map (lift 1) (skipn (S k) gamma)) u (lift 1 (nth k gamma s_op))).
unfold lift; eapply2 lift_rec_ty_preserves_derive.
rewrite map_skipn in H1.
assert(derivation (removen k (map (lift 1) gamma))
          (subst_rec t u k) ty).
 eapply2 IHd. rewrite map_length; omega.
replace s_op with (lift 1 s_op) by auto.
replace(nth k (map (lift 1) gamma) (lift 1 s_op))
with (lift 1 (nth k gamma s_op)).
auto.
rewrite map_nth. auto.
rewrite <- map_removen in H2.
auto.
(* 1 *)
eapply2 derive_push1.
Qed.

Definition preserves_derive (red: termred) :=
forall ty1 ty2, red ty1 ty2 ->
forall gamma t, derivation gamma t ty1 -> derivation gamma t ty2.

Lemma preserves_derive_multi_step:
forall red, preserves_derive red -> preserves_derive (multi_step red).
Proof. red; intros red p ty1 ty2 m; induction m; split_all; eapply2 IHm. Qed.

Inductive instance_context : context -> context -> Prop :=
| instance_context_nil : instance_context nil nil
| instance_context_cons : forall ty1 ty2 gamma1 gamma2, instance ty1 ty2 ->
  instance_context gamma1 gamma2 -> instance_context (cons ty1 gamma1) (cons ty2 gamma2)
.

Hint Resolve instance_context_nil instance_context_cons.

Lemma lift_rec_preserves_instance_context:
forall gamma1 gamma2, instance_context gamma1 gamma2 ->
forall n k, instance_context (map (fun M => lift_rec M n k) gamma1)
                             (map (fun M => lift_rec M n k) gamma2).
Proof.
induction gamma1; split_all; inversion H; subst; split_all.
eapply2 instance_context_cons. eapply2 lift_rec_preserves_instance.
Qed.

Lemma instance_context_preserves_wfc:
forall gamma1, wfc gamma1 -> forall gamma2, instance_context gamma1 gamma2 -> wfc gamma2.
Proof.
intros gamma w; induction w; split_all.
inversion H; split_all.
inversion H0; split_all. eapply2 wfc_cons. subst.
assert((wfs ty -> wfs ty2) /\ (wfs ty2 -> wfs ty)). eapply2 instance_implies_wfs.
split_all.
Qed.

Lemma instance_context_reflects_wfc:
forall gamma1, wfc gamma1 -> forall gamma2, instance_context gamma2 gamma1 -> wfc gamma2.
Proof.
intros gamma1 w; induction w; split_all.
inversion H; split_all.
inversion H0; split_all. eapply2 wfc_cons. subst.  eapply2 instance_implies_wfs.
Qed.

Lemma derive_instance_context :
forall gamma1 t ty, derivation gamma1 t ty ->
forall gamma2, instance_context gamma2 gamma1 -> derivation gamma2 t ty.
Proof.
intros gamma1 t ty d; induction d; intros gamma2 inst; subst; split_all.
(* 8 *)
eapply2 derive_op. eapply2 instance_context_reflects_wfc.
(* 7 *)
inversion inst; subst. eapply2 derive_instance.  eapply2 derive_var.
eapply2 instance_context_reflects_wfc. eapply2 instance_implies_wfs.
(* 6 *)
inversion inst; subst. eapply2 derive_weak. eapply2 instance_implies_wfs.
(* 5 *)
eapply2 derive_abs. eapply2 IHd. eapply2 instance_context_cons.  eapply2 zero_red.
(* 4 *)
eapply2 derive_app.
eapply2 derive_inst.
eapply2 derive_gen1. eapply2 IHd. unfold lift. eapply2 lift_rec_preserves_instance_context.
eapply2 derive_push1.
Qed.

Lemma append_preserves_derive:
forall gamma t ty, derivation gamma t ty ->
forall gamma2, wfc gamma2 -> derivation (gamma ++ gamma2) t ty.
Proof.
intros gamma t ty d; induction d; split_all;
assert(wfc(gamma++gamma2)) by (eapply2 append_preserves_wfc; eapply2 derive_implies_wfcs).
eapply2 derive_op.
eapply2 derive_var.
eapply2 derive_abs.
eapply2 derive_app.
eapply2 derive_inst.
eapply2 derive_gen1.
rewrite map_app. eapply2 IHd.
unfold lift; eapply2 lift_rec_preserves_wfc.
eapply2 derive_push1.
Qed.

Lemma derive_nil :
forall t ty, derivation nil t ty -> forall gamma, wfc gamma -> derivation gamma t ty.
Proof. intros. replace gamma with (app nil gamma) by auto. eapply2 append_preserves_derive. Qed.

Lemma derive_strong_general_k:
forall gamma t ty, derivation gamma t ty ->
forall k, k > maxvar t -> derivation (removen k gamma) t ty.
Proof.
intros gamma t ty d;  induction d; split_all;
assert(wfc (removen k gamma)) by (eapply2 removen_preserves_wfc; eapply2 derive_implies_wfcs).
(* 7 *)
induction k; split_all; try noway. unfold removen, firstn. eapply2 derive_var.
eapply2 append_preserves_wfc.
eapply2 firstn_preserves_wfc.
simpl. eapply2 tl_preserves_wfc. eapply2 skipn_preserves_wfc.
(* 6 *)
induction k; split_all; try noway. unfold removen, firstn. eapply2 derive_weak.
eapply2 IHd.
simpl; omega.
(* 5 *)
eapply2 derive_abs.
cut(derivation (removen (S k) (ty1 :: gamma)) t ty2); [auto| eapply2 IHd; omega].
(* 4 *)
eapply2 derive_app.
eapply2 IHd1. assert(max (maxvar t) (maxvar u) >= maxvar t) by eapply2 max_is_max. omega.
eapply2 IHd2. assert(max (maxvar t) (maxvar u) >= maxvar u) by eapply2 max_is_max. omega.
(* 3 *)
eapply2 derive_inst.
(* 2 *)
eapply2 derive_gen1. rewrite map_removen. eapply2 IHd.
(* 1 *)
eapply2 derive_push1.
Qed.

Lemma derivation_var :
forall gamma t ty, derivation gamma t ty -> forall i, t = Ref i -> length gamma > i.
Proof.
intros gamma t ty i; induction i; split_all; subst.
inversion H1; subst. omega.
inversion H0; subst.  assert(length gamma > i) by auto. omega.
assert(length (map (lift 1) gamma) > i0) by auto.
rewrite map_length in *. auto.
Qed.

Lemma derive_via_op:
forall gamma t ty, derivation gamma t ty ->
forall o, t = Op o -> forall t1, derivation gamma t1 (opty o) -> derivation gamma t1 ty.
Proof.
intros gamma t ty d; induction d; split_all; subst.
(* 3 *)
apply derive_inst with ty1; auto. eapply2 IHd.
(* 2 *)
eapply derive_gen1; auto. eapply2 IHd.
replace(opty o) with (lift_rec (opty o) 0 1) by (case o; auto).
unfold lift; eapply2 lift_rec_ty_preserves_derive.
(* 1 *)
apply derive_push1 with ty; auto. eapply2 IHd.
Qed.

Lemma strip_context: forall gamma t ty, derivation gamma t ty -> forall o, t = Op o -> derivation nil (Op o) ty.
Proof.
intros gamma t ty d; induction d; split_all; invsub; subst.
eapply2 derive_inst.
eapply2 derive_push1.
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.

Open Scope logic.

Lemma sepcon_pred_sepcon:
 forall {A B : Type} {ND: NatDed A} {SL: SepLog A}{CA: ClassicalSep A}
  (f1 f2: B -> A) (P: B -> Prop),
 pred_sepcon f1 P * pred_sepcon f2 P = pred_sepcon (fun i => f1 i * f2 i) P.
Proof.
intros.
rewrite !pred_sepcon_eq.
apply pred_ext.
-
Intros l1 l2.
normalize.
assert (Permutation l1 l2). {
apply NoDup_Permutation; auto.
intros. rewrite H,H1. tauto.
}
rewrite <- (iter_sepcon_permutation f2 H3).
Exists l1.
rewrite prop_true_andp by auto.
clear - CA SL ND.
induction l1. simpl. rewrite emp_sepcon; auto.
simpl. rewrite !sepcon_assoc. apply sepcon_derives.
auto. rewrite <- !sepcon_assoc. pull_left (f2 a).
rewrite !sepcon_assoc.
apply sepcon_derives; auto.
-
Intros l.
Exists l l.
rewrite !prop_true_andp by auto.
clear H H0.
induction l. simpl. rewrite emp_sepcon; auto.
simpl. rewrite !sepcon_assoc. apply sepcon_derives.
auto. rewrite <- !sepcon_assoc. pull_left (f2 a).
rewrite !sepcon_assoc.
apply sepcon_derives; auto.
Qed.

Lemma pred_sepcon_derives:
 forall {A B : Type} {ND: NatDed A} {SL: SepLog A}
  (f1 f2: B -> A) (P: B -> Prop),
 (forall i, P i -> (f1 i |-- f2 i)) ->
 (pred_sepcon f1 P |-- pred_sepcon f2 P).
Proof.
intros.
rewrite !pred_sepcon_eq.
Intros al.
Exists al.
rewrite prop_true_andp by auto.
apply iter_sepcon_derives.
intros.
apply H.
rewrite <- H0.
auto.
Qed.

Lemma distribute_pred_sepcon:
 forall {A B: Type} {NA: NatDed A} {SA: SepLog A}{CA: ClassicalSep A}
        (e: A) (f: B -> A) (P: B -> Prop),
   (e |-- emp) -> (e |-- e * e) ->
   (e * pred_sepcon f P |-- pred_sepcon (fun i => e * f i) P).
Proof.
intros.
rewrite !pred_sepcon_eq.
Intros l; normalize; Exists l; rewrite prop_true_andp by auto;
clear H1 H2 P.
induction l; simpl. rewrite sepcon_emp; auto.
eapply derives_trans; [apply sepcon_derives; [apply H0 | apply derives_refl ] | ].
rewrite !sepcon_assoc.
apply sepcon_derives; auto.
rewrite <- sepcon_assoc.
pull_left (f a).
rewrite !sepcon_assoc.
apply sepcon_derives; auto.
Qed.

Lemma map_inj: forall {A}{B} (f: A -> B),
   (forall u v, f u = f v -> u=v) ->
   forall x y,
   map f x = map f y -> x = y.
Proof.
induction x; destruct y; simpl; intros; try discriminate; auto.
inv H0.
f_equal; auto.
Qed.

Definition iota (n: Z) : list Z := map Z.of_nat (seq 0%nat (Z.to_nat n)).

Lemma Zlength_iota: forall t, 0 <= t -> Zlength (iota t) = t.
Proof.
intros. unfold iota. rewrite Zlength_map.
rewrite Zlength_length; auto. rewrite seq_length; auto.
Qed.

#[export] Hint Rewrite Zlength_iota using lia : Zlength.

Lemma iota_S: forall n, 0 <= n -> iota (n+1) = iota n ++ [n].
Proof.
intros.
rewrite <- (Z2Nat.id n) by lia. clear.
forget (Z.to_nat n) as i.
unfold iota.
rewrite Nat2Z.id.
replace (Z.to_nat (Z.of_nat i + 1)) with (S i) by lia.
rewrite seq_S.
rewrite map_app. auto.
Qed.

Lemma Znth_iota:
 forall i n, 0 <= i < n -> Znth i (iota n) = i.
Proof.
intros.
pose proof (Zlength_iota n ltac:(lia)).
unfold iota in *.
rewrite Zlength_map in H0.
rewrite <- (Z2Nat.id n) in H0|-* by lia.
rewrite <- (Z2Nat.id i) by lia.
assert (Z.to_nat i < Z.to_nat n)%nat by lia.
forget (Z.to_nat i) as j.
forget (Z.to_nat n) as m.
unfold iota in *.
rewrite Nat2Z.id  in *.
rewrite Znth_map by lia.
rewrite <- nth_Znth by lia.
rewrite seq_nth by lia.
lia.
Qed.

Lemma in_iota:
   forall n x, In x (iota n) <-> 0 <= x < n.
 Proof. intros.
 destruct (zlt n 0).
 split; try lia. unfold iota.
 replace (Z.to_nat n) with 0%nat by lia. simpl. tauto.
  rewrite <- (Z2Nat.id n) by lia.
  induction (Z.to_nat n).
  simpl. split; try lia.
  rewrite inj_S. unfold Z.succ. rewrite iota_S by lia.
  rewrite in_app.
  split; intro.
  destruct H.
  rewrite IHn0 in H. lia.
  hnf in H. destruct H; try contradiction.
  lia.
  destruct (zeq x (Z.of_nat n0)).
  subst. right; hnf; auto.
  left. rewrite IHn0. lia.
Qed.

Lemma NoDup_iota:
 forall n, NoDup (iota n).
Proof.
intros.
 destruct (zlt n 0).
 unfold iota.
 replace (Z.to_nat n) with 0%nat by lia. simpl. constructor.
  rewrite <- (Z2Nat.id n) by lia. clear g.
  induction (Z.to_nat n).
  simpl. constructor.
  rewrite inj_S. unfold Z.succ. rewrite iota_S by lia.
 rewrite NoDup_app_iff.
 split; auto.
 split. constructor. intro Hx; inv Hx. constructor.
 intros.
 intro. destruct H0.
 subst x.
 apply in_iota in H. lia. inv H0.
Qed.

Lemma Ers_not_bot: Ers <> Share.bot.
Proof.
unfold Ers.
intro.
apply lub_bot_e in H. destruct H.
apply juicy_mem.extern_retainer_neq_bot; auto.
Qed.

Definition comp_Ers : share := Share.comp Ers.
Lemma comp_Ers_not_bot: comp_Ers <> Share.bot.
Proof.
unfold comp_Ers. unfold Ers.
unfold extern_retainer.
rewrite Share.demorgan1.
intro.
apply sub_glb_bot with (a:= snd (Share.split Share.Rsh)) in H.
rewrite Share.glb_commute in H.
apply sub_glb_bot with (a:= snd (Share.split Share.Rsh)) in H.
-
rewrite Share.glb_idem in H.
destruct (Share.split Share.Rsh) eqn:?H.
simpl in *. subst.
pose proof Share.split_nontrivial _ _ _ H0.
apply initialize.snd_split_fullshare_not_bot.
apply H. auto.
-
apply sepalg.join_sub_trans with Share.Rsh.
exists (fst (Share.split Share.Rsh)).
apply sepalg.join_comm.
apply split_join. destruct (Share.split Share.Rsh); simpl; auto.
apply leq_join_sub.
apply Share.ord_spec1.
rewrite <- comp_Lsh_Rsh.
rewrite <- Share.demorgan1.
f_equal.
symmetry.
rewrite <- (glb_split_x Share.Lsh).
apply Share.lub_absorb.
-
clear.
apply leq_join_sub.
assert (Share.comp (fst (Share.split Share.Rsh)) =
                 Share.lub Share.Lsh (snd (Share.split Share.Rsh))). {
 apply join_top_comp.
 split.
 rewrite Share.distrib1.
replace (Share.glb (fst (Share.split Share.Rsh)) Share.Lsh) with Share.bot.
rewrite Share.lub_commute, Share.lub_bot.
apply glb_split.
symmetry.
rewrite Share.glb_commute.
apply sub_glb_bot with (c:=Share.Rsh).
exists (snd (Share.split Share.Rsh)).
apply split_join.
destruct (Share.split Share.Rsh); auto.
apply glb_Lsh_Rsh.
rewrite Share.lub_commute.
rewrite Share.lub_assoc.
rewrite (Share.lub_commute (snd _)).
destruct (Share.split Share.Rsh) eqn:?H. simpl.
apply Share.split_together in H.
rewrite H.
apply lub_Lsh_Rsh.
}
rewrite H.
apply Share.lub_upper2.
Qed.

Lemma join_Ers_comp_Ers: sepalg.join Ers comp_Ers Tsh.
Proof. apply join_comp_Tsh. Qed.
#[export] Hint Resolve Ers_not_bot comp_Ers_not_bot join_Ers_comp_Ers : shares.

Definition Ers2 := snd (Share.split Share.Rsh).
Lemma Ers2_not_bot: Ers2 <> Share.bot.
Proof.
unfold Ers2.
intro.
destruct (Share.split Share.Rsh) eqn:?H.
simpl in *; subst.
apply Share.split_nontrivial in H0; auto.
unfold Share.Rsh in *.
destruct (Share.split Share.top) eqn:?H.
simpl in *; subst.
apply Share.split_nontrivial in H; auto.
apply Share.nontrivial; auto.
Qed.

Lemma join_Ers_Ers2: sepalg.join Ers Ers2 Ews.
Proof.
unfold Ers, Ers2, Ews.
unfold extern_retainer.
split.
rewrite Share.glb_commute.
rewrite Share.distrib1.
match goal with |- Share.lub ?a ?b = _ => replace a with Share.bot; [replace b with Share.bot |] end.
apply Share.lub_bot.
symmetry.
rewrite Share.glb_commute.
apply glb_split.
symmetry.
apply sub_glb_bot with (c:=Share.Lsh).
exists (snd (Share.split Share.Lsh)).
apply sepalg.join_comm.
destruct (Share.split Share.Lsh) eqn:?H.
apply split_join in H. simpl. apply sepalg.join_comm; auto.
rewrite Share.glb_commute.
apply sub_glb_bot with (c:=Share.Rsh).
exists (fst (Share.split Share.Rsh)).
apply sepalg.join_comm.
destruct (Share.split Share.Rsh) eqn:?H.
apply split_join in H. auto.
apply glb_Lsh_Rsh.
rewrite Share.lub_assoc.
f_equal.
apply Share.split_together.
destruct (Share.split Share.Rsh); auto.
Qed.
#[export] Hint Resolve Ers2_not_bot join_Ers_Ers2 : shares.

Lemma readable_Ers2: readable_share Ers2.
Proof.
unfold Ers2.
red.
red.
red.
intro.
apply identity_share_bot in H.
assert (Share.split Share.Rsh = (fst (Share.split Share.Rsh), snd (Share.split (Share.Rsh)))).
destruct (Share.split Share.Rsh); auto.
apply Share.split_together in H0.
set (z := snd _) in H.
rewrite <- H0 in H.
subst z.
clear H0.
rewrite Share.glb_commute in H.
rewrite Share.distrib1 in H.
rewrite Share.glb_commute in H.
rewrite Share.glb_idem in H.
rewrite glb_split in H.
rewrite Share.lub_commute in H.
rewrite Share.lub_bot in H.
destruct (Share.split Share.Rsh) eqn:?H.
apply Share.split_nontrivial in H0; auto.
apply juicy_mem.nonidentity_Rsh.
rewrite H0; apply bot_identity.
Qed.
#[export] Hint Resolve readable_Ers2 :core.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.
Require Import Algebra.ooGroup.

Local Open Scope path_scope.

(** * Actions of oo-Groups *)

Definition ooAction (G : ooGroup)
  := classifying_space G -> Type.

Definition action_space {G} : ooAction G -> Type
  := fun X => X (point _).

Coercion action_space : ooAction >-> Sortclass.


Require Import VST.floyd.proofauto.
Require Import common_predicates.
Require Import max.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition max_spec :=
  DECLARE _max
   WITH r: val, x: val, y: val
   PRE [ (tptr (Tunion _sslval noattr)), tint, tint ]
   PROP( is_pointer_or_null((r : val)); ssl_is_valid_int((x : val)); ssl_is_valid_int((y : val)) )
   PARAMS(r; x; y)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inl ((Vint (Int.repr 0)) : val))] (r : val)))
   POST[ tvoid ]
   EX m: Z,
   PROP( ((force_signed_int (x : val)) <= (m : Z)); ((force_signed_int (y : val)) <= (m : Z)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inl ((Vint (Int.repr m)) : val))] (r : val))).

Definition Gprog : funspecs :=
  ltac:(with_library prog [max_spec]).

Lemma body_max : semax_body Vprog Gprog f_max max_spec.
Proof.

start_function.
ssl_open_context.
forward_if.

 - {
assert_PROP (isptr r). { entailer!. }
forward.
forward; entailer!.
Exists (x : Z).
ssl_entailer.

}
 - {
assert_PROP (isptr r). { entailer!. }
forward.
forward; entailer!.
Exists (y : Z).
ssl_entailer.

}

Qed.