(*CompCert imports*)
Require Import AST.
Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import Axioms.
Require Import Globalenvs.

Require Import mem_lemmas.

(*A value that is (if its a pointer) not dangling wrt m - a condition
 like this will probably be need to imposed on after-external return
 values (and thus also on the values returned by halted)*)
Definition val_valid (v:val) (m:mem):Prop :=
     match v with Vptr b ofs => Mem.valid_block m b | _ => True
     end.

(*In fact val_valid is a slight relaxtion of valid_pointer*)
Lemma valid_ptr_val_valid: forall b ofs m,
    Mem.valid_pointer m b ofs = true -> val_valid (Vptr b (Int.repr ofs)) m.
Proof. intros.
  apply Mem.valid_pointer_nonempty_perm in H. eapply Mem.perm_valid_block. apply H.
Qed.

Lemma extends_valvalid: forall m1 m2 (Ext: Mem.extends m1 m2) v,
        val_valid v m1 <-> val_valid v m2.
Proof. intros.
  split; intros. destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
  destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
Qed.

Lemma inject_valvalid: forall j m1 m2 (Inj: Mem.inject j m1 m2) v2 (V:val_valid v2 m2) v1,
             val_inject j v1 v2 -> val_valid v1 m1.
Proof. intros.
  inv H. constructor. constructor. constructor.
     simpl in *. eapply Mem.valid_block_inject_1; eassumption.
     constructor.
Qed.

(*Preservation of val_valid along an injection only holds
  if the LHS value is defined*)
Lemma inject_valvalid_1:
  forall (j : meminj) (m1 m2 : mem),
  Mem.inject j m1 m2 ->
  forall v1 : val,
  val_valid v1 m1 -> forall v2 : val, val_inject j v1 v2 ->
  match v1 with Vundef => True
      | _ => val_valid v2 m2
  end.
Proof. intros.
  destruct v1; trivial.
  inv H1; trivial.
  inv H1; trivial.
  inv H1; trivial.
  inv H1. simpl in *.
  eapply Mem.valid_block_inject_2; eassumption.
Qed.

(*memories that do not contain "dangling pointers"*)
Definition mem_wd m := Mem.inject_neutral (Mem.nextblock m) m.

Lemma align_chunk_0: forall chunk, (align_chunk chunk | 0).
Proof.
  intros chunk. destruct chunk; simpl; apply Z.divide_0_r.
Qed.

Lemma mem_wdI: forall m,
  (forall (b:block) ofs  (R:Mem.perm m b ofs Cur Readable),
    memval_inject  (Mem.flat_inj (Mem.nextblock m))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))) -> mem_wd m.
Proof. intros.
  split; intros.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r. trivial.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r.
        apply H. apply H1.
Qed.

Lemma mem_wd_E: forall m, mem_wd m ->  Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m.
Proof. intros. apply Mem.neutral_inject. apply H. Qed.

Lemma meminj_split_flatinjR: forall j m m' (J:Mem.inject j m' m), mem_wd m ->
     j = compose_meminj j (Mem.flat_inj (Mem.nextblock m)).
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   remember (j b).
   destruct o; trivial. destruct p. unfold Mem.flat_inj in *.
   destruct (plt b0 (Mem.nextblock m)).
     rewrite Zplus_0_r. trivial.
   inv J. apply eq_sym in Heqo. specialize (mi_mappedblocks _ _ _ Heqo).
               exfalso. unfold Mem.valid_block in mi_mappedblocks. xomega.
Qed.

Lemma meminj_split_flatinjL: forall j m m' (J:Mem.inject j m m'), mem_wd m ->
     j = compose_meminj (Mem.flat_inj (Mem.nextblock m)) j.
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   unfold Mem.flat_inj in *.
   destruct (plt b (Mem.nextblock m)).
     remember (j b). destruct o. destruct p0.  rewrite Zplus_0_l. trivial. trivial.
  inv J. apply mi_freeblocks. assumption.
Qed.

Lemma mem_wd_inject_splitL: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m1),
     Mem.inject (Mem.flat_inj (Mem.nextblock m1)) m1 m1
     /\ j = compose_meminj (Mem.flat_inj (Mem.nextblock m1)) j.
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjL _ _ _ J WD).
Qed.

Lemma mem_wd_inject_splitR: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m2),
     Mem.inject (Mem.flat_inj (Mem.nextblock m2)) m2 m2
     /\ j = compose_meminj j (Mem.flat_inj (Mem.nextblock m2)).
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjR _ _ _ J WD).
Qed.

(*Preservation of mem_wd by memory operations*)
Lemma mem_wd_empty: mem_wd Mem.empty.
Proof.  apply Mem.empty_inject_neutral. Qed.

Lemma  mem_wd_alloc: forall m b lo hi m' (ALL: Mem.alloc m lo hi = (m',b))
     (WDm: mem_wd m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_alloc _ _ _ _ _ ALL).
  eapply (Mem.alloc_inject_neutral _ _ _ _ _ _ ALL); try omega.
  inv WDm.
         split; intros.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
                 assert (X: Mem.flat_inj (Mem.nextblock m) b1 = Some (b1, 0)).
                     apply flatinj_I. apply (Mem.perm_valid_block _ _ _ _ _ H0).
                  specialize (mi_memval _ _ _ _ X H0). rewrite Zplus_0_r in mi_memval.
                  eapply memval_inject_incr; try eassumption.
                       intros bb; intros.
                        eapply flatinj_mono; try eassumption; xomega.
       xomega.
Qed.

Lemma  mem_wd_drop: forall m b lo hi p m' (DROP: Mem.drop_perm m b lo hi p = Some m')
     (WDm: mem_wd m), Mem.valid_block m b -> mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP).
  eapply (Mem.drop_inject_neutral _ _ _ _ _ _ _ DROP); trivial.
Qed.

Lemma free_neutral: forall (thr : block) (m : mem) (lo hi : Z) (b : block) (m' : Mem.mem')
  (FREE: Mem.free m b lo hi = Some m'),
  Mem.inject_neutral thr m -> Mem.inject_neutral thr m'.
Proof. intros. inv H.
  split; intros.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
        assert (X: Mem.flat_inj thr b1 = Some (b1,0)). apply flatinj_I. assumption.
        assert (Y:= Mem.perm_free_3 _ _ _ _ _ FREE _ _ _ _ H0).
         specialize (mi_memval _ _ _ _ X Y). rewrite Zplus_0_r in *.
         rewrite (Mem.free_result _ _ _ _ _ FREE) in *. simpl in *. apply mi_memval.
Qed.

Lemma mem_wd_free: forall m b lo hi m' (WDm: mem_wd m)
  (FREE: Mem.free m b lo hi = Some m'), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply free_neutral. apply FREE.
   rewrite (Mem.nextblock_free _ _ _ _ _ FREE). assumption.
Qed.

Lemma mem_wd_store: forall m b ofs v m' chunk (WDm: mem_wd m)
  (ST: Mem.store chunk m b ofs v = Some m')
  (V: val_valid v m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply Mem.store_inject_neutral. apply ST.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST). assumption.
      assert (X:= Mem.store_valid_access_3 _ _ _ _ _ _ ST).
          rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
           apply (Mem.valid_access_implies _ _ _ _ _  Nonempty) in X.
                apply Mem.valid_access_valid_block in X. apply X.
            constructor.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
          destruct v; try solve [constructor].
            econstructor. eapply flatinj_I. apply V.
                          rewrite Int.add_zero. trivial.
Qed.

Lemma extends_memwd:
forall m1 m2 (Ext: Mem.extends m1 m2), mem_wd m2 -> mem_wd m1.
Proof.
  intros. eapply mem_wdI. intros.
  assert (Mem.perm m2 b ofs Cur Readable).
    eapply (Mem.perm_extends _ _ _ _ _ _ Ext R).
  assert (Mem.valid_block m2 b).
     apply (Mem.perm_valid_block _ _ _ _ _ H0).
  destruct Ext. rewrite mext_next.
  assert (Mem.flat_inj (Mem.nextblock m2) b = Some (b,0)).
    apply flatinj_I. apply H1.
  destruct mext_inj. specialize (mi_memval b ofs b 0 (eq_refl _) R).
  rewrite Zplus_0_r in mi_memval.
  destruct H. specialize (mi_memval0 b ofs b 0 H2 H0).
  rewrite Zplus_0_r in mi_memval0.
  remember (ZMap.get ofs (PMap.get b (Mem.mem_contents m1))) as v.
  destruct v. constructor. constructor.
  econstructor.
    eapply flatinj_I. inv mi_memval. inv H4. rewrite Int.add_zero in H6.
      rewrite <- H6 in mi_memval0. simpl in mi_memval0. inversion mi_memval0.
      apply flatinj_E in H4. apply H4.
   rewrite Int.add_zero. reflexivity.
Qed.

Require Import reach.

Inductive valid_genv {F V:Type} (ge:Genv.t F V) (m:mem) : Type :=
  mk_valid_genv :
    (forall b, isGlobalBlock ge b=true -> val_valid (Vptr b Int.zero) m) ->
    (forall b f, Genv.find_funct_ptr ge b = Some f -> val_valid (Vptr b Int.zero) m) ->
    valid_genv ge m.

Lemma valid_genv_alloc: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) lo hi b
    (ALLOC: Mem.alloc m lo hi = (m1,b)) (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v _ H).
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v0 _ _ H).
Qed.

Lemma valid_genv_store: forall {F V:Type} (ge:Genv.t F V) m m1 b ofs v chunk
    (STORE: Mem.store chunk m b ofs v = Some m1)
     (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v0 _ H).
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v1 _ _ H).
Qed.

Lemma valid_genv_store_zeros: forall {F V:Type} (ge:Genv.t F V) m m1 b y z
    (STORE_ZERO: store_zeros m b y z = Some m1)
    (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  specialize (v _ H); simpl in *.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. apply G; auto.
  specialize (v0 _ _ H); simpl in *.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. auto.
Qed.

Lemma mem_wd_store_zeros: forall m b p n m1
    (STORE_ZERO: store_zeros m b p n = Some m1) (WD: mem_wd m), mem_wd m1.
Proof. intros until n. functional induction (store_zeros m b p n); intros.
  inv STORE_ZERO; tauto.
  apply (IHo _ STORE_ZERO); clear IHo.
      eapply (mem_wd_store m). apply WD. apply e0. simpl; trivial.
  inv STORE_ZERO.
Qed.

Lemma valid_genv_drop: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) b lo hi p
    (DROP: Mem.drop_perm m b lo hi p = Some m1) (G: valid_genv ge m),
    valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v _ H); auto.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v0 _ _ H); auto.
Qed.

Lemma mem_wd_store_init_data: forall {F V} (ge: Genv.t F V) a (b:block) (z:Z)
  m1 m2 (SID:Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge a.
  destruct a; simpl; intros;
      try apply (mem_wd_store _ _ _ _ _ _ H0 SID); simpl; trivial.
   inv SID; trivial.
   remember (Genv.find_symbol ge i) as d.
     destruct d; inv SID.
     eapply (mem_wd_store _ _ _ _ _ _ H0 H2).
    apply eq_sym in Heqd.
    destruct H.
    apply v.
    unfold isGlobalBlock.
    rewrite orb_true_iff.
    unfold genv2blocksBool; simpl.
    apply Genv.find_invert_symbol in Heqd.
    rewrite Heqd; left; auto.
Qed.

Lemma valid_genv_store_init_data:
  forall {F V}  (ge: Genv.t F V) a (b:block) (z:Z) m1 m2
  (SID: Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge a.
  destruct a; simpl; intros; inv H; constructor;
    try (intros b0 X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          apply H0; auto);
    try (intros b0 ? X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          eapply H1; eauto);
    try (inv SID; auto).
  intros.
  remember (Genv.find_symbol ge i) as d.
  destruct d; inv H2.
  eapply Mem.store_valid_block_1; eauto.
  apply eq_sym in Heqd.
  eapply H0; eauto.
  revert H2. destruct (Genv.find_symbol ge i); intros; try congruence.
  eapply Mem.store_valid_block_1; eauto.
  eapply H1; eauto.
Qed.

Lemma mem_wd_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H2); clear IHl H2.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
  eapply mem_wd_store_init_data. apply Heqd. apply H. apply H0.
Qed.

Lemma valid_genv_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
   valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H1); clear IHl H1.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
Qed.

Lemma mem_wd_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as mm. destruct mm.
    apply eq_sym in Heqmm.
    specialize (mem_wd_alloc _ _ _ _ _ Heqmm). intros.
     eapply (mem_wd_drop _ _ _ _ _  _ GA).
    apply (H1 H).
    apply (Mem.valid_new_block _ _ _ _ _ Heqmm).
remember (Mem.alloc m0 0 (Genv.init_data_list_size (AST.gvar_init v)) ) as mm.
  destruct mm. apply eq_sym in Heqmm.
  remember (store_zeros m b 0 (Genv.init_data_list_size (AST.gvar_init v)))
           as d.
  destruct d; inv GA; apply eq_sym in Heqd.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as dd.
  destruct dd; inv H2; apply eq_sym in Heqdd.
  eapply (mem_wd_drop _ _ _ _ _ _ H3); clear H3.
    eapply (mem_wd_store_init_datalist _ _ _ _ _ _ Heqdd).
    apply (valid_genv_store_zeros _ _ _ _ _ _ Heqd).
    apply (valid_genv_alloc ge _ _ _ _ _ Heqmm H0).
  apply (mem_wd_store_zeros _ _ _ _ _ Heqd).
    apply (mem_wd_alloc _ _ _ _ _ Heqmm H).
  unfold Mem.valid_block.
     apply Genv.store_init_data_list_nextblock in Heqdd.
           rewrite Heqdd. clear Heqdd.
      apply Genv.store_zeros_nextblock in Heqd. rewrite Heqd; clear Heqd.
      apply (Mem.valid_new_block _ _ _ _ _  Heqmm).
Qed.

Lemma valid_genv_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   valid_genv ge m0 -> valid_genv ge m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as d. destruct d.
    apply eq_sym in Heqd.
    apply (valid_genv_drop _ _ _ _ _ _ _ GA).
    apply (valid_genv_alloc _ _ _ _ _ _ Heqd H).
remember (Mem.alloc m0 0 (Genv.init_data_list_size (AST.gvar_init v)) )
         as Alloc.
  destruct Alloc. apply eq_sym in HeqAlloc.
  remember (store_zeros m b 0
           (Genv.init_data_list_size (AST.gvar_init v))) as SZ.
  destruct SZ; inv GA; apply eq_sym in HeqSZ.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as Drop.
  destruct Drop; inv H1; apply eq_sym in HeqDrop.
  eapply (valid_genv_drop _ _ _ _ _ _ _ H2); clear H2.
  eapply (valid_genv_store_init_datalist _ _ _ _ _ _ HeqDrop). clear HeqDrop.
  apply (valid_genv_store_zeros _ _ _ _ _ _ HeqSZ).
    apply (valid_genv_alloc _ _ _ _ _ _ HeqAlloc H).
Qed.

Lemma valid_genv_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   valid_genv ge m0 -> valid_genv ge m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
  eapply (IHl  _ _  H1). clear H1.
    apply (valid_genv_alloc_global _ _ _ _ Heqd H).
Qed.

Lemma mem_wd_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
eapply (IHl  _ _  H2).
    apply (mem_wd_alloc_global ge _ _ _ Heqd H H0).
    apply (valid_genv_alloc_global _ _ _ _ Heqd H0).
Qed.

Lemma mem_wd_load: forall m ch b ofs v
  (LD: Mem.load ch m b ofs = Some v)
  (WD : mem_wd m), val_valid v m.
Proof. intros.
  destruct v; simpl; trivial.
  destruct (Mem.load_valid_access _ _ _ _ _ LD) as [Perms Align].
  apply Mem.load_result in LD.
  apply eq_sym in LD. apply decode_val_pointer_inv in LD.
  destruct LD.
  destruct ch; inv H; simpl in *.
  unfold mem_wd in WD. unfold Mem.inject_neutral in WD.
  destruct WD.
  assert (Arith: ofs <= ofs < ofs + 4). omega.
  specialize (Perms _ Arith).
  assert (VB:= Mem.perm_valid_block _ _ _ _ _ Perms).
  assert (Z:= flatinj_I (Mem.nextblock m) b VB).
  specialize (mi_memval _ _ _ _ Z Perms).
  inv H0. rewrite Zplus_0_r in mi_memval. rewrite H1 in mi_memval.
  inversion mi_memval. clear H9. subst.
  apply flatinj_E in H5. apply H5.
Qed.

Lemma mem_wd_storebytes: forall m b ofs bytes m' (WDm: mem_wd m)
  (ST: Mem.storebytes m b ofs bytes = Some m')
  (BytesValid: forall v, In v bytes ->
               memval_inject (Mem.flat_inj (Mem.nextblock m)) v v),
   mem_wd m'.
Proof. intros. apply mem_wdI. intros.
  assert (F: Mem.flat_inj (Mem.nextblock m) b0 = Some (b0, 0)).
        apply flatinj_I.
        apply (Mem.storebytes_valid_block_2 _ _ _ _ _ ST).
        eapply Mem.perm_valid_block; eassumption.
  apply mem_wd_E in WDm.
  assert (P:= Mem.perm_storebytes_2 _ _ _ _ _ ST _ _ _ _ R).
  specialize (Mem.mi_memval _ _ _ (Mem.mi_inj _ _ _ WDm) _ _ _ _ F P).
  rewrite Zplus_0_r.
  intros MVI.
  rewrite (Mem.nextblock_storebytes _ _ _ _ _ ST).
  rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST).
  remember (eq_block b0 b).
  destruct s; subst; clear Heqs.
  (*case b0=b*)
    rewrite PMap.gss.
    remember (zlt ofs0 ofs) as d.
    destruct d; clear Heqd.
    (*case ofs0 < ofs*)
      rewrite Mem.setN_outside; try (left; assumption).
      assumption.
    (*case ofs0 >= ofs*)
      remember (zlt ofs0 (ofs + (Z.of_nat (length bytes)))) as d.
      destruct d; clear Heqd.
      (*case <*)
        eapply Mem.setN_property.
          apply BytesValid.
          split. omega. apply l.
      (*case >= *)
         rewrite Mem.setN_outside; try (right; assumption).
      assumption.
  (*case b0 <> b*)
    rewrite PMap.gso; trivial.
Qed.

Lemma getN_aux: forall n p c B1 v B2, Mem.getN n p c = B1 ++ v::B2 ->
    v = ZMap.get (p + Z.of_nat (length B1)) c.
Proof. intros n.
  induction n; simpl; intros.
    destruct B1; simpl in *. inv H. inv H.
    destruct B1; simpl in *.
      inv H. rewrite Zplus_0_r. trivial.
      inv H. specialize (IHn _ _ _ _ _ H2). subst.
        rewrite Zpos_P_of_succ_nat.
        remember (Z.of_nat (length B1)) as m. clear Heqm H2. rewrite <- Z.add_1_l.
         rewrite Zplus_assoc. trivial.
Qed.

Lemma getN_range: forall n ofs M bytes1 v bytes2,
  Mem.getN n ofs M = bytes1 ++ v::bytes2 ->
  (length bytes1 < n)%nat.
Proof. intros n.
  induction n; simpl; intros.
    destruct bytes1; inv H.
    destruct bytes1; simpl in *; inv H.
      omega.
    specialize (IHn _ _ _ _ _ H2). omega.
Qed.

Lemma loadbytes_D: forall m b ofs n bytes
      (LD: Mem.loadbytes m b ofs n = Some bytes),
      Mem.range_perm m b ofs (ofs + n) Cur Readable /\
      bytes = Mem.getN (nat_of_Z n) ofs (PMap.get b (Mem.mem_contents m)).
Proof. intros.
  Transparent Mem.loadbytes.
  unfold Mem.loadbytes in LD.
  Opaque Mem.loadbytes.
  remember (Mem.range_perm_dec m b ofs (ofs + n) Cur Readable) as d.
  destruct d; inv LD. auto.
Qed.

Lemma loadbytes_valid: forall m (WD: mem_wd m) b ofs' n bytes
      (LD: Mem.loadbytes m b (Int.unsigned ofs') n = Some bytes)
      v (B: In v bytes),
      memval_inject (Mem.flat_inj (Mem.nextblock m)) v v.
Proof. intros.
  destruct (loadbytes_D _ _ _ _ _ LD) as [Range BB]; subst.
  assert (L:= Mem.loadbytes_length _ _ _ _ _ LD).
  apply In_split in B. destruct B as [bytes1 [bytes2 B]]. subst.
  assert (I: Int.unsigned ofs' <= (Int.unsigned ofs') + Z.of_nat (length bytes1) <
                  Int.unsigned ofs' + n).
    assert (II:= getN_range _ _ _ _ _ _ B).
    clear Range LD B L.
    split. omega.
    assert (Z.of_nat (length bytes1) < Z.of_nat (nat_of_Z n)).
        omega.
    rewrite nat_of_Z_eq in H. omega. clear H.
     unfold nat_of_Z in II.
        destruct n. omega. specialize (Pos2Z.is_pos p); omega.
        rewrite Z2Nat.inj_neg in II. destruct bytes1; simpl in II; inv II.
  specialize (Range _ I).
  assert (F: Mem.flat_inj (Mem.nextblock m) b = Some (b, 0)).
    apply flatinj_I. apply Mem.perm_valid_block in Range. apply Range.
    specialize (Mem.mi_memval _ _ _ WD _ _ _ _ F Range).
    intros. rewrite Zplus_0_r in H.
   apply getN_aux in B. subst. apply H.
Qed.

Lemma freelist_mem_wd: forall l m m'
      (M: Mem.free_list m l = Some m')
      (WD: mem_wd m), mem_wd m'.
Proof. intros l.
  induction l; simpl; intros.
    inv M; trivial.
  destruct a. destruct p.
  remember (Mem.free m b z0 z) as d.
  destruct d; inv M; apply eq_sym in Heqd.
  apply (IHl _ _ H0).
  eapply mem_wd_free; eassumption.
Qed.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class PropositionalVariables: Type := {
  Var: Type
}.

Inductive expr {Sigma: PropositionalVariables}: Type :=
  | andp : expr -> expr -> expr
  | orp : expr -> expr -> expr
  | impp : expr -> expr -> expr
  | sepcon : expr -> expr -> expr
  | wand : expr -> expr -> expr
  | emp : expr
  | falsep : expr
  | varp : Var -> expr.

Arguments expr: clear implicits.

Definition expr_eqb {Sigma: PropositionalVariables} (eqb: Var -> Var -> bool): expr Sigma -> expr Sigma -> bool :=
  fix expr_eqb x1 x2 :=
    match x1, x2 with
    | andp y1 z1, andp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | orp y1 z1, orp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | impp y1 z1, impp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | sepcon y1 z1, sepcon y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | wand y1 z1, wand y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | emp, emp => true
    | falsep, falsep => true
    | varp p, varp q => eqb p q
    | _, _ => false
    end.

Lemma expr_eqb_true {Sigma: PropositionalVariables} (eqb: Var -> Var -> bool):
  (forall p q, eqb p q = true <-> p = q) ->
  (forall x y, expr_eqb eqb x y = true <-> x = y).
Proof.
  intros.
  revert y; induction x; intros; destruct y;
  try solve [split; intros HH; inversion HH].
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; tauto.
  + simpl; tauto.
  + simpl.
    rewrite H.
    split; intros; congruence.
Qed.

Instance L {Sigma: PropositionalVariables}: Language :=
  Build_Language (expr Sigma).

Instance minL {Sigma: PropositionalVariables}: MinimunLanguage L :=
  Build_MinimunLanguage L impp.

Instance pL {Sigma: PropositionalVariables}: PropositionalLanguage L :=
  Build_PropositionalLanguage L andp orp falsep.

Instance sL {Sigma: PropositionalVariables}: SeparationLanguage L :=
  Build_SeparationLanguage L sepcon wand.

Instance s'L {Sigma: PropositionalVariables}: SeparationEmpLanguage L :=
  Build_SeparationEmpLanguage L sL emp.

Definition rank {Sigma: PropositionalVariables}: expr Sigma -> nat :=
  fix rank (x: expr Sigma): nat :=
    match x with
    | andp y z => 1 + rank y + rank z
    | orp y z => 1 + rank y + rank z
    | impp y z => 1 + rank y + rank z
    | sepcon y z => 1 + rank y + rank z
    | wand y z => 1 + rank y + rank z
    | emp => 0
    | falsep => 0
    | varp p => 0
    end.

Definition formula_countable {Sigma: PropositionalVariables}: Countable Var -> Countable (expr Sigma).
  intros.
  assert (forall n, Countable (sig (fun x: expr Sigma => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ (Var + unit + unit)%type); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun x =>
               match x with
               | inl (inl p) => exist (fun x: expr Sigma => rank x <= 0) (varp p) (le_n 0)
               | inl (inr _) => exist (fun x: expr Sigma => rank x <= 0) emp (le_n 0)
               | inr _ => exist (fun x: expr Sigma => rank x <= 0) falsep (le_n 0)
               end)).
      * hnf; intros.
        destruct a1 as [[? | []] | []], a2 as [[? | []] | []]; inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        1: exists (inl (inr tt)); eauto; f_equal; apply proof_irrelevance.
        1: exists (inr tt); eauto; f_equal; apply proof_irrelevance.
        1: exists (inl (inl v)); eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Sigma => rank x <= n)).
      apply (@injection_Countable _ (s * s + s * s + s * s + s * s + s * s + unit + unit + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (inl (inl (inl (inl (inl (inl (exist _ y _, exist _ z _))))))) => proj1_sig x = andp y z
        | inl (inl (inl (inl (inl (inl (inr (exist _ y _, exist _ z _))))))) => proj1_sig x = orp y z
        | inl (inl (inl (inl (inl (inr (exist _ y _, exist _ z _)))))) => proj1_sig x = impp y z
        | inl (inl (inl (inl (inr (exist _ y _, exist _ z _))))) => proj1_sig x = sepcon y z
        | inl (inl (inl (inr (exist _ y _, exist _ z _)))) => proj1_sig x = wand y z
        | inl (inl (inr _)) => proj1_sig x = emp
        | inl (inr _) => proj1_sig x = falsep
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | y z | y z | y z | y z | | | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inl (inl (exist _ y H0, exist _ z H1)))))))); auto.
        (* 2 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1)))))))); auto.
        (* 3 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))))); auto.
        (* 4 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1)))))); auto.
        (* 5 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))); auto.
        (* 6 *) exists (inl (inl (inr tt))); auto.
        (* 7 *) exists (inl (inr tt)); auto.
        (* 8 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | y z | y z | y z | y z | | | p] ?H];
        destruct b1 as [[[[[[[[[y1 ?H] [z1 ?H]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] |] |] | p1]; try solve [inversion H];
        destruct b2 as [[[[[[[[[y2 ?H] [z2 ?H]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] |] |] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 6 *) destruct u, u0; auto.
        (* 7 *) destruct u, u0; auto.
        (* 8 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[[[[[[[y ?H] [z ?H]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] |] |] | p];
        destruct a1 as [[y1 z1 | y1 z1 | y1 z1 | y1 z1 | y1 z1 | | | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | y2 z2 | y2 z2 | y2 z2 | y2 z2 | | | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 6 *) f_equal; apply proof_irrelevance.
        (* 7 *) f_equal; apply proof_irrelevance.
        (* 8 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Sigma => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed. (* 9 seconds *)


(** This chapter addresses part 2A of the POPLmark challenge, namely the proof
  of soundness of the $F_{<:}$ type systems without records. *)

Require Import Arith.
Require Import ZArith.
Require Import List.
Require Import SYextralibrary.
Require Import SYdecidable_IN.
Require Import SYsublist.
Require Import SYpart1a.

(** * Terms *)

(** We now define the syntax of $F_{<:}$ terms and basic syntactic notions such
  as free variables, substitutions, and well-formedness of terms.
  We follow the same approach used for types in chapter 2.  *)

(** ** Syntax and syntactic operations *)

(** The syntax of terms is defined as follows.
  As in types, bound variables are represented by de Bruijn indices,
  while free variables are represented by names.  Bound term variables
  and bound type variables are numbered independently.  In a
  lambda-abstraction [TFun t a], the term variable [Var 0] is bound in
  [a].  In a type abstraction [TApp t a], the type variable [TVar 0]
  is bound in [a]. *)

(* list lemma *)
Lemma notIn_app : forall A  (a:A) (l m :list A),
  ~ In a (l ++ m) ->
  ~ In  a l /\ ~ In  a m.
Proof.
  firstorder.
Qed.

Lemma notIn_app_1 :
  forall A (a: A) (l m : list A),
    ~ In a l -> ~ In a m -> ~ In a (l ++ m).
Proof.
  intuition. elim (in_app_or l m a H1); auto.
Qed.
(* list lemma *)

Inductive term : Set :=
  | Param: name -> term
  | Var: nat -> term
  | Fun: type -> term -> term
  | App: term -> term -> term.

(** The free names of a term include both type names and term names. *)

Fixpoint fv_term (a: term) : list name :=
  match a with
  | Param v => v :: nil
  | Var n => nil
  | Fun t a1 => fv_term a1
  | App a1 a2 => fv_term a1 ++ fv_term a2
  end.

Definition v_termenv := list (nat * term).
Definition p_termenv := list (name * term).
Definition renaming := list (name * name).

Fixpoint v_dom (e: v_termenv) {struct e} : list nat :=
  match e with
    | nil           => nil
    | (x,t) :: e0 => x :: (v_dom e0)
  end.

Fixpoint fun_v_assoc (e: v_termenv) (x: nat) {struct e} : option term :=
  match e with
    | nil => None
    | (y,t) :: e0
      => if eqdec x y then Some t else fun_v_assoc e0 x
  end.

Notation " e ^^ x " := (@fun_v_assoc e x) (at level 60).

Fixpoint v_shift (e: v_termenv) : v_termenv :=
  match e with
  | nil => nil
  | (x, t) :: e0 => (S x, t) :: v_shift e0
  end.

Fixpoint v_less (e: v_termenv) n : nat :=
  match e with
  | nil => 0
  | (i, t) :: e0 => if lt_dec i n
                    then S (v_less e0 n)
                    else v_less e0 n
  end.

Fixpoint vsubst_term (a: term) (e: v_termenv) {struct a} : term :=
  match a with
  | Param v => Param v
  | Var n =>
      match e ^^ n with
      | Some t => t
      | None => Var (n - (v_less e n))
      end
  | Fun t a1 => Fun t (vsubst_term a1 (v_shift e))
  | App a1 a2 => App (vsubst_term a1 e) (vsubst_term a2 e)
  end.

(** There are 4 substitution operations over terms,
  depending on whether we are substituting a named variable ([psubst_])
  or a de Bruijn variable ([vsubst_]), and whether we are substituting
  a term for a term variable ([_term]) or a type for a type variable
  ([_tety]). *)

Fixpoint p_dom (e: p_termenv) {struct e} : list name :=
  match e with
    | nil           => nil
    | (x,t) :: e0 => x :: (p_dom e0)
  end.

Fixpoint fun_p_assoc (e: p_termenv) (x: name) {struct e} : option term :=
  match e with
    | nil => None
    | (y,t) :: e0
      => if eq_name x y then Some t else fun_p_assoc e0 x
  end.

Notation " e ^^^ x " := (@fun_p_assoc e x) (at level 60).

Fixpoint psubst_term (a: term) (e: p_termenv) {struct a} : term :=
  match a with
  | Param v =>
       match e ^^^ v with
         | Some t => t
         | None => Param v
       end
  | Var n => Var n
  | Fun t a1 => Fun t (psubst_term a1 e)
  | App a1 a2 => App (psubst_term a1 e) (psubst_term a2 e)
  end.

Fixpoint subst_term (a: term) (ep: p_termenv) (ev: v_termenv) {struct a} : term :=
  match a with
  | Param v =>
       match ep ^^^ v with
         | Some t => t
         | None => Param v
       end
  | Var n =>
      match ev ^^ n with
      | Some t => t
      | None => Var (n - (v_less ev n))
      end
  | Fun t a1 => Fun t (subst_term a1 ep (v_shift ev))
  | App a1 a2 => App (subst_term a1 ep ev) (subst_term a2 ep ev)
  end.

(** Here are the two ``freshening'' operations that replace the bound variable
  0 with a term or type name, respectively. *)

Definition freshen_term (a: term) (x: name) : term :=
  vsubst_term a ((0, (Param x)) :: nil).

(** Substitutions and freshening play well with free variables. *)
Lemma fv_term_vsubst_term:
  forall x a e, In x (fv_term a) -> In x (fv_term (vsubst_term a e)).
Proof.
  induction a; simpl; intros; auto;
  try contradiction;
  elim (in_app_or _ _ _ H); eauto.
Qed.

Lemma fv_term_freshen_term:
  forall x a y, In x (fv_term a) -> In x (fv_term (freshen_term a y)).
Proof.
  intros; unfold freshen_term; apply fv_term_vsubst_term; auto.
Qed.

Inductive wf_term: typenv -> term -> Prop :=
  | wf_term_param: forall (e : typenv) (x:name),
      kind x = TERM -> In x (dom e) -> wf_term e (Param x)
  | wf_term_fun:
      forall (e : typenv) (t:type) (a:term),
      (forall (x: name) , kind x = TERM
                         -> ~In x ((fv_term a) ++ (dom e))
                         -> wf_term ((x, t) :: e) (freshen_term a x))
      -> wf_term e (Fun t a)
(*  | wf_term_fun: forall e t a,
      (forall x,
       kind x = TERM ->
       ~In x (fv_term a) -> ~In x (dom e) ->
       wf_term (freshen_term a x)) ->
      wf_term (Fun t a)
*)
  | wf_term_app: forall e a1 a2,
      wf_term e a1
      -> wf_term e a2
      -> wf_term e (App a1 a2).

(* added *)
(*
Lemma fv_dom_type: forall x e t, dom_type e t -> In x (fv_type t) -> In x (dom e).
Proof.
  induction 1; simpl; intros.
  - intuition; subst; auto.
  - elim (in_app_or _ _ _ H1);
    intros; [apply IHdom_type1 | apply IHdom_type2]; auto.
 Qed.
(* added *)

Lemma fv_wf_term: forall x e t, wf_term e t -> In x (fv_term t) -> In x (dom e).
Proof.
  induction 1; simpl; intros.
  - intuition; subst; auto.

  - elim (in_app_or _ _ _ H1); intros; induction t; simpl.
    + eapply fv_dom_type; eauto. constructor; auto.  with t; eauto. admit.
    +

        destruct (fresh_name TERM (x :: fv_term a ++ dom e)) as [y [F K]].
        assert (In x (dom ((y, t) :: e))).
        apply H0; eauto. apply fv_term_freshen_term. auto.
  simpl dom in H3. eauto.
  (* app *)
-   elim (in_app_or _ _ _ H1); auto.

  (* tfun *)
  elim (in_app_or _ _ _ H2); intro.
  eapply fv_wf_type; eauto.
  destruct (fresh_name TYPE (x :: fv_term a ++ dom e)) as [y [F K]].
  assert (In x (dom ((y, t) :: e))).
    apply H1; eauto. apply fv_term_freshen_tety. auto.
  simpl dom in H4; eauto.
  (* tapp *)
  elim (in_app_or _ _ _ H1); intro.
  auto.
  eapply fv_wf_type; eauto.
Qed.

unfold dom_type. red. destruct dom_type. destruct (fresh_name TERM (x :: fv_term a ++ dom e)) as [y [F K]].
  assert (In x (dom ((y, t) :: e))).
    apply H1; eauto. apply fv_term_freshen_term. auto.
  simpl dom in H4. eauto.
  (* app *)
  elim (in_app_or _ _ _ H1); auto.
  (* tfun *)
  elim (in_app_or _ _ _ H2); intro.
  eapply fv_wf_type; eauto.
  destruct (fresh_name TYPE (x :: fv_term a ++ dom e)) as [y [F K]].
  assert (In x (dom ((y, t) :: e))).
    apply H1; eauto. apply fv_term_freshen_tety. auto.
  simpl dom in H4; eauto.
  (* tapp *)
  elim (in_app_or _ _ _ H1); intro.
  auto.
  eapply fv_wf_type; eauto.
Qed.
*)

Lemma fv_wf_term: forall t x e, wf_term e t -> In x (fv_term t) -> In x (dom e).
Proof.
  induction 1; simpl; intros; auto. inversion H; subst; auto.
  - intuition; subst; auto.
  - destruct (fresh_name TERM (x :: fv_term a ++ dom e)) as [y [F K]].
  assert (In x (dom ((y, t) :: e))).
  apply H0; eauto. apply fv_term_freshen_term; auto.
  simpl dom in H2; eauto.
  - elim (in_app_or _ _ _ H1); auto.
Qed.

(*
Lemma fv_term_freshen_tety:
  forall x a y, In x (fv_term a) -> In x (fv_term (freshen_tety a y)).
Proof.
  intros; unfold freshen_tety; apply fv_term_vsubst_tety; auto.
Qed.
*)

(** Swaps of two names in a term. *)

(** Swaps commute with the free variables operation. *)

(** Swaps are self-inverse. *)

(** Swaps commute with substitutions and freshening. *)

(** ** Well-formedness of terms *)

(** A term is well-formed in a typing environment if:
  - all types contained within are well-formed as per [wf_type];
  - all names [n] appearing free in a [Param n] subterm are of kind [TERM]
    and are bound in the environment;
  - it does not contain free de Bruijn variables.
*)

(** A term well formed in [e] has all its free names in the domain of [e]. *)

(** Well-formedness is stable under swaps. *)

(** A term well-formed in [e] remains well-formed if extra bindings are added to [e]. *)

(** Here are two admissible rules that prove the well-formedness of [Fun] and [TFun]
  abstractions.  These rules are similar to the [wf_term_fun] and
  [wf_term_tfun] rules, but with a premise of the form ``there exists
  a name'' instead of the original ``for all names''.  *)

(** ** Properties of term substitutions *)

(** To prove the usual properties of term substitutions, we follow the
  same approach as for type substitutions, starting with a
  characterization of terms that have no free de Bruijn variables, or
  all such variables below some threshold. *)

Fixpoint term_vars_below (a: term) (nterm ntype: nat) {struct a} : Prop :=
  match a with
  | Param x => True
  | Var n => n < nterm
  | Fun t b => term_vars_below b (S nterm) ntype
  | App b c => term_vars_below b nterm ntype /\ term_vars_below c nterm ntype
(*  | TFun t b => type_vars_below t ntype /\ term_vars_below b nterm (S ntype)
  | TApp b t => term_vars_below b nterm ntype /\ type_vars_below t ntype*)
  end.

Lemma term_vars_below_vsubst_term:
  forall a nterm ntype a',
  term_vars_below (vsubst_term a ((nterm, a'):: nil)) nterm ntype ->
  term_vars_below a  (S nterm) ntype.
Proof.
  induction a; auto; intros.
  - destruct (compare_nat n nterm); subst; auto; simpl;
    [ omega
    | auto
    | simpl in H;
      destruct (n == nterm); auto with arith; firstorder;
      simpl in H; replace (if lt_dec nterm n then 1 else 0) with 1 in H;
      [ omega
      | destruct lt_dec; auto; contradiction] ].
  - simpl in *; auto.
    apply IHa with a'; auto.
  - simpl in *; destruct H; split; auto; [apply IHa1 with a' | apply IHa2 with a']; auto.
Qed.

(*
Lemma term_vars_below_vsubst_tety:
  forall a nterm ntype a',
  term_vars_below (vsubst_tety a ntype a') nterm ntype ->
  term_vars_below a nterm (S ntype).
Proof.
  generalize type_vars_below_vsubst; intro.
  induction a; simpl; intros; firstorder.
Qed.
*)
(*
Fixpoint In_fv_type (x : name) (t: type) : Prop :=
  match t with
  | Tparam x => In x (fv_type t)
  | Arrow t1 t2 => (In_fv_type x t1) /\ (In_fv_type x t2)
  end.

Lemma wf_type_vars_below_0: forall x e t, In_fv_type x t -> In x (dom e) -> type_vars_below t 0.
Proof.
  induction t; simpl. auto.
  intros; auto. split; destruct H as [Hl Hr] ; [apply IHt1 | apply IHt2]; auto.
Qed.
*)

Lemma wf_term_vars_below_0: forall a e, wf_term e a -> term_vars_below a 0 0.
Proof.
  (* generalize wf_type_vars_below_0; intro. *)
  induction 1; simpl; firstorder.
  destruct (fresh_name TERM (fv_term a ++ dom e)) as [x [F K]].
  apply notIn_app with (l:= (fv_term a)) (m := (dom e)) in F; destruct F as [Fv  Fd].
  apply term_vars_below_vsubst_term with (Param x). apply H0; eauto.
  apply notIn_app_1; auto.
Qed.

Lemma vsubst_term_invariant_below:
  forall a n1 n2 m b, term_vars_below a n1 n2 -> n1 <= m -> vsubst_term a ((m, b) :: nil) = a.
Proof.
  induction a; simpl; intros; try decEq; firstorder.
  destruct ( n == m); auto. subst; omega.
  destruct (lt_dec m n); firstorder.
Qed.

(*
Lemma vsubst_tety_invariant_below:
  forall a n1 n2 m t, term_vars_below a n1 n2 -> n2 <= m -> vsubst_tety a m t = a.
Proof.
  generalize vsubst_invariant_below; intro.
  induction a; simpl; intros; decEq; firstorder.
Qed.
*)

Lemma vsubst_term_wf_term:
  forall a n b e, wf_term e a -> vsubst_term a ((n, b):: nil) = a.
Proof.
  intros. apply vsubst_term_invariant_below with 0 0.
  eapply wf_term_vars_below_0; eauto.  omega.
Qed.

(*
Lemma vsubst_tety_wf_term:
  forall e a n t, wf_term e a -> vsubst_tety a n t = a.
Proof.
  intros. apply vsubst_tety_invariant_below with 0 0.
  eapply wf_term_vars_below_0; eauto. omega.
Qed.
*)

Lemma psubst_vsubst_term:
  forall e a x b n c,
  wf_term e b ->
  vsubst_term (psubst_term a ((x, b) :: nil)) ((n, (psubst_term c ((x, b) :: nil))) :: nil)
  = psubst_term (vsubst_term a ((n, c) :: nil)) ((x, b) :: nil).
Proof.
  induction a; intros; simpl; try decEq; auto.
  - case (eq_name n x); intro; simpl; auto.
    eapply vsubst_term_wf_term; eauto.
  - destruct ( n == n0); subst; auto.
Qed.

Lemma psubst_freshen_term:
  forall e a x b y,
  wf_term e b -> x <> y ->
  freshen_term (psubst_term a ((x, b) :: nil)) y = psubst_term (freshen_term a y) ((x, b) :: nil).
Proof.
  intros; unfold freshen_term.
  rewrite <- (psubst_vsubst_term e); auto.
  simpl. rewrite eq_name_false; auto.
Qed.

(*S
Lemma psubst_vsubst_tety:
  forall e a x b n c,
  wf_type e b ->
  vsubst_tety (psubst_tety a x b) n (psubst_type c x b) =
  psubst_tety (vsubst_tety a n c) x b.
Proof.
  induction a; intros; simpl; try decEq; auto;
  eapply psubst_vsubst_type; eauto.
Qed.

Lemma psubst_freshen_tety:
  forall e a x b y,
  wf_type e b -> x <> y ->
  freshen_tety (psubst_tety a x b) y = psubst_tety (freshen_tety a y) x b.
Proof.
  intros. unfold freshen_tety.
  rewrite <- (psubst_vsubst_tety e); auto.
  simpl. rewrite eq_name_false; auto.
Qed.

Lemma psubst_vsubst_tetety:
  forall e a x b n c,
  wf_type e b ->
  vsubst_term (psubst_tety a x b) n (psubst_tety c x b) =
  psubst_tety (vsubst_term a n c) x b.
Proof.
  induction a; intros; simpl; try decEq; auto.
  destruct (compare_nat n n0); auto.
Qed.

Lemma psubst_freshen_tetety:
  forall e a x b y,
  wf_type e b -> x <> y ->
  freshen_term (psubst_tety a x b) y = psubst_tety (freshen_term a y) x b.
Proof.
  intros. unfold freshen_term.
  rewrite <- (psubst_vsubst_tetety e); auto.
Qed.

Lemma psubst_vsubst_tetyte:
  forall e a x b n c,
  wf_term e b ->
  vsubst_tety (psubst_term a x b) n c = psubst_term (vsubst_tety a n c) x b.
Proof.
  induction a; intros; simpl; try decEq; auto.
  destruct (eq_name n x); auto. eapply vsubst_tety_wf_term; eauto.
Qed.

Lemma psubst_freshen_tetyte:
  forall e a x b y,
  wf_term e b -> x <> y ->
  freshen_tety (psubst_term a x b) y = psubst_term (freshen_tety a y) x b.
Proof.
  intros; unfold freshen_tety. eapply psubst_vsubst_tetyte; eauto.
Qed.
S*)

Lemma vsubst_psubst_term:
  forall x a2 a1 n,
  ~In x (fv_term a1) ->
  (subst_term a1 nil ((n, a2) :: nil)) = (subst_term (subst_term a1 nil ((n, Param x) :: nil)) ((x, a2) :: nil) nil).
(* vsubst_term a1 n a2 = psubst_term (vsubst_term a1 n (Param x)) x a2. *)
Proof.
  induction a1; simpl; intros.
  - rewrite eq_name_false; tauto.
  (* destruct (compare_nat n n0); auto. *)
  (* simpl. rewrite eq_name_true; auto. *)
  - destruct (n == n0); subst; auto.
    + unfold subst_term. simpl. destruct (eq_name x x); subst; tauto.
    + destruct (lt_dec n0 n); auto; simpl; auto with arith.
  - rewrite IHa1; auto.
  - destruct (notIn_app name x (fv_term a1_1) (fv_term a1_2) H). rewrite IHa1_1, IHa1_2; auto.
Qed.

Lemma subst_vsubst :
  forall a ev,
    subst_term a nil ev = vsubst_term a ev.
Proof.
  induction a, ev; auto; intros; simpl;
  [ rewrite IHa
  | rewrite IHa
  | rewrite IHa1, IHa2
  | rewrite IHa1, IHa2] ; auto.
Qed.

Lemma subst_psubst :
  forall a ep,
    subst_term a ep nil = psubst_term a ep.
Proof.
  induction a, ep; intros; simpl; auto with arith;
  [ rewrite IHa
  | rewrite IHa
  | rewrite IHa1, IHa2
  | rewrite IHa1, IHa2] ; auto.
Qed.

Lemma vsubst_psubst_freshen_term:
  forall x a1 a2,
  ~In x (fv_term a1) ->
  (subst_term a1 nil ((0, a2) :: nil)) = (subst_term (freshen_term a1 x) ((x, a2) :: nil) nil).
Proof.
  intros; unfold freshen_term.
  rewrite vsubst_psubst_term with (x:=x); auto.
  rewrite subst_vsubst; auto.
Qed.

(*S
Lemma vsubst_psubst_tety:
  forall x t2 a1 n,
  ~In x (fv_term a1) ->
  vsubst_tety a1 n t2 = psubst_tety (vsubst_tety a1 n (Tparam x)) x t2.
Proof.
  generalize vsubst_psubst_type; intro.
  induction a1; simpl; intros; decEq; auto.
Qed.

Lemma vsubst_psubst_freshen_tety:
  forall x a1 t2,
  ~In x (fv_term a1) ->
  vsubst_tety a1 0 t2 = psubst_tety (freshen_tety a1 x) x t2.
Proof.
  intros; unfold freshen_tety; apply vsubst_psubst_tety; auto.
Qed.
S*)

(** * Typing rules *)

(** We now define the typing judgement ``term [a] has type [t] in
  environment [e]'' as an inductive predicate [has_type e a t]. *)

(* well-formed environment : no duplicate names *)

Inductive wf_env: typenv -> Prop :=
  | wf_env_nil:
      wf_env nil
  | wf_env_cons: forall x t e,
      wf_env e -> ~In x (dom e) ->
      wf_env ((x, t) :: e).

(* Typing *)

Inductive has_type: typenv -> term -> type -> Prop :=
  | t_var: forall e x t,
      wf_env e -> kind x = TERM -> lookup x e = Some t ->
      has_type e (Param x) t
  | t_abs: forall e t1 a t2,
      (forall x,
        kind x = TERM -> ~In x (fv_term a ++ dom e) ->
        has_type ((x, t1) :: e) (freshen_term a x) t2
      )
      -> has_type e (Fun t1 a) (Arrow t1 t2)
  | t_app: forall e a b t1 t2,
      has_type e a (Arrow t1 t2) -> has_type e b t1 ->
      has_type e (App a b) t2.

(** Well-formedness properties: if [has_type e a t] holds, then
  [e] is a well-formed environment, [t] a well-formed type
  and [a] a well-formed term. *)

Lemma has_type_wf_env: forall e a t, has_type e a t -> wf_env e.
Proof.
  induction 1; auto.
  destruct (fresh_name TERM ((fv_term a) ++ (dom e))) as [x [FRESH KIND]]. assert (~ In x (fv_term a)). eauto using notin_app_l.
  (* assert (~ In x (dom e)); eauto using notin_app_r.  *)
  generalize (H0 x KIND FRESH); intros H2. inversion H2; auto.
Qed.

Lemma has_type_wf_term: forall e a t, has_type e a t -> wf_term e a.
Proof.
  induction 1; auto; intros; constructor; auto.
  eapply lookup_inv; eauto.
Qed.

Lemma env_concat_weaken:
  forall delta gamma,
  wf_env (delta ++ gamma) -> env_weaken gamma (delta ++ gamma).
Proof.
  induction delta; red; auto; intros. inversion H; simpl.
  rewrite eq_name_false.
  - apply IHdelta; auto.
  - intro; subst; auto.
    apply H4; unfold dom; rewrite map_append;
    apply in_or_app; right; eauto using lookup_inv.
Qed.

Hint Resolve has_type_wf_env has_type_wf_term.

(** The [has_type] predicate is stable by addition of hypotheses. *)
(*
Lemma wf_type_weaken: forall e e' t, wf_type e t -> env_weaken e e' -> wf_type e' t.
Proof.
  intros. apply wf_type_env_incr with e; auto. apply env_weaken_incl_dom; auto.
Qed.

Lemma wf_term_weaken: forall e e' a, wf_term e a -> env_weaken e e' -> wf_term e' a.
Proof.
  intros. apply wf_term_env_incr with e; auto. apply env_weaken_incl_dom; auto.
Qed.
*)
Lemma env_weaken_add:
  forall e e' x t,
    env_weaken e e'
    -> env_weaken ((x, t) :: e) ((x, t) :: e').
Proof.
  intros; red; intros x' t'. simpl.
  case (eq_name x' x); intro; auto.
Qed.

Hint Resolve env_weaken_add.

(*Lemma trm_dec :
  forall (t t0 : trm), {t = t0} + {t <> t0}.
Proof.
  induction t, t0; try neq_trm.
  destruct (fun_dec f f0); destruct (IHt1 t0_1); destruct (IHt2 t0_2);
  subst; try neq_case; left; auto.
*)

(* type is decidable *)

Lemma eq_type :
  forall (t t0 : type), { t = t0 } + {t <> t0}.
  induction t, t0.
  - decide equality;
    case (eq_name n1 n2); subst; auto.
  - right; discriminate.
  - right; discriminate.
  - decide equality;
    case (eq_name n n0); subst; auto.
Qed.

Lemma eq_te :
  forall (te te0 : (name * type)), {te = te0} + {te <> te0}.
  induction te, te0.
  destruct (eq_name a n); subst; auto.
  - destruct (eq_type b t); subst; auto.
    + right; red; intro F; apply n0; congruence.
  - right; red; intro F; apply n0; congruence.
Qed.

Notation sub_env := (@sublist (name * type) eq_te).
(*
lookup =
fix lookup (x : name) (e : typenv) {struct e} : option type :=
  match e with
  | nil => None
  | (y, t) :: e' => if eq_name x y then Some t else lookup x e'
  end
     : name -> typenv -> option type

IN =
fix IN (A : Type) (decA : decidable A) (a : A) (l : list A) {struct l} :
  Prop :=
  match l with
  | nil => False
  | b :: m => if decA a b then True else IN A decA a m
  end
     : forall A : Type, decidable A -> A -> list A -> Prop

*)

Lemma lookup_IN :
  forall x e t,
    lookup x e = Some t -> IN (eq_te) (x, t) e.
Proof.
  induction e; intros; simpl; auto.
  inversion H.
  destruct (eq_te (x, t) a); subst; auto. inversion H.  destruct a as [y u].
  apply IHe; auto. destruct (eq_name x y); auto. subst; auto.
  simpl in H. destruct (eq_name y y); subst; congruence.
Qed.

Lemma wf_cons_e :
  forall x t e,
    wf_env ((x,t) :: e) ->
    wf_env e.
Proof.
  intros ? ? ? H. inversion H; auto.
Qed.

(* need to move *)
Lemma IN_dom :
  forall x t e,
    IN (eq_te) (x, t) e -> In x (dom e).
Proof.
  induction e as [| [y u] e]; auto; intros; simpl.
  destruct (eq_te (x,t) (y, u));
    [left; inversion e0
    | right; apply IHe; eapply neq_IN_cons]; eauto.
Qed.

Lemma IN_lookup :
  forall x e t,
    wf_env e ->
    IN (eq_te) (x, t) e -> lookup x e = Some t.
Proof.
  induction e as [ | [y u] e] ; intros; auto.
  - inversion H0.
  - destruct (eq_te (y, u) (x, t) ).
    + rewrite e0; auto. simpl; destruct (eq_name x x); subst; auto; congruence.
    + generalize (neq_IN_cons eq_te e n H0); intro H1. inversion H; subst.
      destruct (eq_name x y); subst; auto.
      apply (IN_dom y t e) in  H1. contradiction.
      simpl. destruct (eq_name x y); subst; auto. contradict n0; auto.
Qed.

Lemma sub_env_weaken :
  forall e2,
    wf_env e2 -> (forall e1, sub_env e1 e2 <-> env_weaken e1 e2).
Proof.
(*  split; intros.
  red; intros. unfold sublist in H.
  induction e1. inversion H0.
  apply IHe1; intros. apply H; auto with datatypes.
  destruct a as [n t0]; subst; auto. inversion H0.
  destruct (eq_name x n); subst; auto. apply H2.
*)

  induction e1; split; simpl; auto; intros.
  - red; intros. inversion H1.
  - red; intros. inversion H1.
  - red; intros.

destruct a as [n t]; subst; auto. red; intros.
    apply IHe1; auto with datatypes.
    case (eq_name x n); intro; subst; auto. inversion H0. destruct (eq_name n n) in H2. simpl. destruct (eq_name n n); subst; auto. discriminate.  red.  replace (lookup n ((n, t) :: e1)) with (Some t) in H0; auto.
red.  simpl.  apply H0. decEq. eqDec.

red in IHe1. apply IHe1. eapply sub_cons_1; eauto.
    inversion H0. destruct (eq_name x n); subst; auto. inversion H2; subst.   assert (t = t0). inversion H2; auto. congruence. discriminate.
    rewrite H2. discriminate. red in H0.
congruence.  with datatypes.

 simpl; auto.

(*
Lemma 0 :
  forall x t, look
Lemma has_type_weaken_wf_env :
  forall (x : name) e (t : type), lookup x e = Some t ->
                                   forall e', lookup x e' = Some t ->
                                                                          (* forall e e' a t,
                                                                             has_type e a t -> *)
                                     wf_env e' ->
      (* forall e, env_weaken e e'  *)
                                     wf_env e.
Proof.
  induction e'; intros. simpl in H0. discriminate.
  destruct a as [y u]; inversion H1; subst; auto.  apply IHe'; auto. case (eq_name x y); intros; subst; auto. replace (lookup y e' = Some t) with (exists t, lookup y e' = Some t). apply lookup_exists. apply False_rect. apply H6. simpl in H6. red in H6. intuition. auto congruence. contradiction.  using H6. inversion H1. simpl. apply H6. contradict H4. inversion H0. destruct (

contrapose H. case H.
  generalize (H x t).  apply False_rect. apply H.  in H.
*)

Lemma lookup_env_extends:
  forall e2 x p q y e1,
  wf_env (e1 ++ (x, q) :: e2) ->
  lookup y (e1 ++ (x, p) :: e2) = if eq_name y x then Some p else lookup y (e1 ++ (x, q) :: e2).
Proof.
  induction e1; simpl; intros.
  case (eq_name y x); auto.
  destruct a. inversion H. subst x0; subst t0; subst e.
  case (eq_name y n); intro. subst n.
  rewrite eq_name_false. auto. red; intros; subst x.
  elim H4. unfold dom. rewrite map_append.
  apply in_or_app. right. simpl. tauto.
  apply IHe1. auto.
Qed.

Lemma has_type_cons_notIn_dom :
  forall x t1 e a t2,
    has_type ((x, t1) :: e) a t2 -> ~ In x (dom e).
Proof.
  intros. generalize (has_type_wf_env ((x, t1) :: e) a t2 H); intro H0; inversion H0; auto.
Qed.

(*Lemma has_type_weaken00 :
  forall e1 e2 e3 a t, has_type ( e1 ++ e2) a t ->
                       wf_env (e3 ++ e1++ e2) ->
                       has_type (e3 ++ e1 ++ e2) a t.
Proof.
  intros e1 e2 e3 a t H. generalize dependent e3. induction H; intros e3 HH; subst.
  - apply t_var; auto. set (e0 := (e3 ++ e)).  lookup_exists with (x := x) (e:=e0).  (e3 ++ e)).   unfold lookup. red.
(*  generalize dependent G.
  induction H; intros G Eq Ok; subst.
  Case "typing_var".
    apply typing_var.
      apply Ok.
      apply binds_weaken. apply H0. apply Ok.
  Case "typing_abs".
    pick fresh x and apply typing_abs.
    rewrite <- cons_concat_assoc.
    apply H0.
      auto.
      rewrite cons_concat_assoc. reflexivity.
      rewrite cons_concat_assoc. apply ok_cons.
        apply Ok.
        auto.
  Case "typing_app".
    eapply typing_app.
      eapply IHtyping1. reflexivity. apply Ok.
      eapply IHtyping2. reflexivity. apply Ok.
Qed.*)

Lemma has_type_weaken0 :
  forall e a t1 t2 x, has_type e a t2 -> wf_env ((x, t1) :: e)
                                               ->  has_type ((x, t1) :: e) a t2.
Proof.
  intros. induction H0; auto. simpl. intuition. contradiction. discriminate. induction 1; auto; intros; try constructor; auto.  change (lookup x0 ((x, t1) :: e)) with (lookup x0 (nil ++ ((x, t1) :: e))). rewrite lookup_env_extends with (e1:=nil) (q:= t1). assert (x0 <> x). apply has_type_wf_env in H2.
  case (eq_name x0 x); intros; subst; auto. auto. asserthas_type.
*)

Lemma has_type_weaken:
  forall e a t, has_type e a t ->
                forall e', wf_env e' -> env_weaken e e' -> has_type e' a t.
Proof.
  assert (X: forall e e' x, env_weaken e e' -> ~In x (dom e') -> ~In x (dom e)).
  - intros. generalize (env_weaken_incl_dom _ _ H); auto.
  - induction 1; simpl; intros; try constructor; auto.
    + intros. apply H0; auto.
      * apply notIn_app_1; auto. apply X with e'; auto.
      * constructor; auto.
    + econstructor; eauto.
Qed.

(** The [has_type] predicate is equivariant, i.e. stable by swapping. *)
(*
Lemma has_type_swap:
  forall u v, kind u = kind v ->
  forall e a t, has_type e a t ->
  has_type (swap_env u v e) (swap_term u v a) (swap_type u v t).
Proof.
  intros u v KINDuv. induction 1; simpl.
  (* var *)
  constructor. apply wf_env_swap; auto. rewrite swap_kind; auto.
  apply lookup_swap; auto.
  (* fun *)
  constructor. apply wf_type_swap; auto.
  intros. pose (x' := swap u v x).
  assert (kind x' = TERM).  unfold x'. rewrite swap_kind; auto.
  assert (~In x' (dom e)).
    generalize (in_dom_swap u v x' e). unfold x'. rewrite swap_inv. tauto.
  generalize (H1 x' H4 H5). rewrite freshen_term_swap. simpl.
  replace (swap u v x') with x. auto. unfold x'. rewrite swap_inv. auto.
  (* app *)
  simpl in IHhas_type1. econstructor; eauto.
  (* tfun *)
  constructor. apply wf_type_swap; auto.
  intros. pose (x' := swap u v x).
  assert (kind x' = TYPE).  unfold x'. rewrite swap_kind; auto.
  assert (~In x' (dom e)).
    generalize (in_dom_swap u v x' e). unfold x'. rewrite swap_inv. tauto.
  generalize (H1 x' H4 H5). rewrite freshen_tety_swap.
  rewrite freshen_type_swap. simpl.
  replace (swap u v x') with x. auto. unfold x'. rewrite swap_inv. auto.
  (* tapp *)
  simpl in IHhas_type. rewrite vsubst_type_swap.
  econstructor; eauto. apply is_subtype_swap; auto.
  (* sub *)
  econstructor; eauto. apply is_subtype_swap; auto.
Qed.

(** As a consequence of equivariance, we obtain admissible typing
  rules for functions and type abstractions, similar to rules [t_abs]
  and [t_tabs] but where the variable name is quantified existentially
  rather than universally. *)

Lemma kind_fv_type: forall e t, wf_type e t -> forall x, In x (fv_type t) -> kind x = TYPE.
Proof.
  induction 1; simpl; intros.
  replace x0 with x. auto. tauto.
  tauto.
  elim (in_app_or _ _ _ H1); auto.
  elim (in_app_or _ _ _ H2); intros. auto.
    destruct (fresh_name TYPE (x :: fv_type t2 ++ dom e)) as [y [F K]].
    eapply H1; eauto. apply fv_type_freshen_type. auto.
Qed.

Lemma fv_wf_type_kind: forall x e t, wf_type e t -> kind x = TERM -> ~In x (fv_type t).
Proof.
  intros; red; intros. generalize (kind_fv_type _ _ H _ H1). congruence.
Qed.
*)

Lemma fresh_freshen_term:
  forall x t e a y,
    wf_term ((x, t) :: e) (freshen_term a x) -> ~In y (dom e) -> x <> y ->
    ~In y (fv_term a).
Proof.
  intros.
  red; intro.
  assert (In y (dom ((x, t) :: e))).
  eapply fv_wf_term; eauto. apply fv_term_freshen_term; auto.
  elim H3; simpl; intros; contradiction.
Qed.

(* rename  *)
Fixpoint fun_rename (e: renaming) (x: name) {struct e} : option name :=
  match e with
    | nil => None
    | (y,z) :: e0
      => if eq_name x y then Some z else fun_rename e0 x
  end.

Fixpoint rename_name (e : renaming) (x : name) : name :=
  match e with
    | nil => x
    | (y, z) :: e0 => if eq_name x y then y else rename_name e0 x
  end.

Notation " e // x " := (@rename_name e x) (at level 60).

Fixpoint rename_tp (e : renaming) (t : type) : type :=
  match t with
    | Tparam x => Tparam (e // x)
    | Arrow a1 a2 => Arrow (rename_tp e a1) (rename_tp e a2)
  end.

Fixpoint rename (e : renaming) (a : term) : term :=
  match a with
    | Var n    => Var n
    | Param v   => Param (e // v)
    | Fun t a1 => Fun t (rename e a1)
    | App a1 a2 => App (rename e a1)  (rename e a2)
  end.

Fixpoint rename_env (e : renaming) (env : typenv) : typenv :=
  match env with
      | nil => nil
      | (x, t) :: e0 => ((e // x), (rename_tp e t)) :: (rename_env e e0)
  end.

(* S : Properties of rename  *)
Lemma rename_tp_nil :
  forall (t : type),
    rename_tp nil t = t.
Proof.
  induction t; simpl; f_equal; auto.
Qed.

Lemma rename_nil :
  forall (a : term),
    rename nil a = a.
Proof.
  induction a; simpl; f_equal; auto.
Qed.

Lemma rename_env_nil :
  forall (env : typenv),
    rename_env nil env = env.
 Proof.
   induction env; simpl; auto; destruct a; rewrite rename_tp_nil, IHenv; auto.
Qed.

Lemma rename_env_weaken :
  forall e e1 e2,
    env_weaken e1 e2 ->
    env_weaken (rename_env e e1) (rename_env e e2).
Proof.
  induction e1; simpl; intros; auto.
  - red; intros; inversion H0.
  - { - destruct a as [x t]; auto.

Lemma env_weaken_weaken :
  forall e1 e2 x t,
    env_weaken ((x, t) :: e1) e2 ->
    env_weaken e1 e2.
Proof.
  intros. unfold env_weaken in *; intros. apply H. simpl.
  destruct (eq_name x0 x); auto. specialize (H x0 t0). rewrite e in *; auto.
  assert (lookup x ((x, t) :: e1) = Some t). auto. simpl. destruct (eq_name x x); auto. contradict n; auto. rewrite   with (Some t) in H. simpl in H; red in H.  discriminate.  assert (t= t0).
  discriminate.  H.
        apply IHe1; auto.

  - inversion H.

e1, e; simpl; auto; intros.
  - rewrite! rename_env_nil; auto.
  - red; intros. inversion H0.
  - destruct a as [x t]; subst; auto.
    rewrite! rename_env_nil, rename_tp_nil; auto.
  - destruct a as [x t].  destruct p as [y u]; auto.
    destruct (eq_name x y); subst; auto.
    + unfold env_weaken in *; intros.
      apply IHe1; auto; intros.
      * apply H. simpl. rewrite H1.
      destruct (eq_name x0 y); auto. simpl in IHe1.  assert (t = t1). congruence.
      simpl in H.
      set (t1:= (rename_tp ((y, u) :: e) t)).
      (* lookup x
         ((y, t1) :: rename_env ((y, u) :: e) e1) = Some t0 *)

unfold env_weaken in *; intros.
    destruct a as [y u].

    case  (rename_env ((y, u) :: e) e2). intuition. firstorder. congruence.

 replace (rename_env ((y, u) :: e) e2) with
                         (rename_env ((y, u) :: nil) e2).
    simpl.

unfold rename_env.
    simpl.

  - red; intros; inversion H0.
  - destruct a as [x t]; subst; auto.
    generalize (env_weaken_incl_dom ((x, t) :: e1) e2 H); intros.
    induction e; intros; simpl. auto.
    rewrite! rename_env_nil, rename_tp_nil; auto.
    destruct a as [y u]; subst; auto.
    destruct (eq_name x y); subst; auto.
    + red; intros. apply IHe.
unfold env_weaken in IHe1. unfold env_weaken in *; intros.
    apply IHe1; auto.
    intros. apply H. assert (x1 <> x).

congruence. consimpl. rewrite H1; auto.
    destruct (eq_name x1 x); subst; auto.
    unfold env_weaken; intros. inversion H0.
    destruct (eq_name x0 x). subst; auto.
    + destruct (eq_name x (e // x)).
      rewrite H2. unfold env_weaken in IHe1. apply IHe1; auto. intros.
      unfold env_weaken in H. apply H; auto. simpl.
      destruct (eq_name x0 x). auto. rewrite <- H1.  congruence. subst x; auto.

      assert (x0 <> x).  destruct (eq_name x0 x); subst; auto. case (e // x); intros. apply IHe1. apply H; auto.
    simpl.
    destruct (eq_name x0 x); subst; auto. simpl in H. contradict H. . congruence.
    inversion H0. auto. simpl in H0.  inversion H0. auto.  simpl in H0. inversion H0. auto. tauto. simpl. inversion H.
tauto. simpl. rewrite! rename_env_nil; auto.
  - destruct a as [x t]. change (rename_env ((x, t) :: e) e1 ) with ((e // x, rename_tp e t) :: rename_env e e1).  unfold rename_env; simpl; auto. case (e0 // x); subst; auto.  env_weaken; intros. unfold env_weaken in H.
    unfold rename_env in H0.

inversion H0.
  - destruct a as [x t].

    unfold env_weaken; intros.
    inversion H0.
    destruct (eq_name x0 (e // x)); subst; auto.
    + rewrite H2. unfold env_weaken in H. simpl in H0. apply H.  destruct ( simpl in H0.

Lemma t_abs':
  forall e t1 a t2 x,
  kind x = TERM -> ~In x (fv_term a ++ dom e) ->
  has_type ((x, t1) :: e) (freshen_term a x) t2 ->
  has_type e (Fun t1 a) (Arrow t1 t2).
Proof.
  intros;
  generalize (has_type_wf_env _ _ _ H1); intro. inversion H2; subst.
  (* generalize (has_type_wf_type _ _ _ H2); intro. *)
  generalize (has_type_wf_term _ _ _ H1); intro.
  apply t_abs; auto. intros y KIND DOM.
  case (eq_name x y); intro; subst; auto.
  (* assert (kind x = kind y). *)
  (* + congruence. *)
  (*  assert (~In x (fv_type t1)). eapply fv_wf_type_kind; eauto.
  assert (~In x (fv_type t2)). eapply fv_wf_type_kind; eauto.
  assert (~In y (fv_type t1)). eapply fv_wf_type_kind; eauto.
  assert (~In y (fv_type t2)). eapply fv_wf_type_kind; eauto.*)
  assert (~In y (fv_term a)). apply notIn_app in DOM; destruct DOM as [Fv DOM]; auto.

  (* eapply fresh_freshen_term; eauto. *)
  generalize (has_type_swap x y H6 _ _ _ H2).
  rewrite freshen_term_swap. simpl. rewrite swap_left.
  rewrite (swap_type_not_free x y t1); auto.
  rewrite (swap_type_not_free x y t2); auto.
  rewrite (swap_term_not_free x y a); auto.
  rewrite (swap_env_not_free x y e); auto.
Qed.

Lemma fresh_freshen_tety:
  forall x t1 e a y,
  wf_term ((x, t1) :: e) (freshen_tety a x) -> ~In y (dom e) -> x <> y ->
  ~In y (fv_term a).
Proof.
  intros.
  red; intro.
  assert (In y (dom ((x, t1) :: e))).
    eapply fv_wf_term. eauto. apply fv_term_freshen_tety. auto.
  elim H3; simpl; intros. contradiction. contradiction.
Qed.

Lemma t_tabs':
  forall e t1 a t2 x,
  kind x = TYPE -> ~In x (dom e) -> ~In x (fv_term a) -> ~In x (fv_type t2) ->
  has_type ((x, t1) :: e) (freshen_tety a x) (freshen_type t2 x) ->
  has_type e (TFun t1 a) (Forall t1 t2).
Proof.
  intros. generalize (has_type_wf_env _ _ _ H3); intro. inversion H4; subst.
  generalize (has_type_wf_type _ _ _ H3); intro.
  generalize (has_type_wf_term _ _ _ H3); intro.
  apply t_tabs. auto. intros y KIND DOM.
  case (eq_name x y); intro. subst x; auto.
  assert (kind x = kind y). congruence.
  assert (~In x (fv_type t1)). generalize (fv_wf_type x _ _ H10); tauto.
  assert (~In y (fv_type t1)). generalize (fv_wf_type y _ _ H10); tauto.
  assert (~In y (fv_type t2)). eapply fresh_freshen_type; eauto.
  assert (~In y (fv_term a)).  eapply fresh_freshen_tety; eauto.
  generalize (has_type_swap x y H7 _ _ _ H3).
  rewrite freshen_type_swap. rewrite freshen_tety_swap.
  simpl. rewrite swap_left.
  rewrite (swap_type_not_free x y t1); auto.
  rewrite (swap_type_not_free x y t2); auto.
  rewrite (swap_term_not_free x y a); auto.
  rewrite (swap_env_not_free x y e); auto.
Qed.
*)
(*S
(** * Stability of the typing judgement under substitutions *)

(** We now show that the typing judgement is stable under
  substitutions.  There are two substitutions to consider: of a type
  for a type variable, and of a term for a term variable. *)

Lemma has_type_stable_type_subst:
  forall e1 x p q e2 a t,
  kind x = TYPE ->
  is_subtype e1 p q ->
  has_type (e2 ++ (x, q) :: e1) a t ->
  has_type (psubst_env e2 x p ++ e1) (psubst_tety a x p) (psubst_type t x p).
Proof.
  assert (forall e1 x p q, kind x = TYPE -> is_subtype e1 p q ->
          forall e a t, has_type e a t ->
          forall e2, e = e2 ++ (x, q) :: e1 ->
          has_type (psubst_env e2 x p ++ e1) (psubst_tety a x p) (psubst_type t x p)).
  induction 3; intros; simpl; subst e.
  (* var *)
  elim (lookup_env_concat _ _ _ p _ _ _ H1 H3); intros [A B].
  congruence.
  constructor; auto.
  eapply wf_env_psubst; eauto.
  (* fun *)
  destruct (fresh_name TERM (x :: dom (e2 ++ (x, q) :: e1) ++
                             dom (psubst_env e2 x p ++ e1) ++
                             fv_type (psubst_type t2 x p) ++
                             fv_term (psubst_tety a x p)))
  as [y [F K]].
  apply t_abs' with y; eauto.
  change ((y, psubst_type t1 x p) :: psubst_env e2 x p ++ e1)
    with (psubst_env ((y, t1) :: e2) x p ++ e1).
  rewrite (psubst_freshen_tetety e1). apply H3; eauto.
  eauto. eauto.
  (* app *)
  simpl in IHhas_type1. econstructor; eauto.
  (* tfun *)
  destruct (fresh_name TYPE (x :: dom (e2 ++ (x, q) :: e1) ++
                             dom (psubst_env e2 x p ++ e1) ++
                             fv_type (psubst_type t2 x p) ++
                             fv_term (psubst_tety a x p)))
  as [y [F K]].
  apply t_tabs' with y; eauto.
  change ((y, psubst_type t1 x p) :: psubst_env e2 x p ++ e1)
    with (psubst_env ((y, t1) :: e2) x p ++ e1).
  rewrite (psubst_freshen_tety e1).
  rewrite (psubst_freshen_type e1).
  apply H3; eauto. eauto. eauto. eauto. eauto.
  (* tapp *)
  rewrite <- (psubst_vsubst_type e1). simpl in IHhas_type.
  econstructor; eauto.
  eapply sub_stable_subst; eauto. eauto.
  (* sub *)
  econstructor; eauto. eapply sub_stable_subst; eauto.

  eauto.
Qed.
S*)

Lemma lookup_env_append:
  forall e2 x p y e1,
  wf_env (e1 ++ (x, p) :: e2) ->
  lookup y (e1 ++ (x, p) :: e2) = if eq_name y x then Some p else lookup y (e1 ++ e2).
Proof.
  induction e1; simpl; intros.
  auto.
  destruct a. inversion H; subst.
  case (eq_name y n); intro.
  rewrite eq_name_false. auto. subst n.
  rewrite dom_append in H4. simpl in H4. eauto.
  auto.
Qed.

Lemma wf_env_append:
  forall e2 x p e1, wf_env (e1 ++ (x, p) :: e2) -> kind x = TERM -> wf_env (e1 ++ e2).
Proof.
  induction e1; simpl; intros.
  inversion H; auto.
  inversion H; subst.
  constructor. auto.
  rewrite dom_append. rewrite dom_append in H4. simpl in H4.
  red; intro. elim H4. apply in_or_app. simpl. elim (in_app_or _ _ _ H1); auto.
(*  apply wf_type_strengthen with (e1 ++ (x, p) :: e2). auto.
  intros. rewrite dom_append in H2. simpl in H2. rewrite dom_append.
  apply in_or_app. elim (in_app_or _ _ _ H2); intro. auto.
  elim H6; intro. congruence. auto.*)
Qed.

(*
Lemma is_subtype_strengthen:
  forall e s t, is_subtype e s t ->
  forall e', wf_env e' -> (forall x : name, kind x = TYPE -> lookup x e' = lookup x e) ->
  is_subtype e' s t.
Proof.
  assert (forall e e',
           (forall x : name, kind x = TYPE -> lookup x e' = lookup x e) ->
           (forall x : name, kind x = TYPE -> In x (dom e) -> In x (dom e'))).
    intros. destruct (lookup_exists _ _ H1) as [t L].
    apply lookup_inv with t. rewrite H; auto.
  induction 1; intros.
  (* top *)
  constructor; auto. apply wf_type_strengthen with e; eauto.
  (* refl *)
  econstructor; eauto. rewrite H4; eauto.
  (* trans *)
  econstructor; eauto. rewrite H4; auto.
  (* arrow *)
  constructor; auto.
  (* forall *)
  destruct (fresh_name TYPE (dom e ++ dom e' ++ fv_type s2 ++ fv_type t2)) as [x [F K]].
  apply sa_all' with x; eauto.
  apply H2; eauto. constructor; eauto.
  intros x0 K0. simpl. case (eq_name x0 x); auto.
Qed.
*)

Lemma has_type_stable_term_subst:
  forall e1 x b s e2 a t,
  kind x = TERM -> has_type e1 b s -> has_type (e2 ++ (x, s) :: e1) a t ->
  has_type (e2 ++ e1) (subst_term a ((x, b):: nil) nil) t.
Proof.
  - { assert (forall e1 x b s, kind x = TERM -> has_type e1 b s ->
          forall e a t, has_type e a t ->
          forall e2, e = e2 ++ (x, s) :: e1 ->
          has_type (e2 ++ e1) (subst_term a ((x, b)::nil) nil) t).
  induction 3; intros; simpl; subst e.
      - (* var *)
        rewrite lookup_env_append in H3; auto.
        assert (wf_env (e2 ++ e1));
        [ eapply wf_env_append; eauto
        | destruct (eq_name x0 x)];
          [ replace t with s;
            [eapply has_type_weaken; eauto;
             apply env_concat_weaken; auto
            | congruence]
        | constructor; auto].
      - (* fun *)
        destruct (fresh_name TERM (x :: dom (e2 ++ (x, s) :: e1) ++
                             dom (e2 ++ e1) ++
                             fv_type t1 ++
                             fv_term (subst_term a ((x, b):: nil) nil)))
          as [y [F K]].  (* apply t_abs_ generalize (t_abs (e2 ++ e1) t1 (subst_term a ((x, b) :: nil) nil) t2); intros. simpl in  H3.  y K F).  H3. HH.  with y; intros.  *)
        constructor; intros.
        change ((x0, t1) :: e2 ++ e1) with (((x0, t1) :: e2) ++ e1).
        rewrite subst_psubst; auto. rewrite psubst_freshen_term; eauto.
        rewrite <- subst_psubst.
        eapply H2; eauto. apply notIn_app in H4; destruct H4 as [H4l H4r].
        apply notIn_app_1; auto. intro FF; apply H4l. rewrite subst_psubst. simpl in H4r. with (e0; auto. apply H1; eauto. eauto. eauto.
  rewrite (psubst_freshen_term). apply H3; eauto. eauto. eauto.
  (* app *)
  simpl in IHhas_type1. econstructor; eauto.
  (* tfun *)
  destruct (fresh_name TYPE (x :: dom (e2 ++ (x, s) :: e1) ++
                             dom (e2 ++ e1) ++
                             fv_type t2 ++
                             fv_term (psubst_term a x b)))
  as [y [F K]].
  apply t_tabs' with y; eauto.
  change ((y, t1) :: e2 ++ e1)
    with (((y, t1) :: e2) ++ e1).
  rewrite (psubst_freshen_tetyte e1).
  apply H3; eauto. eauto. eauto.
  (* tapp *)
  simpl in IHhas_type.
  econstructor; eauto.
  eapply is_subtype_strengthen. eauto.
  eapply wf_env_append; eauto.
  intros. rewrite lookup_env_append. rewrite eq_name_false. auto.
  congruence.
  eauto.
  (* sub *)
  econstructor; eauto.
  eapply is_subtype_strengthen. eauto.
  eapply wf_env_append; eauto.
  intros. rewrite lookup_env_append. rewrite eq_name_false. auto.
  congruence. eauto.

  eauto.
Qed.
*)

(** * Dynamic semantics *)

(** The dynamic semantics of $F_{<:}$ is specified by a one-step reduction relation,
  in small-step operational style.  We first define values (final results of reduction
  sequences) as a subset of terms. *)

(* value-eval for Abs-term : value-ABS *)

Inductive isvalue: term -> Prop :=
  | isvalue_fun: forall t a,
      isvalue (Fun t a).

(* value-eval for variable term env *)

Inductive v_isvalue : v_termenv -> Prop :=
| v_Nil : v_isvalue nil
| v_Cons : forall ev t n, v_isvalue ev -> isvalue t -> v_isvalue ((n, t) :: ev).

(** We first give a Plotkin-style specification of the reduction
  relation: it uses inductive rules [red_appfun], [red_apparg],
  [red_tapp] instead of contexts to describe reductions inside
  applications.  The two rules [red_appabs] and [red_tapptabs] are the
  familiar beta-reduction rules for term and type applications,
  respectively. *)

(* call-by-value evaluation : reduction  *)

Inductive red: term -> term -> Prop :=
  | red_appabs: forall t a ep v, (* red-beta  *)
      isvalue v ->
      red (App (Fun t a) v) (subst_term a ep ((0,v)::nil))
  | red_appfun: forall a a' b,  (* red-app-1 *)
      red a a' -> red (App a b) (App a' b)
  | red_apparg: forall v b b',  (* red-app-2 *)
      isvalue v -> red b b' -> red (App v b) (App v b').

(** We now give an alternate specification of the reduction relation
  in the style of Wright and Felleisen.  The [red_top] relation
  captures beta-reductions at the top of a term.  Reductions within
  terms are expressed using reduction contexts (see the [red_context]
  relation).  Contexts are represented as functions from terms to
  terms whose shape is constrained by the [is_context] predicate. *)

(*
Inductive red_top: term -> term -> Prop :=
  | red_top_appabs: forall t a v,
      isvalue v ->
      red_top (App (Fun t a) v) (vsubst_term a 0 v)
  | red_top_tapptabs: forall t a t',
      red_top (TApp (TFun t a) t') (vsubst_tety a 0 t').

Inductive is_context: (term -> term) -> Prop :=
  | iscontext_hole:
      is_context (fun a => a)
  | iscontext_app_left: forall c b,
      is_context c -> is_context (fun x => App (c x) b)
  | iscontext_app_right: forall v c,
      isvalue v -> is_context c -> is_context (fun x => App v (c x))
  | iscontext_tapp: forall c t,
      is_context c -> is_context (fun x => TApp (c x) t).

Inductive red_context: term -> term -> Prop :=
  | red_context_intro: forall a a' c,
      red_top a a' -> is_context c -> red_context (c a) (c a').
*)

(** The Plotkin-style relation is more convenient for doing formal
  proofs.  Since the challenge is given in terms of contexts,
  we feel obliged to prove the equivalence between the two formulations
  of reduction.  The proofs are routine inductions over
  the derivations of [red] and [is_context], respectively. *)
(*S
Lemma red_red_context: forall a a', red a a' -> red_context a a'.
Proof.
  induction 1; intros.
  change (App (Fun t a) v) with ((fun x => x) (App (Fun t a) v)).
  change (vsubst_term a 0 v) with ((fun x => x) (vsubst_term a 0 v)).
  constructor. constructor. auto. constructor.
  change (TApp (TFun t a) t') with ((fun x => x) (TApp (TFun t a) t')).
  change (vsubst_tety a 0 t') with ((fun x => x) (vsubst_tety a 0 t')).
  constructor. constructor. constructor.
  inversion IHred; subst.
  change (App (c a0) b) with ((fun x => App (c x) b) a0).
  change (App (c a'0) b) with ((fun x => App (c x) b) a'0).
  constructor. auto. constructor. auto.
  inversion IHred; subst.
  change (App v (c a)) with ((fun x => App v (c x)) a).
  change (App v (c a')) with ((fun x => App v (c x)) a').
  constructor. auto. constructor. auto. auto.
  inversion IHred; subst.
  change (TApp (c a0) t) with ((fun x => TApp (c x) t) a0).
  change (TApp (c a'0) t) with ((fun x => TApp (c x) t) a'0).
  constructor. auto. constructor. auto.
Qed.

Lemma red_context_red: forall a a', red_context a a' -> red a a'.
Proof.
  assert (forall c, is_context c ->
          forall a a', red_top a a' -> red (c a) (c a')).
  induction 1; intros.
  inversion H; constructor; auto.
  apply red_appfun; auto.
  apply red_apparg; auto.
  apply red_tapp; auto.

  intros. inversion H0. auto.
Qed.
S*)

(** * Type soundness proof *)

(** Type soundness for $F_{<:}$ is established by proving the standard properties of
  type preservation (also called subject reduction) and progress. *)

(** ** Preservation *)

(** Technical inversion lemmas on typing derivations. These lemmas are
  similar (but not fully identical) to lemma A.13 in the on-paper proof. *)
(*S
Lemma has_type_fun_inv:
  forall e a t, has_type e a t ->
  forall b s1 u1 u2, a = Fun s1 b -> is_subtype e t (Arrow u1 u2) ->
  is_subtype e u1 s1 /\
  exists s2,
    is_subtype e s2 u2 /\
    (forall x, kind x = TERM -> ~In x (dom e) -> has_type ((x, s1) :: e) (freshen_term b x) s2).
Proof.
  induction 1; intros; try discriminate.
  injection H2; intros; clear H2; subst s1; subst b.
  inversion H3; subst. split. auto.
  exists t2; split; assumption.
  eapply IHhas_type; eauto. eapply sub_trans; eauto.
Qed.

Lemma has_type_tfun_inv:
  forall e a t, has_type e a t ->
  forall b s1 u1 u2, a = TFun s1 b -> is_subtype e t (Forall u1 u2) ->
  is_subtype e u1 s1 /\
  exists s2,
    (forall x, kind x = TYPE -> ~In x (dom e) ->
        is_subtype ((x, u1) :: e) (freshen_type s2 x) (freshen_type u2 x)) /\
    (forall x, kind x = TYPE -> ~In x (dom e) ->
        has_type ((x, s1) :: e) (freshen_tety b x) (freshen_type s2 x)).
Proof.
  induction 1; intros; try discriminate.
  injection H2; intros; clear H2; subst s1 b.
  inversion H3; subst. split. auto.
  exists t2; split. assumption. assumption.
  eapply IHhas_type; eauto. eapply sub_trans; eauto.
Qed.
S*)

(** The preservation theorem states that if term [a] reduces to [a'], then
  all typings valid for [a] are also valid for [a'].  It is
  proved by an outer induction on the reduction and an inner induction
  on the typing derivation (to get rid of subtyping steps). *)

Theorem preservation: forall e a a' t, red a a' -> has_type e a t -> has_type e a' t.
Proof.
  assert (forall a a', red a a' ->
          forall e a0 t, has_type e a0 t -> forall (EQ: a = a0),
          has_type e a' t).
  induction 1; induction 1; intros; simplify_eq EQ; clear EQ; intros; subst.
  (** Case app abs *)
  - (*assert (is_subtype e (Arrow t1 t2) (Arrow t1 t2)). apply sub_refl; eauto.
  destruct (has_type_fun_inv _ _ _ H0_ _ _ _ _ (refl_equal _) H0)
  as [A [s2 [B C]]].
  apply t_sub with s2; auto.*)
  destruct (fresh_name TERM (dom e ++ fv_term a)) as [x [F K]].

  rewrite (vsubst_psubst_freshen_term x); eauto.
  change e with (nil ++ e).
  apply has_type_stable_term_subst with t; auto.
  apply t_sub with t1; auto.
  simpl; eauto.
  (** Case tapp tabs *)
  assert (is_subtype e (Forall t1 t2) (Forall t1 t2)). apply sub_refl; eauto.
  destruct (has_type_tfun_inv _ _ _ H _ _ _ _ (refl_equal _) H1)
  as [A [s2 [B C]]].
  destruct (fresh_name TYPE (dom e ++ fv_term a ++ fv_type t2)) as [x [F K]].
  rewrite (vsubst_psubst_freshen_tety x); eauto.
  rewrite (vsubst_psubst_freshen_type x); eauto.
  apply t_sub with (psubst_type (freshen_type s2 x) x t0).
  change e with (psubst_env nil x t0 ++ e).
  apply has_type_stable_type_subst with t; eauto.
  apply sub_trans with t1; auto.
  simpl; auto.
  change e with (psubst_env nil x t0 ++ e).
  apply sub_stable_subst with t1; eauto. simpl; auto.
  (** Case context left app *)
  apply t_app with t1; eauto.
  (** Case context right app *)
  apply t_app with t1; eauto.
  (** Case context left tapp *)
  apply t_tapp with t1; eauto.
  (** Final conclusion *)
  eauto.
Qed.

(** ** Progress *)

(** The following lemma, which corresponds to lemma A.14 in the challenge statement,
  determines the shape of a value from its type.  Namely, closed values of function
  types are function abstractions, and closed values of polymorphic types are
  type abstractions. *)

Lemma canonical_forms:
  forall e a t, has_type e a t -> e = nil -> isvalue a ->
  match t with
  | Arrow t1 t2 => exists s, exists b, a = Fun s b
  | Forall t1 t2 => exists s, exists b, a = TFun s b
  | Top => True
  | _ => False
  end.
Proof.
  induction 1; intros; subst e.
  inversion H3.
  exists t1; exists a; auto.
  inversion H2.
  exists t1; exists a; auto.
  inversion H2.
  generalize (IHhas_type (refl_equal _) H2).
  inversion H0; auto.
  simpl in H3; discriminate.
Qed.

(** The progress theorem shows that a term well-typed in the empty environment
  is never ``stuck'': either it is a value, or it can reduce.
  The theorem is proved by a simple induction on the typing derivation for the term
  and a case analysis on whether the subterms of the term are values
  or can reduce further. *)

Theorem progress: forall a t, has_type nil a t -> isvalue a \/ exists a', red a a'.
Proof.
  assert (forall e a t, has_type e a t -> e = nil -> isvalue a \/ exists a', red a a').
  induction 1; intros; subst e.
  (** Free variable: impossible in the empty typing environment. *)
  simpl in H1. discriminate.
  (** Function: already a value. *)
  left; constructor.
  (** Application [App a b]. *)
  right.
  destruct (IHhas_type1 (refl_equal _)) as [Va | [a' Ra]].
  destruct (IHhas_type2 (refl_equal _)) as [Vb | [b' Rb]].
    (** [a] and [b] are values.  [a] must be a [Fun].
        Beta-reduction is possible. *)
    generalize (canonical_forms _ _ _ H (refl_equal _) Va).
    intros [s [c EQ]]. subst a.
    exists (vsubst_term c 0 b). constructor. auto.
    (** [a] is a value, but [b] reduces. [App a b] therefore reduces. *)
    exists (App a b'). constructor; auto.
    (** [a] reduces. [App a b] reduces as well. *)
    exists (App a' b). constructor; auto.
  (** Type abstraction: already a value. *)
  left; constructor.
  (** Type application [TApp a t]. *)
  right. destruct (IHhas_type (refl_equal _)) as [Va | [a' Ra]].
    (** [a] is a value. [a] must be a [TFun].  Beta-reduction is possible. *)
    generalize (canonical_forms _ _ _ H (refl_equal _) Va).
    intros [s [b EQ]]. subst a.
    exists (vsubst_tety b 0 t). constructor.
    (** [a] reduces, and so does [TApp a t]. *)
    exists (TApp a' t). constructor; auto.
  (** Subtyping step. *)
  auto.
  (** Final conclusion. *)
  eauto.
Qed.


(**
In this exercise we consider a variant of the previous exercise. We have a
reference which is initially 0 and two threads running in parallel. One thread
increases the value of the reference by 2, whereas the other multiples the
value of the reference by two. An interesting aspect of this exercise is that
the outcome of this program is non-deterministic. Depending on which thread runs
first, the outcome is either 2 or 4.

There is no "fetch-and-multiply" operation in heap_lang, so we use the spin lock
from exercise 3 instead to make both the addition and the multiplication atomic.

Contrary to the earlier exercises, this exercise is nearly entirely open.
*)
From iris.algebra Require Import excl_auth frac_auth.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import proofmode notation lib.par.
From exercises Require Import ex_03_spinlock.

Definition parallel_add_mul : expr :=
  let: "r" := ref #0 in
  let: "l" := newlock #() in
  (
    (acquire "l";; "r" <- !"r" + #2;; release "l")
  |||
    (acquire "l";; "r" <- !"r" * #2;; release "l")
  );;
  acquire "l";;
  !"r".

(** In this proof we will make use of Boolean ghost variables. *)
Section proof.
  Context `{!heapG Σ, !spawnG Σ, !inG Σ (excl_authR boolO)}.

  (** The same helping lemmas for ghost variables that we have already seen in
  the previous exercise. *)
  Lemma ghost_var_alloc b :
    ⊢ |==> ∃ γ, own γ (●E b) ∗ own γ (◯E b).
  Proof.
    iMod (own_alloc (●E b ⋅ ◯E b)) as (γ) "[??]".
    - by apply excl_auth_valid.
    - by eauto with iFrame.
  Qed.

  Lemma ghost_var_agree γ b c :
    own γ (●E b) -∗ own γ (◯E c) -∗ ⌜ b = c ⌝.
  Proof.
    iIntros "Hγ● Hγ◯".
    by iDestruct (own_valid_2 with "Hγ● Hγ◯") as %<-%excl_auth_agree_L.
  Qed.

  Lemma ghost_var_update γ b' b c :
    own γ (●E b) -∗ own γ (◯E c) ==∗ own γ (●E b') ∗ own γ (◯E b').
  Proof.
    iIntros "Hγ● Hγ◯".
    iMod (own_update_2 _ _ _ (●E b' ⋅ ◯E b') with "Hγ● Hγ◯") as "[$$]".
    { by apply excl_auth_update. }
    done.
  Qed.

  (** *Difficult exercise*: come up with a suitable invariant and prove the spec
  of [parallel_add_mul]. In this proof, you should use Boolean ghost variables,
  and the rules for those as given above. You are allowed to use any number of
  Boolean ghost variables. *)
  Definition parallel_add_mul_inv (r : loc) (γ1 γ2 : gname) : iProp Σ :=
    (∃ (b1 b2 : bool) (z : Z),
        r ↦ #z ∗
       ⌜match b1, b2 with
        | true,  true  => (z = 2 ∨ z = 4)%Z
        | true,  false => z = 2%Z
        | false, _     => z = 0%Z
        end⌝
       ∗ own γ1 (●E b1) ∗ own γ2 (●E b2)
    )%I.

  Lemma parallel_add_mul_spec :
    {{{ True }}} parallel_add_mul {{{ z, RET #z; ⌜ z = 2%Z ∨ z = 4%Z ⌝ }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add_mul. wp_alloc r as "Hr". wp_let.
    iMod (ghost_var_alloc false) as (γ1) "[Hγ1● Hγ1◯]".
    iMod (ghost_var_alloc false) as (γ2) "[Hγ2● Hγ2◯]".
    wp_apply (newlock_spec (parallel_add_mul_inv r γ1 γ2) with "[Hr Hγ1● Hγ2●]").
    { iExists false, false, 0%Z. iFrame. simpl. auto. }
    iIntros (l) "#Hl".
    wp_let.
    (* iMod (inv_alloc nroot _ (parallel_add_mul_inv r γ1 γ2) with "[Hγ1● Hγ2●]") as "#Hinvx". *)
    (* { iNext. iExists false, false. iFrame. } *)
    (* wp_bind (_ ||| _)%E. *)
    wp_smart_apply (wp_par (λ _, own γ1 (◯E true)) (λ _, own γ2 (◯E true))
                      with "[Hγ1◯] [Hγ2◯]").
    - wp_bind (acquire _).
      wp_apply (acquire_spec with "Hl"); iIntros "Hr".
      iDestruct "Hr" as (b1 b2 n) "(Hr & Hb & H1 & H2)".
      wp_seq. wp_load. wp_store.
      iDestruct (ghost_var_agree with "H1 Hγ1◯") as %->.
      iDestruct "Hb" as %->.
      iMod (ghost_var_update γ1 true with "H1 Hγ1◯") as "[H1x H1y]".
      wp_apply (release_spec with "[- H1y $Hl]").
      { iExists true, b2, 2%Z. iFrame. iPureIntro. destruct b2; lia. }
        by iIntros.
    - wp_bind (acquire _).
      wp_apply (acquire_spec with "Hl"); iIntros "Hr".
      iDestruct "Hr" as (b1 b2 n) "(Hr & Hb & H1 & H2)".
      wp_seq. wp_load. wp_store.
      iDestruct (ghost_var_agree with "H2 Hγ2◯") as %->.
      iMod (ghost_var_update γ2 true with "H2 Hγ2◯") as "[H1x H1y]".
      wp_apply (release_spec with "[- H1y $Hl]").
      { iExists b1, true, (n * 2)%Z. iFrame.
        destruct b1; iDestruct "Hb" as %->; iPureIntro; lia.
      }
        by iIntros.
    - iIntros (v1 v2) "[H1 H2]".
      iNext.
      wp_seq.
      wp_apply (acquire_spec _ with "Hl"). iIntros "Hr".
      iDestruct "Hr" as  (b1 b2 n) "(Hr & Hb & H1r & H2r)".
      wp_seq; wp_load.
      iApply "Post".
      iDestruct (ghost_var_agree γ1 with "H1r H1") as %->.
      iDestruct (ghost_var_agree γ2 with "H2r H2") as %->.
      auto.
  Qed.
End proof.


Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export MetaTheory.
Set Implicit Arguments.

(*****************************************************************************)
(* Evaluation context based reduction                                        *)
(*****************************************************************************)

Inductive Ctx : Set :=
  | c_hole
  | c_appfun (c: Ctx) (t: Tm)
  | c_apparg (t: Tm) (v: Value t) (c: Ctx)
  | c_prodl  (c: Ctx) (t: Tm)
  | c_prodr  (t: Tm) (val_t: Value t) (c: Ctx)
  | c_let    (p: Pat) (c: Ctx) (t: Tm).

Fixpoint ctx_app (c : Ctx) (t : Tm) {struct c} : Tm :=
  match c with
    | c_hole           => t
    | c_appfun c' t'   => app (ctx_app c' t) t'
    | c_apparg t' _ c' => app t' (ctx_app c' t)
    | c_prodl c' t'    => prod (ctx_app c' t) t'
    | c_prodr t' _ c'  => prod t' (ctx_app c' t)
    | c_let p c' t'    => lett p (ctx_app c' t) t'
  end.

Inductive red : Tm → Tm → Prop :=
  | E_AppAbs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | E_Let {t1 p t2 t3} :
      Value t1 →
      Match p t1 t2 t3 →
      red (lett p t1 t2) t3
  | E_Ctx {c t t'} :
      red t t' → red (ctx_app c t) (ctx_app c t').

(******************************************************************************)
(* Progress.                                                                  *)
(******************************************************************************)

Lemma local_progress (t : Tm) (U : Ty) (wt: Typing empty t U) :
  Value t ∨ ∃ c t0 t0', red t0 t0' ∧ t = ctx_app c t0.
Proof.
  depind wt; simpl; auto.
  - inversion H.
  - right.
    destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq1]]]]]; subst.
    + destruct IHwt2 as [v2|[c2 [s2 [s2' [r2 eq2]]]]]; subst.
      * destruct (can_form_tarr v1 wt1) as [t12 eq_t2]; subst.
        exists c_hole, (app (abs T11 t12) t2), (substTm X0 t2 t12).
        split; auto; apply E_AppAbs; trivial.
      * exists (c_apparg _ v1 c2), s2, s2'; auto.
    + exists (c_appfun c1 t2), s1, s1'; split; trivial.
  - destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq_t1]]]]]; subst.
    + destruct IHwt2 as [v2|[c2 [s2 [s2' [r2 eq_t2]]]]]; subst.
      * left; auto.
      * right; exists (c_prodr _ v1 c2), s2, s2'; auto.
    + right; exists (c_prodl c1 t2), s1, s1'; auto.
  - right.
    destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq_t1]]]]]; subst.
    + destruct (matching_defined H v1 wt1 t2) as [t3 m].
      exists c_hole, (lett p t1 t2), t3; split; auto using E_Let.
    + exists (c_let p c1 t2), s1, s1'; auto.
Qed.

Lemma progress (t : Tm) (U : Ty) (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof.
  destruct (local_progress wt) as [val_t|(c & s & s' & r & eq)]; auto.
  right; exists (ctx_app c s'); subst; apply E_Ctx; auto.
Qed.

(******************************************************************************)
(* Preservation.                                                              *)
(******************************************************************************)

Lemma context_replacement {Γ c t t' T}
  (hyp: ∀ T', Typing Γ t T' → Typing Γ t' T') :
  Typing Γ (ctx_app c t) T → Typing Γ (ctx_app c t') T.
Proof.
  intro wt; depind wt; induction c; simpl in *; subst;
    try discriminate; try (inversion x; subst); eauto using Typing.
Qed.

Lemma local_preservation_app {Γ} t12 t2 T11 U :
  Typing Γ (app (abs T11 t12) t2) U → Typing Γ (substTm X0 t2 t12) U.
Proof.
  intro wt; depind wt.
  - inversion wt1; eauto using subst_evar_typing with infra.
Qed.

Lemma local_preservation_lett' {Γ} p t1 t2 U t3 :
  Typing Γ (lett p t1 t2) U → Match p t1 t2 t3 →
  Typing Γ t3 U.
Proof.
  intro wt; dependent destruction wt;
    eauto using local_preservation_lett.
Qed.

Lemma preservation {t t'} (r: red t t') :
  ∀ {Γ T}, Typing Γ t T → Typing Γ t' T.
Proof.
  induction r.
  - eauto using local_preservation_app.
  - eauto using local_preservation_lett'.
  - eauto using context_replacement.
Qed.