(**
  [TypeTheory.CwF.CwF_Cats_Simple]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
This module defines a category of CwF structures.
Objects come from [cwf_structure].

Morphisms are defined simply as a pair of natural transformations
for Tm and Ty components of CwF structure.

The main difference from definition in TypeTheory.CwF.CwF_Cats
is that here we do not have a ϕ component (and corresponding axioms)
as it is completely derived from CwF pullback and the simple morphism.

Main definitions are

- [cwf_structure_cat] - category of CwF structures (for a fixed category C).
- [iscontr_cwf_structure_mor_ϕ] — a proof that there is a unique ϕ for every morphism;
- [weq_cwf_structure_mor_with_ϕ] — an equivalence of [cwf_structure_mor] and [cwf_structure_mor_with_ϕ];
*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.yoneda.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.

Require Import TypeTheory.CwF.CwF_def.

Section CwF_structure_cat.
  Context {C : category}.

  (* Extract the terms presheaf from a CwF structure. *)
  Definition TM (X : cwf_structure C) : [C^op, SET]
    := Tm (pr1 X).

  (* Extract the types presheaf from a CwF structure. *)
  Definition TY (X : cwf_structure C) : [C^op, SET]
    := Ty (pr1 X).

  (* Extract the extended context Γ.A
     given Γ and A in a given CwF structure. *)
  Definition cwf_extended_context
             (X : cwf_structure C)
             (Γ : C)
             (A : TY X $p Γ)
    : C
    := pr1 (pr1 (pr2 X _ A)).

  Local Notation "Γ ◂ A" := (cwf_extended_context _ Γ A) (at level 40).

  (* Extract the weakening projection π A : Γ ◂ A --> Γ *)
  Definition cwf_projection
             (X : cwf_structure C)
             (Γ : C)
             (A : TY X $p Γ)
    : Γ ◂ A --> Γ
    := pr2 (pr1 (pr2 X _ A)).

  Local Notation "'π' A" := (cwf_projection _ _ A) (at level 40).

  (* Extract the term in the extended context Γ.A *)
  Definition cwf_extended_context_term
             (X : cwf_structure C)
             (Γ : C)
             (A : TY X $p Γ)
    : TM X $p (Γ ◂ A)
    := pr1 (pr1 (pr2 (pr2 X _ A))).

  Local Notation "'te' A" := (cwf_extended_context_term _ _ A) (at level 40).

  (* CwF morphism data:
     - a natural transformation of terms presheaves;
     - a natural transformation of types presheaves;
  *)
  Definition cwf_structure_mor_data (X X' : cwf_structure C) : UU
    := (TM X --> TM X') × (TY X --> TY X').

  (* TM part of CwF morphism:
     a natural transformation of terms presheaves. *)
  Definition cwf_structure_mor_TM
             {X X' : cwf_structure C}
             (f : cwf_structure_mor_data X X')
    : TM X --> TM X'
    := pr1 f.

  (* TY part of CwF morphism:
     a natural transformation of types presheaves. *)
  Definition cwf_structure_mor_TY
             {X X' : cwf_structure C}
             (f : cwf_structure_mor_data X X')
    : TY X --> TY X'
    := pr2 f.

  (* coherence for "typing" natural transformation *)
  Definition cwf_structure_mor_typing_axiom
             (X X' : cwf_structure C)
             (mor : cwf_structure_mor_data X X')
    : UU
    := pr1 mor ;; pr1 X' = pr1 X ;; pr2 mor.

  Definition is_cwf_structure_mor
             (X X' : cwf_structure C)
             (mor : cwf_structure_mor_data X X')
    : UU
    := cwf_structure_mor_typing_axiom X X' mor.

  Lemma isaprop_is_cwf_structure_mor
        (X X' : cwf_structure C)
        (mor : cwf_structure_mor_data X X')
    : isaprop (is_cwf_structure_mor X X' mor).
  Proof.
    apply homset_property.
  Defined.

  (* CwF morphism:
     - a natural transformation of terms presheaves;
     - a natural transformation of types presheaves;
     - coherence conditions.
  *)
  Definition cwf_structure_mor (X X' : cwf_structure C) : UU
    := ∑ (mor : cwf_structure_mor_data X X'),
       is_cwf_structure_mor X X' mor.

  Coercion cwf_structure_mor_to_data
           (X X' : cwf_structure C)
           (mor : cwf_structure_mor X X')
    : cwf_structure_mor_data X X'
    := pr1 mor.

  (* Prove that two morphisms of CwF structures are equal
     given their constituent parts are equal pairwise. *)
  Definition cwf_structure_mor_eq (X X' : cwf_structure C)
             (f g : cwf_structure_mor X X')
             (* equality of TM components *)
             (e_TM : cwf_structure_mor_TM f = cwf_structure_mor_TM g)
             (* equality of TY components *)
             (e_TY : cwf_structure_mor_TY f = cwf_structure_mor_TY g)
    : f = g.
  Proof.
    use total2_paths_f.
    - use dirprod_paths.
      + apply e_TM.
      + apply e_TY.
    - apply isaprop_is_cwf_structure_mor.
  Defined.

  (* # Yo ϕ part of CwF morphism:
     a morphism in C moving context from one CwF to another. *)
  Definition cwf_structure_mor_Yo_ϕ
             {X X' : cwf_structure C}
             (f : cwf_structure_mor X X')
             (Γ : C^op) (A : TY X $p Γ)
    : Yo (Γ ◂ A) --> Yo (Γ ◂ (cwf_structure_mor_TY f $nt A)).
  Proof.
    set (A' := cwf_structure_mor_TY f $nt A).
    set (X'_isPullback := pr2 (pr2 (pr2 X' Γ A')) : isPullback _).
    set (X_commutes := pr2 (pr1 (pr2 (pr2 X Γ A))) : _ = _).
    apply (X'_isPullback
             _ (# Yo (π A)) (yy (te A) ;; cwf_structure_mor_TM f)).
    etrans. apply maponpaths, pathsinv0, yy_comp_nat_trans.
    etrans. apply assoc.
    etrans. apply maponpaths_2, pathsinv0, yy_natural.
    etrans. apply maponpaths_2, maponpaths, pathsinv0, X_commutes.
    etrans. apply maponpaths_2, pathsinv0, yy_comp_nat_trans.
    etrans. apply assoc'.
    etrans. apply maponpaths, pathsinv0, (pr2 f).
    apply assoc.
  Defined.

  Definition cwf_structure_mor_ϕ_data
             {X X' : cwf_structure C}
             (f : cwf_structure_mor X X')
    : UU
    := ∏ (Γ : C^op) (A : TY X $p Γ),
       (Γ ◂ A --> Γ ◂ (cwf_structure_mor_TY f $nt A)).

  Definition has_cwf_structure_mor_weakening_axiom
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
             (ϕ : cwf_structure_mor_ϕ_data mor)
    : UU
    := ∏ (Γ : C) (A : TY X $p Γ),
       ϕ Γ A ;; π (cwf_structure_mor_TY mor $nt A)
       = π A.

  Definition has_cwf_structure_mor_term_axiom
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
             (ϕ : cwf_structure_mor_ϕ_data mor)
    : UU
    := ∏ (Γ : C) (A : TY X $p Γ),
       (cwf_structure_mor_TM mor $nt (te A))
       = #p (TM X') (ϕ Γ A) (te _).

  Definition cwf_structure_mor_ϕ
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
    : UU
    := ∑ (ϕ : cwf_structure_mor_ϕ_data mor),
       has_cwf_structure_mor_weakening_axiom mor ϕ
         × has_cwf_structure_mor_term_axiom mor ϕ.

  Definition cwf_structure_mor_ϕ_data_of
             {X X' : cwf_structure C}
             (f : cwf_structure_mor X X')
    : cwf_structure_mor_ϕ_data f.
  Proof.
    intros Γ A.
    apply (yoneda_fully_faithful _ ).
    apply cwf_structure_mor_Yo_ϕ.
  Defined.

  Definition cwf_structure_mor_weakening_axiom_of
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
    : has_cwf_structure_mor_weakening_axiom
        mor (cwf_structure_mor_ϕ_data_of mor).
  Proof.
    intros Γ A.
    apply (invmaponpathsweq (# Yo ,, yoneda_fully_faithful _ _ _)).
    etrans. apply functor_comp.
    etrans. apply maponpaths_2.
    apply (homotweqinvweq (# Yo ,, yoneda_fully_faithful _ _ _ )).
    simpl.
    set (A' := cwf_structure_mor_TY mor $nt A).
    set (X'_isPullback := pr2 (pr2 (pr2 X' Γ A'))).
    set (X'_Pullback := make_Pullback _ X'_isPullback).
    set (P := PullbackArrow_PullbackPr1
                X'_Pullback _
                (# Yo (π A))
                (yy (te A) ;; cwf_structure_mor_TM mor)).
    apply P.
  Defined.

  Definition cwf_structure_mor_term_axiom_of
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
    : has_cwf_structure_mor_term_axiom
        mor (cwf_structure_mor_ϕ_data_of mor).
  Proof.
    intros Γ A.
    apply (invmaponpathsweq (@yy _ _ _)).
    etrans. apply pathsinv0, yy_comp_nat_trans.
    apply pathsinv0.
    etrans. apply yy_natural.
    etrans. apply maponpaths_2.
    apply (homotweqinvweq (# Yo ,, yoneda_fully_faithful _ _ _ )).
    set (A' := cwf_structure_mor_TY mor $nt A).
    set (X'_isPullback := pr2 (pr2 (pr2 X' Γ A'))).
    set (X'_Pullback := make_Pullback _ X'_isPullback).
    set (P := PullbackArrow_PullbackPr2
                X'_Pullback _
                (# Yo (π A))
                (yy (te A) ;; cwf_structure_mor_TM mor)).
    apply P.
  Defined.

  Definition cwf_structure_mor_ϕ_of
             {X X' : cwf_structure C}
             (f : cwf_structure_mor X X')
    : cwf_structure_mor_ϕ f
    := (cwf_structure_mor_ϕ_data_of f,,
        cwf_structure_mor_weakening_axiom_of f,,
        cwf_structure_mor_term_axiom_of f).

  Definition iscontr_cwf_structure_mor_ϕ
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor X X')
    : iscontr (cwf_structure_mor_ϕ mor).
  Proof.
    exists (cwf_structure_mor_ϕ_of mor).
    intros ϕ.
    use total2_paths_f.
    - apply funextsec. intros Γ.
      apply funextsec. intros A.
      apply (invmaponpathsweq (# Yo ,, yoneda_fully_faithful _ _ _)).
      set (A' := cwf_structure_mor_TY mor $nt A).
      set (X'_isPullback := pr2 (pr2 (pr2 X' Γ A'))).
      set (P := PullbackArrowUnique
                  _
                  X'_isPullback
                  _
                  (# Yo (π A))
                  (yy (te A) ;; cwf_structure_mor_TM mor)
          ).

      assert ( # Yo (π A) ;; yy A' =
               yy (te A) ;; cwf_structure_mor_TM mor ;; pr1 X')
        as Hcomm.
      {
        etrans. apply maponpaths, pathsinv0, yy_comp_nat_trans.
        etrans. apply assoc.
        set (te_commutes := pr2 (pr1 (pr2 (pr2 X Γ A))) : _ = _).
        set (X'_commutes := cwf_square_comm te_commutes).
        etrans. apply maponpaths_2, X'_commutes.
        etrans. apply assoc'.
        etrans. apply maponpaths, pathsinv0, (pr2 mor).
        apply assoc.
      }

      etrans. apply (P Hcomm).
      + etrans. apply pathsinv0, functor_comp.
        apply maponpaths.
        apply (pr1 (pr2 ϕ)).
      + etrans. apply pathsinv0, yy_natural.
        etrans. apply maponpaths, pathsinv0, (pr2 (pr2 ϕ)).
        apply pathsinv0, yy_comp_nat_trans.
      + apply pathsinv0, P.
        * etrans. apply pathsinv0, functor_comp.
          apply maponpaths.
          apply (cwf_structure_mor_weakening_axiom_of mor).
        * etrans. apply pathsinv0, yy_natural.
          etrans. apply maponpaths, pathsinv0, (cwf_structure_mor_term_axiom_of mor).
          apply pathsinv0, yy_comp_nat_trans.

    - apply dirprod_paths.
      + apply funextsec. intros Γ.
        apply funextsec. intros A.
        apply homset_property.
      + apply funextsec. intros Γ.
        apply funextsec. intros A.
        apply setproperty.
  Defined.

  Definition cwf_structure_mor_with_ϕ (X X' : cwf_structure C)
    : UU
    := ∑ (mor : cwf_structure_mor X X'), cwf_structure_mor_ϕ mor.

  Coercion cwf_structure_mor_with_ϕ_to_mor
           (X X' : cwf_structure C)
           (mor : cwf_structure_mor_with_ϕ X X')
    : cwf_structure_mor X X'
    := pr1 mor.

  Definition weq_cwf_structure_mor_with_ϕ
             {X X' : cwf_structure C}
    : cwf_structure_mor_with_ϕ X X' ≃ cwf_structure_mor X X'.
  Proof.
    apply weqpr1.
    intros mor.
    apply iscontr_cwf_structure_mor_ϕ.
  Defined.

  Definition cwf_structure_mor_with_ϕ_eq
             {X X' : cwf_structure C}
             (f g : cwf_structure_mor_with_ϕ X X')
             (e_TM : cwf_structure_mor_TM f = cwf_structure_mor_TM g)
             (e_TY : cwf_structure_mor_TY f = cwf_structure_mor_TY g)
    : f = g.
  Proof.
    use total2_paths_f.
    - use cwf_structure_mor_eq.
      + apply e_TM.
      + apply e_TY.
    - apply proofirrelevancecontr.
      apply iscontr_cwf_structure_mor_ϕ.
  Defined.

  Definition make_cwf_structure_mor
             {X X' : cwf_structure C}
             (mor : cwf_structure_mor_data X X')
             (e_typing : cwf_structure_mor_typing_axiom X X' mor)
    : cwf_structure_mor X X'
    := (mor ,, e_typing).

  (* Definitions of objects and morphisms for
     the category of CwF structures. *)
  Definition cwf_structure_precategory_ob_mor : precategory_ob_mor
    := make_precategory_ob_mor
         (cwf_structure C) cwf_structure_mor.

  (* Precategory data for CwF structures:
     - definitions of objects & morphisms;
     - definition of identity morphisms;
     - definition of morphism composition.

     All definitions are straighforward and based on
     composition of corresponding natural transformations and morphisms.
   *)
  Definition cwf_structure_precategory_data : precategory_data.
  Proof.
    apply (make_precategory_data cwf_structure_precategory_ob_mor).

    + (* Identity morphisms *)
      intros X.
      use make_cwf_structure_mor.
      - exists (identity _).
        apply identity.
      - unfold cwf_structure_mor_typing_axiom. simpl.
        etrans. apply (id_left (pr1 X)).
        apply pathsinv0, (id_right (pr1 X)).

    + (* Composition of morphisms *)
      intros X Y Z.
      intros [[F_TM F_TY] ax] [[F_TM' F_TY'] ax'].
      use make_cwf_structure_mor.
      - exists (F_TM ;; F_TM').
        apply (F_TY ;; F_TY').
      - unfold cwf_structure_mor_typing_axiom. simpl.
        etrans. apply (assoc' F_TM).
        etrans. apply maponpaths, ax'.
        etrans. apply (assoc F_TM).
        etrans. apply maponpaths_2, ax.
        apply (assoc' (pr1 X)).
  Defined.

  (* Axioms for CwF structure morphisms:
     - identity · f = f
     - f · identity = f
     - f · (g · h) = (f · g) · h
   *)
  Definition cwf_structure_precategory_axioms
    : is_precategory cwf_structure_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - (* Left identity: identity · f = f *)
      intros a b f.
      use cwf_structure_mor_eq.
      + apply id_left.
      + apply id_left.
    - (* Right identity: f · identity = f *)
      intros a b f.
      use cwf_structure_mor_eq.
      + apply id_right.
      + apply id_right.
    - (* Associativity: f · (g · h) = (f · g) · h *)
      intros a b c d.
      intros f g h.
      use cwf_structure_mor_eq.
      + apply assoc.
      + apply assoc.
  Defined.

  (* Precategory of CwF-structures *)
  Definition cwf_structure_precat : precategory
    := (_,, cwf_structure_precategory_axioms).

  Lemma isaset_cwf_structure_mor
           (X X' : cwf_structure C)
     : isaset (cwf_structure_mor X X').
  Proof.
    apply isaset_total2.
    - apply isaset_dirprod.
      + apply homset_property.
      + apply homset_property.
    - intros mor.
      apply isasetaprop.
      apply isaprop_is_cwf_structure_mor.
  Defined.

  Definition cwf_structure_has_homsets
    : has_homsets cwf_structure_precategory_data.
  Proof.
    intros X X'.
    apply isaset_cwf_structure_mor.
  Defined.

  (* Category of CwF-structures *)
  Definition cwf_structure_cat : category
    := (cwf_structure_precat ,, cwf_structure_has_homsets).

End CwF_structure_cat.


Require Import Software.Language.Syntax.
Require Import Software.Lib.Lists.List.

(** * Types *)

Definition store : Type := list term.

(** * Functions *)

Definition alloc (a : term) (sr : store) : store :=
  app sr (cons a nil).

Definition write (n : nat) (t : term) (sr : store) : store := replace n t sr.

Definition read (n : nat) (sr : store) : term := nth n sr tvoid.

(** TODO: Lemmas *)

(** Functions unfold with [simpl]. *)

Arguments alloc a sr /.
Arguments write n t sr /.
Arguments read n sr /.

(** * Constants

    Position [0] in a [store] represents the "null reference". *)

Definition init_store : store := alloc tvoid nil.


Require Import SyntaxAndSemantics.
Require Import JRWTactics.

Require Import Relations.
Require Import Operators_Properties.

Hint Constructors has_type.

Fixpoint is_free_in (x : name) (e : term) : Prop :=
  match e with
  | TConst _ => False
  | TVar y => x = y
  | TIf e1 e2 e3 => is_free_in x e1 \/ is_free_in x e2 \/ is_free_in x e3
  | TAbs y tau e => x <> y /\ is_free_in x e
  | TApp e1 e2 => is_free_in x e1 \/ is_free_in x e2
  end.

Lemma has_type_ext :
  forall Gamma Gamma' e tau,
    has_type Gamma e tau ->
    (forall x, is_free_in x e -> TypingContext.get x Gamma = TypingContext.get x Gamma') ->
    has_type Gamma' e tau.
Proof.
  intros.
  prep_induction H.
  induction H; intros.
  - auto.
  - constructor. now rewrite <- H0 by (simpl; auto).
  - simpl in *. auto 6.
  - simpl in *. constructor.
    apply IHhas_type.
    intros. destruct (name_eq_dec x x0).
    + subst. repeat rewrite TypingContext.get_shadow_same. auto.
    + repeat rewrite TypingContext.get_shadow_diff by auto. auto.
  - simpl in *. firstorder.
Qed.

Lemma subs_free :
  forall x to e,
    is_free_in x (subs x to e) -> is_free_in x to.
Proof.
  induction e; simpl; intros.
  - intuition.
  - break_if.
    + auto.
    + simpl in *. congruence.
  - intuition.
  - break_if; simpl in *; intuition.
  - intuition.
Qed.

Lemma has_type_free :
  forall e Gamma tau x,
    has_type Gamma e tau ->
    is_free_in x e ->
    exists tyx, TypingContext.get x Gamma = Some tyx.
Proof.
  induction e; simpl; intros.
  - intuition.
  - invc H. firstorder.
  - invc H. firstorder.
  - invc H. firstorder.
    eapply_prop_hyp has_type has_type; eauto.
    break_exists_exists. simpl in *.
    rewrite TypingContext.get_shadow_diff in * by auto. auto.
  - invc H. firstorder.
Qed.

Lemma subs_not_free :
  forall x to e tau,
    has_type TypingContext.empty to tau ->
    is_free_in x (subs x to e) -> False.
Proof.
  intros.
  find_apply_lem_hyp subs_free.
  find_eapply_lem_hyp has_type_free; eauto.
  simpl in *. break_exists.
  rewrite TypingContext.get_empty in *. discriminate.
Qed.

Lemma weakening_empty :
  forall Gamma e tau,
    has_type TypingContext.empty e tau ->
    has_type Gamma e tau.
Proof.
  intros.
  eapply has_type_ext; eauto.
  intros.
  find_eapply_lem_hyp has_type_free; eauto.
  simpl in *. break_exists.
  rewrite TypingContext.get_empty in *. discriminate.
Qed.

Lemma canonical_forms_bool :
  forall e,
    has_type TypingContext.empty e TBool ->
    is_value e ->
    e = TConst true \/ e = TConst false.
Proof.
  intros.
  destruct e; invc H; firstorder.
  destruct b; auto.
Qed.

Lemma canonical_forms_arrow :
  forall e ty1 ty2,
    has_type TypingContext.empty e (TArrow ty1 ty2) ->
    is_value e ->
    exists x b, e = TAbs x ty1 b.
Proof.
  intros.
  destruct e; invc H; firstorder.
Qed.

Lemma values_are_irreducible :
  forall e,
    is_value e ->
    irreducible e.
Proof.
  unfold irreducible.
  destruct e; simpl; intuition; solve_by_inversion.
Qed.

Lemma irreducible_no_step :
  forall e e',
    irreducible e ->
    step e e' ->
    False.
Proof.
  unfold irreducible.
  intros. eauto.
Qed.

Lemma step_det :
  forall e1 e2 e2',
    step e1 e2 ->
    step e1 e2' ->
    e2 = e2'.
Proof.
  intros.
  prep_induction H.
  induction H; intros;
  match goal with
  | [ H : step ?x _  |- _ ] => ((is_var x; fail 1) || invc H)
  end; auto; try solve [f_equal; auto]; try solve_by_inversion;
  try solve [exfalso; eauto using irreducible_no_step, values_are_irreducible].
Qed.

Lemma step_star_left_inv :
  forall e e',
    step_star e e' ->
    e = e' \/ exists e'', step e e'' /\ step_star e'' e'.
Proof.
  unfold step_star.
  intros.
  find_apply_lem_hyp clos_rtn1_rt.
  find_apply_lem_hyp clos_rt_rt1n.
  inversion H.
  - auto.
  - right. subst.
    eexists. intuition eauto.
    find_apply_lem_hyp clos_rt1n_rt.
    find_apply_lem_hyp clos_rt_rtn1.
    auto.
Qed.

Lemma terminates_forward_reduction :
  forall e e',
    terminates e ->
    step e e' ->
    terminates e'.
Proof.
  unfold terminates.
  intuition. break_exists_exists. intuition.
  find_apply_lem_hyp step_star_left_inv.
  intuition.
  - subst. exfalso. eauto using irreducible_no_step.
  - break_exists. intuition.
    match goal with
    | [ H : step ?e ?x, H' : step ?e ?y |- _ ] => assert (x = y) by eauto using step_det
    end.
    subst.
    auto.
Qed.

Lemma step_star_step_left :
  forall e e' e'',
    step e e' ->
    step_star e' e'' ->
    step_star e e''.
Proof.
  unfold step_star.
  intros.
  eapply clos_rt_rtn1.
  eapply rt_trans.
  - eauto using rt_step.
  - eauto using clos_rtn1_rt.
Qed.

Lemma terminates_backward_reduction :
  forall e e',
    terminates e' ->
    step e e' ->
    terminates e.
Proof.
  unfold terminates.
  intros. break_exists_exists.
  intuition.
  eauto using step_star_step_left.
Qed.

Lemma step_star_trans :
  forall e e' e'',
    step_star e e' ->
    step_star e' e'' ->
    step_star e e''.
Proof.
  unfold step_star. intros.
  apply clos_rt_rtn1.
  eapply rt_trans; eauto using clos_rtn1_rt.
Qed.

Lemma app_step_star_1 :
  forall e1 e1' e2,
    step_star e1 e1' ->
    step_star (TApp e1 e2)
              (TApp e1' e2).
Proof.
  induction 1; intros.
  - constructor.
  - eapply step_star_trans; eauto.
    eapply step_star_step_left.
    + eapply step_app1; eauto.
    + constructor.
Qed.

Lemma app_step_star_2 :
  forall x tau e1 e2 e2',
    step_star e2 e2' ->
    step_star (TApp (TAbs x tau e1) e2)
              (TApp (TAbs x tau e1) e2').
Proof.
  induction 1; intros.
  - constructor.
  - eapply step_star_trans; eauto.
    eapply step_star_step_left.
    + eapply step_app2; eauto. firstorder.
    + constructor.
Qed.

Lemma step_star_if :
  forall e1 e1' e2 e3,
    step_star e1 e1' ->
    step_star (TIf e1 e2 e3) (TIf e1' e2 e3).
Proof.
  induction 1; intros.
  - constructor.
  - eapply step_star_trans; eauto.
    eapply step_star_step_left.
    + apply step_if_step; eauto.
    + constructor.
Qed.

Lemma subs_not_free_same :
  forall x to e,
    (is_free_in x e -> False) ->
    subs x to e = e.
Proof.
  induction e; simpl; intros.
  - auto.
  - break_if; congruence.
  - f_equal; firstorder.
  - break_if; auto.
    f_equal; firstorder.
  - f_equal; firstorder.
Qed.

Lemma const_terminates :
  forall b,
    terminates (TConst b).
Proof.
  unfold terminates.
  intros. exists (TConst b). intuition.
  - red. intros. solve_by_inversion.
  - red. constructor.
Qed.

Lemma lambda_terminates :
  forall x tau e,
    terminates (TAbs x tau e).
Proof.
  unfold terminates.
  intros.
  exists (TAbs x tau e).
  intuition.
  - red. intros. invc H.
  - constructor.
Qed.

Lemma step_star_left_ind :
  forall (P : term -> term -> Prop),
    (forall x, P x x) ->
    (forall x y z, step x y -> step_star y z -> P y z -> P x z) ->
    forall x a, step_star x a -> P x a.
Proof.
  unfold step_star.
  intros.
  find_apply_lem_hyp clos_rtn1_rt.
  find_apply_lem_hyp clos_rt_rt1n.
  eapply clos_refl_trans_1n_ind; eauto.
  intros.
  eapply H0; eauto.
  eauto using clos_rt1n_rt, clos_rt_rtn1.
Qed.

Lemma step_star_if_inv :
  forall e1 e2 e3 e',
    step_star (TIf e1 e2 e3) e' ->
    irreducible e' ->
    exists e1',
      step_star e1 e1' /\
      irreducible e1' /\
      step_star (TIf e1' e2 e3) e'.
Proof.
  intros.
  prep_induction H.
  induction H using step_star_left_ind; intros; subst.
  - exists e1. intuition; try solve [constructor].
    unfold irreducible in *.
    intros.
    eapply H0. econstructor. eauto.
  - inv H.
    + eexists. intuition.
      * constructor.
      * apply values_are_irreducible. simpl. auto.
      * eauto using step_star_step_left.
    + eexists. intuition.
      * constructor.
      * apply values_are_irreducible. simpl. auto.
      * eauto using step_star_step_left.
    + specialize (IHstep_star _ _ _ $(auto)$ $(eauto)$).
      break_exists_exists. intuition eauto using step_star_step_left.
Qed.

Lemma step_star_TConst :
  forall b e,
    step_star (TConst b) e ->
    e = TConst b.
Proof.
  intros.
  find_apply_lem_hyp step_star_left_inv. intuition.
  break_exists. intuition. solve_by_inversion.
Qed.

Lemma step_star_TAbs :
  forall x tau e e',
    step_star (TAbs x tau e) e' ->
    e' = TAbs x tau e.
Proof.
  intros.
  find_apply_lem_hyp step_star_left_inv.
  firstorder.
  solve_by_inversion.
Qed.

Lemma step_star_value :
  forall v e',
    is_value v ->
    step_star v e' ->
    v = e'.
Proof.
  destruct v; simpl; intuition.
  - symmetry. auto using step_star_TConst.
  - symmetry. auto using step_star_TAbs.
Qed.

Lemma step_star_app_inv_1 :
  forall e1 e2 e',
    step_star (TApp e1 e2) e' ->
    irreducible e' ->
    exists e1',
      step_star e1 e1' /\ irreducible e1' /\ step_star (TApp e1' e2) e'.
Proof.
  intros.
  prep_induction H.
  induction H using step_star_left_ind; intros; subst.
  - exists e1. intuition; try solve [constructor].
    unfold irreducible in *.
    intros.
    eapply H0. econstructor. eauto.
  - inv H.
    + eexists. intuition.
      * constructor.
      * apply values_are_irreducible. simpl. auto.
      * eauto using step_star_step_left.
    + specialize (IHstep_star _ _ $(auto)$ $(eauto)$).
      break_exists_exists. intuition eauto using step_star_step_left.
    + specialize (IHstep_star _ _ $(auto)$ $(eauto)$).
      break_exists_exists. intuition.
      match goal with
      | [ H : is_value _ |- _ ] => eapply step_star_value in H; eauto
      end.
      subst.
      eauto using step_star_step_left.
Qed.

Lemma step_star_app_inv_2 :
  forall e1 e2 e',
    step_star (TApp e1 e2) e' ->
    is_value e1 ->
    irreducible e' ->
    exists e2',
      step_star e2 e2' /\ irreducible e2' /\ step_star (TApp e1 e2') e'.
Proof.
  intros.
  prep_induction H.
  induction H using step_star_left_ind; intros; subst.
  - exists e2. intuition; try solve [constructor].
    unfold irreducible in *.
    intros.
    eapply H1. eapply step_app2; eauto.
  - inv H.
    + eexists. intuition.
      * constructor.
      * apply values_are_irreducible. simpl. auto.
      * eauto using step_star_step_left.
    + exfalso. eauto using irreducible_no_step, values_are_irreducible.
    + specialize (IHstep_star e1 e2' $(auto)$ $(auto)$ $(auto)$).
      break_exists_exists. intuition.
      eauto using step_star_step_left.
Qed.

Lemma inhabited :
  forall tau (x : name),
  exists e,
    has_type TypingContext.empty e tau.
Proof.
  intros. induction tau.
  - exists (TConst true). auto.
  - break_exists_name e2.
    break_exists_name e1.
    exists (TAbs x tau1 e2).
    constructor.
    eauto using weakening_empty.
Qed.

Lemma has_type_empty_not_free :
  forall tau e x,
    has_type TypingContext.empty e tau ->
    is_free_in x e -> False.
Proof.
  intros.
  find_eapply_lem_hyp has_type_free; eauto.
  break_exists. rewrite TypingContext.get_empty in *. discriminate.
Qed.


(* $Id: IVT.v,v 1.17 2003/03/11 13:36:16 lcf Exp $ *)

Require Export CPoly_Contin.
Require Export CPoly_ApZero.

(* Tex_Prose
\chapter{Intermediate Value Theorem}
*)

Section Nested_Intervals.
(* Tex_Prose
\section{Nested intervals}

\begin{convention} Let \verb!a,b:nat->IR! be sequences such that:
\begin{itemize}
\item \verb!a! is increasing;
\item \verb!b! is decreasing;
\item \verb!(i:nat)((a i) [<] (b i))!;
\item for every positive real number \verb!eps!, there is an $i$ such that \verb!(b i) [<] (a i)[+]eps!.
\end{itemize}
\end{convention}
*)

Variables a,b : nat->IR.
Hypothesis a_mon : (i:nat)((a i) [<=] (a (S i))).
Hypothesis b_mon : (i:nat)((b (S i)) [<=] (b i)).
Hypothesis a_b : (i:nat)((a i) [<] (b i)).
Hypothesis b_a : (eps:IR)(Zero [<] eps) -> {i:nat | (b i) [<=] (a i)[+]eps}.

(* Begin_Tex_Verb *)
Lemma a_mon' : (i,j:nat)(le i j) -> ((a i) [<=] (a j)).
(* End_Tex_Verb *)
Intros.
Apply local_mon'_imp_mon'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma b_mon' : (i,j:nat)(le i j) -> ((b j) [<=] (b i)).
(* End_Tex_Verb *)
Intros.
LetTac b':=[i:nat][--](b i).
Step [--][--](b j).
Stepr [--][--](b i).
Fold (b' i) (b' j).
Apply inv_resp_leEq.
Apply local_mon'_imp_mon'.
Unfold b'; Intro; Apply inv_resp_leEq; Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma a_b' : (i,j:nat)((a i) [<] (b j)).
(* End_Tex_Verb *)
Intros.
Elim (le_lt_dec i j); Intro.
Apply leEq_less_trans with (a j).
Apply a_mon'. Auto.
Auto.
Apply less_leEq_trans with (b i).
Auto.
Apply b_mon'. Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma intervals_cauchy : (Cauchy_prop a).
(* End_Tex_Verb *)
Unfold Cauchy_prop.
Unfold AbsSmall.
Intro eps. Intros.
Elim (b_a eps H). Intro n. Intros. Exists n.
Intro i. Intros.
Split; Apply less_leEq.
Apply less_leEq_trans with (Zero::IR).
Stepr [--](Zero::IR).
Apply inv_resp_less. Auto.
Step (a n)[-](a n).
Apply minus_resp_leEq.
Apply a_mon'. Auto.
Apply shift_minus_less'.
Apply less_leEq_trans with (b n).
Apply a_b'.
Auto.
Qed.

(* Begin_Tex_Verb *)
Local a' := (Build_CauchySeq ? a intervals_cauchy).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Cnested_intervals_limit :
  {z:IR | ((i:nat)((a i) [<=] z)) | ((i:nat)(z [<=] (b i)))}.
(* End_Tex_Verb *)
Exists (Lim a').
Intros.
Unfold leEq. Unfold Not. Intros.
Elim (Lim_less_so_seq_less a' (a i)). Intro n. Intros H0.
Elim (le_lt_dec n i); Intro H1.
Cut (Not ((a i) [<] (a i))). Intro H2.
Unfold Not in H1. Elim H2. Apply H0. Auto.
Apply less_irreflexive_unfolded.
Cut (i,j:nat)(le i j) -> ((a i) [<=] (a j)). Intro a_mon''.
Unfold leEq in a_mon''. Unfold Not in a_mon''.
Elim a_mon'' with i n. Auto with arith.
Apply H0.
Auto.
Intros. Apply a_mon'; Auto.
Auto.
Unfold leEq. Unfold Not. Intros.
Elim (less_Lim_so_less_seq a' (b i) H). Intro n. Intros H0.
Elim (le_lt_dec n i); Intro H1.
Cut (Not ((a i) [<] (b i))). Unfold Not. Intro.
Elim H2. Auto. Apply less_antisymmetric_unfolded.
Apply H0.
Auto.
Cut (Not ((a n) [<] (b n))). Unfold Not. Intro H2.
Apply H2. Auto. Apply less_antisymmetric_unfolded.
Apply leEq_less_trans with (b i).
Apply b_mon'. Auto with arith.
Apply H0. Auto.
Qed.

(* Tex_Prose
\begin{convention} Let \verb!f! be a continuous real function.
\end{convention}
*)

Variable f : (CSetoid_un_op IR).
Hypothesis f_contin : (contin f).

(* Begin_Tex_Verb *)
Lemma f_contin_pos :
  (z:IR)(Zero [<] (f z)) ->
    {eps:IR & (Zero [<] eps) &
      ((x:IR)(x [<=] z[+]eps) -> (z [<=] x[+]eps) -> (Zero [<] (f x)))}.
(* End_Tex_Verb *)
Intros.
Unfold contin in f_contin.
Unfold continAt in f_contin.
Unfold funLim in f_contin.
Unfold AbsSmall in f_contin.
Elim (f_contin z (f z)[/]TwoNZ (pos_div_two ?? H)). Intro eps. Intros H1 H2.
Exists eps.
Auto. Intros.
Elim (H2 x). Intros H5 H6.
Step (f z)[-](f z).
Apply shift_minus_less.
Apply shift_less_plus'.
Apply leEq_less_trans with (f z)[/]TwoNZ. Auto. Apply pos_div_two'. Auto.
Split.
Apply shift_leEq_minus.
RStep x[-]eps.
Apply shift_minus_leEq. Auto.
Apply shift_minus_leEq. Stepr x[+]eps. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma f_contin_neg :
  (z:IR)((f z) [<] Zero) ->
    {eps:IR & (Zero [<] eps) &
      ((x:IR)(x [<=] z[+]eps) -> (z [<=] x[+]eps) -> ((f x) [<] Zero))}.
(* End_Tex_Verb *)
Intros.
Unfold contin in f_contin.
Unfold continAt in f_contin.
Unfold funLim in f_contin.
Unfold AbsSmall in f_contin.
Cut Zero [<] [--](f z). Intro.
Elim (f_contin z ([--](f z))[/]TwoNZ (pos_div_two ?? H0)). Intro eps. Intros H2 H3.
Exists eps.
Auto. Intros.
Elim (H3 x). Intros H6 H7.
RStepr (f z)[-][--][--](f z).
Apply shift_less_minus'.
Apply shift_plus_less.
Apply less_leEq_trans with (f z)[/]TwoNZ.
Step (f z). Apply inv_cancel_less. RStep ([--](f z))[/]TwoNZ. Apply pos_div_two'. Auto.
RStep [--]([--](f z))[/]TwoNZ. Auto.
Split.
Apply shift_leEq_minus.
RStep x[-]eps.
Apply shift_minus_leEq. Auto.
Apply shift_minus_leEq. Stepr x[+]eps. Auto.
Step [--](Zero::IR).
Apply inv_resp_less. Auto.
Qed.

(* Begin_Tex_Verb *)
Hypothesis f_a : (i:nat)((f (a i)) [<=] Zero).
Hypothesis f_b : (i:nat)(Zero [<=] (f (b i))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Cnested_intervals_zero :
  {z : IR | ((a (0)) [<=] z) /\ ((z [<=] (b (0))) /\ ((f z) [=] Zero))}.
(* End_Tex_Verb *)
Elim Cnested_intervals_limit. Intro z. Intros H0 H1. Exists z.
Split. Auto. Split. Auto.
Apply not_ap_imp_eq.
Unfold Not.
Intros H2.
Elim (ap_imp_less ? ? ? H2); Intros H3.
Elim (f_contin_neg z H3). Intro eps. Intros H5 H6.
Elim (b_a eps). Intro i. Intros H7.
Cut (b i) [<=] z[+]eps. Intro.
Cut z [<=] (b i)[+]eps. Intro.
Unfold leEq in f_b. Unfold Not in f_b.
Apply f_b with i. Apply H6. Auto. Auto.
Apply leEq_transitive with (b i). Auto.
Step (b i)[+]Zero. Apply plus_resp_leEq_lft. Apply less_leEq. Auto.
Apply leEq_transitive with (a i)[+]eps. Auto.
Apply plus_resp_leEq. Auto. Auto.
Elim (f_contin_pos z H3). Intro eps. Intros H5 H6.
Elim (b_a eps). Intro i. Intros H7.
Cut (a i) [<=] z[+]eps. Intro.
Cut z [<=] (a i)[+]eps. Intro.
Unfold leEq in f_a. Unfold Not in f_a.
Apply f_a with i. Apply H6. Auto. Auto.
Apply leEq_transitive with (b i). Auto.
Auto. Apply leEq_transitive with z. Auto.
Step z[+]Zero. Apply less_leEq. Apply plus_resp_less_lft. Auto.
Auto.
Qed.

End Nested_Intervals.

Section Bisection.
(* Tex_Prose
\section{Bisections}
*)

(* Begin_Tex_Verb *)
Variable f : (CSetoid_un_op IR).
Hypothesis f_apzero_interval : (a,b:IR)(a [<] b) ->
  {c:IR | (a [<=] c) /\ (c [<=] b) & ((f c) [#] Zero)}.
Variable a,b : IR.
Hypothesis a_b : a [<] b.
Hypothesis f_a : (f a) [<=] Zero.
Hypothesis f_b : Zero [<=] (f b).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Local Small : IR := Two[/]ThreeNZ.
Local lft := (Two[*]a[+]b)[/]ThreeNZ.
Local rht := (a[+]Two[*]b)[/]ThreeNZ.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma a_lft : a [<] lft.
(* End_Tex_Verb *)
Unfold lft.
Apply shift_less_div.
Apply pos_three.
RStep Two[*]a[+]a.
Apply plus_resp_less_lft.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma rht_b : rht [<] b.
(* End_Tex_Verb *)
Unfold rht.
Apply shift_div_less.
Apply pos_three.
RStepr b[+]Two[*]b.
Apply plus_resp_less_rht.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma lft_rht : lft [<] rht.
(* End_Tex_Verb *)
Unfold lft. Unfold rht.
Apply div_resp_less_rht.
RStep (a[+]b)[+]a.
RStepr (a[+]b)[+]b.
Apply plus_resp_less_lft.
Auto.
Apply pos_three.
Qed.

(* Begin_Tex_Verb *)
Lemma smaller_lft : rht[-]a [=] Small[*](b[-]a).
(* End_Tex_Verb *)
Unfold Small. Unfold rht.
Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma smaller_rht : b[-]lft [=] Small[*](b[-]a).
(* End_Tex_Verb *)
Unfold Small. Unfold lft.
Rational.
Qed.

Hints Resolve smaller_lft smaller_rht : algebra.

(* Begin_Tex_Verb *)
Lemma Cbisect' :
  {a':IR & { b':IR &
      (a' [<] b') |
      (a [<=] a') /\ (b' [<=] b) /\
      (b'[-]a' [<=] Small[*](b[-]a)) /\
      ((f a') [<=] Zero) /\
      (Zero [<=] (f b'))}}.
(* End_Tex_Verb *)
Elim (f_apzero_interval lft rht lft_rht). Intro c. Intro H.
Elim H. Intros H0 H2 H3.
Cut ({(f c) [<=] Zero} + {Zero [<=] (f c)}).
Intro H4; Inversion_clear H4.
Exists c. Exists b.
Apply leEq_less_trans with rht. Auto. Apply rht_b.
Split. Apply leEq_transitive with lft. Apply less_leEq. Apply a_lft. Auto.
Split. Apply leEq_reflexive.
Split. Stepr b[-]lft. Apply minus_resp_leEq_rht. Auto.
Split. Auto. Auto.
Exists a. Exists c.
Apply less_leEq_trans with lft. Apply a_lft. Auto.
Split. Apply leEq_reflexive.
Split. Apply less_leEq. Apply leEq_less_trans with rht. Auto. Apply rht_b.
Split.
Stepr rht[-]a. Apply minus_resp_leEq. Auto.
Split. Auto. Auto.
Elim (ap_imp_less ? ? ? H3); Intros.
Left. Apply less_leEq. Auto.
Right. Apply less_leEq. Auto.
Qed.

End Bisection.

Section Bisect_Interval.

(* Tex_Prose
\section{Bisection gives an interval}
*)

(* Begin_Tex_Verb *)
Variable f : (CSetoid_un_op IR).
Hypothesis C_f_apzero_interval : (a,b:IR)(a [<] b) ->
  {c:IR | (a [<=] c) /\ (c [<=] b) & ((f c) [#] Zero)}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Local Small : IR := Two[/]ThreeNZ.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Record bisect_interval : Set :=
  { interval_lft     : IR;
    interval_rht     : IR;
    interval_lft_rht : interval_lft [<] interval_rht;
    interval_f_lft   : (f interval_lft) [<=] Zero;
    interval_f_rht   : Zero [<=] (f interval_rht)
  }.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Cbisect_exists : (I:bisect_interval)
  {I':bisect_interval |
    ((interval_rht I')[-](interval_lft I') [<=]
      Small[*]((interval_rht I)[-](interval_lft I))) /\
    (((interval_lft I) [<=] (interval_lft I')) /\
    ((interval_rht I') [<=] (interval_rht I)))}.
(* End_Tex_Verb *)
Intros.
Elim (Cbisect' f C_f_apzero_interval
  ? ? (interval_lft_rht I) (interval_f_lft I) (interval_f_rht I)).
Intro lft. Intro H.
Elim H. Intro rht. Intros H1 H2. Elim H2. Intros H3 H4. Elim H4. Intros H5 H6.
Elim H6. Intros H7 H8.
Elim H8. Intros H9 H10.
Exists (Build_bisect_interval lft rht H1 H9 H10).
Simpl.
Unfold Small.
Split. Auto. Split. Auto. Auto.
Qed.

(* Begin_Tex_Verb *)
Definition bisect : bisect_interval -> bisect_interval :=
  [I:bisect_interval]
    (proj1_sig ? ? (Cbisect_exists I)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma bisect_prop : (I:bisect_interval)
  (((interval_rht (bisect I))[-](interval_lft (bisect I)) [<=]
    Small[*]((interval_rht I)[-](interval_lft I)))) /\
  (((interval_lft I) [<=] (interval_lft (bisect I))) /\
  ((interval_rht (bisect I)) [<=] (interval_rht I))).
(* End_Tex_Verb *)
Intros.
Unfold bisect.
Apply proj2_sig.
Qed.

End Bisect_Interval.

Section IVT_Op.
(* Tex_Prose
\section{IVT for operations}
*)

(* Begin_Tex_Verb *)
Variable f : (CSetoid_un_op IR).
Hypothesis f_contin : (contin f).
Hypothesis f_apzero_interval : (a,b:IR)(a [<] b) ->
  { c:IR | (a [<=] c) /\ (c [<=] b) & ((f c) [#] Zero)}.
Variable a,b : IR.
Hypothesis a_b : a [<] b.
Hypothesis f_a : (f a) [<=] Zero.
Hypothesis f_b : Zero [<=] (f b).

Local Small : IR := Two[/]ThreeNZ.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Fixpoint interval_sequence [n:nat] : (bisect_interval f) :=
  Cases n of
    O => (Build_bisect_interval f a b a_b f_a f_b)
  | (S m) => (bisect f f_apzero_interval (interval_sequence m))
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Local a_ := [i:nat](interval_lft ? (interval_sequence i)).
Local b_ := [i:nat](interval_rht ? (interval_sequence i)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma intervals_smaller :
  (i:nat)((b_ i)[-](a_ i) [<=] Small[^]i[*](b[-]a)).
(* End_Tex_Verb *)
Intros.
Induction i; Intros.
Unfold a_. Unfold b_. Simpl.
RStepr b[-]a.
Apply leEq_reflexive.
Apply leEq_transitive with Small[*]((b_ i)[-](a_ i)).
Elim (bisect_prop f f_apzero_interval (interval_sequence i)).
Intros H H0.
Elim H0; Intros H1 H2.
Auto.
Simpl.
Replace (nexp ? i Small) with Small[^]i. 2: Auto.
RStepr Small[*](Small[^]i[*](b[-]a)).
Apply mult_resp_leEq_lft.
Auto.
Apply less_leEq.
Unfold Small. Apply div_resp_pos. Apply pos_three. Apply pos_two.
Qed.

(* Begin_Tex_Verb *)
Lemma intervals_small'' : (i:nat)(Small[^]i[*](nring i) [<=] One).
(* End_Tex_Verb *)
Intros.
Apply mult_cancel_leEq with ((Three[^]i)::IR).
Apply nexp_resp_pos. Apply pos_three.
Stepr ((Three[^]i)::IR).
Apply leEq_wdl with (((nring i)[*]Two[^]i)::IR).
2: RStepr (nring i)[*](Small[^]i[*]Three[^]i).
2: Stepr (nring i)[*]((Small[*]Three)[^]i).
2: Cut Small[*]Three [=] Two; Algebra.
2: Unfold Small; Rational.
Induction i.
Simpl. Step (Zero::IR). Apply less_leEq. Apply pos_one.
Elim (zerop i); Intro y.
Rewrite y. Simpl.
RStep (Two::IR). RStepr (Three::IR).
Apply less_leEq. Apply two_less_three.
Elim (le_lt_eq_dec ? ? (lt_le_S ? ? y)); Intros H0.
Apply mult_cancel_leEq with ((nring i)::IR).
Step ((nring (0))::IR). Apply nring_less. Auto.
Apply leEq_wdl with ((nring (S i))[*]Two)[*](((nring i)[*]Two[^]i)::IR).
2: Simpl; Rational.
Apply leEq_wdr with ((((nring i)[*]Three)[*]Three[^]i)::IR).
2: Simpl; Rational.
Apply leEq_transitive with ((nring i)[*]Three)[*](((nring i)[*]Two[^]i)::IR).
Apply mult_resp_leEq_rht.
Simpl.
RStep (nring i)[*]Two[+](Two::IR).
RStepr (nring i)[*]Two[+]((nring i)::IR).
Apply plus_resp_leEq_lft.
Elim (le_lt_eq_dec ? ? (lt_le_S ? ? H0)); Intros H1.
Apply less_leEq. Apply nring_less. Auto.
Rewrite <- H1. Apply leEq_reflexive.
Apply less_leEq. Apply mult_resp_pos.
Step ((nring (0))::IR). Apply nring_less. Auto.
Apply nexp_resp_pos. Apply pos_two.
Apply mult_resp_leEq_lft. Auto.
Apply less_leEq. Apply mult_resp_pos.
Step ((nring (0))::IR). Apply nring_less. Auto.
Apply pos_three.
Rewrite <- H0.
RStep (!nring IR (8)).
RStepr (!nring IR (9)).
Apply nring_leEq. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma intervals_small' :
  (eps:IR)(Zero [<] eps) -> {i:nat | Small[^]i[*](b[-]a) [<=] eps}.
(* End_Tex_Verb *)
Intros.
Cut eps [#] Zero. Intro.
Elim (Archimedes (b[-]a)[/]eps[//]H0). Intro i. Intros H1. Exists i.
Stepr eps[*]One.
Apply shift_leEq_mult' with H0. Auto.
Apply leEq_transitive with Small[^]i[*](nring i).
Step Small[^]i[*]((b[-]a)[/]eps[//]H0).
Apply mult_resp_leEq_lft.
Auto.
Apply nexp_resp_nonneg.
Apply less_leEq.
Step (Zero::IR)[/]ThreeNZ. Unfold Small.
Apply div_resp_less_rht. Apply pos_two. Apply pos_three.
Apply intervals_small''.
Apply Greater_imp_ap. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma intervals_small :
  (eps:IR)(Zero [<] eps) -> {i:nat | (b_ i) [<=] (a_ i)[+]eps}.
(* End_Tex_Verb *)
Intros.
Elim (intervals_small' eps H). Intro i. Intros. Exists i.
Apply shift_leEq_plus'.
Apply leEq_transitive with Small[^]i[*](b[-]a).
Apply intervals_smaller.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Civt_op :
  {z:IR | (a [<=] z) /\ ((z [<=] b) /\ ((f z) [=] Zero))}.
(* End_Tex_Verb *)
Cut (i:nat)((a_ i) [<=] (a_ (S i))). Intro.
Cut (i:nat)((b_ (S i)) [<=] (b_ i)). Intro.
Cut (i:nat)((a_ i) [<] (b_ i)). Intro.
Cut (i:nat)((f (a_ i)) [<=] Zero). Intro.
Cut (i:nat)(Zero [<=] (f (b_ i))). Intro.
Elim (Cnested_intervals_zero a_ b_ H H0 H1 intervals_small f f_contin H2 H3).
Intro z. Intro H4. Exists z.
Exact H4.
Intros. Exact (interval_f_rht ? (interval_sequence i)).
Intros. Exact (interval_f_lft ? (interval_sequence i)).
Intros. Exact (interval_lft_rht ? (interval_sequence i)).
Intros. Elim (bisect_prop f f_apzero_interval (interval_sequence i)).
Intros H0 H1. Elim H1. Intros H2 H3.
Unfold b_. Simpl.
Assumption.
Intros. Elim (bisect_prop f f_apzero_interval (interval_sequence i)).
Intros H H0. Elim H0. Intros H1 H2.
Unfold a_. Simpl. Auto.
Qed.

End IVT_Op.

Section IVT_Poly.

(* Tex_Prose
\section{IVT for polynomials}
*)

(* Begin_Tex_Verb *)
Lemma Civt_poly :
  (f:(cpoly_cring IR))(f [#] Zero) ->
  (a,b:IR)(a [<] b) -> (f!a [<=] Zero) -> (Zero [<=] f!b) ->
    { x:IR | (a [<=] x) /\ ((x [<=] b) /\ (f!x [=] Zero))}.
(* End_Tex_Verb *)
Intros.
Cut { x:IR |
  (a [<=] x) /\ ((x [<=] b) /\ (((cpoly_csetoid_op ? f) x) [=] Zero))}.
Intro. Auto.
Apply Civt_op; Auto.
Apply cpoly_op_contin.
Intros.
Change { c:IR | (a0 [<=] c) /\ (c [<=] b0) & ((f!c) [#] Zero)}.
Apply Cpoly_apzero_interval. Auto. Auto.
Qed.

End IVT_Poly.


Require Import Terms.
Require Import LBracketSyntax.
Require Import LThrowBigStep.
Require Import LBracketEquiv.

(** Monotonicity of the pc label. This property is essential for the
    non-interference proof to go through. *)
Lemma pc_eval_monotonic: forall r t pc a pc',
  r |- t, pc ==> a, pc' -> pc <: pc'.
Proof.
  intros r t pc a pc' Heval.
  (eval_cases (induction Heval) Case);
    intros; eauto 4 using flows_refl, flows_trans, join_1_rev.
Qed.

(* Various helpers respect equality *)
Lemma eq_val_eq_bop : forall b v11 v12 v21 v22 l,
  eq_val v11 v21 l ->
  eq_val v12 v22 l ->
  bop_result b v11 v12 = bop_result b v21 v22.
Proof.
  intros b v11 v12 v21 v22 l Heq1 Heq2.
  inversion Heq1; eauto.
  inversion Heq2; eauto.
Qed.

Inductive eq_res : Result -> Result -> Lab -> Prop :=
| eq_s : forall a1 a2 l,
         eq_atom a1 a2 l ->
         eq_res (Suc a1) (Suc a2) l
| eq_t : forall e l, eq_res (Throw e) (Throw e) l.
Hint Constructors eq_res.

Definition eq_res' res1 pc1 res2 pc2 l :=
  (pc1 <: l \/ pc2 <: l) ->
  (pc1 = pc2 /\ eq_res res1 res2 l).

Lemma eq_res_refl : forall res l, eq_res res res l.
Proof. pose proof eq_refl. destruct res; intuition. Qed.

Lemma eq_res_inversion_st : forall a e l,
  ~ (eq_res (Suc a) (Throw e) l).
Proof. intros a e l H. inversion H. Qed.

Lemma eq_res_inversion_ts : forall a e l,
  ~ (eq_res (Throw e) (Suc a)  l).
Proof. intros a e l H. inversion H. Qed.

Lemma eq_res'_inversion_st : forall a pc1 e pc2 l,
  pc1 <: l \/ pc2 <: l -> ~ (eq_res' (Suc a) pc1 (Throw e) pc2 l).
Proof.
  intros a pc1 e pc2 l Hpc H. destruct (H Hpc) as [_ Heq].
  eapply eq_res_inversion_st. eassumption.
Qed.

Lemma eq_res'_inversion_ts : forall a pc1 e pc2 l,
  pc1 <: l \/ pc2 <: l -> ~ (eq_res' (Throw e) pc1 (Suc a) pc2 l).
Proof.
  intros a pc1 e pc2 l Hpc H. destruct (H Hpc) as [_ Heq].
  eapply eq_res_inversion_ts. eassumption.
Qed.

(*
Lemma eq_val_eq_bracket_val : forall r1 r2 l pc l',
  eq_res r1 r2 l ->
  eq_val (bracket_val r1 pc l') (bracket_val r2 pc l') l.
Proof.
  intros r1 r2 l pc l' Heq.
  inversion Heq; unfold bracket_val; subst.
  Case "Suc".
    rename H into Hflow; rename H0 into Heq_a.
    inversion Heq_a. subst. rename l2 into la. rename H5 into Heq_v.
    specialize (Heq_v Hflow).
    destruct (flows_dec (la \_/ pc) l'); econstructor; eauto.
  Case "Throw".
    destruct (flows_dec pc l'); econstructor; eauto.
Qed.
*)

(* random label helper *)

Lemma lt_disj:
  forall l1 l2 l1' l2' l,
    (l1 <: l \/ l2 <: l) -> l1' <: l1 -> l2' <: l2 ->
    (l1' <: l \/ l2' <: l).
intros. destruct H.
 assert (h: l1' <: l) by (eapply (flows_trans _ _ _ H0 H)). tauto.
 assert (h: l2' <: l) by (eapply (flows_trans _ _ _ H1 H)). tauto.
Qed.

(** * Non-interference *)

(** Strengthened version of non-interference. *)
Lemma non_interference_strong :
  forall r1 t pc1 res1 pc1',
    r1 |- t, pc1 ==> res1, pc1' ->
    forall r2 pc2 res2 pc2' l,
      r2 |- t, pc2 ==> res2, pc2' ->
      eq_env' r1 pc1 r2 pc2 l ->
      (eq_env' r1 pc1' r2 pc2' l /\
        eq_res' res1 pc1' res2 pc2' l).
Proof.
  intros r1 t pc1 res1 pc1' H.
  (eval_cases (induction H) Case);
    intros r2 pc2 res2 pc2'; try (rename l into l1);
    intros l Heval2 Heq_env.
  Case "eval_var". invsc Heval2.
    rename H into Hv1. rename H2 into Hv2. intuition.
    pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env Hv1 Hv2);
    econstructor; specialize (H H0); invsc H; eauto.
  Case "eval_const". invsc Heval2. intuition.
    intro H. apply Heq_env in H. intuition.
  Case "eval_let".
    rename r into r1. rename a into a1. rename pc into pc1.
    rename pc' into pc1'. rename pc'' into pc1''. rename res into res1.
    rename H into Heval11. rename H0 into Heval12.
    invsc Heval2; rename pc2' into pc2''; rename H6 into Heval21.
    SCase "Suc".
      rename a into a2. rename H7 into Heval22.
        (* IH *)
      apply IHeval1 with (l:=l) in Heval21; try assumption.
      destruct Heval21 as [Heq_env1 Heq_res1].
      apply IHeval2 with (l:=l) in Heval22.
      destruct Heval22 as [Heq_env2 Heq_res2].
      intuition. eapply eq_env'_cons_inv_env; try assumption. apply Heq_env2.
      apply cons_eq_env'.
      intros Hpc. specialize (Heq_res1 Hpc). invsc Heq_res1.
      split. reflexivity. invsc H0. assumption.
      assumption.
    SCase "Throw". (* spurious case due to inversion of Heval21... *)
      apply IHeval1 with (l:=l) in Heval21; try assumption.
      invsc Heval21. apply intro_and2. intros Hpc.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval12) as Hpc1'.
      apply eq_res'_inversion_st in H0. inversion H0.
      destruct Hpc; eauto using flows_trans.
  Case "eval_let_fail".
    rename r into r1. rename pc into pc1. rename pc' into pc1'.
    rename H into Heval1. invsc Heval2; rename H6 into Heval21.
    SCase "Suc". (* spurious case due to inversion... *)
      apply IHeval with (l:=l) in Heval21; eauto.
      apply intro_and2. intros Hpc.
      destruct Heval21 as [Heq_env' Heq_res'].
      apply eq_res'_inversion_ts in Heq_res'. inversion Heq_res'.
      pose proof (pc_eval_monotonic _ _ _ _ _ H7) as Hpc1'.
      destruct Hpc; eauto using flows_trans.
    SCase "Throw".
      rename ex into ex1. rename ex0 into ex2.
      apply IHeval with (l := l) in Heval21; eauto.
  Case "eval_abs". invsc Heval2.
    rename r into r1. rename pc into pc1. intuition.
    intros Hpc. specialize (Heq_env Hpc).
    invsc Heq_env. rename H0 into Heq_env.
    intuition.
  Case "eval_app".
    rename r into r1. rename r' into rc1. rename x into x1. rename t into t1.
    rename H into Hc1. rename H0 into Ha1. rename H1 into Heval1.
    rename pc into pc1. rename pc' into pc1'. rename a into a1.
    invsc Heval2.
    SCase "Suc".
      rename r' into rc2. rename x into x2. rename t into t2.
      rename l0 into l2. rename a into a2.
      rename H1 into Hc2. rename H3 into Ha2. rename H7 into Heval2.
        (* get the equalities we want *)
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env Hc1 Hc2) as Heq_clo.
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_arg.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans).
      specialize (Heq_clo Hpc). specialize (Heq_arg Hpc).
      destruct Heq_clo as [Heqpc Heq_clo].
      invsc Heqpc. rename pc2 into pc. clear H.
      destruct Heq_arg as [_ Heq_arg].
        (* get deeper equality on the closure *)
      invsc Heq_clo. rename H5 into Heq_clo.
      assert (l2 <: l \/ l2 <: l) as Hflows' by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_clo Hflows'). clear Hflows'.
      invsc Heq_clo. rename H6 into Heq_envc.
      rename x2 into x. rename t2 into t. rename l2 into lc.
        (* apply the IH *)
      apply IHeval with (l:=l) in Heval2.
      destruct Heval2 as [Heq_env' Heq_res].
      specialize (Heq_env' Hpc'). specialize (Heq_res Hpc').
      destruct Heq_env' as [Heqpc Heq_env'].
      invsc Heqpc. rename pc2' into pc'. clear H.
      destruct Heq_res as [_ Heq_res].
      specialize (Heq_env Hpc). destruct Heq_env as [_ Heq_env].
      eauto.
        (* resolve last env equality *)
      apply cons_eq_env'; intros Hpclc; eauto.
    SCase "Throw". (* spurious case due to inversion of Heval2... *)
      rename l0 into l2. rename v' into v2.
      rename H2 into Hc2. rename H6 into Htag.
        (* get the closure (in)equality we want *)
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env Hc1 Hc2) as Heq_clo.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans).
      specialize (Heq_clo Hpc).
      destruct Heq_clo as [Heqpc Heq_clo]. invsc Heqpc. rename pc2 into pc.
      invsc Heq_clo. rename H6 into Heq_clo.
      assert (l2 <: l \/ l2 <: l) as Hflows' by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_clo Hflows'). clear Hflows'.
      invsc Heq_clo. simpl in Htag.
      assert (TagFun = TagFun) as Htag' by reflexivity.
      contradiction.
  Case "eval_app_etype".
    rename v' into v1. rename r into r1.
    rename H into Hv1. rename H0 into Htag1. rename pc into pc1.
    invsc Heval2.
    SCase "Suc". (* spurious *)
      rename H1 into Hv2. rename l0 into l2.
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_clo.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_clo Hpc). destruct Heq_clo as [Heqpc Heq_clo].
      invsc Heqpc. clear H. rename pc2 into pc.
      invsc Heq_clo. rename H6 into Heq_clo.
      apply pc_eval_monotonic in H7. apply join_2_rev in H7.
      (* why can't eauto figure this out? *)
      assert (l2 <: l \/ l2 <: l) as Hflows'.
        left. destruct Hpc'. eapply join_2_rev. eassumption.
        eapply flows_trans. eassumption. assumption.
      specialize (Heq_clo Hflows'). clear Hflows'.
      invsc Heq_clo. simpl in Htag1.
      assert (TagFun = TagFun) as Htag' by reflexivity.
      contradiction.
    SCase "Throw".
      rename v' into v2. rename l0 into l2.
      rename H2 into Hv2. rename H6 into Htag2.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_env Hpc). destruct Heq_env as [Heq_pc Heq_env].
      invsc Heq_pc. rename pc2 into pc. clear H.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_clo.
      invsc Heq_clo; eauto.
  Case "eval_inx". invsc Heval2.
    rename r into r1. rename a into a1. rename H into Ha1. rename pc into pc1.
    rename a0 into a2. rename pc2' into pc2. rename H6 into Ha2.
    split. assumption.
    intros Hpc. specialize (Heq_env Hpc). destruct Heq_env as [Heqpc Heq_env].
    invsc Heqpc. rename pc2 into pc. clear H.
    split. reflexivity.
    eauto using maps_eq_env.
  Case "eval_match".
    rename r into r1. rename d into d1. rename a into a1.
    rename pc into pc1. rename pc' into pc1'. rename H into Ha1.
    rename H0 into Heval1. invsc Heval2.
    SCase "Suc".
      rename a into a2. rename l0 into l2. rename d into d2.
      rename H7 into Ha2. rename H8 into Heval2.
      apply intro_and2. intros Hpc'.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval1) as Hpc1.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval2) as Hpc2.
      assert (pc1 <: l \/ pc2 <: l) as Hpc.
        destruct Hpc'; [left | right].
          eapply join_1_rev. eapply flows_trans. apply Hpc1. assumption.
          eapply join_1_rev. eapply flows_trans. apply Hpc2. assumption.
      specialize (Heq_env Hpc). destruct Heq_env as [Heqpc Heq_env].
      invsc Heqpc. rename pc2 into pc. clear H.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_a.
      invsc Heq_a. rename H5 into Heq_a.
      assert (l2 <: l \/ l2 <: l) as Hflows by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_a Hflows). invsc Heq_a.
      rename H4 into Heq_a. rename d2 into d. rename l2 into la.
      apply IHeval with (l:=l) in Heval2.
      destruct Heval2 as [Heq_env' Heq_res'].
      specialize (Heq_env' Hpc'). specialize (Heq_res' Hpc').
      destruct Heq_env' as [Heqpc Heq_env']. invsc Heqpc; eauto.
      apply cons_eq_env'; intros Hpcla; eauto.
   SCase "Throw". (* spurious *)
      rename v into v2. rename l0 into l2.
      rename H7 into Ha2. rename H8 into Htag2.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc.
        destruct Hpc'.
          left. eapply join_1_rev. eapply flows_trans.
          eapply pc_eval_monotonic. apply Heval1. assumption.
          right. eapply join_1_rev. apply H.
      specialize (Heq_env Hpc). destruct Heq_env as [Heqpc Heq_env].
      invsc Heqpc. rename pc2 into pc. clear H.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_a.
      invsc Heq_a. rename H5 into Heq_a.
      assert (l2 <: l \/ l2 <: l) as Hflows by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_a Hflows). invsc Heq_a. rename H3 into Heq_a.
      simpl in Htag2.
      contradict Htag2; reflexivity.
  Case "eval_match_etype".
    rename v into v1. rename r into r1. rename pc into pc1.
    rename H into Ha1. rename H0 into Htag. invsc Heval2.
    SCase "Suc". (* spurious *)
      rename a into a2. rename l0 into l2.
      rename H7 into Ha2. rename H8 into Heval2. rename Htag into Htag1.
      apply intro_and2. intros Hpc'.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval2) as Hpc2.
      assert (pc1 <: l \/ pc2 <: l) as Hpc.
        destruct Hpc'; [left | right].
          eapply join_1_rev. apply H.
          eapply join_1_rev. eapply flows_trans. apply Hpc2. assumption.
      specialize (Heq_env Hpc). destruct Heq_env as [Heqpc Heq_env].
      invsc Heqpc. rename pc2 into pc. clear H.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_a.
      invsc Heq_a. rename H5 into Heq_a.
      assert (l2 <: l \/ l2 <: l) as Hflows by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_a Hflows). invsc Heq_a. rename H3 into Heq_a.
      simpl in Htag1.
      contradict Htag1; reflexivity.
    SCase "Throw".
      rename v into v2. rename l0 into l2.
      rename H7 into Ha2. rename H8 into Htag2.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_env Hpc). destruct Heq_env as [Heqpc Heq_env].
      invsc Heqpc. rename pc2 into pc. clear H.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_a.
      invsc Heq_a. eauto.
  Case "eval_tag". invsc Heval2.
    rename v into v1. rename r into r1. rename H into Ha1.
    rename v0 into v2. rename l0 into l2. rename H2 into Ha2.
    apply intro_and2. intros Hpc'.
    specialize (Heq_env Hpc'). invsc Heq_env. rename H0 into Heq_env.
    split; eauto.
    pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Ha1 Ha2) as Heq_a.
    split. reflexivity. invsc Heq_a. rename H5 into Heq_a. constructor.
    constructor; auto. intros Hl2. specialize (Heq_a Hl2).
    assert (tag_of v1 = tag_of v2) as Heq_tag by eauto using eq_val_eq_tag.
    rewrite Heq_tag. eauto.
  Case "eval_bop".
    rename pc into pc1, v' into v11, v'' into v12, H into Hv11, H0 into Hv12,
      l0' into l11, l0'' into l12, r into r1.
    invsc Heval2. rename v' into v21, v'' into v22, l0' into l21,
      l0'' into l22, H6 into Hv21, H7 into Hv22.
    apply intro_and2. intros Hpc'.
    assert (pc1 <: l \/ pc2 <: l) as Hpc by
      (destruct Hpc'; eauto using join_1_rev).
    specialize (Heq_env Hpc). invsc Heq_env.
    rename H0 into Heq_env, pc2 into pc.
    pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv11 Hv21) as Heq_a1.
    pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv12 Hv22) as Heq_a2.
    invsc Heq_a1. rename H5 into Heq_v1, l21 into l1.
    invsc Heq_a2. rename H5 into Heq_v2, l22 into l2.
    split; eauto. split. reflexivity.
    assert (l1 <: l \/ l1 <: l) as Hl1 by
      (destruct Hpc'; eauto using join_1_rev, join_2_rev).
    assert (l2 <: l \/ l2 <: l) as Hl2 by
      (destruct Hpc'; eauto using join_2_rev).
    assert (bop_result b v11 v12 = bop_result b v21 v22) as Heq_bop by
      eauto using eq_val_eq_bop. rewrite Heq_bop. eauto using eq_res_refl.
  Case "eval_bracket".
    rename l' into l1', r into r1, pc into pc1, pc' into pc1', res into res1,
      H0 into Heval1, H into Hl1.
    invsc Heval2.
    SCase "Suc".
      rename l0 into l2, l' into l2', res into res2, pc' into pc2',
        H2 into Hl2, H6 into Heval2.
      apply intro_and2. intros Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using join_1_rev).
      specialize (Heq_env Hpc). invsc Heq_env.
      rename H0 into Heq_env, pc2 into pc.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hl1 Hl2) as Heq_l.
      invsc Heq_l. rename H5 into Heq_l.
      assert (l2' <: l \/ l2' <: l) as Hflows by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_l Hflows). invsc Heq_l.
      rename l2 into la, l2' into la'.
      split. eauto. split. reflexivity.
        (* apply the IH! *)
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval1) as Hpc1'.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval2) as Hpc2'.
      apply IHeval with (l:=l) in Heval2.
      destruct Heval2 as [Heq_env' Heq_res].
      constructor. constructor. reflexivity. intros Hla.
        (* lengthy case analysis on the results, opening up bracket_val *)
      destruct res1.
      SSCase "Suc1".
        destruct res2.
        SSSCase "Suc2".
          destruct a as [v1 l1]. destruct a0 as [v2 l2].
          remember (flows_dec (l1 \_/ pc1') (la \_/ (pc \_/ la'))) as f1.
          destruct f1 as [Hflow1 | Hnotflow1].
          SSSSCase "pc1' flow check succeeds".
            assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
              (destruct Hpc'; destruct Hla;
                eauto using join_2_rev, flows_trans, join_minimal).
            specialize (Heq_res Hpc''). invsc Heq_res. rename H0 into Heq_res.
            invsc Heq_res. rename H1 into Heq_a. invsc Heq_a.
            rename H5 into Heq_v.
            apply or_elimrefl in Hpc. apply or_elimrefl in Hflows.
            apply or_elimrefl in Hpc'. apply or_elimrefl in Hpc''.
            apply or_elimrefl in Hla.
            simpl. rewrite <- Heqf1. clear Heqf1.
            assert (l2 <: l \/ l2 <: l) as Hl2f by
              eauto using join_minimal, flows_join_left, flows_trans,
                join_1_rev.
            specialize (Heq_v Hl2f). econstructor; eauto.
          SSSSCase "pc1' flow check fails".
            simpl. rewrite <- Heqf1.
            remember (flows_dec (l2 \_/ pc2') (la \_/ (pc \_/ la'))) as f2.
            destruct f2 as [Hflow2 | Hnotflow2].
            SSSSSCase "pc2' flow check succeeds". (* spurious *)
              assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
                (destruct Hpc'; destruct Hla;
                  eauto using join_2_rev, flows_trans, join_minimal).
              specialize (Heq_res Hpc''). invsc Heq_res.
              rename H0 into Heq_res. invsc Heq_res.
              rename H1 into Heq_a. invsc Heq_a. contradiction.
            SSSSSCase "pc2' flow check fails".
              econstructor; eauto.
        SSSCase "Throw2".
          remember (flows_dec pc2' (la \_/ (pc \_/ la'))) as f2.
          destruct f2 as [Hflow2 | Hnotflow2].
          SSSSCase "pc2' flow check succeeds". (* spurious *)
            assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
              (destruct Hpc'; destruct Hla;
                eauto using join_2_rev, flows_trans, join_minimal).
              specialize (Heq_res Hpc''). invsc Heq_res.
              rename H0 into Heq_res. apply eq_res_inversion_st in Heq_res.
              inversion Heq_res.
          SSSSCase "pc2' flow check fails".
            destruct a as [v1 l1].
            remember (flows_dec (l1 \_/ pc1') (la \_/ (pc \_/ la'))) as f1.
            destruct f1 as [Hflow1 | Hnotflow1].
            SSSSSCase "pc1' flow check succeeds". (* spurious *)
              assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
                (destruct Hpc'; destruct Hla;
                  eauto using join_2_rev, flows_trans, join_minimal).
              specialize (Heq_res Hpc''). invsc Heq_res.
              rename H0 into Heq_res. apply eq_res_inversion_st in Heq_res.
              inversion Heq_res.
            SSSSSCase "pc1' flow check fails".
              unfold bracket_val.
              rewrite <- Heqf1. rewrite <- Heqf2.
              econstructor; eauto.
      SSCase "Throw1".
        destruct res2.
        SSSCase "Suc2".
          destruct a as [v2 l2].
          remember (flows_dec (l2 \_/ pc2') (la \_/ (pc \_/ la'))) as f2.
          destruct f2 as [Hflow2 | Hnotflow2].
          SSSSCase "pc2' flow check succeeds". (* spurious *)
            assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
              (destruct Hpc'; destruct Hla;
                eauto using join_2_rev, flows_trans, join_minimal).
              specialize (Heq_res Hpc''). invsc Heq_res.
              rename H0 into Heq_res. apply eq_res_inversion_ts in Heq_res.
              inversion Heq_res.
          SSSSCase "pc2' flow check fails".
            remember (flows_dec pc1' (la \_/ (pc \_/ la'))) as f1.
            destruct f1 as [Hflow1 | Hnotflow1].
            SSSSSCase "pc1' flow check succeeds". (* spurious *)
              assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
                (destruct Hpc'; destruct Hla;
                  eauto using join_2_rev, flows_trans, join_minimal).
              specialize (Heq_res Hpc''). invsc Heq_res.
              rename H0 into Heq_res. apply eq_res_inversion_ts in Heq_res.
              inversion Heq_res.
            SSSSSCase "pc1' flow check fails".
              unfold bracket_val.
              rewrite <- Heqf1. rewrite <- Heqf2.
              econstructor; eauto.
        SSSCase "Throw2".
          remember (flows_dec pc1' (la \_/ (pc \_/ la'))) as f1.
          destruct f1 as [Hflow1 | Hnotflow1].
          SSSSSCase "pc1' flow check succeeds".
            remember (flows_dec pc2' (la \_/ (pc \_/ la'))) as f2.
            destruct f2 as [Hflow2 | Hnotflow2];
              (assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
                 (destruct Hpc'; destruct Hla;
                   eauto using join_2_rev, flows_trans, join_minimal);
               specialize (Heq_res Hpc''); invsc Heq_res;
               rename H0 into Heq_res; invsc Heq_res;
               unfold bracket_val; rewrite <- Heqf1;
               econstructor; eauto).
          SSSSSCase "pc1' flow check fails".
            remember (flows_dec pc2' (la \_/ (pc \_/ la'))) as f2.
            destruct f2 as [Hflow2 | Hnotflow2].
            SSSSSSCase "pc2' flow check succeeds".
              (assert (pc1' <: l \/ pc2' <: l) as Hpc'' by
                   (destruct Hpc'; destruct Hla;
                     eauto using join_2_rev, flows_trans, join_minimal);
                 specialize (Heq_res Hpc''); invsc Heq_res;
                 rename H0 into Heq_res; invsc Heq_res;
                 unfold bracket_val; rewrite <- Heqf1;
                 econstructor; eauto).
            SSSSSSCase "pc2' flow check fails".
              unfold bracket_val. rewrite <- Heqf1. rewrite <- Heqf2.
              econstructor; eauto.
        (* final env obligation *)
      intros _. eauto.
    SCase "Throw". (* spurious *)
      rename v into v2, l0 into l2, H2 into Hl2, H6 into Htag2.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using join_1_rev).
      specialize (Heq_env Hpc). invsc Heq_env.
      rename H0 into Heq_env, pc2 into pc.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hl1 Hl2) as Heq_l.
      invsc Heq_l. rename H5 into Heq_l.
      assert (l2 <: l \/ l2 <: l) as Hflows by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans,
          flows_join_left).
      specialize (Heq_l Hflows). invsc Heq_l.
      contradict Htag2. reflexivity.
  Case "eval_bracket_etype".
    rename v into v1, r into r1, H into Hv1, H0 into Htag1, pc into pc1.
    invsc Heval2.
    SCase "Suc". (* spurious *)
      rename res into res2, l0 into l2, l' into l2', H2 into Hv2,
        H6 into Heval2.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using join_1_rev).
      specialize (Heq_env Hpc). invsc Heq_env.
      rename H0 into Heq_env, pc2 into pc.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_v.
      invsc Heq_v. rename H5 into Heq_l.
      assert (l2' <: l \/ l2' <: l) as Hflows by
        (destruct Hpc'; eauto using join_2_rev).
      specialize (Heq_l Hflows). invsc Heq_l.
      contradict Htag1. reflexivity.
    SCase "Throw".
      rename v into v2, l0 into l2, H2 into Hv2, H6 into Htag2.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using join_1_rev).
      specialize (Heq_env Hpc). invsc Heq_env.
      rename H0 into Heq_env, pc2 into pc.
      pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_v.
      invsc Heq_v. eauto.
  Case "eval_label_of". invsc Heval2.
    rename H into Hv1, H2 into Hv2.
    apply intro_and2. intro Hpc'.
    specialize (Heq_env Hpc').
    invsc Heq_env. rename H0 into Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_v.
    invsc Heq_v. split; eauto.
  Case "eval_get_pc". invsc Heval2.
    split; intros Hpc; eauto.
    specialize (Heq_env Hpc). invsc Heq_env; eauto.
  Case "eval_throw". invsc Heval2.
    rename pc into pc1, r into r1, v into v1, H into Hv1, v0 into v2,
      l0 into l2, H2 into Hv2.
    apply intro_and2. intro Hpc'.
    assert (pc1 <: l \/ pc2 <: l) as Hpc by
      (destruct Hpc'; eauto using join_1_rev).
    specialize (Heq_env Hpc).
    invsc Heq_env. rename H0 into Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ Heq_env Hv1 Hv2) as Heq_v.
    invsc Heq_v. rename H5 into Heq_v.
    assert (l2 <: l \/ l2 <: l) as Hl2 by
      (destruct Hpc'; eauto using join_2_rev).
    specialize (Heq_v Hl2). invsc Heq_v; eauto.
  Case "eval_catch_no_excp".
    rename r into r1, pc into pc1, pc' into pc1', a into a1, H into Heval1.
    invsc Heval2.
    SCase "Suc".
      rename a into a2, H6 into Heval2.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans).
      specialize (Heq_env Hpc). invsc Heq_env. rename H0 into Heq_env.
      apply IHeval with (l:=l) in Heval2; try (intros _; eauto).
      destruct Heval2 as [Heq_env' Heq_res].
      specialize (Heq_env' Hpc'). specialize (Heq_res Hpc').
      invsc Heq_env'. rename H0 into Heq_env'. destruct Heq_res as [_ Heq_res].
      eauto.
    SCase "Throw". (* spurious *)
      rename pc2' into pc2'', pc' into pc2', H6 into Heval2, H7 into Heval2'.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans).
      specialize (Heq_env Hpc). invsc Heq_env. rename H0 into Heq_env.
      apply IHeval with (l:=l) in Heval2; try (intros _; eauto).
      destruct Heval2 as [Heq_env' Heq_res].
      apply eq_res'_inversion_st in Heq_res. inversion Heq_res.
      destruct Hpc'; eauto using pc_eval_monotonic, flows_trans.
  Case "eval_catch_excp".
    rename r into r1, pc into pc1, pc' into pc1', pc'' into pc1'',
      ex into ex1, H into Heval11, H0 into Heval12.
    invsc Heval2.
    SCase "Suc". (* spurious *)
      rename a into a2, H6 into Heval2.
      apply intro_and2. intro Hpc'.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc'; eauto using pc_eval_monotonic, flows_trans).
      specialize (Heq_env Hpc). invsc Heq_env. rename H0 into Heq_env.
      apply IHeval1 with (l:=l) in Heval2; try (intros _; eauto).
      destruct Heval2 as [Heq_env' Heq_res].
      apply eq_res'_inversion_ts in Heq_res. inversion Heq_res.
      destruct Hpc'; eauto using pc_eval_monotonic, flows_trans.
    SCase "Throw".
      rename ex into ex2, pc2' into pc2'', pc' into pc2',
        H6 into Heval21, H7 into Heval22.
      apply intro_and2. intro Hpc''.
      assert (pc1 <: l \/ pc2 <: l) as Hpc by
        (destruct Hpc''; eauto using pc_eval_monotonic, flows_trans).
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval12) as Hpc1'.
      pose proof (pc_eval_monotonic _ _ _ _ _ Heval22) as Hpc2'.
      assert (pc1' <: l \/ pc2' <: l) as Hpc' by
        (destruct Hpc''; eauto using flows_trans).
      specialize (Heq_env Hpc). invsc Heq_env. rename H0 into Heq_env.
      apply IHeval1 with (l:=l) in Heval21; try (intros _; eauto).
      destruct Heval21 as [Heq_env' Heq_res]. rename pc2 into pc.
      specialize (Heq_env' Hpc'). specialize (Heq_res Hpc').
      invsc Heq_env'. rename H0 into Heq_env'. destruct Heq_res as [_ Heq_res].
      rename pc2' into pc'.
      apply IHeval2 with (l:=l) in Heval22.
      destruct Heval22 as [Heq_env'' Heq_res'].
      specialize (Heq_env'' Hpc''). specialize (Heq_res' Hpc'').
      invsc Heq_res'; eauto.
      invsc Heq_res. apply cons_eq_env'; intros _; eauto.
Qed.

(** Finally, non-interference. *)

Theorem non_interference: forall r1 t pc1 res1 pc1' r2 pc2 res2 pc2' l,
    eq_env' r1 pc1 r2 pc2 l ->
    r1 |- t, pc1 ==> res1, pc1' ->
    r2 |- t, pc2 ==> res2, pc2' ->
    eq_res' res1 pc1' res2 pc2' l.
Proof.
  intros r1 t pc1 res1 pc1' r2 pc2 res2 pc2' l
    Hequiv_env Heval1 Heval2.
  assert (eq_env' r1 pc1' r2 pc2' l /\ eq_res' res1 pc1' res2 pc2' l) by
    eauto using non_interference_strong.
  intuition.
Qed.