Require Export Qual.grade.
Require Export Qual.defeq.
Require Export Qual.labels.
Require Export Qual.narrowing.
Require Export Qual.uniq.
Require Export Qual.subst.
Require Export Qual.consist.
Require Export Qual.pumping.
Require Export Qual.typing_ctx_fv.

Set Implicit Arguments.
Open Scope grade_scope.

(* -------------------------------------- *)

Lemma Typing_Grade : forall W psi a A, Typing W psi a A -> Grade (labels W) psi a.
Proof.
  intros W psi a A h.
  induction h; intros; subst; simpl; simpl_env; auto.
  all: try solve [fresh_apply_Grade x; auto;
    repeat spec x;
    match goal with [ H2 : Grade _ _ _ |- _ ] => simpl in H2; simpl_env in H2 end;
    eauto].
  - (* Var *)
    eapply G_Var with (psi0 := psi0); eauto using leq_join_r.
  - (* Abs *)
    fresh_apply_Grade x; auto; repeat spec x.
    simpl_env in H1.
    move: (Grade_uniq H1) => u. destruct_uniq.
    eapply Grade_narrowing; eauto. econstructor; eauto using leq_join_l, P_sub_refl, Typing_uniq.
    inversion IHh. subst.
    pick fresh x. repeat spec x.
    have LC: psi <= q_C. { eapply Typing_leq_C; eauto. }
    destruct (q_leb q_Top psi) eqn: LE.
    + assert (q_Top = q_C). { apply q_leb_antisym; auto. transitivity psi; auto.
                              eapply leq_Top. }
      assert (q_C = psi).  { apply q_leb_antisym; auto. rewrite <- H. auto. }
      subst.

      have Lemma: forall W, (meet_ctx_l q_Top W) = W.
      { clear. intro W. induction W. simpl; auto.
        destruct a. destruct p. simpl.
        rewrite meet_comm.
        rewrite meet_leq.
        eapply leq_Top. f_equal. auto. }
      rewrite <- H in H5.
      rewrite Lemma in H5.
      eapply CG_Leq; eauto.
      rewrite <- H. auto.
    + eapply CG_Nleq; eauto using Grade_lc.
      rewrite LE. done.
      apply Grade_uniq in H2. simpl_env in H2. destruct_uniq. auto.
  - (* App *)
    eapply G_App; eauto.
    destruct (q_leb psi0 psi) eqn:LE.
    rewrite join_leq in IHh2. rewrite LE. auto. auto.
    eapply CG_Nleq; eauto using Typing_lc1, Grade_uniq. rewrite LE. done.
  - (* AppI *)
    eapply G_App; eauto. eapply CG_Nleq; eauto using  Typing_lc1, Grade_uniq.
    move: (Typing_leq_C h1) => LE.
    move: (lt_not_leq ltac:(eassumption)) => NLQ.
    eapply not_leq_lower; eauto.
  - (* WPair *)
    destruct (q_leb psi0 psi) eqn:LE.
    eapply G_WPair; eauto. rewrite join_leq in IHh2. rewrite LE. auto. auto.
    eapply G_WPair; eauto.  eapply CG_Nleq; eauto using Typing_lc1, Grade_uniq. rewrite LE. done.
  - (* WPairI *)
    eapply G_WPair; eauto.
    eapply CG_Nleq; eauto using  Typing_lc1, Grade_uniq.
    move: (Typing_leq_C h3) => LE.
    move: (lt_not_leq ltac:(eassumption)) => NLQ.
    eapply not_leq_lower; eauto.
  - (* LetPair *)
    fresh_apply_Grade x; auto; repeat spec x.
    pick fresh y. repeat spec y.
    eapply Grade_narrowing; eauto.
    simpl; econstructor; eauto using leq_join_l, P_sub_refl, Typing_uniq.
  - (* SPair *)
    destruct (q_leb psi0 psi) eqn:LE.
    eapply G_SPair; eauto. rewrite join_leq in IHh2. rewrite LE. auto. auto.
    eapply G_SPair; eauto.  eapply CG_Nleq; eauto using Typing_lc1, Grade_uniq. rewrite LE. done.
 Qed.

Lemma Typing_meet_ctx_l : forall W psi b B q,
    Typing W psi b B ->
    Typing (meet_ctx_l q W) psi b B.
Proof.
  intros W psi b B q h. eapply Typing_narrowing; eauto.
  eapply meet_ctx_l_ctx_sub; eauto using Typing_uniq.
Qed.

(* Can only go up to CTime in typing *)
Lemma Typing_subsumption : forall psi1 a A W,
    Typing W psi1 a A ->
    forall psi2, psi1 <= psi2 -> psi2 <= q_C ->
    Typing W psi2 a A.
Proof.
  induction 1; intros.
  all: eauto 5 using leq_join_r.
  - (* var *)
    eapply T_Var with (psi0 := psi0); eauto.  transitivity psi; auto.
  - (* pi *)
    fresh_apply_Typing x; auto.
    repeat spec x.
    specialize (H5 psi2 ltac:(auto) ltac:(auto)).
    apply Typing_pumping with (psi1:=psi2) in H5; try reflexivity.
    eapply Typing_narrowing; eauto.
    econstructor; eauto using ctx_sub_refl, Typing_uniq.
    eapply leq_join_r.
    auto.
  - (* abs *)
    fresh_apply_Typing x; eauto.
    repeat spec x.
    specialize (H4 psi2 ltac:(auto) ltac:(auto)).
    apply Typing_pumping with (psi1:=psi2) in H4; try reflexivity.
    rewrite <- join_assoc in H4.
    rewrite (join_leq psi psi2) in H4. eauto.
    eauto.

  - (* app *)
    have LE: psi0 * psi2 <= q_C.
    { eapply join_lub; auto. }
    eapply T_App; eauto.
    eapply IHTyping2; eauto.
    eauto using po_join_r.
  - (* wsigma *)
    fresh_apply_Typing x; eauto.
    repeat spec x.
    specialize (H5 psi2 ltac:(auto) ltac:(auto)).
    apply Typing_pumping with (psi1:=psi2) in H5; try reflexivity.
    eapply Typing_narrowing; eauto.
    econstructor; eauto using ctx_sub_refl, Typing_uniq.
    eapply leq_join_r.
  - (* wpair *)
    have LE: psi0 * psi2 <= q_C.
    { eapply join_lub; auto. }
    eapply T_WPair; eauto.
    eapply IHTyping2; eauto.
    eauto using po_join_r.
  - (* letpair *)
    fresh_apply_Typing x; eauto.
    move=> y FrY.
    clear H H0 H2.
    spec x. spec y.
    specialize (H0 psi2 ltac:(auto) ltac:(auto)).
    apply Typing_pumping with (psi1:=psi2) in H0; try reflexivity.
    rewrite <- join_assoc in H0.
    rewrite (join_leq psi psi2) in H0. auto.
    auto.
  - (* SSigma *)
    fresh_apply_Typing x; eauto.
    repeat spec x.
    specialize (H5 psi2 ltac:(auto) ltac:(auto)).
    apply Typing_pumping with (psi1:=psi2) in H5; try reflexivity.
    eapply Typing_narrowing; eauto.
    econstructor; eauto using ctx_sub_refl, Typing_uniq.
    eapply leq_join_r.
  - (* SPair *)
    have LE: psi0 * psi2 <= q_C.
    { eapply join_lub; auto. }
    eapply T_SPair; eauto using po_join_r.
  - (* proj1 *)
    eapply T_Proj1; eauto. transitivity psi; auto.
  - (* case *)
    fresh_apply_Typing x; eauto.
    transitivity psi; auto.
Qed.

Lemma Typing_lift : forall W psi a A, Typing W psi a A -> Typing (meet_ctx_l q_C W) q_C a A.
Proof.
  intros.
  eapply Typing_subsumption with (psi1 := psi); eauto.
  eapply Typing_narrowing; eauto.
  eapply meet_ctx_l_ctx_sub.
  eapply Typing_uniq. eauto.
  eapply Typing_leq_C; eauto.
  reflexivity.
Qed.

(*
   The difficult case of this lemma is when ~ psi <= q_C.
   We need to go from a "squashed judgement" at q_C to one that is squashed down to q_C + psi.
   If psi >= q_C then we are done. But if not, then the meet will be lower than q_C and we don't
   want that.
 *)

Lemma meet_ctx_l_CTyping : forall W psi a A, CTyping W psi a A -> CTyping (meet_ctx_l q_C W) (q_C + psi) a A.
Proof.
  intros. inversion H. subst.
  + have L: psi <= q_C. eapply Typing_leq_C; eauto.
    rewrite meet_comm.
    eapply CT_Leq; eauto.
    rewrite meet_leq. auto.
    eapply Typing_meet_ctx_l. auto. eapply leq_meet_r.
  + subst.
    have h1: (q_C + psi <= q_C). eapply leq_meet_l.
    eapply CT_Leq; eauto.
    inversion H1. rewrite meet_leq; auto.
Qed.

Lemma Ctx_meet_ctx_l : forall W, Ctx W -> Ctx (meet_ctx_l q_C W).
Proof.
  induction 1; simpl; simpl_env; eauto.
  econstructor; simpl_env; eauto.
  rewrite dom_meet_ctx_l. auto.
Qed.

Lemma Ctx_regularity : forall G x psi A, Ctx G -> binds x (psi, A) G
                                    -> exists s, Typing (meet_ctx_l q_C G) q_C A (a_Type s).
Proof.
  induction 1; intros; eauto. inversion H.
  simpl in H2.
  destruct (binds_cons_1 _ _ _ _ _ _ H2).
  + split_hyp. inversion H4. subst.
    simpl_env. eexists.
    eapply Typing_weakening; eauto.
    unfold meet_ctx_l; auto.
    move: (Typing_uniq H0) => u. unfold meet_ctx_l in u.
    simpl. solve_uniq.
  + simpl_env.
    destruct IHCtx as [s0 T]; auto.
    eexists.
    eapply Typing_weakening; eauto.
    unfold meet_ctx_l; auto.
    move: (Typing_uniq H0) => u. unfold meet_ctx_l in u.
    simpl. solve_uniq.
Qed.

Ltac subst_CTyping_ih :=
    match goal with
      [ H3 : forall x0 psi1 A1 W3 W4, [(?y, (?q, ?A0))] ++ ?W2 ++ [(?x, (?psi0, ?A))] ++ ?W1 ~= _ -> _ |- _ ] =>
      specialize (H3 x psi0 A W1 ([(y, (q, A0))] ++ W2)) ; simpl_env in H3 ;
      specialize (H3 ltac:(reflexivity) ltac:(eassumption)) ;
      unfold subst_ctx in H3; simpl_env in H3 ; specialize (H3 ltac:(solve_uniq));
        repeat rewrite subst_tm_tm_open_tm_wrt_tm in H3; eauto using CTyping_lc1;
          rewrite subst_tm_tm_var_neq in H3; auto end.

Lemma Typing_substitution_CTyping : forall x psi0 A W1 W2 psi b a B,
    Typing (W2 ++ [(x, (psi0, A))] ++ W1) psi b B ->
    Ctx W1 ->
    CTyping W1 psi0 a A ->
    Typing (subst_ctx a x W2 ++ W1) psi (subst_tm_tm a x b) (subst_tm_tm a x B).
Proof.
  intros.
  have uu: uniq (subst_ctx a x W2 ++ W1) by
    move: (Typing_uniq H) => u1; unfold subst_ctx; solve_uniq.
  dependent induction H.
  all: simpl; eauto 2.
  - (* conv *)
    simpl_env in *.
    eapply T_Conv with (psi:=psi); simpl_env; eauto 3.
    -- match goal with [ H3 : CTyping _ _ _ _ |- _ ] => inversion H3; subst; clear H3 end.
    + eapply DefEq_substitution_same; eauto.
      eapply Typing_Grade.
      eapply Typing_subsumption; eauto.
      eapply Typing_narrowing; eauto.
      eapply meet_ctx_l_ctx_sub.
      eapply Typing_uniq; eauto.
      eapply Typing_leq_C; eauto.
    + match goal with [ H4 : q_C < ?psi0 |- _ ] => inversion H4 end.
      rewrite meet_leq in H0; auto.
      eapply DefEq_substitution_same; eauto.
      eapply Typing_Grade.
      eapply Typing_subsumption; eauto. reflexivity. reflexivity.
    -- eapply IHTyping2. eauto.
       eauto using Ctx_meet_ctx_l.
       eapply meet_ctx_l_CTyping; eauto.
       move: (Typing_uniq H1) => u.
       unfold subst_ctx. solve_uniq.
  - (* var *)
    destruct (x0 == x) eqn:E.
    match goal with [ H3 : CTyping _ _ _ _ |- _ ] => inversion H3; subst; clear H3 end.
    + (* substituting for this variable, relevant. *)
      apply binds_mid_eq in H1; auto. inversion H1. subst. clear H1.
      destruct_uniq.
      rewrite subst_tm_tm_fresh_eq; eauto.
      move: (Typing_ctx_fv ltac:(eassumption) ltac:(eassumption)) => [h1 h2]. fsetdec.
      eapply Typing_weakening_middle with (W2 := nil); simpl_env; eauto.
      eapply Typing_subsumption; eauto.
    + (* this variable, but irrelevant. contradiction *)
      apply binds_mid_eq in H1; auto. inversion H1. subst. clear H1.
      move: (lt_not_leq H6) => LE.
      have L: psi0 <= q_C by transitivity psi; auto.
      done.
    + eapply T_Var; eauto.
      apply binds_remove_mid in H1; auto.
      destruct (binds_app_1 _ _ _ _ _ H1).
      ++ eapply binds_map with (f := fun '(q, A) => (q, subst_tm_tm a x A)) in H5.
         eapply binds_app_2. auto.
      ++ eapply binds_app_3.
         rewrite subst_tm_tm_fresh_eq; eauto.
         move: (Ctx_regularity _ _ _ ltac:(eassumption) H5) => [s0 h1].
         move: (Typing_ctx_fv h1 (Ctx_meet_ctx_l H3)) => [h2 h3].
         destruct_uniq.
         rewrite dom_meet_ctx_l in h2.
         fsetdec.
  - (* pi *)
    fresh_apply_Typing y; eauto.
    repeat spec y.
    subst_CTyping_ih.
  - (* abs *)
    fresh_apply_Typing y.  repeat spec y.
    subst_CTyping_ih.
    simpl_env. eapply IHTyping; simpl_env; eauto.
    eauto using Ctx_meet_ctx_l.
    eapply meet_ctx_l_CTyping; eauto.
    move: (Typing_uniq H1) => u.
    unfold subst_ctx. simpl_env in u. solve_uniq.
  - (* App *)
    rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
  - (* AppI *)
    rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
    simpl_env in H0.
    eapply T_AppIrrel; eauto.
    fold subst_tm_tm.
    simpl_env.
    eapply IHTyping2; eauto using Ctx_meet_ctx_l. simpl_env. eauto.
    + eapply meet_ctx_l_CTyping; eauto.
    + move: (Typing_uniq H0) => u. destruct_uniq.
      unfold subst_ctx in *.
      eapply uniq_app; eauto.
  - (* WSigma *)
    fresh_apply_Typing y; eauto.
    repeat spec y.
    subst_CTyping_ih.
  - (* WPair *)
    eapply T_WPair; eauto.
    + specialize (IHTyping1 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
      simpl in IHTyping1.
      simpl_env in IHTyping1.
      simpl_env. eapply IHTyping1; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
      move: (Typing_uniq H) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
    + specialize (IHTyping3 x psi0 A W1 W2 ltac:(auto)).
      rewrite subst_tm_tm_open_tm_wrt_tm in IHTyping3; eauto using CTyping_lc1.
  - (* WPairI *)
    eapply T_WPairIrrel; simpl_env; eauto.
    + specialize (IHTyping1 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
      simpl in IHTyping1.
      simpl_env in IHTyping1.
      simpl_env. eapply IHTyping1; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
      move: (Typing_uniq H) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
    + specialize (IHTyping2 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
      simpl in IHTyping2.
      simpl_env in IHTyping2.
      simpl_env. eapply IHTyping2; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
      move: (Typing_uniq H) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
    + specialize (IHTyping3 x psi0 A W1 W2 ltac:(auto)).
      rewrite subst_tm_tm_open_tm_wrt_tm in IHTyping3; eauto using CTyping_lc1.
  - (* LetPair *)
    rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
    move: (Typing_uniq H1) => u.
    fresh_apply_Typing y.
    + clear H H2 H3. spec y.
      specialize (H x (q_C + psi0) A (meet_ctx_l q_C W1) ([(y, (q_C, a_WSigma psi1 A0 B))] ++ meet_ctx_l q_C W2)).
      simpl in H. simpl_env in H.
      specialize (H ltac:(eauto) ltac:(eauto using Ctx_meet_ctx_l) ltac:(eauto using meet_ctx_l_CTyping)).
      rewrite subst_tm_tm_open_tm_wrt_tm in H; eauto using CTyping_lc1.
      rewrite subst_tm_tm_var_neq in H; eauto.
      simpl_env. eapply H.
      eapply uniq_cons_3; eauto.
      unfold subst_ctx. unfold meet_ctx_l.
      solve_uniq.
      unfold subst_ctx. unfold meet_ctx_l.
      auto.
    + eapply IHTyping; eauto.
    + clear H H0 H2 IHTyping.
      move=> z Frz.
      spec y. spec z.
      specialize (H0 x psi0 A W1 ([(y, (psi1 * psi, A0))] ++ W2)).
      simpl_env in H0.
      specialize (H0 ltac:(reflexivity) ltac:(eassumption) ltac:(auto)).
      simpl in H0. simpl_env in H0.
      repeat rewrite subst_tm_tm_open_tm_wrt_tm in H0; eauto using CTyping_lc1.
      rewrite subst_tm_tm_var_neq in H0. auto.
      repeat rewrite subst_tm_tm_close_tm_wrt_tm in H0; eauto using CTyping_lc1.
      repeat rewrite subst_tm_tm_open_tm_wrt_tm in H0; eauto using CTyping_lc1.
      simpl in H0.
      destruct (y == x) eqn:E. subst. clear Frz. fsetdec. rewrite E in H0.
      destruct (z == x) eqn:E2. subst. clear Fr. fsetdec. rewrite E2 in H0.
      simpl_env in H0.
      eapply H0.
      unfold subst_ctx.
      solve_uniq.
  - (* SSigma *)
    fresh_apply_Typing y; eauto.
    repeat spec y.
    subst_CTyping_ih.
  - (* SPair *)
    eapply T_SPair; eauto.
    + specialize (IHTyping1 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
      simpl in IHTyping1.
      simpl_env in IHTyping1.
      simpl_env. eapply IHTyping1; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
      move: (Typing_uniq H) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
    + specialize (IHTyping3 x psi0 A W1 W2 ltac:(auto)).
      rewrite subst_tm_tm_open_tm_wrt_tm in IHTyping3; eauto using CTyping_lc1.
  - (* Proj1 *)
    eapply T_Proj1; eauto.
  - (* Proj2 *)
    rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
    eapply T_Proj2; eauto.
  - (* Sum *)
    eauto.
  - (* Inj1 *)
    eapply T_Inj1; eauto.
    specialize (IHTyping2 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
    simpl in IHTyping2.
    simpl_env in IHTyping2.
    simpl_env. eapply IHTyping2; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
    move: (Typing_uniq H0) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
  - (* Inj2 *)
    eapply T_Inj2; eauto.
    specialize (IHTyping2 x (q_C + psi0) A (meet_ctx_l q_C W1) (meet_ctx_l q_C W2)).
    simpl in IHTyping2.
    simpl_env in IHTyping2.
    simpl_env. eapply IHTyping2; eauto using meet_ctx_l_CTyping, Ctx_meet_ctx_l.
    move: (Typing_uniq H0) => u. simpl_env in u. unfold subst_ctx. solve_uniq.
  - (* case *)
    have US:  uniq (subst_ctx a x (meet_ctx_l q_C W2) ++ meet_ctx_l q_C W1).
    { eapply uniq_map_app_l.
      rewrite <- meet_ctx_l_app.
      eapply uniq_map_2.
      unfold subst_ctx in uu. solve_uniq.
      }
    have LCa: lc_tm a. eauto using CTyping_lc1.
    rewrite subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
    pick fresh y and apply T_Case; auto.
    3: { instantiate (1 := subst_tm_tm a x B1).
         replace (a_Var_f y) with (subst_tm_tm a x (a_Var_f y)).
         rewrite <- subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
         rewrite H2. eauto.
         rewrite -> subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
         rewrite subst_tm_tm_var_neq; auto.
    }
    3: { instantiate (1 := subst_tm_tm a x B2).
         replace (a_Var_f y) with (subst_tm_tm a x (a_Var_f y)).
         rewrite <- subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
         rewrite H3. eauto.
         rewrite -> subst_tm_tm_open_tm_wrt_tm; eauto using CTyping_lc1.
         rewrite subst_tm_tm_var_neq; auto.
    }

    + simpl_env.
      repeat spec y.
      specialize (H2 x (q_C + psi0) A (meet_ctx_l q_C W1) ([(y, (q_C, a_Sum A1 A2))] ++ (meet_ctx_l q_C W2))).
      simpl_env in H2.
      specialize (H2 ltac:(auto) ltac:(eauto using Ctx_meet_ctx_l) ltac:(eauto using meet_ctx_l_CTyping)).
      rewrite subst_tm_tm_open_tm_wrt_tm in H2; eauto using CTyping_lc1.
      rewrite subst_tm_tm_var_neq in H2. auto.
      simpl in H2. simpl_env in H2.
      eapply H2.
      eapply uniq_cons_3. auto.
      repeat rewrite dom_app. unfold subst_ctx. rewrite dom_map. repeat rewrite dom_meet_ctx_l. eauto.
    + eapply IHTyping1; eauto.
    + eapply IHTyping2; eauto.
    + eapply IHTyping3; eauto.
Qed.

Lemma Typing_substitution_middle : forall x psi0 A W1 W2 psi b a B,
    Typing (W2 ++ [(x, (psi0, A))] ++ W1) psi b B ->
    Typing W1 psi0 a A -> Ctx W1 ->
    Typing (subst_ctx a x W2 ++ W1) psi (subst_tm_tm a x b) (subst_tm_tm a x B).
Proof.
  intros.
  have LT: (psi0 <= q_C) by eauto using Typing_leq_C.
  eapply Typing_substitution_CTyping; eauto.
Qed.

Lemma Typing_substitution_irrel : forall x psi0 psi A W1 W2 b a B,
    Typing (W2 ++ [(x, (psi0, A))] ++ W1) psi b B ->
    q_C < psi0 ->
    Typing (meet_ctx_l q_C W1) q_C a A -> Ctx W1 ->
    Typing (subst_ctx a x W2 ++ W1) psi (subst_tm_tm a x b) (subst_tm_tm a x B).
Proof.
  intros.
  eapply Typing_substitution_CTyping; eauto.
Qed.

Lemma Typing_substitution : forall x psi0 A W psi b a B,
    Typing ([(x, (psi0, A))] ++ W) psi b B ->
    Typing W psi0 a A ->  Ctx W ->
    Typing W psi (subst_tm_tm a x b) (subst_tm_tm a x B).
intros. eapply Typing_substitution_middle with (W2 := nil); eauto. Qed.

Lemma Typing_open : forall x psi0 A W psi b a B,
    x `notin` fv_tm_tm b \u fv_tm_tm B ->
    Typing ([(x, (psi0, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x)) ->
    Typing W psi0 a A -> Ctx W ->
    Typing W psi (open_tm_wrt_tm b a) (open_tm_wrt_tm B a).
Proof.
  intros.
  rewrite (subst_tm_tm_intro x b); auto.
  rewrite (subst_tm_tm_intro x B); auto.
  eapply Typing_substitution; eauto.
Qed.

Local Lemma CTyping_Var : forall y psi0 A W, y `notin` dom W -> uniq W -> CTyping ([(y, (psi0, A))] ++ W) psi0 (a_Var_f y) A.
Proof.
  intros.
  destruct (order_q_C_dec psi0).
  eapply CT_Leq; eauto.
  eapply T_Var; eauto using q_leb_refl.
  eapply CT_Top; eauto; simpl_env.
  eapply T_Var; unfold meet_ctx_l; eauto using q_leb_refl.
  inversion q.
  rewrite meet_leq; auto.
Qed.

Lemma Typing_rename : forall x y W psi0 A psi b B,
   x `notin` fv_tm_tm b \u fv_tm_tm B  ->
   y `notin` fv_tm_tm b \u fv_tm_tm B \u dom W \u {{x}} ->
   Typing ([(x, (psi0, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x)) ->
   Ctx ([(y, (psi0, A))] ++ W) ->
   Typing ([(y, (psi0, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f y)) (open_tm_wrt_tm B (a_Var_f y)).
Proof.
  intros.
  move: (Typing_uniq H1) => u. destruct_uniq.
  apply Typing_weakening_middle with (W := [(y,(psi0,A))]) in H1.
  rewrite (subst_tm_tm_intro x b); auto.
  rewrite (subst_tm_tm_intro x B); auto.
  eapply Typing_substitution_CTyping with (W2 := nil); simpl_env; eauto.
  eapply CTyping_Var; eauto.
  solve_uniq.
Qed.

Lemma Typing_rename_Type : forall x y W psi0 A psi b s,
   x `notin` fv_tm_tm b  ->
   y `notin` fv_tm_tm b \u dom W \u {{x}} ->
   Typing ([(x, (psi0, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f x)) (a_Type s)->
   Ctx ([(y, (psi0, A))] ++ W) ->
   Typing ([(y, (psi0, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f y)) (a_Type s).
Proof.
  intros.
  move: (Typing_uniq H1) => u. destruct_uniq.
  apply Typing_weakening_middle with (W := [(y,(psi0,A))]) in H1.
  rewrite (subst_tm_tm_intro x b); auto.
  replace (a_Type s) with (subst_tm_tm (a_Var_f y) x (a_Type s)).
  eapply Typing_substitution_CTyping with (W2 := nil); simpl_env; eauto.
  eapply CTyping_Var; eauto.
  reflexivity.
  solve_uniq.
Qed.

Lemma T_Pi_inversion: forall (x : atom) W (psi psi1 : grade) (A B C : tm),
    x `notin` dom W \u fv_tm_tm B ->
    Typing W psi (a_Pi psi1 A B) C ->
    Ctx W ->
    exists s1, exists s2, exists s3, rule_pi s1 s2 s3 /\
  Typing W psi A (a_Type s1) /\
  Typing ([(x, (psi, A))] ++ W) psi (open_tm_wrt_tm B (a_Var_f x)) (a_Type s2) /\
  DefEq (labels (meet_ctx_l q_C W)) q_C  C (a_Type s3).
Proof.
  intros.
  dependent induction H0.
  - (* conv *)
    edestruct IHTyping1 as [s1 [s2 [s3 [r [hA [psi0 hh]]]]]]; eauto.
    repeat eexists; eauto.
  - (* Pi *)
    pick fresh y.
    repeat spec y.  clear IHTyping.
    eapply (@Typing_rename_Type y) in H1; eauto.
    repeat eexists.
    eauto. eauto. eauto.
    eapply Eq_Refl; eauto.
    econstructor.
    apply labels_uniq. move: (Typing_uniq H0) => u. unfold meet_ctx_l. auto.
    econstructor; eauto using Typing_lift.
Qed.

(* This is from Misha-Linger's thesis. I don't know if we need it. *)
(*
Lemma Sq_Pi_inversion: forall (x : atom) W (psi psi1 : grade) (A B C : tm),
    x `notin` dom W \u fv_tm_tm B ->
    q_C < psi ->
    CTyping W psi (a_Pi psi1 A B) C ->
    Ctx W ->
    CTyping W psi A a_Type /\
            CTyping ([(x, (psi1, A))] ++ W) psi (open_tm_wrt_tm B (a_Var_f x)) a_Type /\
            DefEq (labels (meet_ctx_l q_C W)) q_C  C a_Type.
Proof.
  intros.
  inversion H1. subst.
  + move: (Typing_leq_C H3) => LE.
    inversion H0. apply q_leb_antisym in LE; auto. done.
  + subst.
    eapply T_Pi_inversion with (x:= x) in H3; eauto. split_hyp.
    move: (Typing_uniq H5) => u. destruct_uniq.
    repeat split.
    eapply CT_Top; eauto.
    eapply CT_Top; eauto.
    simpl_env.
    eapply Typing_narrowing; eauto.
    econstructor; eauto using ctx_sub_refl, Typing_uniq.
    eapply leq_meet_l.
    simpl_env in *. auto.
    unfold meet_ctx_l. auto.
    eauto using Ctx_meet_ctx_l.
Qed.
*)

Lemma T_SSigma_inversion: forall (x : atom) W (psi psi1 : grade) (A B C : tm),
    x `notin` dom W \u fv_tm_tm B ->
    Typing W psi (a_SSigma psi1 A B) C ->
    Ctx W ->
     exists s1, exists s2, exists s3, rule_sig s1 s2 s3 /\
    Typing W psi A (a_Type s1) /\
    Typing ([(x, (psi, A))] ++ W) psi (open_tm_wrt_tm B (a_Var_f x)) (a_Type s2) /\
    DefEq (labels (meet_ctx_l q_C W)) q_C C (a_Type s3).
Proof.
  intros.
  dependent induction H0.
  - (* conv *)
    edestruct IHTyping1 as [s1 [s2 [s3 [r [hA [psi0 hh]]]]]]; split_hyp; eauto.
    repeat eexists; eauto.
  - (* Pi *)
    pick fresh y.
    repeat spec y.  clear IHTyping.
    eapply (@Typing_rename_Type y) in H1; eauto.
    repeat eexists.
    eauto. eauto. eauto.
    eapply Eq_Refl; eauto.
    econstructor.
    apply labels_uniq. move: (Typing_uniq H0) => u. unfold meet_ctx_l. auto.
    econstructor; eauto using Typing_lift.
Qed.

Lemma T_WSigma_inversion: forall (x : atom) W (psi psi1 : grade) (A B C : tm),
   x `notin` dom W \u fv_tm_tm B ->
   Typing W psi (a_WSigma psi1 A B) C ->
   Ctx W ->
   exists s1, exists s2, exists s3, rule_sig s1 s2 s3 /\
   Typing W psi A (a_Type s1) /\
   Typing ([(x, (psi, A))] ++ W) psi (open_tm_wrt_tm B (a_Var_f x)) (a_Type s2) /\
   DefEq (labels (meet_ctx_l q_C W)) q_C C (a_Type s3).
Proof.
  intros.
  dependent induction H0.
  - (* conv *)
    edestruct IHTyping1 as [s1 [s2 [s3 [r [hA [psi0 hh]]]]]]; split_hyp; eauto.
    repeat eexists; eauto.
  - (* Pi *)
    pick fresh y.
    repeat spec y.  clear IHTyping.
    eapply (@Typing_rename_Type y) in H1; eauto.
    repeat eexists. eauto. eauto. eauto.
    eapply Eq_Refl; eauto.
    econstructor.
    apply labels_uniq. move: (Typing_uniq H0) => u. unfold meet_ctx_l. auto.
    econstructor; eauto using Typing_lift.
Qed.

(* Coherence *)
Lemma Typing_regularity :
  forall G psi a A, Typing G psi a A -> Ctx G -> exists s, Typing (meet_ctx_l q_C G) q_C A (a_Type s).
Proof.
  induction 1; split_hyp; intros.
  all: try solve [eexists; eauto].
  all: try solve [ unfold meet_ctx_l; eauto using q_leb_refl ].
  - (* sort *)
    destruct (sort_regularity s2).
    exists x. eapply T_Type; eauto. reflexivity.
  - (* var *) eapply Ctx_regularity; eauto.
  - (* pi *)
    destruct (IHTyping ltac:(assumption)).
    destruct (sort_regularity s3).
    exists x0. eapply T_Type; eauto using Typing_uniq. reflexivity.
  - (* app *)
    clear IHTyping2. clear H.
    destruct IHTyping1 as [s h]; auto.
    pick fresh x.
    have Fr2: x `notin` dom (meet_ctx_l q_C W). unfold meet_ctx_l; eauto.
    move: (@T_Pi_inversion x (meet_ctx_l q_C W) q_C psi0 A B (a_Type s) ltac:(auto) ltac:(eauto) ltac:(eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r hh]]]].
    exists s2.
    split_hyp.
    rewrite (subst_tm_tm_intro x); eauto.
    replace (a_Type s2) with (subst_tm_tm a x (a_Type s2)).
    eapply Typing_substitution; eauto 3.
    eapply Typing_meet_ctx_l; eauto.
    eapply Typing_subsumption; eauto.
    eapply Typing_leq_C; eauto.
    reflexivity.
    eauto using Ctx_meet_ctx_l.
    auto.
  - (* AppI *)
    clear IHTyping2. clear H.
    destruct IHTyping1 as [s h]; auto.

    pick fresh x.
    have Fr2: x `notin` dom (meet_ctx_l q_C W). unfold meet_ctx_l; eauto.
    move: (@T_Pi_inversion x (meet_ctx_l q_C W) q_C psi0 A B (a_Type s) ltac:(auto) ltac:(eauto)  ltac:(eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r hh]]]].
    exists s2.
    split_hyp.
    rewrite (subst_tm_tm_intro x); auto.
    replace (a_Type s2) with (subst_tm_tm a x (a_Type s2)).
    eapply Typing_substitution; eauto.
    eauto using Ctx_meet_ctx_l.
    auto.
  - (* ... *)
    destruct (sort_regularity s3).
    exists x. eapply T_Type; eauto using Typing_uniq. reflexivity.
  - (* LetPair *)
    pick fresh x.
    repeat spec x.
    pick fresh y.
    repeat spec y.
    rewrite (subst_tm_tm_intro x); auto.
    clear H2. clear H3.
    destruct (IHTyping ltac:(assumption)) as [s1 hh].
    exists s.
    replace (a_Type s) with (subst_tm_tm a x (a_Type s)).
    eapply Typing_substitution; eauto 3.
    eapply Typing_meet_ctx_l; eauto.
    eapply Typing_subsumption; eauto.
    eapply Typing_leq_C; eauto.
    reflexivity.
    eauto using Ctx_meet_ctx_l.
    auto.
  - (* sigma *)
    destruct (IHTyping ltac:(assumption)).
    destruct (sort_regularity s3).
    exists x0. eapply T_Type; eauto using Typing_uniq. reflexivity.
  - (* Proj1 *)
    pick fresh x.
    specialize (IHTyping ltac:(eauto)).
    destruct IHTyping as [s hT].
    have Fr2: x `notin` dom (meet_ctx_l q_C W). unfold meet_ctx_l; eauto.
    move: (@T_SSigma_inversion x (meet_ctx_l q_C W) q_C psi0 A B (a_Type s) ltac:(auto) ltac:(eauto)  ltac:(eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r [h [psi1 hh]]]]]].
    split_hyp.
    eauto.
  - (* Proj2 *)
    pick fresh x.
    have Fr2: x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B. unfold meet_ctx_l; eauto.
    destruct IHTyping as [s hT]; auto.
    move: (@T_SSigma_inversion x _ _ psi0 A B (a_Type s) ltac:(auto) ltac:(eauto)  ltac:(eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r [h [psi1 hh]]]]]].
    split_hyp.
    rewrite (subst_tm_tm_intro x); auto.
    exists s2.
    replace (a_Type s2) with (subst_tm_tm (a_Proj1 psi0 a) x (a_Type s2)).
    eapply Typing_substitution; eauto 1.
    eapply T_Proj1; eauto.
    eapply Typing_meet_ctx_l; eauto.
    eapply Typing_subsumption; eauto.
    eapply Typing_leq_C; eauto. reflexivity.
    eauto using Ctx_meet_ctx_l.
    auto.
  - (* case *)
    pick fresh x. exists s.
    repeat spec x.
    rewrite (subst_tm_tm_intro x); auto.
    replace (a_Type s) with (subst_tm_tm a x (a_Type s)).
    eapply Typing_substitution; eauto 3.
    eapply Typing_meet_ctx_l; eauto.
    eapply Typing_subsumption; eauto.
    eapply Typing_leq_C; eauto.
    reflexivity.
    eauto using Ctx_meet_ctx_l.
    auto.
  -  destruct (sort_regularity s).
    exists x. eapply T_Type; eauto using Typing_uniq. reflexivity.
Unshelve. exact star.
Qed.

Lemma T_App_inversion: forall W (psi psi0 : grade) (a b C : tm),
    Typing W psi (a_App b psi0 a) C -> Ctx W ->
    exists A B, Typing W psi b (a_Pi psi0 A B) /\
           CTyping W (psi0 * psi) a A /\
           DefEq (labels (meet_ctx_l q_C W)) q_C C (open_tm_wrt_tm B a).
Proof.
  intros.
  dependent induction H.
  + (* conv *)
    edestruct IHTyping1 as [A1 [B1 hh]]; auto; try reflexivity.
    split_hyp.
    exists A1. exists B1.
    split; eauto.
  + (* app *)
    clear IHTyping1. clear IHTyping2.
    exists A. exists B.
    have LT: (psi0 * psi) <= q_C. eauto using Typing_leq_C.
    repeat split; auto.
    move: (Typing_regularity H ltac:(auto)) => [s0 hh].
    eapply Eq_PiSnd.
    eapply Eq_Refl.
    eapply Typing_Grade. eauto.
    eapply Eq_Refl.
    eapply Typing_Grade.
    eapply Typing_narrowing.
    eapply Typing_subsumption; eauto.
    eapply Typing_leq_C; eauto.
    eapply meet_ctx_l_ctx_sub.
    eapply Typing_uniq; eauto.
  + exists A. exists B.
    repeat split; auto.
    have: (q_C < psi0 * psi).
    { eapply still_higher; eauto using Typing_leq_C. }
    eapply CT_Top; eauto.
    apply Typing_regularity in H.
    move: H => [s0 HH].
    pick fresh x.
    apply (@T_Pi_inversion x) in HH; auto.
    move: HH => [s1 [s2 [s3 [r TH]]]].
    split_hyp.
    eapply Eq_Refl; eauto.
    eapply Typing_Grade with (A := subst_tm_tm a x (a_Type s2)) ; eauto.
    rewrite (subst_tm_tm_intro x); auto.
    eapply Typing_substitution; eauto using Ctx_meet_ctx_l.
    unfold meet_ctx_l; eauto.
    eauto using Ctx_meet_ctx_l.
    auto.
Qed.

Lemma T_Abs_inversion: forall W (psi psi0 : grade) (b C A : tm),
    Typing W psi (a_Abs psi0 A b) C ->
    Ctx W ->
    forall x, x `notin` dom W \u fv_tm_tm b ->
         exists s B,
           Typing ([(x, (psi0 * psi, A))] ++ W) psi (open_tm_wrt_tm b (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x)) /\
           (DefEq (labels (meet_ctx_l q_C W)) q_C C (a_Pi psi0 A B) /\
            Typing (meet_ctx_l q_C W) q_C (a_Pi psi0 A B) (a_Type s)) /\
            x `notin` fv_tm_tm B.
Proof.
  intros.
  dependent induction H.
  + (* conv *)
    edestruct IHTyping1 as [s0 [B1 hh]]; auto; try reflexivity.
    split_hyp.
    repeat eexists; eauto 2.
    eapply Eq_Trans with (b:=A0); auto.
  + (* abs *)
    clear IHTyping.
    move: (Typing_ctx_fv H1 ltac:(eauto using Ctx_meet_ctx_l)) => [h0 _].
    simpl in h0. rewrite dom_meet_ctx_l in h0.
    pick fresh y. repeat spec y.
    have Fr1: y `notin` dom (meet_ctx_l q_C W). {     rewrite dom_meet_ctx_l. auto. }

    move: (@T_Pi_inversion y (meet_ctx_l q_C W) q_C psi0 A B (a_Type s) ltac:(auto) ltac:(eauto)  ltac:(eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r [h [hh1 hh2]]]]]].
    exists s. exists B.
    repeat split; eauto 3.
    eapply (@Typing_rename y); auto 2.
    fsetdec.
    econstructor; eauto.
    eapply Eq_Refl.
    eapply Typing_Grade.
    eauto.
    eauto.
    eauto using Ctx_meet_ctx_l.

    fsetdec.
Qed.

Lemma T_SPair_inversion : forall W psi a psi0 b C,
       Typing W psi (a_SPair a psi0 b) C ->
       exists s A B, Typing (meet_ctx_l q_C W) q_C (a_SSigma psi0 A B) (a_Type s) /\
              Typing W (psi0 * psi) a A /\
              Typing W psi b (open_tm_wrt_tm B a) /\
              DefEq (labels (meet_ctx_l q_C W)) q_C C (a_SSigma psi0 A B).
Proof.
  intros.
  dependent induction H.
  - edestruct IHTyping1 as [s0 [A1 [B1 hh]]]; auto; try reflexivity.
    split_hyp.
    repeat eexists; eauto.
  - exists s. exists A. exists B.
    repeat split; eauto 1.
    eapply Eq_Refl; eauto.
    eapply Typing_Grade; eauto.
Qed.

Lemma T_WPair_inversion : forall W psi a psi0 b C,
       Typing W psi (a_WPair a psi0 b) C ->
       exists s A B, Typing (meet_ctx_l q_C W) q_C (a_WSigma psi0 A B) (a_Type s) /\
              CTyping W (psi0 * psi) a A /\
              Typing W psi b (open_tm_wrt_tm B a) /\
              DefEq (labels (meet_ctx_l q_C W)) q_C C (a_WSigma psi0 A B).
Proof.
  intros.
  dependent induction H.
  - edestruct IHTyping1 as [s0 [A1 [B1 hh]]]; auto; try reflexivity.
    split_hyp.
    repeat eexists; eauto.
  - exists s. exists A. exists B.
    have LT: (psi0 * psi <= q_C) by eauto using Typing_leq_C.
    repeat split; eauto 3.
    eapply Eq_Refl; eauto.
    eapply Typing_Grade; eauto.
  - exists s. exists A. exists B.
    repeat split; eauto 3.
    eapply CT_Top; eauto using still_higher, Typing_leq_C.
    eapply Eq_Refl; eauto.
    eapply Typing_Grade; eauto.
Qed.

Lemma T_Inj1_inversion : forall {W psi a0 C},
      Typing W psi (a_Inj1 a0) C -> Ctx W ->
      exists A1 A2, DefEq (labels (meet_ctx_l q_C W)) q_C (a_Sum A1 A2) C /\
               Typing W psi a0 A1.
Proof.
      intros. dependent induction H.
      - edestruct IHTyping1 as [A1 [A2 hh]]; eauto.
        exists A1. exists A2. split_hyp. split.
        eapply Eq_Trans with (b := A); auto using Eq_Sym.
        auto.
      - exists A1. exists A2. split.
        move: (Typing_regularity H ltac:(auto)) => hh.
        eapply Eq_Sym; eauto using Eq_Refl, Typing_Grade.
        auto.
Qed.

Lemma T_Inj2_inversion : forall {W psi a0 C},
      Typing W psi (a_Inj2 a0) C -> Ctx W ->
      exists A1 A2, DefEq (labels (meet_ctx_l q_C W)) q_C (a_Sum A1 A2) C /\
               Typing W psi a0 A2.
Proof.
      intros. dependent induction H.
      - edestruct IHTyping1 as [A1 [A2 hh]]; eauto.
        exists A1. exists A2. split_hyp. split.
        eapply Eq_Trans with (b := A); auto using Eq_Sym.
        auto.
      - exists A1. exists A2. split.
        move: (Typing_regularity H ltac:(auto)) => hh.
        eapply Eq_Sym; eauto using Eq_Refl, Typing_Grade.
        auto.
Qed.

Lemma Typing_preservation : forall W psi a A, Typing W psi a A -> Ctx W -> forall b, Step a b -> Typing W psi b A.
Proof.
  intros W psi a A h. induction h; intros;
                        match goal with [ H0 : Step ?a ?b |- _ ] => inversion H0; subst end.
  all: eauto.
  - (* Beta *)
    clear IHh1. clear IHh2.
    move: (T_Abs_inversion h1) => hh.
    pick fresh x.
    destruct (hh ltac:(auto) x ltac:(auto)) as [s [B0 hh1]]. split_hyp.
    have FrB0: x `notin` fv_tm_tm B0. eauto. clear hh.
    have FrW : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B0. unfold meet_ctx_l. auto.
    move: (T_Pi_inversion FrW ltac:(eassumption) ltac:(eauto using Ctx_meet_ctx_l)) =>
    [s1 [s2 [s3 [r hh]]]]. split_hyp.
    have EA: DefEq (labels (meet_ctx_l q_C W)) q_C A A0.
      {
        eapply Eq_PiFst; eauto.
      }
      have DO: DefEq (labels (meet_ctx_l q_C W)) q_C (open_tm_wrt_tm B a) (open_tm_wrt_tm B0 a).
      {
        eapply Eq_PiSnd; eauto 2.
        eapply Eq_Refl; eauto.
        eapply Typing_Grade; eauto.
        eapply Typing_subsumption with (psi1 := psi0 *psi); eauto.
        eapply Typing_narrowing; eauto.
        eapply meet_ctx_l_ctx_sub.
        eapply Typing_uniq.
        eauto.
        eapply Typing_leq_C.
        eauto.
        reflexivity.
      }
      move: (Typing_regularity h1 ltac:(auto)) => [s4 TAB].
      have FrW1 : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B. unfold meet_ctx_l. auto.
      move: (T_Pi_inversion FrW1 TAB ltac:(eauto using Ctx_meet_ctx_l)) =>
         [s1' [s2' [s3' [r' hh]]]]. split_hyp.

      eapply Eq_Sym in DO.
      eapply T_Conv with (A := open_tm_wrt_tm B0 a) (s:= s2'); auto.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      eapply Typing_substitution; eauto using Ctx_meet_ctx_l.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      replace (a_Type s2') with (subst_tm_tm a x (a_Type s2')).
      eapply Typing_substitution; eauto using Ctx_meet_ctx_l.

      eapply Typing_subsumption with (psi1 := psi0 * psi); eauto.
      eapply Typing_narrowing; eauto.
      eapply meet_ctx_l_ctx_sub.
      eapply Typing_uniq; eauto.
      eapply Typing_leq_C; eauto.
      reflexivity.
      auto.
  - (* AppI *)
    move: (T_Abs_inversion h1 ltac:(auto)) => hh.
    pick fresh x.
    destruct (hh x ltac:(auto)) as [s0 [B0 hh1]]. split_hyp.
    have FrB0: x `notin` fv_tm_tm B0. auto. clear hh.
    have FrW : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B0. unfold meet_ctx_l. auto.
    move: (T_Pi_inversion FrW ltac:(eassumption) ltac:(eauto using Ctx_meet_ctx_l)) =>  [s1 [s2 [s3 [r hh]]]]. split_hyp.
    have EA: DefEq (labels (meet_ctx_l q_C W)) q_C A A0.
      {
        eapply Eq_PiFst; eauto.
      }
      have DO: DefEq (labels (meet_ctx_l q_C W)) q_C (open_tm_wrt_tm B a) (open_tm_wrt_tm B0 a).
      {
        eapply Eq_PiSnd; eauto 2.
        eapply Eq_Refl.
        eapply Typing_Grade; eauto.
      }
      move: (Typing_regularity h1 ltac:(auto)) => [s4 TAB].
      have FrW1 : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B. unfold meet_ctx_l. auto.
      move: (T_Pi_inversion FrW1 TAB ltac:(eauto using Ctx_meet_ctx_l)) =>
      [s1' [s2' [s3' [r' hh']]]]. split_hyp.

      eapply Eq_Sym in DO.
      eapply T_Conv with (A := open_tm_wrt_tm B0 a)(s:=s2'); auto.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      eapply Typing_substitution_irrel with (W2 := nil); eauto using Ctx_meet_ctx_l.
      eapply still_higher; eauto using Typing_leq_C.
      eapply T_Conv with (A := A); simpl_env; eauto.

      rewrite (subst_tm_tm_intro x _ a). eauto.
      replace (a_Type s2') with (subst_tm_tm a x (a_Type s2')).
      eapply Typing_substitution; eauto using Ctx_meet_ctx_l.
      auto.

  - (* LetPair *)

    specialize (IHh ltac:(auto) ltac:(auto) ltac:(auto)).
    move: (Typing_lift h) => L1.
    move: (Typing_lift IHh) => L2'.
    have TCa: (Typing (meet_ctx_l q_C W) q_C (open_tm_wrt_tm C a) (a_Type s)).
    {
      pick fresh x. repeat spec x.
      rewrite (subst_tm_tm_intro x _ a). eauto.
      replace (a_Type s) with (subst_tm_tm a x (a_Type s)). 2:auto.
      eapply Typing_substitution; eauto using Ctx_meet_ctx_l.
    }
    have WE: DefEq (labels (meet_ctx_l q_C W)) q_C (a_SSigma psi0 A C) (a_SSigma psi0 A C).
      { eapply Eq_Refl.
        pick fresh x. move: (@T_WSigma_inversion x) => hh.
        move: (Typing_regularity h ltac:(auto)) => [s' R].
        specialize (hh  (meet_ctx_l q_C W) q_C psi0 A B (a_Type s')).
        specialize (hh ltac:(rewrite dom_meet_ctx_l; eauto) R ltac:(eauto using Ctx_meet_ctx_l)).
        destruct hh as [s1 [s2 [s3 [r hh]]]].
        split_hyp.
        fresh_apply_Grade y. eapply Typing_Grade; eauto.
        specialize (H y ltac:(auto)).
        eapply Typing_Grade in H. simpl_env in H.
        eapply H.
      }
    have ECaa: DefEq (labels (meet_ctx_l q_C W)) q_C  (open_tm_wrt_tm C a')  (open_tm_wrt_tm C a).
      { eapply Eq_SSigmaSnd. eapply WE. eapply Eq_Sym. eapply Eq_Beta; eauto using Typing_Grade. }
    eapply T_Conv with (A := open_tm_wrt_tm C a'); try eauto 1.
    + pick fresh x and apply T_LetPair; eauto.

  - (* LetPair Beta1 *)
    clear H0. clear H2. clear IHh.
    pick fresh x. repeat spec x.
    pick fresh y. repeat spec y.
    move: (T_WPair_inversion h) => [s0 [A0 [B0 hh]]]. split_hyp.
    move: (Typing_regularity h ltac:(auto)) => [s' TWS].
    apply (@T_WSigma_inversion x) in TWS; try rewrite dom_meet_ctx_l; auto using Ctx_meet_ctx_l.
    destruct TWS as [s1 [s2 [s3 [r TWS]]]].
    split_hyp.

    have Ta1 : CTyping W (psi0 * psi) a1 A.
    {
      inversion H2; subst.
      eapply CT_Leq.
      eapply T_Conv; eauto 1.
      eapply Eq_WSigmaFst; eauto.
      auto.
      eapply CT_Top; eauto 1.
      eapply T_Conv; eauto 1.
      simpl_env.
      eapply Eq_WSigmaFst; eauto.
      simpl_env.  eauto.
    }

    have Ta2 : Typing W psi a2 (open_tm_wrt_tm B a1).
    {
      eapply T_Conv. eassumption.
      eapply Eq_WSigmaSnd; eauto.
      eapply Typing_Grade; eauto.
      inversion H2; subst; eauto using Typing_lift.
      rewrite (subst_tm_tm_intro x); auto.
      replace (a_Type _) with (subst_tm_tm a1 x (a_Type s2)). 2: reflexivity.
      inversion H2; subst.
      + eapply Typing_substitution; eauto 3 using Ctx_meet_ctx_l.
        eapply Typing_lift.
        eapply T_Conv; eauto 1.
        eapply Eq_WSigmaFst; eauto.
      + eapply Typing_substitution; eauto 3 using Ctx_meet_ctx_l.
        eapply T_Conv; eauto 1.
        simpl_env.
        eapply Eq_WSigmaFst; eauto.
        simpl_env. eauto.
    }

    have Tca1: Typing W psi (open_tm_wrt_tm c a1)
                     (a_Pi q_Bot (open_tm_wrt_tm B a1)
                          (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair a1 psi0 (a_Var_f y))))).
    {
      rewrite (subst_tm_tm_intro x); auto.
      replace  (a_Pi q_Bot (open_tm_wrt_tm B a1) (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair a1 psi0 (a_Var_f y)))))
         with
        (subst_tm_tm a1 x (a_Pi q_Bot (open_tm_wrt_tm B (a_Var_f x))
                          (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair (a_Var_f x) psi0 (a_Var_f y)))))).
      eapply Typing_substitution_CTyping with (W2 := nil); eauto 1.
      simpl.
      repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto using Typing_lc1.
      rewrite subst_tm_tm_var.
      rewrite subst_tm_tm_fresh_eq; eauto.
      f_equal.
      repeat rewrite subst_tm_tm_close_tm_wrt_tm; eauto using Typing_lc1.
      repeat rewrite subst_tm_tm_open_tm_wrt_tm; eauto using Typing_lc1.
      rewrite subst_tm_tm_fresh_eq; eauto.
      replace  (subst_tm_tm a1 x (a_WPair (a_Var_f x) psi0 (a_Var_f y))) with
          (a_WPair (subst_tm_tm a1 x (a_Var_f x)) psi0 (subst_tm_tm a1 x (a_Var_f y))).
      rewrite subst_tm_tm_var.
      rewrite subst_tm_tm_var_neq. auto.
      auto.
      reflexivity.
    }
    have Tb : Typing W psi (a_App (open_tm_wrt_tm c a1) q_Bot a2)
                     (open_tm_wrt_tm (close_tm_wrt_tm y (open_tm_wrt_tm C (a_WPair a1 psi0 (a_Var_f y)))) a2).
    {
      eapply T_App; eauto 4 using leq_Bot.
      eapply Typing_subsumption. eassumption. eapply leq_join_r.
      eapply join_lub; eauto using Typing_leq_C, leq_Bot.
    }
    rewrite <- subst_tm_tm_spec in Tb.
    rewrite subst_tm_tm_open_tm_wrt_tm in Tb. eauto using Typing_lc1.
    rewrite subst_tm_tm_fresh_eq in Tb. auto.
    simpl in Tb.
    rewrite subst_tm_tm_fresh_eq in Tb. auto.
    destruct (y == y) eqn:h1. rewrite h1 in Tb. auto. done.
  - (* Proj1 *)
    move: (T_SPair_inversion h) => [s0 [A0 [B0 hh]]]. split_hyp.
    move: (Eq_SSigmaFst _ _ _ _ _ _ _ ltac:(eassumption)) => h1.
    apply Typing_regularity in h; auto. destruct h as [s tS].
    pick fresh x.
    apply (@T_SSigma_inversion x) in tS. move: tS => [s1 [s2 [s3 [r hh]]]]. split_hyp.
    eapply T_Conv; eauto.
    rewrite join_leq in H3; auto.
    rewrite dom_meet_ctx_l. auto. eapply Ctx_meet_ctx_l; auto.

  - (* Proj2 Cong *)
    move: (Typing_regularity h ltac:(auto)) => [s0 TSS].
    pick fresh x.
    have FrW: x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B.  unfold meet_ctx_l. auto.
    move: (T_SSigma_inversion FrW TSS ltac: (eauto using Ctx_meet_ctx_l)) => [s1 [s2 [s3 [r hh]]]]. split_hyp.

    have ES: DefEq (labels (meet_ctx_l q_C W)) q_C (a_SSigma psi0 A B) (a_SSigma psi0 A B).
    { eapply Eq_Refl. eapply Typing_Grade; eauto. }

    have SE: DefEq (labels (meet_ctx_l q_C W)) q_C (a_Proj1 psi0 a) (a_Proj1 psi0 a').
    { eapply Eq_Beta; eauto.
      eapply Typing_Grade; eauto.
      eapply T_Proj1; eauto.
      eapply Typing_lift; eauto.
      eapply Typing_Grade; eauto.
      eapply T_Proj1; eauto.
      eapply Typing_lift with (psi := psi); eauto.
    }
    eapply T_Conv with (A := open_tm_wrt_tm B (a_Proj1 psi0 a')).
    eapply T_Proj2; eauto.
    eapply Eq_SSigmaSnd; eauto.

    match goal with
      [ H2 : Typing ([(?x, (q_C, ?A))] ++ _) _ _ _ |- _ ] =>
        eapply Typing_substitution with (a := a_Proj1 psi0 a) in H2;
        simpl in H2;
        try rewrite <- subst_tm_tm_intro in H2; eauto
        end.

    eapply T_Proj1; eauto.
    eapply Typing_lift; eauto.
    eauto using Ctx_meet_ctx_l.
  - (* Proj2 beta *)
    clear IHh.
    move: (T_SPair_inversion h) => [s0 [A0 [B0 hh]]]. split_hyp.
    subst.
    pick fresh x.
    have FrW : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B0. unfold meet_ctx_l. auto.
    move: (T_SSigma_inversion FrW H2 ltac:(eauto using Ctx_meet_ctx_l)) => ?. split_hyp.
    move: (Typing_regularity h ltac:(auto)) => [s1 hh].
    have FrW1 : x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B. unfold meet_ctx_l. auto.
    move: (T_SSigma_inversion FrW1 hh ltac:(eauto using Ctx_meet_ctx_l)) => [s2 [s3 [s4 ?]]]. split_hyp.

    have TP : Typing (meet_ctx_l q_C W) q_C (a_Proj1 psi0 (a_SPair a1 psi0 b)) A0.
    {
      eapply T_Proj1; auto.
      eapply T_SPair; simpl_env; eauto.
      rewrite join_leq; auto.
      eapply Typing_lift; eauto.
      eapply Typing_lift; eauto.
    }

    eapply T_Conv with (A := (open_tm_wrt_tm B0 a1)); auto.
    eapply Eq_SSigmaSnd; eauto 1.
    eapply Eq_Sym; eauto 1.
    eapply Eq_Sym; eauto 1.
    eapply Eq_Beta; eauto 1.
    eapply Typing_Grade; eauto.
    eapply S_Proj1Beta; eauto.
    eapply Typing_Grade; eauto using Typing_lift.

    eapply Typing_substitution with (a := (a_Proj1 psi0 (a_SPair a1 psi0 b))) in H10.
    rewrite <- subst_tm_tm_intro in H10;  eauto.
    eapply T_Conv; simpl_env; eauto 2.
    eapply Eq_SSigmaFst; eauto 1.
    eapply Eq_Sym; eauto 1.
    eauto using Ctx_meet_ctx_l.
  - (* case cong *)
    clear H0.
    specialize (IHh1 ltac:(auto) _ ltac:(eauto)).
    clear IHh2 IHh3.
    move: (Typing_regularity IHh1) => TS.
    specialize (TS ltac:(auto)). destruct TS as [s0 TS].
    pick fresh x.
    move: (H x ltac:(auto)) => TB.
    have EP: DefEq (labels (meet_ctx_l q_C W)) q_C (a_Pi q_C (a_Sum A1 A2) B) (a_Pi q_C (a_Sum A1 A2) B).
    {
      eapply Eq_Refl.
      fresh_apply_Grade y; eauto using Typing_Grade.
      move: (@H y ltac:(auto)) => h.
      eapply Typing_Grade in h. simpl_env in h.
      auto.
    }
    eapply T_Conv.
    eapply T_Case; eauto.
    eapply Eq_PiSnd; eauto 2.
    eapply Eq_Sym.
    eapply Eq_Beta; eauto using Typing_lift, Typing_Grade.
    repeat spec x.
    replace (a_Type _) with (subst_tm_tm a x (a_Type s)). 2: reflexivity.
    rewrite (subst_tm_tm_intro x). auto.
    eapply Typing_substitution; eauto using Typing_lift, Ctx_meet_ctx_l.
  - (* case inj1 *)
    have [s1 TA1]: exists s, Typing (meet_ctx_l q_C W) q_C A1 (a_Type s) .
    { move: (Typing_regularity h2 ltac:(auto)) => [s0 TP1].
      pick fresh x.
      have F2: x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B1.  rewrite dom_meet_ctx_l. auto.
      move: (@T_Pi_inversion x _ _ _ A1 B1 _ F2 TP1 ltac:(eauto using Ctx_meet_ctx_l)) =>
      [s1 [s2 [s3 h0]]].
      split_hyp. eauto. }
    have [sb TB] : exists s, Typing (meet_ctx_l q_C W) q_C (open_tm_wrt_tm B (a_Inj1 a0)) (a_Type s).
    {
      pick fresh x.
      exists s.
      replace (a_Type s) with (subst_tm_tm (a_Inj1 a0) x (a_Type s)). 2: auto.
      rewrite (subst_tm_tm_intro x B); auto.
      eapply Typing_substitution; eauto 2.
      eapply Typing_lift; eauto.
      eapply Ctx_meet_ctx_l; eauto.
    }

    move: (T_Inj1_inversion h1 ltac:(auto)) => [A1' [A2' hh]]. split_hyp.
    eapply T_Conv with (A := open_tm_wrt_tm B1 a0); eauto 1.
    eapply T_App; eauto.
    eapply T_Conv with (A := A1'); eauto 2 using Typing_leq_C.
    eapply Typing_subsumption; eauto using leq_join_r.
    rewrite join_leq; auto. eapply Typing_leq_C; eauto.
    transitivity psi; auto. eapply Typing_leq_C; eauto.
    pick fresh x.
    rewrite (subst_tm_tm_intro x B1); auto.
    rewrite H1; auto.
    rewrite subst_tm_tm_open_tm_wrt_tm; auto.
    rewrite subst_tm_tm_fresh_eq; auto.
    replace (subst_tm_tm a0 x (a_Inj1 (a_Var_f x))) with (a_Inj1 a0).
    eapply Eq_Refl.
    eapply Typing_Grade; eauto.
    simpl. destruct (x == x) eqn:E. rewrite E.  auto. done.
  - (* case inj 2 *)
    have [s2 TA2] : exists s2, Typing (meet_ctx_l q_C W) q_C A2 (a_Type s2).
    { move: (Typing_regularity h3 ltac:(auto)) => [s0 TP1].
      pick fresh x.
      have F2: x `notin` dom (meet_ctx_l q_C W) \u fv_tm_tm B2.  rewrite dom_meet_ctx_l. auto.
      move: (@T_Pi_inversion x _ _ _ A2 B2 _ F2 TP1 ltac:(eauto using Ctx_meet_ctx_l)) => [s4 [s2 [s3 h0]]].
      split_hyp. eauto. }
    have [sb TB] : exists s, Typing (meet_ctx_l q_C W) q_C (open_tm_wrt_tm B (a_Inj2 a0)) (a_Type s).
    {
      pick fresh x. eexists.
      replace (a_Type s) with (subst_tm_tm (a_Inj2 a0) x (a_Type s)). 2: auto.
      rewrite (subst_tm_tm_intro x B); auto.
      eapply Typing_substitution; eauto 2.
      eapply Typing_lift; eauto.
      eapply Ctx_meet_ctx_l; eauto.
    }

    move: (T_Inj2_inversion h1 ltac:(auto)) => [A1' [A2' hh]]. split_hyp.
    eapply T_Conv with (A := open_tm_wrt_tm B2 a0); eauto 1.
    eapply T_App; eauto.
    eapply T_Conv with (A := A2'); eauto 2 using Typing_leq_C.
    eapply Typing_subsumption; eauto using leq_join_r.
    rewrite join_leq; auto. eapply Typing_leq_C; eauto.
    transitivity psi; auto. eapply Typing_leq_C; eauto.
    pick fresh x.
    rewrite (subst_tm_tm_intro x B2); auto.
    rewrite H2; auto.
    rewrite subst_tm_tm_open_tm_wrt_tm; auto.
    rewrite subst_tm_tm_fresh_eq; auto.
    replace (subst_tm_tm a0 x (a_Inj2 (a_Var_f x))) with (a_Inj2 a0).
    eapply Eq_Refl.
    eapply Typing_Grade; eauto.
    simpl. destruct (x == x) eqn:E. rewrite E.  auto. done.
Qed.


Require Import List Omega.

Require Import bf_vs_bi.
Require Import bigstep.
Require Import coinduction.
Require Import copy.
Require Import datatypes.
Require Import dither.
Require Import halting_defs.
Require Import join.
Require Import Ndiv2oo.
Require Import shift.
Require Import shift_maxsource.
Require Import streams_vs_lists.
Require Import witness.

(* First half of the proof:
   supposing that Witness halts leads to absurd
*)

Lemma witness_stops_absurd:
      halt witness (gamma witness) -> False.
unfold halt; intro.
elim H; clear H. intro t; intro.

cut (bi witness (pair Bs (app_ls (ones (S (gamma witness))) Bs)) 0).
intro. apply bf_not_bi with
       witness (pair Bs (app_ls (ones (S (gamma witness))) Bs))
       0 t (max_source witness 0 + 1).
assumption. assumption.
unfold witness at 1.

(* First decomposition *)

apply join_loop with
      (pair Bs (app_ls (ones (S (gamma witness)))
                       (Cons B (app_ls (ones (S (gamma witness))) Bs))))
      7.

(* Copy machine *)

apply Copy_stops.

(* Second decomposition *)

apply join_loop with (pair Bs (Cons one Bs))
                     (max_source HM 0 + 8).

(* HM machine *)

change 7 with (7+0) at 2.
change 8 with (7+1). rewrite (Nat.add_comm 7 1).
rewrite Nat.add_assoc. rewrite (Nat.add_comm (max_source HM 0 + 1) 7).
apply shift_preserves_stop. apply HM_decides_stop.
unfold halt. exists t. assumption.
clear H t.

(* Dither machine *)

change (max_source HM 0 + 8) with (0 + (max_source HM 0 + 8)) at 2.
rewrite (Nat.add_comm 0 (max_source HM 0 + 8)). apply shift_preserves_loop.
apply Dither_loops.

(* join condition: 1st check
*)

clear H t; unfold not, Dither. simpl; intros.

assert (i <= (max_source HM 0)+7).
apply shift_maxsource. assumption.
omega.

(* 2nd check
*)

clear H t; unfold not, Dither. simpl; intros.

assert (i >= 7 \/ In i (proj_target
       ((max_source HM 0 + 8 + 0, one, max_source HM 0 + 8 + 1, R)
          :: (max_source HM 0 + 8 + 1, B, max_source HM 0 + 8 + 0, L)
             :: (max_source HM 0 + 8 + 1, one, max_source HM 0 + 8 + 2, L)
                :: nil))).
apply app_shift with HM. assumption.
clear H; simpl in H1. omega.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*i Due to L.Thery i*)

(************************************************************)
(* Definitions of log and Rpower : R->R->R; main properties *)
(************************************************************)

Require Import XRbase.
Require Import XRfunctions.
Require Import XSeqSeries.
Require Import XRtrigo1.
Require Import XRanalysis1.
Require Import XExp_prop.
Require Import XRsqrt_def.
Require Import XR_sqrt.
Require Import XSqrt_reg.
Require Import XMVT.
Require Import XRanalysis4.
Local Open Scope XR_scope.

Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
Proof.
  intros P x y H1 H2; unfold Rmin; case (Rle_dec x y); intro;
    assumption.
Qed.

Lemma exp_le_3 : exp R1 <= R3.
Proof.
  assert (exp_1 : exp R1 <> R0).
  assert (H0 := exp_pos R1); red; intro; rewrite H in H0;
    elim (Rlt_irrefl _ H0).
  apply Rmult_le_reg_l with (/ exp R1).
  apply Rinv_0_lt_compat; apply exp_pos.
  rewrite <- Rinv_l_sym.
  apply Rmult_le_reg_l with (/ R3).
  apply Rinv_0_lt_compat; exact Rlt_0_3.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm R3); rewrite <- Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; replace (/ exp R1) with (exp (-R1)).
  unfold exp; case (exist_exp (-R1)) as (?,e); simpl in |- *;
    unfold exp_in in e;
      assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
  cut
    (sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (S (2 * 1)) <= x <=
      sum_f_R0 (tg_alt (fun i:nat => / INR (fact i))) (2 * 1)).
  intro; elim H0; clear H0; intros H0 _; simpl in H0; unfold tg_alt in H0;
    simpl in H0.
  replace (/ R3) with
  (R1 * / R1 + -R1 * R1 * / R1 + -R1 * (-R1 * R1) * / R2 +
    -R1 * (-R1 * (-R1 * R1)) * / (R2 + R1 + R1 + R1 + R1)).
  apply H0.
{
  repeat rewrite Rmult_1_l.
  repeat rewrite Rmult_1_r.
  repeat rewrite Rinv_1.
  repeat rewrite Rmult_1_r.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite Ropp_involutive.
  repeat rewrite Rmult_1_l.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r, Rplus_0_l.
  eapply Rplus_eq_reg_r.
  rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
  repeat rewrite <- Rplus_assoc.
  fold R3.
  repeat rewrite Rplus_assoc.
  fold R2.
  rewrite (Rplus_comm R1).
  fold R3.
  rewrite <- double.
  rewrite Rinv_mult_distr.
  pattern (/R3) at 1;rewrite <- Rmult_1_l.
  rewrite <- Rmult_plus_distr_r.
  pattern R1;rewrite double_var.
  unfold Rdiv.
  pattern (/ IZR 2) at 3;rewrite <- Rmult_1_l.
  rewrite <- Rmult_plus_distr_r.
  rewrite <- Rmult_plus_distr_r.
  fold R2.
  fold R3.
  rewrite Rmult_comm.
  rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l.
  reflexivity.
  exact Neq_3_0.
  exact Neq_2_0.
  exact Neq_3_0.
}
  apply H.
  unfold Un_decreasing; intros;
    apply Rmult_le_reg_l with (INR (fact n)).
  apply INR_fact_lt_0.
  apply Rmult_le_reg_l with (INR (fact (S n))).
  apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
  apply INR_fact_neq_0.
  apply INR_fact_neq_0.
  assert (H0 := cv_speed_pow_fact R1); unfold Un_cv; unfold Un_cv in H0;
    intros; elim (H0 _ H1); intros; exists x0; intros;
      unfold R_dist in H2; unfold R_dist;
        replace (/ INR (fact n)) with (R1 ^ n / INR (fact n)).
  apply (H2 _ H3).
  unfold Rdiv; rewrite pow1; rewrite Rmult_1_l; reflexivity.
  unfold infinite_sum in e; unfold Un_cv, tg_alt; intros; elim (e _ H0);
    intros; exists x0; intros;
      replace (sum_f_R0 (fun i:nat => (-R1) ^ i * / INR (fact i)) n) with
      (sum_f_R0 (fun i:nat => / INR (fact i) * (-R1) ^ i) n).
  apply (H1 _ H2).
  apply sum_eq; intros; apply Rmult_comm.
  apply Rmult_eq_reg_l with (exp R1).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
    rewrite <- Rinv_r_sym.
  reflexivity.
  assumption.
  assumption.
  exact Neq_3_0.
  assumption.
Qed.

(******************************************************************)
(** *                     Properties of  Exp                      *)
(******************************************************************)

Theorem exp_increasing : forall x y:R, x < y -> exp x < exp y.
Proof.
  intros x y H.
  assert (H0 : derivable exp).
  apply derivable_exp.
  assert (H1 := positive_derivative _ H0).
  unfold strict_increasing in H1.
  apply H1.
  intro.
  replace (derive_pt exp x0 (H0 x0)) with (exp x0).
  apply exp_pos.
  symmetry ; apply derive_pt_eq_0.
  apply (derivable_pt_lim_exp x0).
  apply H.
Qed.

Theorem exp_lt_inv : forall x y:R, exp x < exp y -> x < y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ].
  assumption.
  rewrite H1 in H; elim (Rlt_irrefl _ H).
  assert (H2 := exp_increasing _ _ H1).
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H H2)).
Qed.

Lemma exp_ineq1 : forall x:R, R0 < x -> R1 + x < exp x.
Proof.
  intros; apply Rplus_lt_reg_l with (- exp R0); rewrite <- (Rplus_comm (exp x));
    assert (H0 := MVT_cor1 exp R0 x derivable_exp H); elim H0;
      intros; elim H1; intros; unfold Rminus in H2; rewrite H2;
        rewrite Ropp_0; rewrite Rplus_0_r;
          replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
  rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
    pattern x at 1; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
      apply Rmult_lt_compat_l.
  apply H.
  rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
  symmetry ; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
Qed.

Lemma ln_exists1 : forall y:R, R1 <= y -> { z:R | y = exp z }.
Proof.
  intros; set (f := fun x:R => exp x - y).
  assert (H0 : R0 < y) by (apply Rlt_le_trans with R1; auto with real).
  cut (f R0 <= R0); [intro H1|].
  cut (continuity f); [intro H2|].
  cut (R0 <= f y); [intro H3|].
  cut (f R0 * f y <= R0); [intro H4|].
  pose proof (IVT_cor f R0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7));
    exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7.
  pattern R0 at 2; rewrite <- (Rmult_0_r (f y));
    rewrite (Rmult_comm (f R0)); apply Rmult_le_compat_l;
      assumption.
  unfold f; apply Rplus_le_reg_l with y; left;
    apply Rlt_trans with (R1 + y).
  rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
  replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | idtac ].
rewrite Rplus_minus. reflexivity.
  unfold f; change (continuity (exp - fct_cte y));
    apply continuity_minus;
      [ apply derivable_continuous; apply derivable_exp
        | apply derivable_continuous; apply derivable_const ].
  unfold f; rewrite exp_0; apply Rplus_le_reg_l with y;
    rewrite Rplus_0_r; replace (y + (R1 - y)) with R1; [ apply H | idtac ].
rewrite Rplus_minus. reflexivity.
Qed.

(**********)
Lemma ln_exists : forall y:R, R0 < y -> { z:R | y = exp z }.
Proof.
  intros; destruct (Rle_dec R1 y) as [Hle|Hnle].
  apply (ln_exists1 _ Hle).
  assert (H0 : R1 <= / y).
  apply Rmult_le_reg_l with y.
  apply H.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ Hnle).
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  destruct (ln_exists1 _ H0) as (x,p); exists (- x);
    apply Rmult_eq_reg_l with (exp x / y).
  unfold Rdiv; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
    rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
      rewrite Rmult_1_r; symmetry ; apply p.
  red; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
  unfold Rdiv; apply prod_neq_R0.
  assert (H3 := exp_pos x); red; intro H4; rewrite H4 in H3;
    elim (Rlt_irrefl _ H3).
  apply Rinv_neq_0_compat; red; intro H3; rewrite H3 in H;
    elim (Rlt_irrefl _ H).
Qed.

(* Definition of log R+* -> R *)
Definition Rln (y:posreal) : R :=
  let (a,_) := ln_exists y (cond_pos y) in a.

(* Extension on R *)
Definition ln (x:R) : R :=
  match Rlt_dec R0 x with
    | left a => Rln (mkposreal x a)
    | right a => R0
  end.

Lemma exp_ln : forall x:R, R0 < x -> exp (ln x) = x.
Proof.
  intros; unfold ln; decide (Rlt_dec R0 x) with H.
  unfold Rln;
    case (ln_exists (mkposreal x H) (cond_pos (mkposreal x H))) as (?,Hex).
  symmetry; apply Hex.
Qed.

Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
Proof.
  intros x y H; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ]; auto;
    assert (H2 := exp_increasing _ _ H1); rewrite H in H2;
      elim (Rlt_irrefl _ H2).
Qed.

Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
Proof.
  intros x; assert (H : exp x <> R0).
  assert (H := exp_pos x); red; intro; rewrite H0 in H;
    elim (Rlt_irrefl _ H).
  apply Rmult_eq_reg_l with (r := exp x).
  rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
  apply Rinv_r_sym.
  apply H.
  apply H.
Qed.

(******************************************************************)
(** *                     Properties of  Ln                       *)
(******************************************************************)

Theorem ln_increasing : forall x y:R, R0 < x -> x < y -> ln x < ln y.
Proof.
  intros x y H H0; apply exp_lt_inv.
  repeat rewrite exp_ln.
  apply H0.
  apply Rlt_trans with x; assumption.
  apply H.
Qed.

Theorem ln_exp : forall x:R, ln (exp x) = x.
Proof.
  intros x; apply exp_inv.
  apply exp_ln.
  apply exp_pos.
Qed.

Theorem ln_1 : ln R1 = R0.
Proof.
  rewrite <- exp_0; rewrite ln_exp; reflexivity.
Qed.

Theorem ln_lt_inv : forall x y:R, R0 < x -> R0 < y -> ln x < ln y -> x < y.
Proof.
  intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y).
  apply exp_increasing; apply H1.
  assumption.
  assumption.
Qed.

Theorem ln_inv : forall x y:R, R0 < x -> R0 < y -> ln x = ln y -> x = y.
Proof.
  intros x y H H0 H'0; case (Rtotal_order x y); [ intros H1 | intros [H1| H1] ];
    auto.
  assert (H2 := ln_increasing _ _ H H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
  assert (H2 := ln_increasing _ _ H0 H1); rewrite H'0 in H2;
    elim (Rlt_irrefl _ H2).
Qed.

Theorem ln_mult : forall x y:R, R0 < x -> R0 < y -> ln (x * y) = ln x + ln y.
Proof.
  intros x y H H0; apply exp_inv.
  rewrite exp_plus.
  repeat rewrite exp_ln.
  reflexivity.
  assumption.
  assumption.
  apply Rmult_lt_0_compat; assumption.
Qed.

Theorem ln_Rinv : forall x:R, R0 < x -> ln (/ x) = - ln x.
Proof.
  intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp.
  reflexivity.
  assumption.
  apply Rinv_0_lt_compat; assumption.
Qed.

Lemma Rgt_minus : forall r1 r2, r2 < r1 -> R0 < r1 - r2.
Proof.
  intros.
  unfold Rminus.
  eapply Rplus_lt_reg_r.
  rewrite Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_r, Rplus_0_l.
  assumption.
Qed.

Lemma Rgt_ge : forall r1 r2, r2 < r1 -> r2 <= r1.
Proof.
  intros; red; tauto.
Qed.

Theorem ln_continue :
  forall y:R, R0 < y -> continue_in ln (fun x:R => R0 < x) y.
Proof.
  intros y H.
  unfold continue_in, limit1_in, limit_in; intros eps Heps.
  cut (R1 < exp eps); [ intros H1 | idtac ].
  cut (exp (- eps) < R1); [ intros H2 | idtac ].
  exists (Rmin (y * (exp eps - R1)) (y * (R1 - exp (- eps)))); split.
  apply P_Rmin.
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_l with R1.
  rewrite Rplus_0_r; replace (R1 + (exp eps - R1)) with (exp eps);
    [ apply H1 | idtac ].
rewrite Rplus_minus. reflexivity.
  apply Rmult_lt_0_compat.
  assumption.
  apply Rplus_lt_reg_l with (exp (- eps)).
  rewrite Rplus_0_r; replace (exp (- eps) + (R1 - exp (- eps))) with R1;
    [ apply H2 | idtac ].
rewrite Rplus_minus. reflexivity.
  unfold dist, R_met, R_dist; simpl.
  intros x [[H3 H4] H5].
  cut (y * (x * / y) = x).
  intro Hxyy.
  replace (ln x - ln y) with (ln (x * / y)).
  case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ].
  rewrite Rabs_left.
  apply Ropp_lt_cancel; rewrite Ropp_involutive.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Ropp_lt_cancel.
  apply Rplus_lt_reg_l with (r := y).
  replace (y + - (y * exp (- eps))) with (y * (R1 - exp (- eps)));
  [ idtac | idtac ].
2:{
unfold Rminus.
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
rewrite <- Ropp_mult_distr_r.
reflexivity.
}
  replace (y + - x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_r.
  rewrite Rabs_left.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
rewrite Rplus_comm.
reflexivity.
  apply (Rlt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply ln_increasing.
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite Hxy; rewrite Rinv_r.
  rewrite ln_1; rewrite Rabs_R0; apply Heps.
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  rewrite Rabs_right.
  apply exp_lt_inv.
  rewrite exp_ln.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy.
  apply Rplus_lt_reg_l with (r := - y).
  replace (- y + y * exp eps) with (y * (exp eps - R1)).
2:{
unfold Rminus.
rewrite Rmult_plus_distr_l.
rewrite <- Ropp_mult_distr_r.
rewrite Rmult_1_r.
rewrite Rplus_comm.
reflexivity.
}
  replace (- y + x) with (Rabs (x - y)).
  apply Rlt_le_trans with (1 := H5); apply Rmin_l.
  rewrite Rabs_right.
unfold Rminus. rewrite Rplus_comm. reflexivity.
  left; apply (Rgt_minus _ _ Hxy).
  apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
  rewrite <- ln_1.
  apply Rgt_ge; apply ln_increasing.
  apply Rlt_0_1.
  apply Rmult_lt_reg_l with (r := y).
  apply H.
  rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
  rewrite ln_mult.
  rewrite ln_Rinv.
reflexivity.
  assumption.
  assumption.
  apply Rinv_0_lt_compat; assumption.
  rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_l. reflexivity.
  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
  apply Rmult_lt_reg_l with (exp eps).
  apply exp_pos.
  rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
    apply H1.
  rewrite <- exp_0.
  apply exp_increasing; apply Heps.
Qed.

(******************************************************************)
(** *                     Definition of  Rpower                   *)
(******************************************************************)

Definition Rpower (x y:R) := exp (y * ln x).

Local Infix "^R" := Rpower (at level 30, right associativity) : XR_scope.

(******************************************************************)
(** *                     Properties of  Rpower                   *)
(******************************************************************)

(** Note: [Rpower] is prolongated to [1] on negative real numbers and
    it thus does not extend integer power. The next two lemmas, which
    hold for integer power, accidentally hold on negative real numbers
    as a side effect of the default value taken on negative real
    numbers. Contrastingly, the lemmas that do not hold for the
    integer power of a negative number are stated for [Rpower] on the
    positive numbers only (even if they accidentally hold due to the
    default value of [Rpower] on the negative side, as it is the case
    for [Rpower_O]). *)

Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
Proof.
  intros x y z; unfold Rpower.
  rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
Qed.

Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
Proof.
  intros x y z; unfold Rpower.
  rewrite ln_exp.
  replace (z * (y * ln x)) with (y * z * ln x).
  reflexivity.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  reflexivity.
Qed.

Theorem Rpower_O : forall x:R, R0 < x -> x ^R R0 = R1.
Proof.
  intros x _; unfold Rpower.
  rewrite Rmult_0_l; apply exp_0.
Qed.

Theorem Rpower_1 : forall x:R, R0 < x -> x ^R R1 = x.
Proof.
  intros x H; unfold Rpower.
  rewrite Rmult_1_l; apply exp_ln; apply H.
Qed.

Theorem Rpower_pow : forall (n:nat) (x:R), R0 < x -> x ^R INR n = x ^ n.
Proof.
  intros n; elim n; simpl; auto; fold INR.
  intros x H; apply Rpower_O; auto.
  intros n1; case n1.
  intros H x H0; simpl; rewrite Rmult_1_r; apply Rpower_1; auto.
  intros n0 H x H0.
  simpl.
rewrite Rpower_plus. rewrite H; try rewrite Rpower_1;
    try apply Rmult_comm || assumption.
Qed.

Theorem Rpower_lt :
  forall x y z:R, R1 < x -> y < z -> x ^R y < x ^R z.
Proof.
  intros x y z H H1.
  unfold Rpower.
  apply exp_increasing.
  apply Rmult_lt_compat_r.
  rewrite <- ln_1; apply ln_increasing.
  apply Rlt_0_1.
  apply H.
  apply H1.
Qed.

Theorem Rpower_sqrt : forall x:R, R0 < x -> x ^R (/ R2) = sqrt x.
Proof.
  intros x H.
  apply ln_inv.
  unfold Rpower; apply exp_pos.
  apply sqrt_lt_R0; apply H.
  apply Rmult_eq_reg_l with (INR 2).
  apply exp_inv.
  fold Rpower.
  cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2).
  unfold Rpower; auto.
  rewrite Rpower_mult.
  rewrite Rinv_l.
  change R1 with (INR 1).
  repeat rewrite Rpower_pow; simpl.
  pattern x at 1; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
repeat rewrite <- Rmult_assoc. reflexivity.
  apply sqrt_lt_R0; apply H.
  apply H.
  apply not_O_INR; discriminate.
  apply not_O_INR; discriminate.
Qed.

Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
Proof.
  unfold Rpower.
  intros x y; rewrite Ropp_mult_distr_l_reverse.
  apply exp_Ropp.
Qed.

Lemma powerRZ_Rpower x z : (R0 < x)%R -> powerRZ x z = Rpower x (IZR z).
Proof.
  intros Hx.
  assert (x <> R0)%R
    by now intros Habs; rewrite Habs in Hx; apply (Rlt_irrefl R0).
  destruct (intP z).
  - now rewrite Rpower_O.
  - rewrite <- pow_powerRZ, <- Rpower_pow by assumption.
    now rewrite INR_IZR_INZ.
  - rewrite opp_IZR, Rpower_Ropp.
    rewrite powerRZ_neg, powerRZ_inv by assumption.
    now rewrite <- pow_powerRZ, <- INR_IZR_INZ, Rpower_pow.
Qed.

Theorem Rle_Rpower :
  forall e n m:R, R1 <= e -> n <= m -> e ^R n <= e ^R m.
Proof.
  intros e n m [H | H]; intros H1.
  case H1.
    intros H2; left; apply Rpower_lt; assumption.
    intros H2; rewrite H2; right; reflexivity.
  now rewrite <- H; unfold Rpower; rewrite ln_1, !Rmult_0_r; apply Rle_refl.
Qed.

Theorem ln_lt_2 : / R2 < ln R2.
Proof.
  apply Rmult_lt_reg_l with (r := R2).
exact Rlt_0_2.
  rewrite Rinv_r.
  apply exp_lt_inv.
  apply Rle_lt_trans with (1 := exp_le_3).
  change (R3 < R2 ^R (R1 + R1)).
  repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
rewrite double.
unfold R3.
apply Rplus_lt_compat_l.
unfold R2.
pattern R1 at 1;rewrite <- Rplus_0_l.
apply Rplus_lt_compat_r.
exact Rlt_0_1.
exact Rlt_0_2.
exact Neq_2_0.
Qed.

(*****************************************)
(** * Differentiability of Ln and Rpower *)
(*****************************************)

Theorem limit1_ext :
  forall (f g:R -> R) (D:R -> Prop) (l x:R),
    (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
Proof.
  intros f g D l x H; unfold limit1_in, limit_in.
  intros H0 eps H1; case (H0 eps); auto.
  intros x0 [H2 H3]; exists x0; split; auto.
  intros x1 [H4 H5]; rewrite <- H; auto.
Qed.

Theorem limit1_imp :
  forall (f:R -> R) (D D1:R -> Prop) (l x:R),
    (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
Proof.
  intros f D D1 l x H; unfold limit1_in, limit_in.
  intros H0 eps H1; case (H0 eps H1); auto.
  intros alpha [H2 H3]; exists alpha; split; auto.
  intros d [H4 H5]; apply H3; split; auto.
Qed.

Theorem Rinv_Rdiv : forall x y:R, x <> R0 -> y <> R0 -> / (x / y) = y / x.
Proof.
  intros x y H1 H2; unfold Rdiv; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  assumption.
  assumption.
  apply Rinv_neq_0_compat; assumption.
Qed.

Theorem Dln : forall y:R, R0 < y -> D_in ln Rinv (fun x:R => R0 < x) y.
Proof.
  intros y Hy; unfold D_in.
  apply limit1_ext with
    (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
  intros x [HD1 HD2]; repeat rewrite exp_ln.
  unfold Rdiv; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  apply Rmult_comm.
  apply Rminus_eq_contra.
  red; intros H2; case HD2.
  symmetry ; apply (ln_inv _ _ HD1 Hy H2).
  apply Rminus_eq_contra; apply (not_eq_sym HD2).
  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red; intros H2;
    case HD2; apply ln_inv; auto.
  assumption.
  assumption.
  apply limit_inv with
    (f := fun x:R => (exp (ln x) - exp (ln y)) / (ln x - ln y)).
  apply limit1_imp with
    (f := fun x:R => (fun x:R => (exp x - exp (ln y)) / (x - ln y)) (ln x))
    (D := Dgf (D_x (fun x:R => R0 < x) y) (D_x (fun x:R => True) (ln y)) ln).
  intros x [H1 H2]; split.
  split; auto.
  split; auto.
  red; intros H3; case H2; apply ln_inv; auto.
  apply limit_comp with
    (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
  apply ln_continue; auto.
  assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
    unfold limit1_in; unfold limit_in;
      simpl; unfold R_dist; intros; elim (H0 _ H);
        intros; exists x; split.
  apply (cond_pos x).
  intros; pattern y at 3; rewrite <- exp_ln.
  pattern x0 at 1; replace x0 with (ln y + (x0 - ln y)).
  apply H1.
  elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
    apply Rminus_eq_contra; apply (not_eq_sym (A:=R));
      apply H3.
  elim H2; clear H2; intros _ H2; apply H2.
rewrite Rplus_minus. reflexivity.
  assumption.
  red; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
Qed.

Lemma derivable_pt_lim_ln : forall x:R, R0 < x -> derivable_pt_lim ln x (/ x).
Proof.
  intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
    unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
      unfold derivable_pt_lim; intros; elim (H0 _ H1);
        intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / R2));
          assert (H4 : R0 < alp).
  unfold alp; unfold Rmin; case (Rle_dec x0 (x / R2)); intro.
  apply H2.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; exact Rlt_0_2 ].
  exists (mkposreal _ H4); intros; pattern h at 2;
    replace h with (x + h - x).
2:{
unfold Rminus. rewrite Rplus_comm.
rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l.
reflexivity.
}
  apply H3; split.
  unfold D_x; split.
  destruct (Rcase_abs h) as [Hlt|Hgt].
  assert (H7 : Rabs h < x / R2).
  apply Rlt_le_trans with alp.
  apply H6.
  unfold alp; apply Rmin_r.
  apply Rlt_trans with (x / R2).
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; exact Rlt_0_2 ].
  rewrite Rabs_left in H7.
  apply Rplus_lt_reg_l with (- h - x / R2).
  replace (- h - x / R2 + x / R2) with (- h).
2:{
unfold Rminus.
rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
reflexivity.
}
  pattern x at 2; rewrite double_var.
  change (IZR 2) with R2.
  replace (- h - x / R2 + (x / R2 + x / R2 + h)) with (x / R2).
2:{
  unfold Rminus.
  symmetry.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_comm.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_r, Rplus_0_r.
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  reflexivity.
}
assumption.
  apply Hlt.
  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply Hgt ].
  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
    [ apply H5 | idtac ].
unfold Rminus. rewrite Rplus_assoc. fold (h-x). rewrite Rplus_minus. reflexivity.
  replace (x + h - x) with h;
  [ apply Rlt_le_trans with alp;
    [ apply H6 | unfold alp; apply Rmin_l ]
    | idtac ].
unfold Rminus. rewrite Rplus_assoc. fold (h-x). rewrite Rplus_minus. reflexivity.
Qed.

Theorem D_in_imp :
  forall (f g:R -> R) (D D1:R -> Prop) (x:R),
    (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
Proof.
  intros f g D D1 x H; unfold D_in.
  intros H0; apply limit1_imp with (D := D_x D x); auto.
  intros x1 [H1 H2]; split; auto.
Qed.

Theorem D_in_ext :
  forall (f g h:R -> R) (D:R -> Prop) (x:R),
    f x = g x -> D_in h f D x -> D_in h g D x.
Proof.
  intros f g h D x H; unfold D_in.
  rewrite H; auto.
Qed.

Theorem Dpower :
  forall y z:R,
    R0 < y ->
    D_in (fun x:R => x ^R z) (fun x:R => z * x ^R (z - R1)) (
      fun x:R => R0 < x) y.
Proof.
  intros y z H;
    apply D_in_imp with (D := Dgf (fun x:R => R0 < x) (fun x:R => True) ln).
  intros x H0; repeat split.
  assumption.
  apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
  unfold Rminus; rewrite Rpower_plus; rewrite Rpower_Ropp;
    rewrite (Rpower_1 _ H); unfold Rpower.
rewrite Rmult_comm.
repeat rewrite Rmult_assoc.
reflexivity.
  apply Dcomp with
    (f := ln)
    (g := fun x:R => exp (z * x))
    (df := Rinv)
    (dg := fun x:R => z * exp (z * x)).
  apply (Dln _ H).
  apply D_in_imp with
    (D := Dgf (fun x:R => True) (fun x:R => True) (fun x:R => z * x)).
  intros x H1; repeat split; auto.
  apply
    (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
      (fun x:R => z * x) exp); simpl.
  apply D_in_ext with (f := fun x:R => z * R1).
  apply Rmult_1_r.
  apply (Dmult_const (fun x => True) (fun x => x) (fun x => R1)); apply Dx.
  assert (H0 := derivable_pt_lim_D_in exp exp (z * ln y)); elim H0; clear H0;
    intros _ H0; apply H0; apply derivable_pt_lim_exp.
Qed.

Theorem derivable_pt_lim_power :
  forall x y:R,
    R0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - R1)).
Proof.
  intros x y H.
  unfold Rminus; rewrite Rpower_plus.
  rewrite Rpower_Ropp.
  rewrite Rpower_1; auto.
  rewrite <- Rmult_assoc.
  unfold Rpower.
  apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
  apply derivable_pt_lim_ln; assumption.
  rewrite (Rmult_comm y).
  apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
  pattern y at 2; replace y with (R0 * ln x + y * R1).
  apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
  apply derivable_pt_lim_const with (a := y).
  apply derivable_pt_lim_id.
rewrite Rmult_0_l, Rmult_1_r, Rplus_0_l. reflexivity.
  apply derivable_pt_lim_exp.
Qed.

(* added later. *)

Lemma Rpower_mult_distr :
  forall x y z, R0 < x -> R0 < y ->
   Rpower x z * Rpower y z = Rpower (x * y) z.
intros x y z x0 y0; unfold Rpower.
rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto.
Qed.

Lemma Rlt_Rpower_l a b c: R0 < c -> R0 < a < b -> a ^R c < b ^R c.
Proof.
intros c0 [a0 ab]; apply exp_increasing.
now apply Rmult_lt_compat_l; auto; apply ln_increasing.
Qed.

Lemma Rle_Rpower_l a b c: R0 <= c -> R0 < a <= b -> a ^R c <= b ^R c.
Proof.
intros [c0 | c0];
 [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ].
  intros [a0 [ab|ab]].
  now apply Rlt_le, Rlt_Rpower_l;[ | split].
  rewrite ab; apply Rle_refl.
 apply Rlt_le_trans with a; tauto.
tauto.
Qed.

(* arcsinh function *)

Definition arcsinh x := ln (x + sqrt (x ^ 2 + R1)).

Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x.
intros x; unfold sinh, arcsinh.
assert (Rminus_eq_0 : forall r, r - r = R0).
{ intros. unfold Rminus. now rewrite Rplus_opp_r. }
rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus.
rewrite exp_plus.

match goal with |- context[sqrt ?a] =>
  replace a with (((exp x + exp(-x))/R2)^2)
end.

rewrite sqrt_pow2;
 [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos |
                            apply Rinv_0_lt_compat, Rlt_0_2]].
match goal with |- context[ln ?a] => replace a with (exp x) end.
rewrite ln_exp; reflexivity.

symmetry.
unfold Rdiv.
rewrite <- Rmult_plus_distr_r.
repeat rewrite Rplus_assoc.
rewrite Rplus_comm.
repeat rewrite Rplus_assoc.
rewrite (Rplus_comm (exp x)).
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_l.
rewrite <- double.
rewrite Rmult_comm.
rewrite <- Rmult_assoc, Rinv_l, Rmult_1_l.
reflexivity. exact Neq_2_0.

simpl.
repeat rewrite Rmult_1_r.
unfold Rdiv.
repeat rewrite Rmult_plus_distr_r.
repeat rewrite Rmult_plus_distr_l.
repeat rewrite Rmult_assoc.
rewrite (Rmult_comm (/R2)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_mult_distr.
rewrite (Rmult_comm (/R2)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_mult_distr.
rewrite double.
fold R4.
repeat rewrite <- Rmult_assoc.
rewrite <- Rmult_plus_distr_r.
rewrite <- Rmult_plus_distr_r.
rewrite <- Rmult_plus_distr_r.
repeat rewrite Rmult_assoc.
rewrite (Rmult_comm (/R2)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_mult_distr.
rewrite double.
fold R4.
repeat rewrite <- Rmult_assoc.
repeat rewrite <- Rplus_assoc.
rewrite <- Rmult_plus_distr_r.
rewrite <- Rmult_plus_distr_r.
rewrite <- Rmult_plus_distr_r.
set (ex := exp x).
set (emx := exp (-x)).
symmetry.
eapply Rplus_eq_reg_l.
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_l.
symmetry.
unfold Rdiv.
rewrite Ropp_mult_distr_l.
rewrite <- Rmult_plus_distr_r.
repeat rewrite Ropp_plus_distr.
repeat rewrite <- Ropp_mult_distr_l.
repeat rewrite <- Ropp_mult_distr_r.
repeat rewrite Ropp_involutive.
repeat rewrite <- Rplus_assoc.
rewrite (Rplus_comm _ (ex*ex)).
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_l.
repeat rewrite <- Rplus_assoc.
rewrite (Rplus_comm _ (-(emx*emx))).
repeat rewrite <- Rplus_assoc.
rewrite (Rplus_comm _ (emx*emx)).
repeat rewrite <- Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_l.
repeat rewrite (Rmult_comm emx).
pattern (ex*emx);rewrite <- Rmult_1_r.
repeat rewrite <- Rmult_plus_distr_l.
fold R2.
repeat rewrite Rplus_assoc.
fold R2.
fold R4.
repeat rewrite Rmult_assoc.
rewrite Rinv_r, Rmult_1_r.
reflexivity.
apply Rlt_not_eq'; exact Rlt_0_4.
exact Neq_2_0.
exact Neq_2_0.
exact Neq_2_0.
exact Neq_2_0.
exact Neq_2_0.
exact Neq_2_0.
Qed.

Lemma sinh_arcsinh x : sinh (arcsinh x) = x.
unfold sinh, arcsinh.
assert (cmp : R0 < x + sqrt (x ^ 2 + R1)).
 destruct (Rle_dec x R0).
  replace (x ^ 2) with ((-x) ^ 2).
  assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+R1)).
   apply sqrt_lt_1_alt.
   split;[apply pow_le | ].
rewrite <- Ropp_0. apply Ropp_le_contravar. assumption.
  pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
   assert (t:= sqrt_pos ((-x)^2)).
{
  simpl.
  rewrite Rmult_1_r, sqrt_square, Ropp_involutive.
  rewrite Rmult_1_r.
  eapply Rplus_lt_reg_l.
  rewrite Rplus_opp_l.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  exact Rlt_0_1.
  rewrite <- Ropp_0.
  apply Ropp_le_contravar.
  assumption.
}
{
  rewrite sqrt_pow2.
  rewrite Ropp_involutive. reflexivity.
  rewrite <- Ropp_0. apply Ropp_le_contravar.
  assumption.
}
{
admit.
}
{
simpl. repeat rewrite Rmult_1_r.
rewrite <- Ropp_mult_distr_l.
rewrite <- Ropp_mult_distr_r.
rewrite Ropp_involutive.
reflexivity.
}
{
apply Rnot_le_lt in n.
apply Rplus_lt_le_0_compat.
assumption.
apply sqrt_pos.
}
rewrite exp_ln;[ | assumption].
rewrite exp_Ropp, exp_ln;[ | assumption].
assert (Rmult_minus_distr_r :
         forall x y z, (x - y) * z = x * z - y * z).
{
  intros a b c.
  unfold Rminus.
  rewrite Rmult_plus_distr_r.
  rewrite <- Ropp_mult_distr_l.
  reflexivity.
}
apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r.
assert (t: forall x y z, x - z = y -> x - y - z = R0);[ | apply t; clear t].
 intros a b c H; rewrite <- H.
{
  unfold Rminus.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_r, Rplus_0_r.
  rewrite Rplus_opp_r.
  reflexivity.
}
apply Rmult_eq_reg_l with (R2 * (x + sqrt (x ^ 2 + R1)));[ |
 apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]].
assert (pow2_sqrt : forall x, R0 <= x -> sqrt x ^ 2 = x) by
 (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto).
{
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  apply Rmult_eq_compat_l.
  unfold Rminus.
  pattern x at 3;rewrite <- Rmult_1_r.
  rewrite Ropp_mult_distr_l.
  pattern R1 at 2;rewrite <- Rinv_r with R2.
  repeat rewrite <- Rmult_assoc.
  rewrite <- Rmult_plus_distr_r.
  apply Rmult_eq_compat_r.
  unfold R2 at 1.
  rewrite Rmult_plus_distr_l.
  rewrite Rmult_1_r.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_comm.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_r.

  eapply Rmult_eq_reg_r.
  rewrite Rinv_l.
  rewrite Rmult_plus_distr_r.
  rewrite Rmult_plus_distr_l.
  rewrite sqrt_sqrt.
  rewrite Rmult_plus_distr_l.
  rewrite <- Ropp_mult_distr_l.
  repeat rewrite Rplus_assoc.
  rewrite Rplus_comm.
  rewrite <- Ropp_mult_distr_l.
  rewrite (Rmult_comm x (sqrt _)).
  repeat rewrite Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_r.
  rewrite Rplus_comm.
  repeat rewrite Rplus_assoc.
  simpl.
  rewrite Rmult_1_r.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_r.
  reflexivity.
  apply Rplus_le_le_0_compat.
simpl. rewrite Rmult_1_r. fold (Rsqr x).
apply Rle_0_sqr.
left. exact Rlt_0_1.
apply Rlt_not_eq'. assumption.
apply Rlt_not_eq'. assumption.
exact Neq_2_0.
Admitted.

Lemma derivable_pt_lim_arcsinh :
  forall x, derivable_pt_lim arcsinh x (/sqrt (x ^ 2 + R1)).
intros x; unfold arcsinh.
assert (R0 < x + sqrt (x ^ 2 + R1)).
 destruct (Rle_dec x R0);
  [ | assert (R0 < x) by (apply Rnot_le_gt; assumption);
    apply Rplus_lt_le_0_compat; auto; apply sqrt_pos].
 replace (x ^ 2) with ((-x) ^ 2).
2:{
simpl. repeat rewrite Rmult_1_r.
rewrite <- Ropp_mult_distr_l.
rewrite <- Ropp_mult_distr_r.
rewrite Ropp_involutive.
reflexivity.
}
 assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+R1)).
  apply sqrt_lt_1_alt.
{
  split;[apply pow_le|].
rewrite <- Ropp_0. apply Ropp_le_contravar. assumption.
apply Rlt_plus_1.
}
 pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
{
  assert (t:= sqrt_pos ((-x)^2)).
  eapply Rplus_lt_reg_l.
  rewrite Rplus_0_r.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r, Rplus_0_l.
  assumption.
}
{
 simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto.
rewrite <- Ropp_0. apply Ropp_le_contravar; assumption.
}
assert (R0 < x ^ 2 + R1).
 apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|idtac].
exact Rlt_0_1.
replace (/sqrt (x ^ 2 + R1)) with
 (/(x + sqrt (x ^ 2 + R1)) *
    (R1 + (/(R2 * sqrt (x ^ 2 + R1)) * (INR 2 * x ^ 1 + R0)))).
apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + R1)) ln).
 apply (derivable_pt_lim_plus).
  apply derivable_pt_lim_id.
   apply (derivable_pt_lim_comp (fun x => x ^ 2 + R1) sqrt x).
    apply derivable_pt_lim_plus.
     apply derivable_pt_lim_pow.
    apply derivable_pt_lim_const.
   apply derivable_pt_lim_sqrt; assumption.
  apply derivable_pt_lim_ln; assumption.
 replace (INR 2 * x ^ 1 + R0) with (R2 * x).
2:{
simpl. rewrite Rplus_0_r.
rewrite Rmult_1_r. unfold R2. reflexivity.
}
replace (R1 + / (R2 * sqrt (x ^ 2 + R1)) * (R2 * x)) with
 (((sqrt (x ^ 2 + R1) + x))/sqrt (x ^ 2 + R1));
 [ | (* field; apply Rgt_not_eq, sqrt_lt_R0; assumption *) ].
2:{
  simpl.
  repeat rewrite Rmult_1_r.
  unfold Rdiv.
  rewrite Rmult_plus_distr_r.
  rewrite Rinv_r.
  rewrite Rinv_mult_distr.
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm (/R2)).
  repeat rewrite Rmult_assoc.
  rewrite (Rmult_comm R2).
  repeat rewrite Rmult_assoc.
  rewrite Rinv_l.
  rewrite Rmult_1_r.
  apply Rplus_eq_compat_l.
  rewrite Rmult_comm.
  reflexivity.
  exact Neq_2_0.
  exact Neq_2_0.
  simpl in H0.
  rewrite Rmult_1_r in H0.
  apply Rgt_not_eq.
  apply sqrt_lt_R0.
  assumption.
  apply Rgt_not_eq.
  apply sqrt_lt_R0.
  simpl in H0.
  rewrite Rmult_1_r in H0.
  assumption.
}
apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + R1));
  [ | apply Rgt_not_eq; assumption].
rewrite <- Rmult_assoc, Rinv_r.
{
  rewrite Rmult_1_l.
  unfold Rdiv.
  rewrite Rplus_comm.
  reflexivity.
}
apply Rgt_not_eq; auto;
  apply sqrt_lt_R0; assumption.
Qed.

Lemma arcsinh_lt : forall x y, x < y -> arcsinh x < arcsinh y.
intros x y xy.
case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ].
intros abs; case (Rlt_not_le _ _ xy).
rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x).
destruct abs as [lt | q];[| rewrite q].
2:{
right. reflexivity.
}
apply Rlt_le, sinh_lt; assumption.
Qed.

Lemma arcsinh_le : forall x y, x <= y -> arcsinh x <= arcsinh y.
intros x y [xy | xqy].
 apply Rlt_le, arcsinh_lt; assumption.
rewrite xqy; apply Rle_refl.
Qed.

Lemma arcsinh_0 : arcsinh R0 = R0.
 unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1;
  [reflexivity | discriminate].
Qed.


Require Import String.
Require Import List.

Require Import fun_domains.
Require Import fun_domains_aux.
Require Import maps.
Require Import equate_map_reflection.
Require Import patterns.

(** A predicate saying two stacks are equivalent,
    requires exact equality of the code but compares
    environments up to map equality *)
Fixpoint stk_equiv (s1 s2 : list Frame) : Prop :=
  match s1, s2 with
    | nil, nil => True
    | frame k1 e1::s1', frame k2 e2::s2' =>
      k1 = k2 /\ e1 ~= e2 /\ stk_equiv s1' s2'
    | _, _ => False
  end.

Arguments stk_equiv s1 s2 : simpl nomatch.

(** Register it as an equivalence relations,
    mostly just so we can say "reflexivity" *)
Lemma stk_equiv_refl : forall s, stk_equiv s s.
Proof.
induction s;simpl;auto.
destruct a. simpl. auto using equivRefl.
Qed.

Lemma stk_equiv_sym : forall s1 s2, stk_equiv s1 s2 -> stk_equiv s2 s1.
Proof.
induction s1;destruct s2;simpl;firstorder.
destruct a;trivial.
destruct a,f;firstorder.
Qed.

Lemma stk_equiv_trans : forall s1 s2 s3,
  stk_equiv s1 s2 -> stk_equiv s2 s3 -> stk_equiv s1 s3.
Proof.
induction s1.
destruct s2;intros. assumption. destruct H.

destruct s2.
intros. destruct a. simpl in H. destruct H.
intros. destruct s3. destruct f. simpl in H0. destruct H0.
destruct a.
destruct f.
destruct f0.
simpl in * |- *.
intuition.
congruence.
equate_maps.
eauto.
Qed.

Add Relation (list Frame) stk_equiv
  reflexivity proved by stk_equiv_refl
  symmetry proved by stk_equiv_sym
  transitivity proved by stk_equiv_trans
  as stk_equiv_rel.

Definition kequiv (k1 k2 : kcfg) : Prop :=
  match k1, k2 with
    | KCfg k1 store1 stk1 heap1 funs1,
      KCfg k2 store2 stk2 heap2 funs2 =>
      k1 = k2 /\ store1 ~= store2 /\ stk_equiv stk1 stk2
      /\ heap1 ~= heap2 /\ funs1 ~= funs2
  end.

Require Import Setoid.
Require Import ZArith.

Add Morphism KCfg with signature
  @eq k ==> MapEquiv ==> stk_equiv ==> MapEquiv ==> MapEquiv ==> kequiv as KCfg_mor.
Proof. firstorder. Qed.

(* Simple predicate that a computation reaches a return of
   the given value, without effects on the stack or heap *)
(* Might be simpler to claim that calls evaluate to values *)
Definition returning' c e c' : Prop :=
     match c' with
       | KCfg (kra (KStmt (SReturn e')) _) _ stack' heap' functions' =>
         match c with
           | KCfg kcell _ stack heap functions =>
               e = e'
               /\ stk_equiv stack stack'
               /\ heap ~= heap'
               /\ functions ~= functions'
         end
       | _ => False
     end.
Lemma returning_returns : forall c e c', returning' c e c' ->
  exists krest,
  kcell c' = kra (KStmt (SReturn e)) krest.
Proof.
destruct c'.
simpl;intro H.
repeat match type of H with
| (match ?x with _ => _ end) => destruct x;try solve[destruct H];[idtac]
end.
intuition.
exists kcell.
congruence.
Qed.

Definition returning c v := returning' c (ECon v).
Inductive returns (c : kcfg) (v : Z) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_claim : returns c v c (returning c v).

Definition returning_bool c b := returning' c (BCon b).
Inductive returns_bool (c : kcfg) (v : bool) : kcfg -> (kcfg -> Prop) -> Prop :=
  returns_bool_claim : returns_bool c v c (returning_bool c v).

Definition get_returning (c : kcfg) : option Z :=
  match kcell c with
    | kra (KStmt (SReturn (ECon v'))) _ => Some v'
    | _ => None
  end.
Lemma get_returning_returns : forall c,
  match get_returning c with
    | Some v => exists krest, kcell c = kra (KStmt (SReturn (ECon v))) krest
    | None => True
  end.
Proof.
destruct c.
unfold get_returning. simpl.
repeat match goal with
| [|- match (match ?x with _ => _ end) with _ => _ end]
   => destruct x;try (exact I)
end.
eexists.
reflexivity.
Qed.

Definition returning_heap_pat c P v c' : Prop :=
  match c' with
    | KCfg (kra (KStmt (SReturn (ECon v'))) _) _ stack' heap' functions' =>
      match c with
        | KCfg kcell _ stack _ functions =>
               v = v'
               /\ stk_equiv stack stack'
               /\ functions ~= functions'
               /\ heap' |= P
      end
    | _ => False
  end.

Lemma returning_spec :
  forall c v c',
    returning c v c' <-> returning_heap_pat c (litP (heap c)) v c'.
Proof.
destruct c;destruct c';simpl;intuition;
repeat match type of H with
| (match ?x with _ => _ end) => destruct x;try solve[destruct H];[idtac]
end;intuition.
subst. symmetry in H1.
repeat split;assumption.
congruence.
symmetry. assumption.
Qed.

Lemma use_returning : forall ckcell cstore cstk cheap cfunctions
     e (Q : kcfg -> (kcfg -> Prop) -> Prop) (P : kcfg -> Prop),
  (forall kstore kheap kfunctions,
    cheap ~= kheap ->
    cfunctions ~= kfunctions ->
   forall kstk,
    stk_equiv cstk kstk ->
   forall krest,
    Q (KCfg (kra (KStmt (SReturn e)) krest)
            kstore kstk kheap kfunctions) P
   ) ->
  (forall k', returning'
     (KCfg ckcell cstore cstk cheap cfunctions)
    e k' -> Q k' P).
intros.
pose proof (returning_returns _ _ _ H0).
destruct H1.
destruct k';simpl in * |- *;subst.
intuition.
Qed.

Lemma expose_frame : forall p m stk (Q : list Frame -> Prop),
  (forall m' stk',
     m' ~= m -> stk_equiv stk stk' -> Q (frame p m'::stk')) ->
  (forall stk',
     stk_equiv (frame p m::stk) stk' -> Q stk').
intros.
destruct stk';[solve[destruct H0]|].
destruct f.
simpl in H0.
intuition. subst.
symmetry in H0.
auto.
Qed.

(* Somehow simple "apply" doesn't unify well enough *)
Ltac use_expose_frame :=
  match goal with
  | [|- forall stk, stk_equiv (frame ?p ?m::?tail) stk -> @?C stk ] =>
      apply (expose_frame p m tail C)
  end.