(** * Simplicial Complexes *)

From Coq Require Import
  Lists.List Sets.Ensembles Sets.Powerset_facts QArith.QArith.
From DEZ.Is Require Export
  Equivalence.

Arguments Ensembles.Empty_set {_}.
Arguments Ensembles.In {_} _ _.
Arguments Included {_} _ _.
Arguments Singleton {_} _.
Arguments Union {_} _ _.
Arguments Same_set {_} _ _.

(** ** Abstract Simplicial Complex *)

(** We deviate slightly from the standard definition.
    Instead of requiring that every subset of the set of faces is nonempty,
    we require that the empty set is a face in every complex. *)

Class IsAbsSimpComp (A : Type) (F : Ensemble (Ensemble A)) : Prop := {
  abs_simp_comp_nonempty : Ensembles.In F Ensembles.Empty_set;
  abs_simp_comp_cumulative (P S : Ensemble A) (C : Included P S)
    (E : Ensembles.In F S) : Ensembles.In F P;
}.

Inductive IsIm (A B : Type) (X : B -> B -> Prop) (P : Ensemble A)
  (f : A -> B) : Ensemble B :=
  IsIm_intro (x : A) (J : In P x) (y : B) (a : X y (f x)) :
  Ensembles.In (IsIm X P f) y.

(** ** Simplicial Complex *)

Class IsSimpComp (A B : Type)
  (F : Ensemble (Ensemble A)) (X : B -> B -> Prop)
  (K : Ensemble B -> Ensemble B -> Ensemble B -> Prop)
  (f : A -> B) : Prop := {
  simp_comp_is_equiv :> IsEquiv X;
  simp_comp_is_abs_simp_comp :> IsAbsSimpComp F;
  simp_comp_coherent (P S : Ensemble A)
    (EP : Ensembles.In F P) (ES : Ensembles.In F S)
    (T : Ensemble B) (ET : K (IsIm X P f) (IsIm X S f) T) :
    exists V : Ensemble A, Ensembles.In F V ->
    Included V P /\ Included V S;
}.

Module Example.

Import ListNotations.

#[local] Open Scope nat_scope.

Equations Ensemble_of_list (A : Type) (a : list A) : Ensemble A :=
  Ensemble_of_list [] := Ensembles.Empty_set;
  Ensemble_of_list (x :: b) := Union (Singleton x) (Ensemble_of_list b).

Definition P0 : Ensemble nat := Ensemble_of_list [].
Definition P1 : Ensemble nat := Ensemble_of_list [6].
Definition P2 : Ensemble nat := Ensemble_of_list [7].
Definition P3 : Ensemble nat := Ensemble_of_list [8].
Definition P4 : Ensemble nat := Ensemble_of_list [9].
Definition P5 : Ensemble nat := Ensemble_of_list [11].
Definition P6 : Ensemble nat := Ensemble_of_list [6; 7].
Definition P7 : Ensemble nat := Ensemble_of_list [6; 8].
Definition P8 : Ensemble nat := Ensemble_of_list [7; 8].
Definition P9 : Ensemble nat := Ensemble_of_list [8; 9].
Definition P10 : Ensemble nat := Ensemble_of_list [6; 7; 8].

Equations F : Ensemble (Ensemble nat) :=
  F P := Exists (Same_set P) [P0; P1; P2; P3; P4; P5; P6; P7; P8; P9; P10].

#[local] Instance is_abs_simp_comp : IsAbsSimpComp F.
Proof.
  unfold F.
  split.
  { left. split. apply Included_Empty. apply Included_Empty. }
  (* unfold P0, P1, P2, P3, P4, P5, P6, P7, P8, P9, P10. *)
  (* unfold Ensemble_of_list. *)
  intros S T C E. inversion E as [V a X | V a X]; subst.
  - destruct X as [C0 C1]. hnf. left.
    split. eapply Inclusion_is_transitive; eauto.
    unfold P0. unfold Ensemble_of_list. apply Included_Empty.
  - hnf. right. inversion X; subst.
    admit.
Admitted.

Equations Q2eq (x y : Q * Q) : Prop :=
  Q2eq (x0, x1) (y0, y1) := Qeq x0 y0 /\ Qeq x1 y1.

#[local] Existing Instances
  QOrderedType.Q_as_OT.eq_refl
  QOrderedType.Q_as_OT.eq_sym
  QOrderedType.Q_as_OT.eq_trans.

#[local] Instance Q2eq_is_refl : IsRefl Q2eq.
Proof. intros [x0 x1]. split; reflexivity. Qed.

#[local] Instance Q2eq_is_sym : IsSym Q2eq.
Proof.
  intros [x0 x1] [y0 y1] [a0 a1].
  split; symmetry; assumption.
Qed.

#[local] Instance Q2eq_is_trans : IsTrans Q2eq.
Proof.
  intros [x0 x1] [y0 y1] [z0 z1] [a0 a1] [b0 b1].
  split; etransitivity; eassumption.
Qed.

#[local] Instance Q2eq_is_equiv : IsEquiv Q2eq.
Proof. split; typeclasses eauto. Qed.

Equations K_dec (x y : list (Q * Q)) : list (list (Q * Q)) :=
  K_dec x y := (** Tricky! *) [].

Equations K (x y z : Ensemble (Q * Q)) : Prop :=
  K x y z := (** Tricky! *) False.

#[local] Open Scope Q_scope.

Equations f (n : nat) : Q * Q :=
  f 6 := (8.5, 161);
  f 7 := (143, 169);
  f 8 := (157.5, 8.5);
  f 9 := (255.5, 24);
  f 11 := (31, 260);
  f _ := (0, 0).

#[local] Instance is_simp_comp : IsSimpComp F Q2eq K f.
Proof.
  split.
  - typeclasses eauto.
  - typeclasses eauto.
  - intros P S EP ES T ET. inversion ET.
Qed.

End Example.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.priority.
Require Import rt.model.schedule.global.schedulability.
Require Import rt.model.schedule.global.jitter.job rt.model.schedule.global.jitter.schedule
               rt.model.schedule.global.jitter.platform.
Require Import rt.analysis.global.jitter.workload_bound
               rt.analysis.global.jitter.interference_bound_edf
               rt.analysis.global.jitter.bertogna_edf_comp.
Require Import rt.implementation.global.jitter.job
               rt.implementation.global.jitter.task
               rt.implementation.global.jitter.schedule
               rt.implementation.global.jitter.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisEDF.

  Import JobWithJitter ScheduleWithJitter SporadicTaskset Priority Schedulability Platform InterferenceBoundEDFJitter WorkloadBoundJitter ResponseTimeIterationEDF.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 2; task_period := 5; task_deadline := 3; task_jitter := 1|}.
    Let tsk2 := {| task_id := 2; task_cost := 4; task_period := 6; task_deadline := 5; task_jitter := 0|}.
    Let tsk3 := {| task_id := 3; task_cost := 2; task_period := 12; task_deadline := 11; task_jitter := 2|}.

    (* Let ts be a task set containing these three tasks. *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    Section FactsAboutTaskset.

      Fact ts_has_valid_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

      Fact ts_has_constrained_deadlines:
        forall tsk,
          tsk \in ts ->
          task_deadline tsk <= task_period tsk.
      Proof.
        intros tsk IN.
        repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
      Qed.

    End FactsAboutTaskset.

    (* Assume there are two processors. *)
    Let num_cpus := 2.

    (* Recall the EDF RTA schedulability test. *)
    Let schedulability_test :=
      edf_schedulable task_cost task_period task_deadline task_jitter num_cpus.

    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      unfold schedulability_test, edf_schedulable, edf_claimed_bounds; desf.
      apply negbT in Heq; move: Heq => /negP ALL.
      exfalso; apply ALL; clear ALL.
      assert (STEPS: \sum_(tsk <- ts) (task_deadline tsk - task_cost tsk) + 1 = 12).
      {
        by rewrite unlock; compute.
      } rewrite STEPS; clear STEPS.

      Ltac f :=
        unfold edf_rta_iteration; simpl;
        unfold edf_response_time_bound, div_floor, total_interference_bound_edf, interference_bound_edf, interference_bound_generic, W_jitter; simpl;
        repeat rewrite addnE;
        repeat rewrite big_cons; repeat rewrite big_nil;
        repeat rewrite addnE; simpl;
        unfold num_cpus, divn; simpl.

      rewrite [edf_rta_iteration]lock; simpl.

      unfold locked at 12; destruct master_key; f.
      unfold locked at 11; destruct master_key; f.
      unfold locked at 10; destruct master_key; f.
      unfold locked at 9; destruct master_key; f.
      unfold locked at 8; destruct master_key; f.
      unfold locked at 7; destruct master_key; f.
      unfold locked at 6; destruct master_key; f.
      unfold locked at 5; destruct master_key; f.
      unfold locked at 4; destruct master_key; f.
      unfold locked at 3; destruct master_key; f.
      unfold locked at 2; destruct master_key; f.
      by unfold locked at 1; destruct master_key; f.
    Qed.

    (* Let arr_seq be the periodic arrival sequence from ts. *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* Let sched be the work-conserving EDF scheduler. *)
    Let sched := scheduler job_arrival job_cost job_jitter num_cpus arr_seq
                           (JLFP_to_JLDP (EDF job_arrival job_deadline)).

    (* Recall the definition of deadline miss. *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* Next, we prove that ts is schedulable with the result of the test. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      intros tsk IN.
      have VALID := periodic_arrivals_valid_job_parameters ts ts_has_valid_parameters.
      have VALIDTS := ts_has_valid_parameters.
      unfold valid_sporadic_job_with_jitter,
             valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_edf_rta with (task_cost := task_cost) (task_period := task_period)
               (task_deadline := task_deadline) (ts0 := ts) (task_jitter := task_jitter)
               (job_jitter := job_jitter); try (by done).
      - by apply ts_has_constrained_deadlines.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_execute_after_jitter.
      - apply scheduler_completed_jobs_dont_execute.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - apply scheduler_sequential_jobs.
        -- by apply periodic_arrivals_are_consistent.
        -- by apply periodic_arrivals_is_a_set.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy.
        -- by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- by intros t x y; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisEDF.


Require Export Iron.Language.SystemF2Effect.Store.Bind.

(******************************************************************************)
(* Types of store bindings. *)
Inductive TypeB : kienv -> tyenv -> stenv -> stprops -> stbind -> ty -> Prop :=
 (* A store binding that contains a live value.
    Requiring that the region handle is well kinded ensures that it's
    mentioned in the store properties. *)
 | TbValue
   :  forall ke te se sp p v t
   ,  In (SRegion p) sp
   -> TypeV  ke te se sp v t
   -> TypeB  ke te se sp (StValue p v) (TRef (TRgn p) t)

 (* After a store binding has been dealloated,
    we can treat the location has having any type we want.
    The progress theorem guarantees these dead bindings will never be read,
    so there is no opportunity to treat it has having the wrong type. *)
 | TbDead
   :  forall ke te se sp p t
   ,  In (SRegion p) sp
   -> TypeB  ke te se sp (StDead p)    (TRef (TRgn p) t).

Hint Constructors TypeB.

(******************************************************************************)
(* Weakening store environment in type of store binding *)
Lemma typeB_stenv_snoc
 :  forall ke te se sp v t1 t2
 ,  TypeB  ke te se sp v t1
 -> ClosedT t2
 -> TypeB  ke te (t2 <: se) sp v t1.
Proof.
 intros.
 inverts H; eauto.
Qed.
Hint Resolve typeB_stenv_snoc.

(* Weakening store properties  in type of store binding *)
Lemma typeB_stprops_snoc
 :  forall ke te se sp v t p
 ,  TypeB  ke te se sp v t
 -> TypeB  ke te se (p <: sp) v t.
Proof.
 intros.
 inverts H; eauto using kind_stprops_snoc.
Qed.
Hint Resolve typeB_stprops_snoc.

Lemma typeB_stprops_cons
 :  forall ke te se sp v t p
 ,  TypeB  ke te se sp v t
 -> TypeB  ke te se (sp :> p) v t.
Proof.
 intros.
 inverts H; eauto using kind_stprops_cons.
Qed.
Hint Resolve typeB_stprops_snoc.

Lemma typeB_mergeT
 :  forall ke te se sp b t p1 p2
 ,  In (SRegion p1) sp
 -> TypeB  ke te se sp b t
 -> TypeB  ke (mergeTE p1 p2 te) (mergeTE p1 p2 se) sp
              (mergeB p1 p2 b) (mergeT p1 p2 t).
Proof.
 intros.
 destruct b.

 Case "StValue".
 { have (p2 = n \/ ~(p2 = n)) as HN.
   inverts HN.
   - inverts H0.
     + snorm; subst.
       * eapply TbValue; eauto.
         eapply TxVal in H9.
         eapply mergeX_typeX in H9.
         inverts H9. eauto.
         inverts_kind. auto.
       * nope.
   - inverts H0.
     + snorm; subst.
       * nope.
       * eapply TbValue; eauto.
         eapply TxVal in H10.
         eapply mergeX_typeX in H10.
         inverts H10. eauto. auto.
 }

 Case "StDead".
 { have (p2 = n \/ ~(p2 = n)) as HN.
   inverts HN.
   - inverts H0.
     snorm.
   - inverts H0.
     snorm.
 }
Qed.


(* Prove that all real number instances are equivalent *)

Require Import Real.
Require Import testsearch.
Require Import rounding.
Require Import Psatz.

Lemma Npow2_hom : forall n m, Npow2 (n + m)%nat = ((Npow2 n) * (Npow2 m))%nat.
Proof.
  intros.
  induction n.
  simpl; lia.
  simpl.
  rewrite IHn.
  lia.
Defined.

Section RealEquivalent.

  Generalizable Variables K M Real_S Real_T.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real_S : Type}
          {SemiDecOrderedField_Real_S : SemiDecOrderedField Real_S}
          {ComplArchiSemiDecOrderedField_Real_S : @ComplArchiSemiDecOrderedField _ _ _ SemiDecOrderedField_Real_S}
          {Real_T : Type}
          {SemiDecOrderedField_Real_T : SemiDecOrderedField Real_T}
          {ComplArchiSemiDecOrderedField_Real_T : @ComplArchiSemiDecOrderedField _ _ _ SemiDecOrderedField_Real_T}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (@realTheory _ _ Real_S _ ) (constants [IZReal_tac]).
  Add Ring realRing : (@realTheory _ _ Real_T _ ) (constants [IZReal_tac]).

  (* Context (S T : ComplArchiSemiDecOrderedField). *)
  (* Notation SR := (CarrierField S). *)
  (* Notation TR := (CarrierField T). *)

  (* Ltac S_IZReal_tac t := *)
  (*   match t with *)
  (*   | @real_0 SR => constr:(0%Z) *)
  (*   | @real_1 SR => constr:(1%Z) *)
  (*   | @IZreal SR ?u => *)
  (*     match isZcst u with *)
  (*     | true => u *)
  (*     | _ => constr:(InitialRing.NotConstant) *)
  (*     end *)
  (*   | _ => constr:(InitialRing.NotConstant) *)
  (*   end. *)

  (* Add Ring realRing : (realTheory SR) (constants [S_IZReal_tac]). *)

  (* Ltac T_IZReal_tac t := *)
  (*   match t with *)
  (*   | @real_0 TR => constr:(0%Z) *)
  (*   | @real_1 TR => constr:(1%Z) *)
  (*   | @IZreal TR ?u => *)
  (*     match isZcst u with *)
  (*     | true => u *)
  (*     | _ => constr:(InitialRing.NotConstant) *)
  (*     end *)
  (*   | _ => constr:(InitialRing.NotConstant) *)
  (*   end. *)

  (* Add Ring realRing : (realTheory TR) (constants [T_IZReal_tac]). *)

  Lemma converging_dyadic_sequence_converging :
    forall f : nat -> M Z, @M_is_fast_cauchy _ _ _ _ _ _ Real_S _ _ (@dyadic_M_sequence _ _ _ _ _ _ f) -> @M_is_fast_cauchy _ _ _ _ _ _ Real_T _ _ (@dyadic_M_sequence _ _ _ _ _  _ f).
  Proof.
    intros.
    intros n m.
    rewrite M_all_picture_1.
    intros.
    rewrite M_all_picture_1.
    intros.
    pose proof (H n m).
    rewrite M_all_picture_1 in H2.
    unfold dyadic_M_sequence in H0.
    unfold dyadic_M_sequence in H1.
    rewrite M_fun_cont in H0.
    rewrite M_fun_cont in H1.
    destruct H0.
    destruct H0.
    destruct H1.
    destruct H1.
    induction (eq_sym H3).
    induction (eq_sym H4).
    clear H3 H4.
    assert (@dist _ _ _ _ _ _  Real_S _ _ (prec n * IZreal x) (prec m * IZreal x0) <= (@prec _ _ Real_S _   n) + (@prec _ _ Real_S _ m)).
    pose proof (H2 (prec n * IZreal x)).
    unfold dyadic_M_sequence in H3.
    rewrite M_fun_cont in H3.
    assert (exists a : Z, M_picture_1 (f n) a /\ @prec _ _ Real_S _ n * IZreal x = prec n * IZreal a).
    exists x.
    split; auto.
    pose proof (H3 H4).
    rewrite M_all_picture_1 in H5.
    pose proof (H5 (prec m * IZreal x0)).
    apply H6.
    rewrite M_fun_cont.
    exists x0.
    auto.

    apply (real_le_mult_pos_le (@Nreal _ _ Real_S _ (Npow2 (n + m)%nat)) _ _ (Nreal_Npow2_pos _ )) in H3.
    rewrite (@dist_scale _ _ _ _ _ _ Real_S _ _ (prec n * IZreal x) (prec m * IZreal x0) (Nreal (Npow2 (n + m)%nat)) (Nreal_Npow2_pos _)) in H3.
    rewrite Npow2_hom in H3.
    rewrite Nreal_mult in H3.
    replace (Nreal (Npow2 n) * Nreal (Npow2 m) * (prec n * IZreal x)) with
        (prec n * @Nreal _ _ Real_S _ (Npow2 n) * (Nreal (Npow2 m) * IZreal x)) in H3 by ring.
    replace (Nreal (Npow2 n) * Nreal (Npow2 m) * (prec m * IZreal x0)) with
        (prec m * @Nreal _ _ Real_S _ (Npow2 m)  * (Nreal (Npow2 n) * IZreal x0)) in H3 by ring.

    replace (  Nreal (Npow2 n) * Nreal (Npow2 m) * (prec n + prec m)) with
        ((@prec _ _ Real_S _ n * Nreal (Npow2 n)) * Nreal (Npow2 m) + (prec m * Nreal (Npow2 m) * Nreal (Npow2 n))) in H3 by ring.

    rewrite prec_Npow2_unit in H3.
    rewrite prec_Npow2_unit in H3.
    rewrite real_mult_unit in H3.
    rewrite real_mult_unit in H3.
    rewrite real_mult_unit in H3.
    rewrite real_mult_unit in H3.

    rewrite IZreal_Nreal in H3.
    rewrite IZreal_Nreal in H3.
    rewrite <- IZreal_hom in H3.
    rewrite <- IZreal_mult_hom in H3.
    rewrite <- IZreal_mult_hom in H3.
    rewrite IZreal_dist in H3.
    rewrite IZreal_le in H3.

    rewrite <- (@IZreal_le _ _ Real_T _) in H3.
    rewrite <- IZreal_dist in H3.
    rewrite  IZreal_mult_hom in H3.
    rewrite  IZreal_mult_hom in H3.
    rewrite  IZreal_hom in H3.
    rewrite <- IZreal_Nreal in H3.
    rewrite <- IZreal_Nreal in H3.
    apply (real_le_mult_pos_le ((prec (n + m)%nat)) _ _ (prec_pos _ )) in H3.
    rewrite dist_scale in H3.
    rewrite prec_hom in H3.
    replace  (prec n * prec m * (Nreal (Npow2 m) * IZreal x))  with
         (@prec _ _ Real_T _ m * Nreal (Npow2 m) * prec n * IZreal x) in H3 by ring.
    replace  (prec n * prec m * (Nreal (Npow2 n) * IZreal x0))  with
         (@prec _ _ Real_T _ n * Nreal (Npow2 n) * prec m * IZreal x0) in H3 by ring.
    replace (prec n * prec m * (Nreal (Npow2 m) + Nreal (Npow2 n))) with
        (@prec _ _ Real_T _ m * Nreal (Npow2 m) * prec n + prec n * Nreal (Npow2 n) * prec m) in H3 by ring.
    rewrite prec_Npow2_unit in H3.
    rewrite prec_Npow2_unit in H3.
    rewrite real_mult_unit in H3.
    rewrite real_mult_unit in H3.
    exact H3.
    apply prec_pos.
  Defined.

  Definition translate_inj :
    forall a b f g x y,
      M_is_fast_limit_all a (@dyadic_M_sequence _ _ _ _ Real_S _ f) ->
      M_is_fast_limit_all b (@dyadic_M_sequence _ _ _ _ Real_S _ g) ->
      M_is_fast_limit_all x (@dyadic_M_sequence _ _ _ _ Real_T _ f) ->
      M_is_fast_limit_all y (@dyadic_M_sequence _ _ _ _ Real_T _ g) ->
      a = b -> x = y.
  Proof.
    intros.
    induction H3.
    apply (proj1  (dist_zero x y)).
    destruct (dist_pos x y); auto.
    pose proof (real_Archimedean _ H3).
    destruct H4 as [p].
    pose proof (M_W_destruct (f (p + 2)%nat)).
    destruct H5.
    pose proof (M_W_destruct (g (p + 2)%nat)).
    destruct H6.
    pose proof (H (p + 2)%nat).
    pose proof (H0 (p + 2)%nat).
    rewrite M_all_picture_1 in H7.
    rewrite M_all_picture_1 in H8.
    assert (dist a (prec (p + 2)%nat * IZreal x0 ) <= prec (p + 2)%nat).
    apply H7.
    unfold dyadic_M_sequence.
    rewrite M_fun_cont.
    exists x0.
    split; auto.
    assert (dist a (prec (p + 2)%nat * IZreal x1 ) <= prec (p + 2)%nat).
    apply H8.
    unfold dyadic_M_sequence.
    rewrite M_fun_cont.
    exists x1.
    split; auto.
    clear H7 H8.
    rewrite dist_symm in H10.
    pose proof (real_le_le_plus_le _ _ _ _ H10 H9).
    pose proof (real_le_le_le _ _ _ (real_ge_le _ _ (dist_tri _ _ _ )) H7).
    clear H9 H10 H7.
    pose proof (H1 (p + 2)%nat).
    rewrite M_all_picture_1 in H7.
    assert (dist x (prec (p + 2) * IZreal x0) <= prec (p + 2)).
    apply H7.
    unfold dyadic_M_sequence.
    rewrite M_fun_cont.
    exists x0; auto.
    clear H7.
    pose proof (H2 (p + 2)%nat).
    rewrite M_all_picture_1 in H7.
    assert (dist y (prec (p + 2) * IZreal x1) <= prec (p + 2)).
    apply H7.
    unfold dyadic_M_sequence.
    rewrite M_fun_cont.
    exists x1; auto.
    clear H7.

    (* transporting *)
    assert (
        @dist _ _ _ _ _ _ Real_T _ _  (prec (p + 2) * IZreal x1) (prec (p + 2) * IZreal x0) <= prec (p + 2) + prec (p + 2)
      ).
    clear H5 H6 H9 H10.
    apply (real_le_mult_pos_le (@Nreal _ _ Real_S _ (Npow2 (p + 2)%nat)) _ _ (Nreal_Npow2_pos _ )) in H8.
    rewrite (dist_scale) in H8.
    replace  (Nreal (Npow2 (p + 2)) * (prec (p + 2) * IZreal x1)) with
         (@prec _ _ Real_S _ (p + 2) * Nreal (Npow2 (p + 2)) * IZreal x1) in H8 by ring.
    replace  (Nreal (Npow2 (p + 2)) * (prec (p + 2) * IZreal x0)) with
         (@prec _ _ Real_S _ (p + 2) * Nreal (Npow2 (p + 2)) * IZreal x0) in H8 by ring.
    replace (Nreal (Npow2 (p + 2)) * (prec (p + 2) + prec (p + 2))) with
        (@prec _ _ Real_S _ (p + 2) * Nreal (Npow2 (p + 2)) + prec (p + 2) * Nreal (Npow2 (p + 2))) in H8 by ring.

    rewrite prec_Npow2_unit in H8.
    rewrite real_mult_unit in H8.
    rewrite real_mult_unit in H8.
    replace (real_1 + real_1) with (@IZreal _ _ Real_S _ 2) in H8 by ring.
    rewrite IZreal_dist in H8.
    rewrite IZreal_le in H8.

    rewrite <- (@IZreal_le _ _ Real_T _ ) in H8.
    rewrite <- IZreal_dist in H8.
    (* replace (IZreal x1) with (@real_1 TR * IZreal x1) in H8 by ring. *)
    (* replace (IZreal x0) with (@real_1 TR * IZreal x0) in H8 by ring. *)
    replace (IZreal 2) with (@real_1 _ _ Real_T _ + real_1) in H8 by ring.
    apply (real_le_mult_pos_le ((prec (p + 2)%nat)) _ _ (prec_pos _ )) in H8.
    rewrite dist_scale in H8.
    replace (prec (p + 2) * (real_1 + real_1)) with (@prec _ _ Real_T _ (p + 2) + prec (p + 2)) in H8 by ring.
    exact H8.
    apply prec_pos.
    apply Nreal_Npow2_pos.
    (* done *)
    clear H8.
    pose proof (real_le_le_plus_le _ _ _ _ H10 H7).
    pose proof (real_le_le_le _ _ _ (real_ge_le _ _ (dist_tri _ _ _)) H8).
    rewrite dist_symm in H9.
    pose proof (real_le_le_plus_le _ _ _ _ H11 H9).
    pose proof (real_le_le_le _ _ _ (real_ge_le _ _ (dist_tri _ _ _)) H12).
    replace (p + 2)%nat with (p + 1 + 1)%nat in H13 by lia.
    rewrite prec_twice in H13.
    rewrite real_plus_comm in H13.
    rewrite <- real_plus_assoc in H13.
    rewrite prec_twice in H13.
    rewrite prec_twice in H13.
    rewrite dist_symm in H13.
    contradiction (real_gt_nle _ _ H4 H13).
  Defined.

End RealEquivalent.

Section RealEquivalent2.

  Generalizable Variables K M Real_S Real_T.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real_S : Type}
          {SemiDecOrderedField_Real_S : SemiDecOrderedField Real_S}
          {ComplArchiSemiDecOrderedField_Real_S : @ComplArchiSemiDecOrderedField _ _ _ SemiDecOrderedField_Real_S}
          {Real_T : Type}
          {SemiDecOrderedField_Real_T : SemiDecOrderedField Real_T}
          {ComplArchiSemiDecOrderedField_Real_T : @ComplArchiSemiDecOrderedField _ _ _ SemiDecOrderedField_Real_T}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (@realTheory _ _ Real_S _ ) (constants [IZReal_tac]).
  Add Ring realRing : (@realTheory _ _ Real_T _ ) (constants [IZReal_tac]).

  Definition translation : Real_S -> Real_T.
  Proof.
    intros x.
    pose proof (converging_dyadic_M_sequence x).
    destruct X.
    destruct a.

    pose proof (@converging_dyadic_sequence_converging _ _ _ _ _ _ Real_S _ _ Real_T _ _ x0 H).
    pose proof (real_mslimit_all (@dyadic_M_sequence _ _ _ _ Real_T _ x0) H1).
    destruct X.
    exact x1.
  Defined.

  Definition translation_inv : Real_T -> Real_S.
  Proof.
    intros x.
    pose proof (converging_dyadic_M_sequence x).
    destruct X.
    destruct a.
    pose proof (@converging_dyadic_sequence_converging _ _ _ _ _ _  Real_T _ _ Real_S _ _ x0 H).
    pose proof (real_mslimit_all (@dyadic_M_sequence _ _ _ _ Real_S _ x0) H1).
    destruct X.
    exact x1.
  Defined.

  Theorem Reals_equivalent : is_equiv translation.
  Proof.
    exists translation_inv.
    split.
    unfold translation.
    unfold translation_inv.
    unfold id.
    unfold fc.
    apply fun_ext; intro.
    destruct (converging_dyadic_M_sequence x).
    destruct a.
    destruct ( real_mslimit_all (dyadic_M_sequence x0) (@converging_dyadic_sequence_converging _ _ _ _ _ _  Real_S _ _ Real_T _ _ x0 m)).
    destruct ( converging_dyadic_M_sequence x1).
    destruct a.
    destruct (real_mslimit_all (dyadic_M_sequence x2) (@converging_dyadic_sequence_converging _ _ _ _ _ _ Real_T _ _ Real_S _ _ x2 m2)).
    apply eq_sym, (translate_inj x1 x1 x0 x2 x x3 m1 m3 ); auto.

    unfold translation.
    unfold translation_inv.
    unfold id.
    unfold fc.
    apply fun_ext; intro.
    destruct (converging_dyadic_M_sequence x).
    destruct a.
    destruct ( @real_mslimit_all _ _ _ _ _ _ _ _ _ (@dyadic_M_sequence _ _ _ _ Real_S _ x0) (@converging_dyadic_sequence_converging _ _ _ _ _ _ Real_T _ _  Real_S _ _  x0 m)).
    destruct (@converging_dyadic_M_sequence _ _ _ _ _ _ Real_S _ _  x1 ).
    destruct a.
    destruct (@real_mslimit_all _ _ _ _ _ _ _ _ _  (@dyadic_M_sequence _ _ _ _ Real_T _ x2) (@converging_dyadic_sequence_converging _ _ _ _ _ _ Real_S _ _  Real_T _ _ x2 m2)).

    apply eq_sym, (translate_inj x1 x1 x0 x2 x x3 m1 m3 ); auto.
  Defined.

End RealEquivalent2.


(***************************************************************************
* System-F pure with capabilities                                          *
* (based on the F<: implementation in locally-nameless project)            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.
Implicit Types X : var.

(* ********************************************************************** *)
(** * Description of the Language *)

(** Representation of pre-types *)

Inductive typ       : Set   :=
  | typ_bvar        : nat -> typ
  | typ_fvar        : var -> typ
  | typ_base        : typ
  | typ_eff         : typ
  | typ_stoic  : typ -> typ -> typ       (* effect closeded term abstraction *)
  | typ_all    : typ -> typ.             (* effect closeded type abstraction *)

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : trm -> trm
  | trm_tapp : trm -> typ -> trm.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar J            => If K = J then U else (typ_bvar J)
  | typ_fvar X            => typ_fvar X
  | typ_base              => typ_base
  | typ_eff               => typ_eff
  | typ_stoic T1 T2       => typ_stoic (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1            => typ_all (open_tt_rec (S K) U T1)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

(** Opening up a type binder occuring in a term *)

Fixpoint open_te_rec (K : nat) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_app e1 e2 => trm_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | trm_tabs e1   => trm_tabs (open_te_rec (S K) U e1)
  | trm_tapp e1 V => trm_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Definition open_te t U := open_te_rec 0 U t.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | trm_tabs e1   => trm_tabs (open_ee_rec k f e1)
  | trm_tapp e1 V => trm_tapp (open_ee_rec k f e1) V
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (open_tt T (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

(** Types as locally closeded pre-types *)

Inductive type : typ -> Prop :=
  | type_var : forall X,
      type (typ_fvar X)
  | type_base: type typ_base
  | type_eff: type typ_eff
  | type_stoic : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_stoic T1 T2)
  | type_all : forall L T2,
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all T2).

(** Terms as locally closeded pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L e1,
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Environment is an associative list of bindings. *)

(** Binding are either mapping type or term variables.
 [: X :] is a type variable asumption and [x ~: T] is
 a typing assumption *)

Inductive bind : Set :=
  | bind_tvar : bind
  | bind_typ  : typ -> bind.

Notation "[: X :]" := (X ~ bind_tvar)
  (at level 23) : env_scope.
Notation "x ~: T" := (x ~ bind_typ T)
  (at level 24, left associativity) : env_scope.

Definition env := LibEnv.env bind.

(** Well-formedness of a pre-type T in an environment E: all the type
  variables of T must be bound via [: T :] in E. This predicates
  implies that T is a type *)

Inductive wft : env -> typ -> Prop :=
  | wft_var : forall E X,
      binds X bind_tvar E ->
      wft E (typ_fvar X)
  | wft_stoic : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_stoic T1 T2)
  | wft_all : forall L E T,
      (forall X, X \notin L ->
        wft (E & [: X :]) (T open_tt_var X)) ->
      wft E (typ_all T).

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_X : forall E X,
      okt E -> X # E -> okt (E & [: X :])
  | okt_typ : forall E x T,
      okt E -> wft E T -> x # E -> okt (E & x ~: T).

(* closed rules *)
Fixpoint closed_typ(t: typ) := match t with
  | typ_bvar _          => false  (* impossible, ill-formed *)
  | typ_fvar _          => true
  | typ_base            => true
  | typ_eff             => false
  | typ_stoic U V       => true   (* effect-closed lambda abstraction *)
  | typ_all T           => true   (* effect-closed type abstraction *)
  end.

Fixpoint pure(E: env) := match E with
  | nil => nil
  | cons (X, bind_tvar) E' => cons (X, bind_tvar) (pure E')
  | cons (x, bind_typ T) E' => if closed_typ T then
                               cons (x, bind_typ T) (pure E')
                             else
                               pure E'
    end.

(* capsafe types are not capability producing, i.e. capable of creating an instance of E *)
Inductive capsafe: typ -> Prop :=
 | capsafe_base: capsafe typ_base
 | capsafe_var: forall X, capsafe (typ_fvar X)
 | capsafe_eff_any: forall S T, type T -> caprod S -> capsafe (typ_stoic S T)
 | capsafe_any_safe: forall S T, type S -> capsafe T -> capsafe (typ_stoic S T)
 | capsafe_all: forall L T, type (typ_all T) ->
                          (forall X, X \notin L -> capsafe (T open_tt_var X)) ->
                          capsafe (typ_all T)

with caprod: typ -> Prop :=
 | caprod_eff: caprod typ_eff
 | caprod_safe_eff: forall S T, capsafe S -> caprod T -> caprod (typ_stoic S T)
 | caprod_all: forall L T, type (typ_all T) ->
                         (forall X, X \notin L -> caprod (T open_tt_var X)) ->
                         caprod (typ_all T).

(* capsafe environment *)
Inductive healthy: env -> Prop :=
  | healthy_empty: healthy empty
  | healthy_typ: forall x E T, capsafe T -> healthy E ->
                                  x # E -> healthy (E & x ~: T)
  | healthy_tvar: forall X E, healthy E ->
                                  X # E -> healthy (E & [: X :]).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_abs_closed: forall L E V e1 T1,
      okt E ->
      (forall x, x \notin L ->
        typing ((pure E) & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_stoic V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_stoic T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs_closed : forall L E e1 T1,
      okt E ->
      (forall X, X \notin L ->
        typing ((pure E) & [: X :]) (e1 open_te_var X) (T1 open_tt_var X)) ->
      typing E (trm_tabs e1) (typ_all T1)
  | typing_tapp : forall T1 E e1 T,
      wft E T -> capsafe T ->
      typing E e1 (typ_all T1) ->
      typing E (trm_tapp e1 T) (open_tt T1 T).

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_tabs : forall e1, term (trm_tabs e1) ->
                 value (trm_tabs e1).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V)
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2)
  | red_tabs : forall e1 V,
      term (trm_tabs e1) ->
      type V ->
      red (trm_tapp (trm_tabs e1) V) (open_te e1 V).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.

(* effect safety : it's impossible to construct a term of typ_eff in pure environment  *)
Definition effect_safety := forall E, healthy E ->
  ~exists e, typing E e typ_eff.

(* ********************************************************************** *)
(** * Additional Definitions Used in the Proofs *)

(** Computing free type variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | typ_bvar J            => \{}
  | typ_base              => \{}
  | typ_eff               => \{}
  | typ_fvar X            => \{X}
  | typ_stoic T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_all T1      => (fv_tt T1)
  end.

(** Computing free type variables in a term *)

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{}
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs e1   => (fv_te e1)
  | trm_tapp e1 V => (fv_tt V) \u (fv_te e1)
  end.

(** Computing free term variables in a type *)

Fixpoint fv_ee (e : trm) {struct e} : vars :=
  match e with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  | trm_tabs e1   => (fv_ee e1)
  | trm_tapp e1 V => (fv_ee e1)
  end.

(** Substitution for free type variables in types. *)

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar J            => typ_bvar J
  | typ_base              => typ_base
  | typ_eff               => typ_eff
  | typ_fvar X            => If X = Z then U else (typ_fvar X)
  | typ_stoic T1 T2 => typ_stoic (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T        => typ_all (subst_tt Z U T)
  end.

(** Substitution for free type variables in terms. *)

Fixpoint subst_te (Z : var) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs V e1  => trm_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | trm_app e1 e2 => trm_app  (subst_te Z U e1) (subst_te Z U e2)
  | trm_tabs e1   => trm_tabs (subst_te Z U e1)
  | trm_tapp e1 V => trm_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

(** Substitution for free term variables in terms. *)

Fixpoint subst_ee (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs V e1  => trm_abs V (subst_ee z u e1)
  | trm_app e1 e2 => trm_app (subst_ee z u e1) (subst_ee z u e2)
  | trm_tabs e1   => trm_tabs (subst_ee z u e1)
  | trm_tapp e1 V => trm_tapp (subst_ee z u e1) V
  end.

(** Substitution for free type variables in environment. *)

Definition subst_tb (Z : var) (P : typ) (b : bind) : bind :=
  match b with
  | bind_tvar => bind_tvar
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red.

Hint Resolve
  typing_var typing_app typing_tapp.

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv_te x) in
  let D := gather_vars_with (fun x : trm => fv_ee x) in
  let E := gather_vars_with (fun x : typ => fv_tt x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u C \u D \u E \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; autos*.

(** Tactic to undo when Coq does too much simplification *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tb Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; autos*.

(* ********************************************************************** *)
(** * Properties of Set *)

(* ********************************************************************** *)

Lemma notin_union_inv: forall x E F,
  x \notin (E \u F) -> x \notin E /\ x \notin F.
Proof. intros. autos. Qed.

Lemma union_empty_inv: forall (A:Type) (a b: fset A),
   a \u b = \{} -> a = \{} /\ b = \{}.
Proof. intros. split.
  apply fset_extens. rewrite <- H. apply subset_union_weak_l. apply subset_empty_l.
  apply fset_extens. rewrite <- H. apply subset_union_weak_r. apply subset_empty_l.
Qed.

Lemma subset_trans: forall (T: Type) (a b c: fset T),
  a \c b -> b \c c -> a \c c.
Proof. unfolds subset. autos. Qed.

Lemma subset_strengthen: forall (T: Type) (a b: fset T) (x: T),
  a \c (b \u \{x}) -> x \notin a -> a \c b.
Proof. unfolds subset. intros. forwards K: (H x0 H1).
  rewrite in_union in K. destruct* K.
  rewrite in_singleton in H2. subst.
  tryfalse.
Qed.

Lemma subset_union : forall (T: Type) (a b c: fset T),
  a \u b \c c -> a \c c /\ b \c c.
Proof. intros. unfolds subset.
  split; intros x; specializes H x; rewrite in_union in H; auto.
Qed.

(* ********************************************************************** *)
(** * Properties of Substitutions *)

(* ********************************************************************** *)
(** ** Properties of type substitution in type *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_tt_rec_type_core : forall T j V U i, i <> j ->
  (open_tt_rec j V T) = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_tt_rec_type : forall T U,
  type T -> forall k, T = open_tt_rec k U T.
Proof.
  induction 1; intros; simpl; f_equal*. unfolds open_tt.
  pick_fresh X. apply* (@open_tt_rec_type_core T2 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_tt T -> subst_tt Z U T = T.
Proof.
  induction T; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1; intros k; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_tt_rec_type.
Qed.

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_tt T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in terms *)

Lemma open_te_rec_term_core : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H; f_equal*; f_equal*.
Qed.

Lemma open_te_rec_type_core : forall e j Q i P, i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
   e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H0; f_equal*;
  match goal with H: ?i <> ?j |- ?t = open_tt_rec ?i _ ?t =>
   apply* (@open_tt_rec_type_core t j) end.
Qed.

Lemma open_te_rec_term : forall e U,
  term e -> forall k, e = open_te_rec k U e.
Proof.
  intros e U WF. induction WF; intros; simpl;
    f_equal*; try solve [ apply* open_tt_rec_type ].
  unfolds open_ee. pick_fresh x.
   apply* (@open_te_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_te_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_te_fresh : forall X U e,
  X \notin fv_te e -> subst_te X U e = e.
Proof.
  induction e; simpl; intros; f_equal*; autos* subst_tt_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e; intros; simpls; f_equal*;
  autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_te_intro : forall X U e,
  X \notin fv_te e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_type_core : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv H; simpls; inversion H; f_equal*.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_ee_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_ee_open_ee : forall t1 t2 u x, term u ->
  subst_ee x u (open_ee t1 t2) =
  open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_ee_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> term u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> term u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P x e,
  (subst_te Z P e) open_ee_var x = subst_te Z P (e open_ee_var x).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e; intros; simpl; f_equal*. case_nat*.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z u e X, term u ->
  (subst_ee z u e) open_te_var X = subst_ee z u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e; intros; simpl; f_equal*.
  case_var*. symmetry. autos* open_te_rec_term.
Qed.

(** Substitutions preserve local closedure. *)

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
Qed.

Lemma subst_te_term : forall e Z P,
  term e -> type P -> term (subst_te Z P e).
Proof.
  lets: subst_tt_type. induction 1; intros; simpl; auto.
  apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
  apply_fresh* term_tabs as x. rewrite* subst_te_open_te_var.
Qed.

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
  apply_fresh* term_tabs as Y. rewrite* subst_ee_open_te_var.
Qed.

Hint Resolve subst_tt_type subst_te_term subst_ee_term.

(* ********************************************************************** *)
(** * Properties of well-formedness of a type in an environment *)

(** If a type is well-formed in an environment then it is locally closeded. *)

Lemma wft_type : forall E T,
  wft E T -> type T.
Proof.
  induction 1; eauto.
Qed.

(** Through weakening *)

Lemma wft_weaken : forall G T E F,
  wft (E & G) T ->
  ok (E & F & G) ->
  wft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  (* case: var *)
  apply wft_var. apply* binds_weaken.
  (* case arrow *)
  (* case: all *)
  apply_fresh* wft_all as Y. apply_ih_bind* H0.
Qed.

(** Through strengthening *)

Lemma wft_strengthen : forall E F x U T,
 wft (E & x ~: U & F) T -> wft (E & F) T.
Proof.
  intros. gen_eq G: (E & x ~: U & F). gen F.
  induction H; intros F EQ; subst; auto.
  apply* wft_var.
  destruct (binds_concat_inv H) as [?|[? ?]].
    apply~ binds_concat_right.
    destruct (binds_push_inv H1) as [[? ?]|[? ?]].
      subst. false.
      apply~ binds_concat_left.
  (* todo: binds_cases tactic *)
  apply_fresh* wft_all as Y. apply_ih_bind* H0.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall F E Z P T,
  wft (E & [: Z :] & F) T ->
  wft E P ->
  ok (E & map (subst_tb Z P) F) ->
  wft (E & map (subst_tb Z P) F) (subst_tt Z P T).
Proof.
  introv WT WP. gen_eq G: (E & [: Z :] & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*. apply_empty* wft_weaken.
    destruct (binds_concat_inv H) as [?|[? ?]].
      apply wft_var.
       apply~ binds_concat_right.
       replace bind_tvar with ((subst_tb Z P) bind_tvar) by reflexivity.
       apply~ binds_map.
      destruct (binds_push_inv H1) as [[? ?]|[? ?]].
        subst. false~.
        applys wft_var. apply* binds_concat_left.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) bind_tvar).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U T,
  ok E ->
  wft E (typ_all T) ->
  wft E U ->
  wft E (open_tt T U).
Proof.
  introv Ok WA WU. inversions WA. pick_fresh X.
  autos* wft_type. rewrite* (@subst_tt_intro X).
  lets K: (@wft_subst_tb empty).
  specializes_vars K. clean_empty K. apply* K.
  (* todo: apply empty ? *)
Qed.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma ok_from_okt : forall E,
  okt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply ok_from_okt.

(** Extraction from a typing assumption in a well-formed environments *)

Lemma wft_from_env_has_typ : forall x U E,
  okt E -> binds x (bind_typ U) E -> wft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H2.
       apply_empty* wft_weaken.
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3. apply_empty* wft_weaken.
       apply_empty* wft_weaken.
Qed.

(** Extraction from a well-formed environment *)

Lemma wft_from_okt_typ : forall x T E,
  okt (E & x ~: T) -> wft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. false.
  destruct (eq_push_inv H0) as [? [? ?]]. inversions~ H4.
Qed.

(** Automation *)

Lemma wft_weaken_right : forall T E F,
  wft E T ->
  ok (E & F) ->
  wft (E & F) T.
Proof.
  intros. apply_empty* wft_weaken.
Qed.

Hint Resolve wft_weaken_right.
Hint Resolve wft_strengthen.
Hint Resolve wft_from_okt_typ.
Hint Immediate wft_from_env_has_typ.
Hint Resolve wft_subst_tb.

(* ********************************************************************** *)
(** ** Properties of well-formedness of an environment *)

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> exists T, B = bind_tvar \/ B = bind_typ T.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). subst. exists* (typ_fvar X).
    lets (?&?&?): (eq_push_inv H). subst*.
Qed.

Lemma okt_push_tvar_inv : forall E X,
  okt (E & [: X :]) -> okt E /\ X # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
    lets (?&?&?): (eq_push_inv H). false.
Qed.

Lemma okt_push_typ_inv : forall E x T,
  okt (E & x ~: T) -> okt E /\ wft E T /\ x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). false.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
Qed.

Lemma okt_push_typ_type : forall E x T,
  okt (E & x ~: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_typ_inv. Qed.

Hint Immediate okt_push_typ_type.

(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
 introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_typ_inv O).
  rewrite concat_assoc in *.
   lets (U&[?|?]): okt_push_inv O; subst.
      applys~ okt_X. apply IHF. applys* okt_push_tvar_inv.
      apply ok_from_okt in O.
      lets (? & H): (ok_push_inv O). eauto.

      applys~ okt_typ. apply IHF. applys* okt_push_typ_inv.
      applys* wft_strengthen.
      apply ok_from_okt in O.
      lets (? & H): (ok_push_inv O). eauto.
Qed.

Lemma okt_weaken : forall E F,
  okt (E & F) -> okt E.
Proof.
  induction F using env_ind; rew_env_concat; introv Okt. auto.
  lets(T & [H | H]): (okt_push_inv Okt); subst.
  apply IHF. lets*: okt_push_tvar_inv Okt.
  apply IHF. lets*: okt_push_typ_inv Okt.
Qed.

(** Through type substitution *)

Lemma okt_subst_tb : forall Z P (E F:env),
  okt (E & [: Z :] & F) ->
  wft E P ->
  okt (E & map (subst_tb Z P) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_tvar_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets (U&[?|?]): okt_push_inv O; subst.
     lets*: (okt_push_tvar_inv O).
     lets*: (okt_push_typ_inv O).
      applys~ okt_typ; lets*: H.
Qed.

(** Automation *)

Hint Resolve okt_subst_tb wft_weaken.
Hint Immediate okt_strengthen.

(* ********************************************************************** *)
(** ** Environment is unchanged by substitution from a fresh name *)

Lemma notin_fv_tt_open : forall Y X T,
  X \notin fv_tt (T open_tt_var Y) ->
  X \notin fv_tt T.
Proof.
 introv. unfold open_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 apply* IHT.
Qed.

Lemma notin_fv_wf : forall E X T,
  wft E T -> X # E -> X \notin fv_tt T.
Proof.
  induction 1; intros Fr; simpl.
  eauto.
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H Fr.
  notin_simpl; auto.
  notin_simpl; auto. pick_fresh Y. apply* (@notin_fv_tt_open Y).
Qed.

Lemma map_subst_tb_id : forall G Z P,
  okt G -> Z # G -> G = map (subst_tb Z P) G.
Proof.
  induction 1; intros Fr; autorewrite with rew_env_map; simpl.
  auto.
  rewrite <- IHokt. reflexivity. eauto.
  rewrite <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf. eauto.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)
(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e.
Proof.
  induction 1; auto.
  splits.
    pick_fresh y. specializes H1 y. destructs~ H1.
    apply_fresh* term_abs as y.
      pick_fresh y. specializes H1 y. destructs~ H1.
        forwards*: okt_push_typ_inv.
      specializes H1 y. destructs~ H1.
  splits*.
  splits*.
    apply term_tabs with L. intros.
    specializes H1 X. destructs~ H1.
  splits*. destructs IHtyping.
     apply* term_tapp. apply* wft_type.
Qed.

(** The value relation is restricted to well-formed objects. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; autos*.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  induction 1; split; autos* value_regular.
  inversions H. pick_fresh y. rewrite* (@subst_ee_intro y).
  inversions H. pick_fresh Y. rewrite* (@subst_te_intro Y).
Qed.

(** Automation *)

Hint Extern 1 (okt ?E) =>
  match goal with
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (wft ?E ?T) =>
  match goal with
  | H: typing E _ T |- _ => apply (proj33 (typing_regular H))
  end.

Hint Extern 1 (type ?T) =>
  let go E := apply (@wft_type E); auto in
  match goal with
  | H: typing ?E _ T |- _ => go E
  end.

Hint Extern 1 (term ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (proj32 (typing_regular H))
  | H: red ?e _ |- _ => apply (proj1 (red_regular H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular H))
  end.

(* ********************************************************************** *)
(** * Properties of environment *)
Lemma pure_dist: forall E F, pure (E & F) = pure E & pure F.
Proof. rewrite concat_def. intros. gen E. induction F; intros E; autos.
  rewrite LibList.app_cons. destruct a. destruct b.
  simpl. rewrite LibList.app_cons. rewrite* <- IHF.
  simpl. destruct* (closed_typ t). rewrite LibList.app_cons. rewrite* <- IHF.
Qed.

Lemma pure_dom_subset : forall E, dom (pure E) \c dom E.
Proof. intros. induction E.
  simpl. apply subset_refl.
  destruct a. destruct b.
  simpl. repeat(rewrite cons_to_push). repeat(rewrite dom_push).
    eapply subset_trans. eapply subset_union_2.
    eapply subset_refl. exact IHE. apply subset_refl.
  simpl. destruct* (closed_typ t).
    repeat(rewrite cons_to_push; rewrite dom_push).
      apply* subset_union_2. apply subset_refl.
    rewrite cons_to_push. rewrite dom_push.
      eapply subset_trans. exact IHE. apply subset_union_weak_r.
Qed.

Lemma pure_binds: forall E x v, ok E -> binds x v (pure E) -> binds x v E.
Proof. intros. induction E.
  simpl in *. autos.
  destruct a. destruct b.
    simpl in *. rewrite cons_to_push in *. destruct (binds_push_inv H0).
      destruct H1. subst. apply binds_push_eq.
      destruct H1. apply* binds_push_neq.
    simpl in *.  rewrite cons_to_push in *. destruct (closed_typ t).
      destruct (binds_push_inv H0).
        destruct H1. substs. apply* binds_push_eq.
        destruct H1. apply* binds_push_neq.
      rewrite <- concat_empty_r. apply binds_weaken; rewrite* concat_empty_r.
Qed.

Lemma pure_binds_reverse: forall E x, binds x bind_tvar E -> binds x bind_tvar (pure E).
Proof. intros. induction E.
  simpl in *. autos.
  destruct a. destruct b.
    simpl in *. rewrite cons_to_push in *. destruct (binds_push_inv H).
      destruct H0. subst. apply binds_push_eq.
      destruct H0. apply* binds_push_neq.
    simpl in *. rewrite cons_to_push in *. destruct (binds_push_inv H). false H0.
      destruct H0. destruct* (closed_typ t).
Qed.

Lemma pure_binds_in: forall E x T, closed_typ T = true ->
   binds x (bind_typ T) E -> binds x (bind_typ T) (pure E).
Proof. intros. induction E.
  (* nil *)
  rewrite <- empty_def in H0. destruct(binds_empty_inv H0).
  (* x::xs *)
  destruct a. destruct b.
    (* bind_tvar *)
    simpl. rewrite cons_to_push in *. destruct (binds_push_inv H0).
    destruct H1. inversion H2.
    destruct H1. apply* binds_push_neq.
    (* bind_typ *)
    simpls. rewrite cons_to_push in *. destruct (binds_push_inv H0).
    destruct H1. inversions H2. rewrite* H.
    destruct H1. destruct* (closed_typ t).
Qed.

Lemma pure_wft: forall E V, ok E -> wft (pure E) V -> wft E V.
Proof. intros. remember (pure E) as G. gen E. induction H0; intros; subst.
  apply wft_var. apply* pure_binds.
  apply* wft_stoic.
  apply_fresh* wft_all as Y. apply* H0. repeat(rewrite <- cons_to_push). autos.
Qed.

Lemma pure_wft_weaken: forall E F G V,
  ok (E & F & G) -> wft (E & (pure F) & G) V -> wft (E & F & G) V.
Proof. intros. inductions H0; intros; subst.
  apply wft_var. binds_cases H0.
    apply binds_concat_left; autos. apply* binds_concat_left_ok.
    apply binds_concat_left; autos. apply* binds_concat_right. apply* pure_binds.
      lets*: ok_concat_inv_r (ok_concat_inv_l H).
    apply binds_concat_right. auto.
  apply* wft_stoic.
  apply_fresh* wft_all as Y.
    assert (HI: ok (E & F & (G & [: Y :]))).
      rewrite concat_assoc. apply* ok_push.
    forwards~ HII: (H0 Y). apply HI.  rewrite* concat_assoc.
    rewrite* <- concat_assoc.
Qed.

Lemma pure_wft_reverse: forall E V, wft E V -> wft (pure E) V.
Proof. intros. induction H.
  apply wft_var. apply* pure_binds_reverse.
  apply* wft_stoic.
  apply_fresh* wft_all as Y. forwards~ HI: (H0 Y).
    rewrite pure_dist in HI. rewrite single_def in *. autos.
Qed.

Lemma pure_empty : pure empty = empty.
Proof. rewrite empty_def. reflexivity. Qed.

Lemma pure_single_true : forall x U, closed_typ U = true ->
  pure (x ~: U) = x ~: U.
Proof. intros.
  replace (x ~: U) with (empty & x ~: U) by rewrite* concat_empty_l.
  rewrite <- cons_to_push. simpls. rewrite H.
  rewrite pure_empty. reflexivity.
Qed.

Lemma pure_single_tvar : forall X, pure ([:X:]) = [:X:].
Proof. intros. replace ([:X:]) with (empty & [:X:]) by rewrite* concat_empty_l.
  rewrite <- cons_to_push. simpl. rewrite pure_empty. reflexivity.
Qed.

Lemma pure_single_false : forall x U, closed_typ U = false ->
  pure (x ~: U) = empty.
Proof. intros.
  replace (x ~: U) with (empty & x ~: U) by rewrite* concat_empty_l.
  rewrite <- cons_to_push. simpls. rewrite H.
  rewrite pure_empty. reflexivity.
Qed.

Lemma pure_okt : forall E,
  okt E -> okt (pure E).
Proof. intros. induction* E.
  destruct a. destruct b; simpl; rewrite cons_to_push in *.
  apply okt_X. apply IHE. lets*: okt_push_tvar_inv H.
  unfolds. lets(_ & HI): okt_push_tvar_inv H. autos* (pure_dom_subset E).
  destructs (okt_push_typ_inv H). destruct* (closed_typ t).
    apply okt_typ. apply* IHE. apply* pure_wft_reverse.
    lets: pure_dom_subset E. unfolds subset.
    unfolds notin. autos.
Qed.

Lemma closed_subst_tt: forall T,
  closed_typ T = true ->
  forall Z P, closed_typ P = true ->
              closed_typ (subst_tt Z P T) = true.
Proof. intros. inductions T; inversions H; simpls; auto. case_if*. Qed.

Lemma closed_subst_tt_false: forall T,
  closed_typ T = false ->
  forall Z P, closed_typ P = true ->
              closed_typ (subst_tt Z P T) = false.
Proof. intros. inductions T; inversions H; simpls; auto. Qed.

Lemma pure_map : forall E Z P, closed_typ P = true ->
  pure (map (subst_tb Z P) E) = map (subst_tb Z P) (pure E).
Proof. intros. induction E.
  simpl. rewrite <- empty_def. rewrite map_empty. apply pure_empty.
  destruct a. destruct b; simpl.
    repeat(rewrite cons_to_push). repeat(rewrite map_push). simpl.
      rewrite <- cons_to_push. simpl. rewrite cons_to_push. rewrite* IHE.
    repeat(rewrite cons_to_push). repeat(rewrite map_push). simpl.
      rewrite <- cons_to_push. simpl. remember (closed_typ t). destruct b; symmetry in Heqb.
      lets*: (@closed_subst_tt t Heqb Z P H). rewrite H0. rewrite map_push.
        rewrite <- cons_to_push. simpl. rewrite* IHE.
      lets*: (@closed_subst_tt_false t Heqb Z P H). rewrite* H0.
Qed.

Lemma pure_eq : forall E, pure (pure E) = pure E.
Proof. intros. induction E; autos.
  destruct a. destruct b; autos.
  simpls. rewrite* IHE.
  simpls. remember (closed_typ t). symmetry in Heqb. destruct* b.
    simpls. rewrite* Heqb. rewrite* IHE.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs_closed as x.
    repeat(rewrite pure_dist in *). rewrite <- concat_assoc.
    apply* H1. rewrite* concat_assoc. rewrite concat_assoc. repeat(rewrite <- pure_dist).
    apply okt_typ.  apply* pure_okt.
    forwards~ K: (H0 x). lets(Hk & _): typing_regular K. lets: wft_from_okt_typ Hk.
    apply pure_wft_reverse. apply* wft_weaken. apply* pure_wft. rewrite* pure_dist.
    assert (Ha: x \notin dom E \u dom F \u dom G) by autos.
    intros HI. apply Ha. repeat(rewrite pure_dist in HI). repeat(rewrite dom_concat in HI).
      repeat(rewrite in_union in *). rewrite or_assoc in HI.  branches HI.
     branch 1. lets*: pure_dom_subset E.
     branch 2. lets*: pure_dom_subset F.
     branch 3. lets*: pure_dom_subset G.
  apply* typing_app.
  apply_fresh* typing_tabs_closed as X.
    repeat(rewrite pure_dist in *). rewrite <- concat_assoc.
    apply* H1. rewrite* concat_assoc. rewrite concat_assoc. repeat(rewrite <- pure_dist).
    apply okt_X.  apply* pure_okt.
    forwards~ K: (H0 X). lets(Hk & _): typing_regular K.
    assert (Ha: X \notin dom E \u dom F \u dom G) by autos.
    intros HI. apply Ha. repeat(rewrite pure_dist in HI). repeat(rewrite dom_concat in HI).
      repeat(rewrite in_union in *). rewrite or_assoc in HI.  branches HI.
     branch 1. lets*: pure_dom_subset E.
     branch 2. lets*: pure_dom_subset F.
     branch 3. lets*: pure_dom_subset G.
  apply* typing_tapp.
Qed.

Lemma typing_wft: forall E e T, typing E e T -> wft E T.
Proof.
  intros. induction H. applys~ wft_from_env_has_typ x.
  apply wft_stoic. pick_fresh x. forwards~: (H0 x).
    lets(H3 & _): (typing_regular H2). lets*: wft_from_okt_typ H3.
    apply* pure_wft.

    pick_fresh x. forwards~: (H1 x).
    rewrite <- (@concat_empty_r bind (x ~: V) ) in H2. rewrite concat_assoc in H2.
    lets: wft_strengthen H2. rewrite concat_empty_r in H3. apply* pure_wft.
  inverts* IHtyping1.
  let L := gather_vars in (apply* (@wft_all L)). intros.
    forwards~: (H1 X). rewrite <- (@concat_empty_l bind E).
    apply pure_wft_weaken; rewrite* concat_empty_l.
  apply* wft_open.
Qed.

Lemma typing_weakening_env : forall E F G e T,
  typing (E & (pure F) & G) e T ->
  okt (E & F & G) ->
  typing (E & F & G) e T.
Proof. intros. inductions H.
  apply* typing_var. binds_cases H0; autos.
    apply* binds_weaken. apply* binds_concat_left.
    apply binds_concat_right. apply* pure_binds.
    autos* ok_concat_inv_l ok_concat_inv_r ok_from_okt.
  apply_fresh typing_abs_closed as x. auto.
    repeat(rewrite pure_dist in *). rewrite pure_eq in *.
    apply_ih_bind* H1. rewrite* pure_eq. forwards~ : H0 x.
  apply* typing_app.
  apply_fresh typing_tabs_closed as X; auto.
    repeat(rewrite pure_dist in *). rewrite pure_eq in *.
    apply_ih_bind* H1. rewrite* pure_eq. forwards~ : H0 X.
  apply typing_tapp; auto. apply* pure_wft_weaken.
Qed.

Lemma typing_strengthen_env: forall E u U, value u -> typing E u U ->
  closed_typ U = true -> typing (pure E) u U.
Proof. intros. induction H0; simpls; inversion H1.
  apply typing_var. apply* pure_okt. apply* pure_binds_in.
  apply_fresh* typing_abs_closed as y. apply* pure_okt. rewrite* pure_eq.
  inversion H.
  apply_fresh* typing_tabs_closed as y. apply* pure_okt. rewrite* pure_eq.
  inversion H.
Qed.

(* ********************************************************************** *)
(** * Properties of Healthy Evnironment *)

Hint Constructors capsafe caprod.

Scheme capsafe_mut := Induction for capsafe Sort Prop
with caprod_mut := Induction for caprod Sort Prop.

Lemma capsafe_regular: forall T, capsafe T -> type T.
  apply (capsafe_mut
           (fun T safeT => type T )
           (fun T prodT => type T )
        );  eauto.
Qed.

Lemma caprod_regular: forall T, caprod T -> type T.
  apply (caprod_mut
           (fun T safeT => type T )
           (fun T prodT => type T )
        );  eauto.
Qed.

Hint Immediate capsafe_regular caprod_regular.

Lemma capsafe_subst_tt: forall T,
  capsafe T -> forall Z P, capsafe P -> capsafe (subst_tt Z P T).
  apply (capsafe_mut
           (fun T safeT => forall Z P, capsafe P -> capsafe (subst_tt Z P T) )
           (fun T prodT => forall Z P, capsafe P -> caprod (subst_tt Z P T) )
        ); intros; simpls; eauto.
  case_if*.
  let L' := gather_vars in apply capsafe_all with L'; auto.
    unsimpl (subst_tt Z P (typ_all T)). auto.
    intros. rewrite* subst_tt_open_tt_var.
  let L' := gather_vars in apply caprod_all with L'; auto.
    unsimpl (subst_tt Z P (typ_all T)). auto.
    intros. rewrite* subst_tt_open_tt_var.
Qed.

Lemma caprod_subst_tt: forall T,
  caprod T -> forall Z P, capsafe P -> caprod (subst_tt Z P T).
  apply (caprod_mut
           (fun T safeT => forall Z P, capsafe P -> capsafe (subst_tt Z P T) )
           (fun T prodT => forall Z P, capsafe P -> caprod (subst_tt Z P T) )
        ); intros; simpls; eauto.
  case_if*.
  let L' := gather_vars in apply capsafe_all with L'; auto.
    unsimpl (subst_tt Z P (typ_all T)). auto.
    intros. rewrite* subst_tt_open_tt_var.
  let L' := gather_vars in apply caprod_all with L'; auto.
    unsimpl (subst_tt Z P (typ_all T)). auto.
    intros. rewrite* subst_tt_open_tt_var.
Qed.

Lemma capsafe_closed_typ: forall T, capsafe T -> closed_typ T = true.
Proof. intros. inductions H; try reflexivity; try false; autos. Qed.

Lemma capsafe_not_caprod : forall T, capsafe T -> ~ caprod T.
  apply (capsafe_mut
           (fun T safeT => ~ caprod T )
           (fun T prodT => ~ capsafe T )
        ); intros; intros Hc; inversions Hc; eauto.
  pick_fresh X. forwards~ : H X.
  pick_fresh X. forwards~ : H X.
Qed.

Lemma caprod_not_capsafe : forall T, caprod T -> ~ capsafe T.
  apply (caprod_mut
           (fun T safeT => ~ caprod T )
           (fun T prodT => ~ capsafe T )
        ); intros; intros Hc; inversions Hc; eauto.
  pick_fresh X. forwards~ : H X.
  pick_fresh X. forwards~ : H X.
Qed.

Lemma capsafe_caprod_classic: forall T, type T -> capsafe T \/ caprod T.
Proof. intros T Ht. inductions Ht; iauto.
  pick_fresh X. forwards~ : H0 X. destruct H1.
  left. apply capsafe_all with (L \u fv_tt T2). apply* type_all.
    intros. forwards~ : capsafe_subst_tt H1 X (typ_fvar X0).
    rewrite* <- (@subst_tt_intro X) in H3.
  right. apply caprod_all with L. apply* type_all.
    intros. forwards~ : caprod_subst_tt H1 X (typ_fvar X0).
    rewrite* <- (@subst_tt_intro X) in H3.
Qed.

Lemma capsafe_decidable: forall T, type T -> capsafe T \/ ~ capsafe T.
Proof. intros. destruct (capsafe_caprod_classic H). left*.
  right. intros Hc. lets*: capsafe_not_caprod Hc.
Qed.

Lemma not_capsafe_caprod : forall T, type T -> ~capsafe T -> caprod T.
Proof. intros. destruct* (capsafe_caprod_classic H). Qed.

Lemma healthy_env_closed: forall E, healthy E -> pure E = E.
Proof. intros. inductions H.
  rewrite empty_def. reflexivity.
  rewrite <- cons_to_push. simpls. lets: capsafe_closed_typ H.
    rewrite* H2. rewrite* IHhealthy.
  rewrite <- cons_to_push. simpls. rewrite* IHhealthy.
Qed.

Lemma healthy_env_capsafe : forall E S x, healthy E ->
   binds x (bind_typ S) E ->  capsafe S.
Proof. introv H Hb. inductions H.
  false* binds_empty_inv.
  destruct (binds_push_inv Hb).
    destruct H2. inversions* H3.
    destruct H2. autos.
  destruct (binds_push_inv Hb).
    destruct H1. inversions* H2.
    destruct H1. autos.
Qed.

Hint Resolve capsafe_subst_tt capsafe_closed_typ.

(************************************************************************ *)
(** Preservation by Term Substitution (8) *)

Lemma open_tt_fv_subset: forall k U T,
  fv_tt T \c fv_tt (open_tt_rec k U T).
Proof. intros. gen k. induction T; intros; simpls;
  autos* subset_refl subset_empty_l subset_union_2.
Qed.

Lemma open_te_fv_subset: forall k U e,
  fv_te e \c fv_te (open_te_rec k U e).
Proof. intros. gen k. induction e; intros; simpls;
  autos* subset_empty_l subset_union_2 open_tt_fv_subset.
Qed.

Lemma open_ee_fv_subset: forall k u e,
  fv_ee e \c fv_ee (open_ee_rec k u e).
Proof. intros. gen k. induction e; intros; simpls;
  autos* subset_empty_l subset_refl subset_union_2.
Qed.

Lemma open_ee_te_fv_eq: forall k U e,
  fv_ee e = fv_ee (open_te_rec k U e).
Proof. intros. gen k. induction e; intros; simpls; autos.
  rewrites (IHe1 k).
  rewrites (IHe2 k).
  reflexivity.
Qed.

Lemma open_te_ee_fv_subset: forall k u e,
  fv_te e \c fv_te (open_ee_rec k u e).
Proof. intros. gen k. induction e; intros; simpls;
  autos* subset_empty_l subset_union_2 subset_refl.
Qed.

Lemma open_tt_tt_fv_subset: forall k T1 T2,
  fv_tt (open_tt_rec k T1 T2) \c fv_tt T1 \u fv_tt T2.
Proof. intros. gen k. induction T2; intros; simpls;
  autos* union_comm subset_empty_l subset_union_weak_r.
  destruct (prop_degeneracy (k = n)).
    (* k = n*)
    apply is_True_inv in H2. rewrite* If_l. apply subset_union_weak_l.
    (* k != n*)
    apply is_False_inv in H2. rewrite* If_r.

  lets*: (subset_union_2 (IHT2_1 k) (IHT2_2 k)).
  rewrite union_assoc in H2.
  rewrite union_comm in H2.
  replace ((fv_tt T1 \u fv_tt T2_1) \u fv_tt T1) with (fv_tt T1 \u fv_tt T2_1) in H2 by
    (rewrite union_comm; rewrite <- union_assoc; rewrite* union_same).
  rewrite union_assoc. rewrite*  union_comm.
Qed.

Lemma wft_fv_tt: forall E T,
  wft E T -> fv_tt T \c dom E.
Proof.
  intros. induction H; simpls.
  lets: get_some_inv (binds_get H). unfolds. intros.
    rewrite in_singleton in H1. rewrite* H1.
  replace (dom E) with (dom E \u dom E) by (autos* union_same). apply* subset_union_2.
  pick_fresh X. forwards~ HI: (H0 X). rewrite dom_concat in HI. rewrite dom_single in HI.
    assert (HII: fv_tt T \c dom E \u \{X}).
      apply subset_trans with (fv_tt (T open_tt_var X)).
      autos* open_tt_fv_subset. autos.
    apply subset_strengthen with X; autos.
Qed.

Ltac solve_subsets :=
  match goal with
    | [|- _ \u _ \c dom ?E ] => rewrite <- union_same; eapply subset_trans;
                                apply* subset_union_2; apply pure_dom_subset
    | [|- _ \c dom ?E ] => eapply subset_trans; eauto; apply pure_dom_subset
    | [_: ?a \c ?E, _: ?b \c ?E |- ?a \u ?b \c ?E ] =>
      rewrite <- union_same; apply* subset_union_2
  end.

Ltac splits_solve_subsets := splits*; try solve_subsets.

Lemma typing_env_fv : forall E e T,
  typing E e T -> fv_te e \c dom E /\ fv_ee e \c dom E /\ fv_tt T \c dom E.
Proof. intros. inductions H.
  (* var *)
  simpls. splits; try solve [autos* subset_empty_l wft_fv_tt].
    forwards~ K:  get_some_inv (binds_get H0). unfolds subset.
    intros. rewrite in_singleton in H1. subst*.
  (* abs closed *)
  simpl. pick_fresh x. forwards~ : H0 x. forwards~ : H1 x. destructs H3.
  rewrite dom_concat in *. rewrite dom_single in *.
  forwards~ : subset_strengthen (subset_trans (@open_te_ee_fv_subset 0 (trm_fvar x) e1) H3).
  forwards~ : subset_strengthen (subset_trans (@open_ee_fv_subset 0 (trm_fvar x) e1) H4).
  forwards~ : subset_strengthen H5.
  forwards~ : wft_fv_tt (wft_from_okt_typ (proj1 (typing_regular H2))).
  splits_solve_subsets.
  (* app *)
  destructs IHtyping1. simpls. destruct (subset_union H3). destructs IHtyping2.
  splits_solve_subsets.
  (* tabs closed *)
  simpl. pick_fresh X. forwards~ : H1 X. destructs H2.
  rewrite dom_concat in *. rewrite dom_single in *.
  forwards~ : subset_strengthen (subset_trans (@open_te_fv_subset 0 (typ_fvar X) e1) H2).
  unfold open_te in H3. rewrite <- open_ee_te_fv_eq in H3. forwards~ : subset_strengthen H3.
  forwards~ : subset_strengthen (subset_trans (@open_tt_fv_subset 0 (typ_fvar X) T1) H4).
  splits_solve_subsets.
  (* tapp *)
  destructs IHtyping. simpls. lets: wft_fv_tt H. splits_solve_subsets.
  eapply subset_trans. apply open_tt_tt_fv_subset. solve_subsets.
Qed.

Lemma typing_through_subst_ee : forall U E F x T e u,
  value u ->
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv Hv TypT TypU. inductions TypT; introv; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs_closed as y. destruct (typing_regular TypU).
    rewrite* subst_ee_open_ee_var.
    (* if U is closed, then use IH; else  x is free in e1; *)
    repeat(rewrite pure_dist in *). remember (closed_typ U) as b. destruct b.
      (* closed_typ U = true *)
      symmetry in Heqb. rewrite* pure_single_true in H1.
      intros. rewrite <- concat_assoc. apply H1 with U; autos. rewrite* concat_assoc.
      apply* typing_strengthen_env.
      (* closed_typ U = false *)
      symmetry in Heqb. rewrite* pure_single_false in H0. rewrite concat_empty_r in H0.
      lets: ok_middle_inv (ok_from_okt H). forwards~ HI: H0 y.
      rewrite* subst_ee_fresh. destructs (typing_env_fv HI). unfolds notin. intros HII.
      assert (HIII: x \in dom (pure E & pure F & y ~: V)) by unfolds* subset.
      repeat(rewrite dom_concat in HIII). repeat(rewrite in_union in HIII).
      rewrite dom_single in HIII. rewrite or_assoc in HIII. destruct H4. branches HIII.
        apply H4. lets*: pure_dom_subset E.
        apply H8. lets*: pure_dom_subset F.
        rewrite in_singleton in H9. substs. apply* Fry. repeat(rewrite in_union).
          autos* in_singleton_self.
  apply* typing_app.
  apply_fresh* typing_tabs_closed as Y.  destruct (typing_regular TypU).
    rewrite* subst_ee_open_te_var.
    (* if U is closed, then use IH; else  x is free in e1; *)
    repeat(rewrite pure_dist in *). remember (closed_typ U) as b. destruct b.
      (* closed_typ U = true *)
      symmetry in Heqb. rewrite* pure_single_true in H1.
      intros. rewrite <- concat_assoc. apply H1 with U; autos. rewrite* concat_assoc.
      apply* typing_strengthen_env.
      (* closed_typ U = false *)
      symmetry in Heqb. rewrite* pure_single_false in H0. rewrite concat_empty_r in H0.
      lets: ok_middle_inv (ok_from_okt H). forwards~ HI: H0 Y.
      rewrite* subst_ee_fresh. destructs (typing_env_fv HI). unfolds notin. intros HII.
      assert (HIII: x \in dom (pure E & pure F & [:Y:])) by unfolds* subset.
      repeat(rewrite dom_concat in HIII). repeat(rewrite in_union in HIII).
      rewrite dom_single in HIII. rewrite or_assoc in HIII. destruct H4. branches HIII.
        apply H4. lets*: pure_dom_subset E.
        apply H8. lets*: pure_dom_subset F.
        rewrite in_singleton in H9. substs. apply* FrY. repeat(rewrite in_union).
          autos* in_singleton_self.
  apply* typing_tapp.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution (11) *)

Lemma typing_through_subst_te : forall E F Z e T P,
  capsafe P ->
  typing (E & [: Z :] & F) e T ->
  wft E P ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Hcap Typ PsubQ.
  inductions Typ; introv; simpls subst_tt; simpls subst_te.
  apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
   binds_cases H0; unsimpl_map_bind*. eauto using okt_weaken.
  apply_fresh* typing_abs_closed as y.
    repeat(rewrite pure_dist in *). rewrite pure_single_tvar in *.
    rewrite* subst_te_open_ee_var. rewrite* pure_map.
    unsimpl (subst_tb Z P (bind_typ V)). rewrite <- concat_assoc. rewrite <- map_push.
    apply* H1. rewrite* concat_assoc. apply* pure_wft_reverse.
  apply* typing_app.
  apply_fresh* typing_tabs_closed as Y.
    repeat(rewrite pure_dist in *). rewrite pure_single_tvar in *.
    rewrite* subst_te_open_te_var; eauto using wft_type.
    rewrite* subst_tt_open_tt_var; eauto using wft_type.
    rewrite* pure_map. unsimpl (subst_tb Z P bind_tvar).
    rewrite <- concat_assoc. rewrite <- map_push.
    apply* H1. rewrite* concat_assoc. apply* pure_wft_reverse.
  rewrite* subst_tt_open_tt.
Qed.

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

(* ********************************************************************** *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ apply* typing_app ].
  inversions Typ1. pick_fresh x. forwards~ K: (H7 x).
  rewrite* (@subst_ee_intro x).
    apply_empty typing_through_subst_ee; substs*.
    rewrite <- (@concat_empty_l bind _). rewrite concat_assoc.
    apply typing_weakening_env. rewrite* concat_empty_l.
    rewrite concat_empty_l. apply* okt_typ.
    autos* typing_wft.
    lets*: typing_regular Typ2.
  (* case: tapp *)
  inversions Red. try solve [ apply* typing_tapp ].
  inversions Typ. pick_fresh X. forwards~ : H7 X.
  rewrite* (@subst_te_intro X).
  rewrite* (@subst_tt_intro X).
  asserts_rewrite (E = E & map (subst_tb X T) empty).
    rewrite map_empty. rewrite~ concat_empty_r.
  apply* typing_through_subst_te. rewrite concat_empty_r.
  rewrite <- (@concat_empty_l bind E).
  apply typing_weakening_env. rewrite* concat_empty_l.
  rewrite concat_empty_l. apply* okt_X.
Qed.

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

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_stoic U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ. gen_eq E: (@empty bind).
  gen_eq T: (typ_stoic U1 U2). gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
Qed.

Lemma canonical_form_tabs : forall t U1,
  value t -> typing empty t (typ_all U1) ->
  exists e1, t = trm_tabs e1.
Proof.
  introv Val Typ. gen_eq E: (@empty bind).
  gen_eq T: (typ_all U1). gen U1.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
Qed.

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty bind). lets Typ': Typ.
  induction Typ; intros EQ; subst; autos.
  (* case: var *)
  false* binds_empty_inv.
  (* case: abs closed *)
  left*. apply value_abs. lets*: typing_regular Typ'.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
    destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
      subst. exists* (open_ee e3 e2). apply* red_abs. lets*: typing_regular Typ1.
    exists* (trm_app e1' e2). apply* red_app_1. lets*: typing_regular Typ2.
  (* case: tabs_closed *)
  left*. apply* value_tabs. lets*: typing_regular Typ'.
  (* case: tapp *)
  right. destruct~ IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ) as [e EQ].
      subst. exists* (open_te e T). apply* red_tabs. lets*: typing_regular Typ.
      autos* wft_type.
Qed.

(* ********************************************************************** *)
(** * effect safety *)

Lemma healthy_env_term_capsafe: forall E t T,
  healthy E ->
  typing E t T ->
  capsafe T.
Proof. intros. inductions H0.
  apply* healthy_env_capsafe.
  pick_fresh x. forwards~ : H1 x.
    assert (HI: type V) by destruct* (typing_regular H3).
    destruct (capsafe_decidable HI).
      apply* capsafe_any_safe. apply* (H2 x). rewrite* (healthy_env_closed H).
      apply* healthy_typ. lets*: not_capsafe_caprod H4.
      apply* capsafe_eff_any. autos* wft_type typing_wft.
  forwards~ : IHtyping1 H. forwards~ : IHtyping2 H. inversions* H0.
    lets*: capsafe_not_caprod T1.
  assert (typing E (trm_tabs e1) (typ_all T1)) by apply* typing_tabs_closed.
    let L' := gather_vars in apply capsafe_all with L'; autos* wft_type typing_wft.
    intros. apply* H2. rewrite* (healthy_env_closed H). apply* healthy_tvar.
  lets: IHtyping H. inversions H3. pick_fresh X. forwards~ : H6 X.
    forwards~ : capsafe_subst_tt H3 X T.
    rewrite* <- (@subst_tt_intro X) in H4.
Qed.

Lemma effect_safety_result : effect_safety.
Proof. intros E H He. destruct He.
  lets*: healthy_env_term_capsafe H0. inversions H1.
Qed.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.

Require Import Value.
Require Import PrincipalTyping.
Require Import Typing.

(** * Definition *)

Inductive casting : term -> type -> term -> Prop :=
| Ct_Lit : forall n A,
    casting (Ann (Lit n) A) Int (Ann (Lit n) Int)
| Ct_Top : forall v,
    lc v ->
    casting v Top (Ann (Lit 1) Top)
| Ct_Lam : forall A B C D E e,
    lc (Lam A e B) ->
    sub E (Arr C D) ->
    ordinary D ->
    casting (Ann (Lam A e B) E)
            (Arr C D)
            (Ann (Lam A e D) (Arr C D))
| Ct_Rcd : forall v v' A l,
    ordinary A ->
    casting v A v' ->
    casting (Fld l v) (Rcd l A) (Fld l v')
| Ct_Mrg_L : forall v1 v2 v A,
    casting v1 A v ->
    ordinary A ->
    casting (Mrg v1 v2) A v
| Ct_Mrg_R : forall v1 v2 v A,
    casting v2 A v ->
    ordinary A ->
    casting (Mrg v1 v2) A v
| Ct_And : forall v1 v2 v A A1 A2,
    splitable A A1 A2 ->
    casting v A1 v1 ->
    casting v A2 v2 ->
    casting v A (Mrg v1 v2).

Hint Constructors casting : core.

Notation "e ⇝ [ A ] e'" := (casting e A e') (at level 68).

(** * Casting & Value *)

(** Value property is preserved by casting *)

Lemma casting_lc :
  forall v v' A,
    lc v ->
    casting v A v' ->
    lc v'.
Proof.
  introv Lc Ct.
  dependent induction Ct; eauto 3; econstructor; eauto.
Qed.

Lemma casting_value :
  forall v v' A,
    value v ->
    casting v A v' ->
    value v'.
Proof.
  introv Val Ct.
  induction Ct; eauto.
  inversion Val; eauto.
Qed.

(** * Progress *)

Lemma casting_progress' :
  forall v A B,
    value v ->
    typing nil v Inf A ->
    sub A B ->
    exists v', casting v B v'.
Proof.
  introv Val Typ Sub. gen v.
  induction Sub; intros.
  - Case "Sub-Int".
    dependent destruction Typ; eauto.
    dependent destruction Val. dependent destruction H.
    + SCase "Lit".
      dependent destruction Typ; eauto.
    + SCase "Lam".
      dependent destruction Typ; eauto.
      dependent destruction Typ; eauto.
  - Case "Sub-Top".
    dependent destruction Typ; eauto.
  - Case "Sub-Arr".
    dependent destruction Typ; eauto.
    dependent destruction Val. dependent destruction H0; eauto.
    dependent destruction Typ. dependent destruction Typ.
    dependent destruction H2; eauto.
  - Case "Sub-Rcd".
    dependent destruction Typ; eauto.
    + dependent destruction Val. destruct (IHSub e); eauto.
    + dependent destruction Val.
      destruct H0.
      repeat (dependent destruction Typ). dependent destruction H2; eauto.
      repeat (dependent destruction Typ). dependent destruction H3; eauto.
  - Case "Sub-And".
    pose proof (IHSub1 _ Val Typ). pose proof (IHSub2 _ Val Typ).
    destruct_conjs; eauto.
  - Case "Sub-And-L".
    dependent destruction Typ; eauto.
    dependent destruction Val.
    pose proof (IHSub _ Val1 Typ1). destruct_conjs; eauto.
  - Case "Sub-And-R".
    dependent destruction Typ; eauto.
    dependent destruction Val.
    pose proof (IHSub _ Val2 Typ2). destruct_conjs; eauto.
Qed.

Lemma casting_progress :
  forall v A ,
    value v ->
    typing nil v Chk A ->
    exists v', casting v A v'.
Proof.
  introv Val Typ.
  dependent destruction Typ.
  eapply casting_progress'; eauto.
Qed.

(** * Preservation *)

Lemma casting_preservation :
  forall v v' A B,
    value v ->
    typing nil v Inf B ->
    casting v A v' ->
    exists C, typing nil v' Inf C /\ isosub C A.
Proof.
  introv Val Typ Ct. gen B.
  induction Ct; intros; try solve [eexists; eauto].
  - Case "Lam".
    exists (Arr C D). split; eauto 3.
    repeat (dependent destruction Typ).
    dependent destruction Val.
    assert (Sub1: sub (Arr A B) (Arr C D)) by (eapply sub_transitivity; eauto).
    dependent destruction Sub1; eauto 3.
    assert (Sub2: sub (Arr A D) (Arr C D)) by eauto.
    eapply Ty_Ann; eauto. eapply Ty_Sub; eauto.
    eapply Ty_Lam; eauto. intros. eapply typing_chk_sub; eauto.
  - Case "Rcd".
    dependent destruction Val. dependent destruction Typ; eauto.
    pose proof (IHCt Val _ Typ). destruct H0. destruct H0.
    exists (Rcd l x). split; eauto.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ; eauto.
  - Case "Merge".
    pose proof (IHCt1 Val B Typ) as IH1. destruct IH1 as [x1 IH1].
    pose proof (IHCt2 Val B Typ) as IH2. destruct IH2 as [x2 IH2].
    destruct_conjs.
    exists (And x1 x2). split; eauto.
Qed.


Require Import Frap Pset12Sig.

Module Impl.
(* Part 1: read Pset12Sig.v and answer the questions below. This task is
 * ungraded, but we are assigning it in hope it helps you complete the
 * following parts.

(these are duplicative with past psets:)

- Which syntactic construct can be used to implement sequencing of two commands?

- Which step rules allow a sequenced program to make progress?

- Which step rule is used when a loop terminates?

- Which step rule is used when a loop continues?

- Why is there no step rule for Fail?

(these are about the programming language in this pset:)

- Which syntactic construct is used to spawn new threads?

- Which step rules allow a multi-threaded program to make progress?

- How can threads in this language communicate with each other?

- What do the steps that are factored out into the astep inductive have in common?

(these are about the program logic:)

- Which rule of the program logic handles astep commands?

- What is the meaning of the "rely" argument [R]?

- What would [R] be for a program that can run in any environment?

- What would [R] be for a program that can only run alone?

- Which constructors of [hoare_triple] change [R]? Do they make it more or less permissive?

- What is the meaning of the "guarantee" argument [G]?

- Which cases of [hoare_triple] require you to prove [G]?

- What would [G] be for a program that can run in any environment?

- What would [G] be for a program that can only run alone?

(these are about program logic tactics:)

- What syntactic forms of commands does [step] handle?

- What syntactic forms of commands does [fork] handle?

- What are the six arguments to the tactic [fork]? Classify them into two groups of three, and then (differently) classify them into three pairs.

- What syntactic forms of commands does [atomic] handle?

- What is the argument to the tactic [atomic]?
*)

(* Part 2: prove a program *)

(* Pset12Example.v contains an example verification of a non-trivial program.
 * You can use it as a reference when trying to figure out what the rules,
 * lemmas, and tactics here do, but you are not required to understand it.
 * The program in this file is much simpler. *)

(* Verify that this program manages to increase the counter value. *)
Lemma ht_increment : forall init,
  hoare_triple
    (fun h => h $! 0 = init)
    (fun _ _ => False)
    (   (tmp <- Atomic (Read 0); Atomic (Write 0 (tmp + 1)))
     || (tmp <- Atomic (Read 0); Atomic (Write 0 (tmp + 1)))
    )
    (fun _ _ => True)
    (fun _ h => h $! 0 > init).
Proof.
Admitted.

(* Part 3: prove soundness of the program logic *)

(* Now it remains to prove that having a [hoare_triple] actually means
 * that execution will proceed safely, and if the program terminates then the
 * postcondition will be satisfied. *)

(* If non-negligible time has passed since you read the sig file, please
 * review the definitions of [trsys_of] and [notAboutToFail] now. *)

(* Then, feel free to just skim the next lemmas, right until the final
 * theorem you are asked to prove. *)

(* Here are a few more lemmas that you may find helpful: *)

Lemma HtStrengthen : forall {t : Set} P R c G (Q : t -> _) (P' : hprop),
    hoare_triple P R c G Q
    -> (forall h, P' h -> P h)
    -> stableP P' R
    -> hoare_triple P' R c G Q.
Proof. eauto. Qed.

Lemma HtWeakenFancy : forall {t : Set} P R c G Q (G' : hrel) (Q' : t -> hprop),
    hoare_triple P R c G Q
    -> (forall v h, Q v h -> Q' v h)
    -> (forall h h', G h h' -> G' h h')
    -> hoare_triple P R c G' Q'.
Proof. eauto using always_stableP. Qed.

Lemma HtReturn' : forall {t : Set} (P : hprop) (R G : hrel) (Q : _ -> hprop) (v : t),
    stableP P R
    -> (forall h, P h -> Q v h)
    -> hoare_triple P R (Return v) G Q.
Proof.
  simplify.
  eapply HtConsequence with (P' := P) (R' := R) (G' := G); eauto.
  simplify; propositional; subst; eauto.
Qed.

Lemma stableP_self : forall h R, stableP (fun h' => R^* h h') R.
Proof. simp. eauto using trc_trans. Qed.

Lemma stableP_star : forall R h h', R^* h h' ->
    forall P, stableP P R -> P h -> P h'.
Proof. induct 1; simplify; eauto. eapply IHtrc; eauto. Qed.

Lemma stableP_weakenR : forall P R, stableP P R -> forall R' : hrel,
    (forall h1 h2, R' h1 h2 -> R h1 h2) -> stableP P R'.
Proof. simp; eauto. Qed.

Local Hint Resolve stableP_self : core.

Lemma stable_stableQ : forall (t : Set) P (Q : t -> _) R r,
  stable P Q R -> stableP (Q r) R.
Proof. unfold stable; propositional; eauto. Qed.
Local Hint Resolve stable_stableQ : core.

Lemma stable_stableP : forall (t : Set) P (Q : t -> _) R,
  stable P Q R -> stableP P R.
Proof. unfold stable; propositional; eauto. Qed.
Local Hint Resolve stable_stableP : core.

Lemma trc_imply :forall t R (s s' : t), R^* s s' ->
  forall (R':_->_->Prop), (forall s s', R s s' -> R' s s') ->
  R'^* s s'.
Proof. induct 1; simplify; eauto. Qed.

Local Hint Extern 1 (_ >= _) => linear_arithmetic : core.
Local Hint Constructors notAboutToFail : core.

Theorem hoare_triple_sound : forall (t : Set) P (c : cmd t) Q,
  hoare_triple P (fun _ _ => False) c (fun _ _ => True) Q ->
  forall h, P h ->
  invariantFor (trsys_of h c) (fun st => notAboutToFail (snd st)).
Proof.
  (* Stuck? See hints.md. *)
Admitted.
End Impl.

Module ImplCorrect : Pset12Sig.S := Impl.


Require Import SetoidClass SetoidCat.

Definition andS := injF2 and _.

Definition orS := injF2 or _.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import HoTT.Homotopy.
Require Import tactics.

Lemma map_twovar_nondep {A : Type} {P : Type} {B : Type}
   {x y : A} {a : P } {b : P }
  (f : forall x : A, P  -> B) (p : x = y) (q :  a = b) :
  f x a = f y b.
Proof.
  induction p.
  simpl in q.
  induction q.
  apply idpath.
Defined.

Lemma map_twovar_2eq_nondep {A : Type} {P : Type} {B : Type}
   {x y : A} {a : P }
  (f : forall x : A, P  -> B) (p : x = y) :
  f x a = f y a.
Proof.
  induction p.
  apply idpath.
Defined.