(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2004-12-22, 2009-11-04 (Dershowitz' improvement)
- Joerg Endrullis, 2008-06-19 (extension to minimal chains)

dependancy pairs
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ATrs ACalls ACap ASN RelUtil ListUtil
     SN VecUtil VecOrd NatUtil BoolUtil.

Section S.

Variable Sig : Signature.

Notation term := (term Sig). Notation terms := (vector term).
Notation rule := (rule Sig). Notation rules := (list rule).
Notation lhs := (@lhs Sig).

Variable R : rules.

(***********************************************************************)
(** definition of dependancy pairs *)

Definition negb_subterm (t u : term) := negb (bsubterm u t).

Fixpoint mkdp (S : rules) : rules :=
  match S with
    | nil => nil
    | a :: S' => let (l, r) := a in
      map (mkRule l) (filter (negb_subterm l) (calls R r)) ++ mkdp S'
  end.

Definition dp := mkdp R.

Lemma mkdp_app : forall l1 l2, mkdp (l1 ++ l2) = mkdp l1 ++ mkdp l2.

Proof.
induction l1; simpl; intros. refl. destruct a as [l r].
rewrite app_ass, IHl1. refl.
Qed.

Lemma mkdp_elim : forall l t S, In (mkRule l t) (mkdp S) -> exists r,
  In (mkRule l r) S /\ In t (calls R r) /\ negb_subterm l t = true.

Proof.
induction S; simpl; intros. contr. destruct a.
rewrite in_app in H. destruct H. destruct (in_map_elim H). destruct H0.
injection H1. intros. subst x. subst lhs. clear H1.
rewrite filter_In in H0. destruct H0.
exists rhs. intuition. destruct (IHS H). destruct H0. destruct H1.
exists x. intuition.
Qed.

Arguments mkdp_elim [l t S] _.

(***********************************************************************)
(** basic properties *)

Lemma dp_intro : forall l r t, In (mkRule l r) R -> In t (calls R r) ->
  negb_subterm l t = true -> In (mkRule l t) dp.

Proof.
intros. ded (in_elim H). do 2 destruct H2. ded (in_elim H0). do 2 destruct H3.
unfold dp. rewrite H2, mkdp_app. simpl. rewrite H3, filter_app, map_app. simpl.
rewrite H1. apply in_appr. apply in_appl. apply in_appr. apply in_eq.
Qed.

Lemma dp_elim : forall l t, In (mkRule l t) dp -> exists r,
  In (mkRule l r) R /\ In t (calls R r) /\ negb_subterm l t = true.

Proof.
intros. apply mkdp_elim. hyp.
Qed.

Arguments dp_elim [l t] _.

Lemma in_calls_hd_red_dp : forall l r t s, In (mkRule l r) R ->
  In t (calls R r) -> negb_subterm l t = true -> hd_red dp (sub s l) (sub s t).

Proof.
intros. exists l. exists t. exists s. intuition.
eapply dp_intro. apply H. hyp. hyp.
Qed.

Lemma lhs_dp : incl (map lhs dp) (map lhs R).

Proof.
unfold incl. intros. ded (in_map_elim H). do 2 destruct H0. subst a.
destruct x as [l r]. ded (dp_elim H0). do 2 destruct H1.
change (In (lhs (mkRule l x)) (map lhs R)). apply in_map. exact H1.
Qed.

(*FIXME: to be finished

Lemma is_notvar_lhs_dp_aux :
  forall S, forallb (@is_notvar_lhs Sig) (mkdp S) = true.

Proof.
induction S; simpl; intros. refl. destruct a. simpl. rewrite forallb_app.
Qed.

Lemma is_notvar_lhs_dp : forallb (@is_notvar_lhs Sig) dp = true.

Proof.
unfold dp.
Qed.*)

(***********************************************************************)
(** dependency chains *)

Definition chain := int_red R # @ hd_red dp.

Lemma in_calls_chain : forall l r t s, In (mkRule l r) R ->
  In t (calls R r) -> negb_subterm l t = true -> chain (sub s l) (sub s t).

Proof.
intros. unfold chain, compose. exists (sub s l). split. apply rt_refl.
eapply in_calls_hd_red_dp. apply H. hyp. hyp.
Qed.

Lemma gt_chain : forall f ts us v,
  Vrel1 (red R) ts us -> chain (Fun f us) v -> chain (Fun f ts) v.

Proof.
unfold chain, compose. intros. do 2 destruct H0. exists x. split.
apply rt_trans with (y := Fun f us). apply rt_step. apply Vgt_prod_fun.
exact H. exact H0. exact H1.
Qed.

(***********************************************************************)
(** minimal dependency chain (subterms are terminating) *)

Definition chain_min s t := chain s t
  /\ lforall (SN (red R)) (direct_subterms s)
  /\ lforall (SN (red R)) (direct_subterms t).

Lemma chain_min_incl_chain : chain_min << chain.

Proof.
red. intros x y cmin. elim cmin. auto.
Qed.

Lemma gt_chain_min : forall f ts us v, Vrel1 (red R) ts us ->
  Vforall (SN (red R)) ts -> chain_min (Fun f us) v -> chain_min (Fun f ts) v.

Proof.
intros f ts us v gt_ts_us sn_ts chain_min_fus_v.
unfold chain_min in chain_min_fus_v.
destruct chain_min_fus_v as [chain_fus_v sn].
destruct sn as [esn_us esn_ts].
unfold chain_min.
split. apply gt_chain with us; trivial.
split. simpl. apply Vforall_lforall in sn_ts. trivial. trivial.
Qed.

(***********************************************************************)
(** hyps on rules *)

Variable hyp1 : forallb (@is_notvar_lhs Sig) R = true.

Variable hyp2 : rules_preserve_vars R.

Arguments hyp2 [l r] _ _ _.

(***********************************************************************)
(** dp preserves variables *)

Lemma dp_elim_vars : forall l t, In (mkRule l t) dp -> exists r,
  In (mkRule l r) R /\ In t (calls R r) /\ negb_subterm l t = true
  /\ incl (vars t) (vars l).

Proof.
intros. destruct (dp_elim H). decomp H0. exists x. intuition.
trans (vars x). unfold incl. intros.
eapply subterm_eq_vars. eapply in_calls_subterm. apply H3. hyp.
apply hyp2. hyp.
Qed.

Arguments dp_elim_vars [l t] _.

Lemma dp_preserve_vars : rules_preserve_vars dp.

Proof.
unfold rules_preserve_vars. intros. destruct (dp_elim_vars H). intuition.
Qed.

(***********************************************************************)
(** fundamental dp theorem *)

Notation capa := (capa R).
Notation cap := (cap R).
Notation alien_sub := (alien_sub R).

Notation SNR := (SN (red R)).

Lemma chain_min_fun : forall f, defined f R = true
  -> forall ts, SN chain_min (Fun f ts) -> Vforall SNR ts -> SNR (Fun f ts).

Proof.
cut (forall t, SN chain_min t -> forall f, defined f R = true
  -> forall ts, t = Fun f ts -> Vforall SNR ts -> SNR t).
intros. apply H with (f := f) (ts := ts); (hyp || refl).
(* induction on t with chain_min as well-founded ordering *)
intros t H. elim H. clear t H. intros t H IH f H0 ts H1 Hsnts.
assert (SN (Vrel1 (red R)) ts). apply Vforall_SN_rel1. hyp.
(* induction on ts with red as well-founded ordering (ts is SN) *)
gen IH. rewrite H1. elim H2. clear IH ts H1 Hsnts H2.
intros ts H1 IH1 IH2.
assert (Hsnts : Vforall SNR ts). apply SN_rel1_forall. apply SN_intro.
hyp. clear H1.
assert (H1 : forall y, Vrel1 (red R) ts y -> SNR (Fun f y)). intros. apply IH1.
hyp. intros. eapply IH2. eapply gt_chain_min. apply H1.
trivial. apply H2. apply H3. apply H4. hyp. clear IH1.
(* we prove that every reduct of (Fun f ts) is SN *)
apply SN_intro. intros u H2. redtac. destruct c; simpl in xl, yr.
(* c = Hole *)
destruct (fun_eq_sub xl).
(* lhs = Fun f us *)
destruct e as [ls]. rewrite H2, sub_fun in xl. Funeqtac.
(* the substitution s is SN *)
assert (Hsnsx : forall x, In x (vars l) -> SNR (s x)). intros.
eapply sub_fun_sn with (f := f). subst l. apply H4.
rewrite H3 in Hsnts. exact Hsnts.
(* we decompose r into its caps and its aliens *)
subst u. assert (r = sub (alien_sub r) (cap r)). apply sym_eq.
apply (alien_sub_cap R). rewrite H4, sub_sub.
apply no_call_sub_sn. hyp. apply calls_cap.
(* we prove that the alien substitution is SN *)
intros. ded (vars_cap R H5).
case (le_lt_dec x (maxvar r)); intro; unfold sub_comp, ACap.alien_sub.
(* x <= maxvar r *)
ded (vars_cap_inf R H5 l0). ded (hyp2 lr _ H7).
rewrite fsub_inf. simpl. apply Hsnsx. hyp. hyp.
(* x > maxvar r *)
rewrite (fsub_nth (aliens (capa r)) l0 H6).
set (a := Vnth (aliens (capa r)) (lt_pm (k:=projT1 (capa r)) l0 H6)).
assert (Fun f ts = sub s l). rewrite H3, H2. refl.
assert (In a (calls R r)). apply aliens_incl_calls. unfold a. apply Vnth_in.
ded (in_calls H8). destruct H9 as [g]. destruct H9 as [vs]. destruct H9.
(* every call is SN *)
eapply calls_sn with (r := r). hyp.
intros. apply Hsnsx. apply (hyp2 lr _ H11).
intros h ws H13 H14.
case_eq (negb_subterm l (Fun h ws)); intros. rename H11 into z.
apply IH2 with (y := Fun h (Vmap (sub s) ws)) (f := h) (ts := Vmap (sub s) ws).
unfold chain_min. split.
rewrite H7, <- sub_fun. eapply in_calls_chain.
apply lr. hyp. hyp.
split. simpl. apply Vforall_lforall. trivial.
simpl. apply Vforall_lforall. trivial.
eapply in_calls_defined. apply H13. refl. hyp.
(* Dershowitz' improvement *)
revert H11. unfold negb_subterm. rewrite negb_lr. simpl negb.
rewrite bsubterm_ok. intro H11.
rewrite H2 in H11. destruct (subterm_fun_elim H11). destruct H12.
apply subterm_eq_sn with (t := sub s x0). eapply Vforall_in. apply Hsnts.
rewrite H3. apply Vin_map_intro. hyp. apply subterm_eq_sub. hyp.
hyp.
(* lhs = Var x *)
decomp e. subst l. is_var_lhs.
(* c <> Hole *)
Funeqtac. subst u. apply H1. rewrite H2. apply Vrel1_cast_intro.
apply Vrel1_app_intro_l. apply Vrel1_cons_intro. left. split.
eapply red_rule. hyp. refl.
Qed.

Lemma chain_fun : forall f, defined f R = true
  -> forall ts, SN chain (Fun f ts) -> Vforall SNR ts -> SNR (Fun f ts).

Proof.
intros f defined_f ts sn_chain_f_ts sn_ts.
apply chain_min_fun; auto.
apply (SN_incl chain). apply chain_min_incl_chain. hyp.
Qed.

Lemma WF_chain : WF chain -> WF (red R).

Proof.
intro Hwf. unfold WF. apply term_ind_forall.
(* var *)
apply sn_var. apply hyp1.
(* fun *)
intro f. case_eq (defined f R); intros.
(* f defined *)
apply chain_fun. hyp. apply Hwf. hyp.
(* f undefined *)
apply sn_args_sn_fun; auto.
Qed.

Lemma chain_hd_red_mod : chain << hd_red_mod R dp.

Proof.
unfold chain, hd_red_mod. comp. apply rtc_incl.
apply int_red_incl_red.
Qed.

End S.

(***********************************************************************)
(** declaration of implicit arguments *)

Arguments dp_elim [Sig] _ [l t] _.
Arguments dp_elim_vars [Sig] _ _ [l t] _.

(***********************************************************************)
(** tactics *)

From CoLoR Require Import AVariables.

Ltac chain := no_relative_rules; apply WF_chain;
  [ check_eq || fail 10 "a LHS is a variable"
  | rules_preserve_vars
  | idtac].


From fae_gtlc_mu Require Import prelude.
From fae_gtlc_mu.cast_calculus Require Import consistency.
From fae_gtlc_mu.backtranslation Require Import alternative_consistency.
From fae_gtlc_mu.backtranslation.implication_consistencies.help_lemmas Require Import first_half second_half.

(* Proof that classical consistency relation implies the alternative one.
   We will need this when defining the backtranslation on expressions. *)

Lemma cons_co τi pτi τf pτf : consistency τi pτi τf pτf → alternative_consistency [] τi τf.
Proof.
  intro. apply alternative_consistency_pre_alternative_consistency.
  by apply struct_validity.
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section SemicocartesianMonoidal.

Context {C : Category}.

(* A semi-cartesian monoidal category is basically an assertion that the unit
   is terminal. *)

(* jww (2017-06-02): Define this using the dual construction. *)

Class SemicocartesianMonoidal `{@Monoidal C} := {
  generate {x} : I ~> x;

  unit_initial {x} (f g : I ~> x) : f ≈ g;

  embed_left  {x y} : x ~> x ⨂ y := id ⨂ generate ∘ unit_right⁻¹;
  embed_right {x y} : y ~> x ⨂ y := generate ⨂ id ∘ unit_left⁻¹
}.

Corollary generate_comp `{@Monoidal C} `{@SemicocartesianMonoidal _} `{f : A ~> B} :
  f ∘ generate ≈ generate.
Proof. intros; apply unit_initial. Qed.

End SemicocartesianMonoidal.

Require Import Category.Structure.Initial.

(* Wikipedia: "In any cocartesian monoidal category, the initial object is the
   tensor unit." *)

Program Definition SemicocartesianMonoidal_Initial `{@Monoidal C}
        `{@SemicocartesianMonoidal C _} : @Initial C := {|
  terminal_obj := @I C _;
  one := @generate _ _ _;
  one_unique := @unit_initial _ _ _
|}.

Import EqNotations.

(* Likewise, any monoidal category whose initial object is the unit object, is
   semicocartesian monoidal. *)

Program Definition Initial_SemicocartesianMonoidal `{M : @Monoidal C}
        `{T : @Initial C} (Heq : @initial_obj C T = @I C M) :
  @SemicocartesianMonoidal C _ := {|
  generate := fun x => _ (@zero C T x);
  unit_initial := fun x f g => _ (@zero_unique C T x) f g
|}.
Next Obligation. rewrite Heq in x0; apply x0. Defined.


(** ** The functions of the over-towers defined by S

by Vladimir Voevodsky, started on Feb. 1, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.S_St .

(** *** The definition of an extended operation S and its elementary properties. *)

Definition S_ext_dom { BB : lBsystem_carrier } ( r : Tilde BB ) ( X : BB ) := isover X ( dd r ) .

Identity Coercion S_dom_to_isabove : S_ext_dom >-> isover .

Definition S_ext { BB : lBsystem_carrier } ( S : S_ops_type BB )
           { r : Tilde BB } { X : BB } ( inn : S_ext_dom r X ) : BB .
Proof .
  intros.
  destruct ( ovab_choice inn ) as [ isab | eq ] .
  exact ( S _ _ isab ) .

  exact ( ft ( dd r ) ) .

Defined.

Lemma isover_S_ext { BB : lBsystem_carrier }
      ( S : S_ops_type BB ) ( ax1b : S_ax1b_type S )
      { r : Tilde BB } { X : BB } ( inn : S_ext_dom r X ) :
  isover ( S_ext S inn ) ( ft ( dd r ) ) .
Proof .
  intros .
  unfold S_ext .
  destruct ( ovab_choice inn ) as [ isab | eq ] .
  exact ( ax1b _ _ _ ) .

  exact ( isover_XX _ ) .

Defined.

Lemma ll_S_ext { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) ( X : BB ) ( inn : S_ext_dom r X ) : ll ( S_ext S inn ) = ll X - 1.
Proof.
  intros .
  unfold S_ext .
  simpl .
  destruct ( ovab_choice inn ) as [ isab | eq ] .
  apply ax0 .

  rewrite ll_ft .
  rewrite eq .
  apply idpath .

Defined.

Lemma isover_S_ext_S_ext_2 { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 :  S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
      { r : Tilde BB } { X2 X2' : BB } ( inn : S_ext_dom r X2 ) ( inn' : S_ext_dom r X2' )
      ( is : isover X2 X2' ) : isover ( S_ext S inn ) ( S_ext S inn' ) .
Proof .
  intros . unfold S_ext .
  destruct ( ovab_choice inn ) as [ isab | eq ] .
  destruct ( ovab_choice inn' ) as [ isab' | eq' ] .
  apply ( isover_S_S_2 ax0 ax1a _ _ is ) .

  exact ( ax1b _ _ _ ) .

  destruct ( ovab_choice inn' ) as [ isab' | eq' ] .
  assert ( absd : empty ) .
  rewrite eq in is .
  assert ( ge := isover_geh is ) .
  assert ( gt := isabove_gth isab' ) .
  exact ( ge gt ) .

  destruct absd .

  exact ( isover_XX _ ) .

Defined.

(** *** The over-monotone function S_fun of the over-towers defined by the extended operation S *)

Definition S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) ( X2' : ltower_over ( dd r ) ) : ltower_over ( ft ( dd r ) ) .
Proof .
  intros .
  set ( X2 := pr1 X2' ) . set ( isov := pr2 X2' : isover X2 ( dd r ) ) .
  split with ( S_ext S isov )  .

  apply ( isover_S_ext S ax1b ) .

Defined.

Lemma isovmonot_S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB )
      ( X3' X2' : ltower_over ( dd r ) ) ( isov : isover X3' X2' ) :
  isover ( S_fun ax1b r X3' ) ( S_fun ax1b r X2' ) .
Proof .
  intros .
  apply isinvovmonot_pocto .
  unfold S_fun . simpl .
  apply ( isover_S_ext_S_ext_2 ax0 ax1a ax1b ) .
  apply isovmonot_pocto .
  exact isov .

Defined.

Definition ovmonot_S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) : ovmonot_fun ( ltower_over ( dd r ) ) ( ltower_over ( ft ( dd r ) ) ) :=
  ovmonot_fun_constr _ ( isovmonot_S_fun ax0 ax1a ax1b r ) .

Lemma ll_S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1b : S_ax1b_type S )
      { r : Tilde BB } ( X2' : ltower_over ( dd r ) ) : ll ( S_fun ax1b r X2' ) = ll X2' .
Proof.
  intros .
  change _ with ( ll ( pr1 ( S_fun ax1b r X2' ) ) - ll ( ft ( dd r ) ) = ll ( pr1 X2' ) - ll ( dd r ) ) .
  unfold S_fun . unfold S_ext .
  simpl .
  destruct ( ovab_choice (pr2 X2') ) as [ isab | eq ] .
  rewrite ax0 .
  rewrite ll_ft .
  apply natmiusmius1mminus1 .
  apply ( isabove_gt0 isab ) .

  apply ll_dd .

  rewrite natminusnn .
  rewrite eq .
  rewrite natminusnn .
  apply idpath .

Defined.

Lemma isllmonot_S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) : isllmonot ( S_fun ax1b r ) .
Proof.
  intros. unfold isllmonot. intros X Y .
  repeat rewrite ll_S_fun .
  apply idpath .

  apply ax0.

  apply ax0.

Defined.

Lemma isbased_S_fun { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) : isbased ( S_fun ax1b r ) .
Proof.
  intros. unfold isbased. intros X eq0 .
  rewrite ll_S_fun .

  exact eq0.

  exact ax0.

Defined.

Definition ltower_fun_S { BB : lBsystem_carrier }
      { S : S_ops_type BB } ( ax0 : S_ax0_type S ) ( ax1a : S_ax1a_type S ) ( ax1b : S_ax1b_type S )
      ( r : Tilde BB ) :
  ltower_fun ( ltower_over ( dd r ) ) ( ltower_over ( ft ( dd r ) ) ) :=
  ltower_fun_constr ( isovmonot_S_fun ax0 ax1a ax1b r )
                    ( isllmonot_S_fun ax0 ax1b r )
                    ( isbased_S_fun ax0 ax1b r ) .

(* The end of the file lBsystems_S_fun.v *)


(***********************************)
(** The gadget for abort semantics *)

Lemma rho_s_em_em:

        rho_s = ∅ -> { _ : 𝒟(qs)⁻ | rho_s <> ∅ } = ∅.

Proof.
    move => ->.
    replace (∅ ≠ ∅) with False => //.
    by apply propositional_extensionality.
Qed.

Lemma rho_s_nem_U:

        rho_s <> ∅ -> { _ : 𝒟(qs)⁻ | rho_s <> ∅ } = 𝕌.

Proof.
    move => H.
    replace (rho_s <> ∅) with True => //.
    by apply propositional_extensionality.
Qed.


(**********************************************************************************
 * PredomKleisli.v                                                                *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * July 2010                                                                      *
 * Build with Coq 8.2pl1 plus SSREFLECT                                           *
 **********************************************************************************)
Set Automatic Coercions Import.
Require Import PredomCore.
Require Import PredomLift.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Unset Automatic Introduction.

Definition kleislit D E (f: D -> Stream E) :=
(*=kl *)
 cofix kl (l:Stream D) := match l with Eps l => Eps (kl l) | Val d => f d end.
(*=End *)

Lemma kleisli_inv : forall D0 D1 (f: D0 -> Stream D1) (l : Stream D0), kleislit f l =
 match l with Eps l' => Eps (kleislit f l')
            | Val d => f d
 end.
move=> D0 D1 f l.
transitivity  (match kleislit f l with Eps x => Eps x | Val d => Val d end).
apply (DL_inv (D:=D1)).
case l ; auto.
move => d.
simpl.
symmetry.
apply DL_inv.
Qed.

(* Monad stuff *)
Lemma left_unit : forall D0 (D1:ordType) (d:D0) (f : D0 -> Stream D1), kleislit f (Val d) =-= f d.
intros; auto. rewrite kleisli_inv ; auto.
Qed.

Lemma kleisli_Eps: forall D E (x : Stream D) (f:D -> Stream E), kleislit f (Eps x) = Eps (kleislit f x).
intros ; rewrite kleisli_inv. auto.
Qed.

Lemma kleisli_Val: forall D E (d:D) (f:D -> Stream E), kleislit f (Val d) = f d.
Proof.
  intros.
  rewrite kleisli_inv.
  auto.
Qed.

(* Revising kleislival to work with nats first cos that'll make the induction work better... *)
Lemma kleislipredValVal : forall D (E:ordType) k (e:E) (M:lift_ordType D) (f : D -> lift_ordType E),
   pred_nth (kleislit f M) k = Val e -> exists d, M =-= Val d /\ f d =-= Val e.
move => D E. elim.
- move => e M f P.
  simpl in P. rewrite kleisli_inv in P.
  case: M P => t Eq ; first by [].
  exists t. by rewrite Eq.
- move => n IH e M f P.
  rewrite kleisli_inv in P.
  case: M P => t Eq.
  + specialize (IH e t f Eq). case: IH => d [A B]. exists d. split ; last by [].
    by apply (Oeq_trans (predeq (Eps t))).
  + exists t. split ; first by [].
    apply Oeq_sym. apply (@Val_exists_pred_eq _ (f t)). by exists (S n).
Qed.

Lemma kleisli_Valeq: forall (D E:ordType) v (d:D) (f : D =-> lift_ordType E), v =-= Val d ->
   kleislit f v =-= (f d:lift_ordType E).
move => D E v d M. case => [v1 v2].
case: (DLle_Val_exists_pred v2) => n [dd [pd ld]].
have DD:dd =-= d.
- apply Ole_antisym. have xx:=DLle_pred_nth_left n v1. rewrite pd in xx.
  apply vleinj. apply xx. by apply ld.
have X:stable M by []. specialize (X _ _ DD).
rewrite <- X. clear ld DD X d v1 v2.
elim: n v pd.
- move => v. simpl. move => e. rewrite e. by rewrite kleisli_Val.
- move => n IH. case.
  + simpl. move => x e. rewrite -> kleisli_Eps. specialize (IH _ e). rewrite <- IH.
    by apply: (Oeq_trans (predeq _)).
  + move => x. simpl. case => e. rewrite e. by rewrite kleisli_Val.
Qed.

Hint Resolve DLle_leVal.

Lemma kleisli_ValVal : forall D E (M: lift_ordType D) (f : D =-> lift_ordType E) e,
                kleislit f M =-= Val e -> exists d, M =-= Val d /\ f d =-= Val e.
move => D E M N e [kv1 kv2].
case: (DLvalval kv2) => n [d [pd ld]].
case: (kleislipredValVal pd) => md [vm ndm].
exists md. split ; first by [].
refine (Oeq_trans ndm _). move: kv1. rewrite (kleisli_Valeq N vm). rewrite -> ndm.
move => kv1.
split ; first by [].
by apply: DLle_leVal.
Qed.

Lemma kleislit_mono D E (X:D =-> lift_ordType E) : monotonic (kleislit X).
move => D E X x y L. simpl. apply: DLless_cond => e C.
case: (kleisli_ValVal C) => dd [P Q].
rewrite (kleisli_Valeq X P).
rewrite -> P in L.
destruct (DLle_Val_exists_eq L) as [y0 [yv Py]].
rewrite (kleisli_Valeq X yv). by apply fmonotonic.
Qed.

Definition kleislim D E (X:D =-> lift_ordType E) : lift_ordType D =-> lift_ordType E :=
mk_fmono (kleislit_mono X).

Lemma eta_val: forall D f, @eta D f = Val f.
auto.
Qed.

Lemma eta_injp D E (f g :D =-> E) : eta << f =-= eta << g -> f =-= g.
intros D E f g. intros C. apply: fmon_eq_intro.
intros d. assert (X:=fmon_eq_elim C d).
apply: vinj. apply X.
Qed.

Lemma eta_leinjp D E (f g :D =-> E) : eta << f <= eta << g -> f <= g.
intros D E f g. intros C.
intros d. assert (X:= C d). apply vleinj. apply X.
Qed.

Lemma kleisli_cont (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : continuous (kleislim f).
intros D0 D1 f.
unfold continuous.
intros h.
simpl.
apply: DLless_cond.
intros xx C.
destruct (kleisli_ValVal C) as [x' [P Q]].
rewrite (kleisli_Valeq f P).
apply Ole_trans with (y:=@lub (D1 _BOT) (kleislim f << h)) ; auto.
clear C Q xx.
destruct (lubval P) as [k [hk [hkv Pk]]].
destruct (DLvalgetchain hkv) as [c Pc].
apply Ole_trans with (y:=((lub ((f:ordCatType _ _) << c)))).
- assert (continuous f) as cf by auto. rewrite <- cf. apply fmonotonic.
  apply vleinj. rewrite <- P. apply Ole_trans with (y:=eta (lub c)) ; last by [].
  rewrite -> (@lub_comp_eq _ _ eta c).
  rewrite -> (lub_lift_left _ k). refine (lub_le_compat _).
  intros n. by destruct (Pc n) ; auto.
- rewrite -> (@lub_lift_left (D1 _BOT) (kleislim f << h) k).
  refine (lub_le_compat _).
  intros n.
  apply Ole_trans with (y:=kleislit f (h (k+n)%N)) ; last by auto.
  specialize (Pc n). by rewrite -> (kleisli_Valeq f Pc).
Qed.

Definition kleisliX (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : (D0 _BOT) =-> D1 _BOT :=
   Eval hnf in mk_fcont (kleisli_cont f).

Definition kleisli (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : (D0 _BOT) =-> D1 _BOT := locked (kleisliX f).

Lemma kleisliValVal : forall D E (M: D _BOT) (f : D =-> E _BOT) e,
                kleisli f M =-= Val e -> exists d, M =-= Val d /\ f d =-= Val e.
intros D E M N e kv. unlock kleisli in kv.
apply (kleisli_ValVal kv).
Qed.

Lemma kleisli_simpl (D0 D1: cpoType) (f:D0 =-> D1 _BOT) v : kleisli f v = kleislit f v.
by unlock kleisli.
Qed.

Lemma kleisliVal D E d (f:D =-> E _BOT) : kleisli f (Val d) =-= f d.
intros D E d f. apply (@Oeq_trans _ _ (kleislit f (Val d))) ; first by unlock kleisli.
by rewrite kleisli_Val.
Qed.

Lemma kleisli_mono (D0 D1 : cpoType) : monotonic (@kleisli D0 D1).
unfold monotonic. move => D0 D1 f g fgL x.
simpl. apply: DLless_cond => e C.
case: (kleisliValVal C) => d [P Q]. unlock kleisli. simpl.
rewrite (kleisli_Valeq f P).
rewrite (kleisli_Valeq g P).
by apply fgL.
Qed.

Definition Kleisli (D0 D1 : cpoType) : ordCatType (D0 -=> D1 _BOT) (D0 _BOT -=> D1 _BOT) :=
Eval hnf in mk_fmono (@kleisli_mono D0 D1).

Lemma Kleisli_simpl (D0 D1 : cpoType) (f:D0 =-> D1 _BOT)  : Kleisli _ _ f = kleisli f.
by [].
Qed.

Lemma Kleisli_cont (D0 D1: cpoType) : continuous (@Kleisli D0 D1).
move => D0 D1 c d0. simpl.
apply: DLless_cond.
intros e C.
destruct (@kleisliValVal D0 D1 d0 ((lub c)) e C) as [d [V hd]]. simpl. unlock kleisli. simpl.
rewrite (@kleisli_Valeq _ _ _ _ ((fcont_lub c)) V). simpl.
refine (lub_le_compat _). move => n. simpl. rewrite -> V. by rewrite kleisliVal.
Qed.

Definition KLEISLI (D0 D1: cpoType) : (D0 -=> D1 _BOT) =-> D0 _BOT -=> D1 _BOT :=
   Eval hnf in mk_fcont (@Kleisli_cont D0 D1).

Add Parametric Morphism (D0 D1:cpoType) : (@kleisli D0 D1)
with signature (@Ole (D0 -=> D1 _BOT)) ++> (@Ole (D0 _BOT -=> D1 _BOT))
as kleisli_le_compat.
move => f f' m. apply: (Ole_trans (y:=KLEISLI _ _ f)) ; first by [].
have X:monotonic (KLEISLI D0 D1) by apply: fmonotonic.
specialize (X _ _ m). by rewrite -> X.
Qed.

Add Parametric Morphism (D0 D1:cpoType) : (@kleisli D0 D1)
with signature (@tset_eq _) ==> (@tset_eq _)
as kleisli_eq_compat.
move => f f' e. split ; [apply (kleisli_le_compat (proj1 e)) | apply (kleisli_le_compat (proj2 e))].
Qed.

Implicit Arguments KLEISLI [D0 D1].

Lemma KLEISLI_simpl (D0 D1: cpoType) (f:D0 =-> D1 _BOT) : KLEISLI f = kleisli f.
auto.
Qed.

Definition total D E (f:D -> lift_ordType E) := forall d, exists e, f d =-= eta_m e.

Definition DLgetelem D (x :lift_ordType  D) (P:exists x', x =-= Val x') : D.
intros D x P. assert (hasVal x). unfold hasVal. destruct P as [x' E].
destruct (eqValpred E) as [n [d [X Eq]]].
exists n. exists d. apply X.
apply (extract (exist (@hasVal D) x H)).
Defined.

Lemma total_mono D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : monotonic (fun d => @DLgetelem E (f d) (Tot _)).
move => D E f Tot x y L. apply extractmono. simpl. assert (monotonic f) as m by auto.
by apply m.
Qed.

Definition totalLmX D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : D =-> E :=
  Eval hnf in mk_fmono (total_mono Tot).

Definition totalLm D (E : ordType) (f:D =-> lift_ordType E) (Tot:total f) : D =-> E :=
  locked (totalLmX Tot).

Lemma total_cont (D E : cpoType) (f:D =-> E _BOT) (Tot:total f) : continuous (totalLmX Tot).
intros D E f Tot.
unfold continuous. intros c. simpl. apply vleinj.
unfold DLgetelem. rewrite <- extractworks. simpl projj.
rewrite (fcontinuous f). rewrite -> (@lub_comp_eq _ _ eta (totalLmX Tot << c)).
refine (lub_le_compat _) => n. simpl.
apply (Oeq_le). simpl. unfold DLgetelem. simpl. by apply: (Oeq_trans _ (extractworks _)).
Qed.

Definition totalLX (D E :cpoType) (f:D =-> E _BOT) (Tot:total f) : D =-> E :=
  Eval hnf in mk_fcont (total_cont Tot).

Definition totalL (D E :cpoType) (f:D =-> E _BOT) (Tot:total f) : D =-> E := locked (totalLX Tot).

Lemma DLgetelem_eta D (x : lift_ordType D) (P:exists x', x =-= Val x') : Val (DLgetelem P) =-= x.
intros D x P.
unfold DLgetelem.
rewrite <- extractworks. simpl. auto.
Qed.

Lemma totalLm_eta D (E :ordType) (f:D =-> lift_ordType E) (Tot:total f) : eta_m << totalLm Tot =-= f.
intros D E f Tot.
apply: fmon_eq_intro => n. simpl. unlock totalLm. simpl. by apply DLgetelem_eta.
Qed.

Lemma totalL_eta D (E :cpoType) (f:D =-> E _BOT) (Tot:total f) : eta << totalL Tot =-= f.
intros D E f Tot.
assert (x:= totalLm_eta Tot).
apply: fmon_eq_intro.
intros d.
assert (xx := fmon_eq_elim x d).
rewrite <- xx. unlock totalL. by unlock totalLm.
Qed.

Lemma eta_m_total D (f : D =-> lift_ordType D) : f =-= eta_m -> total f.
intros D f P.
unfold total. intros d.
exists d.
apply (fmon_eq_elim P d).
Qed.

Lemma eta_total D (f : D =-> D _BOT) : f =-= eta -> total f.
intros D f P.
unfold total. intros d.
exists d.
apply (fmon_eq_elim P d).
Qed.

Lemma totalLm_etap D E (f : D =-> lift_ordType E) (Tot : total f) d : eta_m (totalLm Tot d) =-= f d.
intros D E f Tot d.
apply (fmon_eq_elim (totalLm_eta Tot) d).
Qed.

Lemma totalL_etap D E (f : D =-> E _BOT) (Tot : total f) d : eta (totalL Tot d) =-= f d.
intros D E f Tot d.
apply (fmon_eq_elim (totalL_eta Tot) d).
Qed.

Lemma valtotalm D (E :ordType) (f:D =-> lift_ordType E) (Tot:total f) x : Val (totalLm Tot x) =-= f x.
intros D E f Tot x.
assert (X := fmon_eq_elim (totalLm_eta Tot) x). by apply X.
Qed.

Lemma valtotal D (E :cpoType) (f:D =-> E _BOT) (Tot:total f) x : Val (totalL Tot x) =-= f x.
intros D E f Tot x.
assert (X := fmon_eq_elim (totalL_eta Tot) x). by apply X.
Qed.

Lemma kleislit_comp: forall D E F (f : E _BOT =-> F _BOT) (g:D =-> E _BOT) d,
   (forall x xx, f x =-= Val xx -> exists y, x =-= Val y) ->
         kleislit (f << g) d =-= f (kleislit g d).
intros D E F f g d S. split. simpl.
apply: DLless_cond.

intros ff kv.
destruct (kleisli_ValVal (f:= (f << g)) kv) as [dd [dv fdd]].
rewrite (kleisli_Valeq ( (f << g)) dv). rewrite -> fdd.
assert (f (g dd) =-= f (kleisli g d)). apply: fmon_stable. rewrite -> dv. by rewrite kleisliVal.
unlock kleisli in H. simpl in H. rewrite <- H. by auto.

simpl. apply: DLless_cond.
intros xx fx.
specialize (S _ _ fx).
destruct S as [e ke].
destruct (kleisli_ValVal ke) as [dd [de ge]].
rewrite (kleisli_Valeq ( (f << g)) de). apply: fmonotonic. rewrite <- ge in ke.
by auto.
Qed.

Lemma kleisli_comp: forall D0 D1 D2 (f:D0 =-> D1 _BOT) (g:D1 =-> D2 _BOT),
       kleisli g << kleisli f =-= kleisli (kleisli g << f).
intros.
refine (fmon_eq_intro _) => d. simpl. unlock {2} kleisli. simpl.
rewrite <- (@kleislit_comp _ _ _ (kleisli g) f d) ; first by unlock kleisli.
intros e ff.
intros kl. destruct (kleisliValVal kl) as [dd [edd gd]].
exists dd. by auto.
Qed.

Lemma kleisli_leq: forall (D E F:cpoType) a b (f:D =-> E _BOT) (g: F =-> E _BOT),
      (forall aa, a =-= Val aa -> exists bb, b =-= Val bb /\ f aa <= g bb) ->
   @kleisli D E f a <= @kleisli F E g b.
Proof.
intros D E F a b f g V. simpl. apply: DLless_cond.
intros xx [_ kl].
destruct (DLle_Val_exists_pred kl) as [n [dd [pd ld]]]. unlock kleisli in pd.
destruct (kleislipredValVal pd) as [aa [va fa]]. rewrite -> va. rewrite kleisliVal.
specialize (V _ va).
destruct V as [bb [vb fg]]. rewrite -> vb. rewrite kleisliVal. by apply fg.
Qed.

Lemma kleisli_eq: forall (D E F:cpoType) a b (f:D =-> E _BOT) (g: F =-> E _BOT),
      (forall aa, a =-= Val aa -> exists bb, b =-= Val bb /\ f aa =-= g bb) ->
      (forall bb, b =-= Val bb -> exists aa, a =-= Val aa /\ f aa =-= g bb) ->
   @kleisli D E f a =-= @kleisli F E g b.
Proof.
intros D E F a b f g V1 V2.
apply: Ole_antisym.
apply kleisli_leq.
intros aa va. destruct (V1 _ va) as [bb [vb fa]].
exists bb. by auto.
apply kleisli_leq. intros bb vb.
destruct (V2 _ vb) as [aa [f1 f2]].
exists aa. by auto.
Qed.

Lemma kleislim_eta_com: forall D E f, @kleislim D E f << eta_m =-= f.
intros D E f. refine (fmon_eq_intro _) => d.
simpl. by rewrite kleisli_Val.
Qed.

Lemma kleisli_eta_com: forall D E f, @kleisli D E f << eta =-= f.
intros D E f.
refine (fmon_eq_intro _) => d. simpl. by apply (kleisliVal d f).
Qed.

Lemma kleisli_point_unit: forall D (d:lift_ordType D), kleislit (eta_m) d =-= d.
intros D d.
split. simpl. apply: DLless_cond.

intros dd kl.
assert (kleislit eta_m d =-= Val dd) as kkl by auto.
destruct (kleisli_ValVal kkl) as [d1 [P1 P2]].
simpl in P2. rewrite -> P2 in P1.
rewrite (kleisli_Valeq (eta_m) P1) ; auto.

simpl. apply: DLless_cond.
intros dd kl.
rewrite (kleisli_Valeq eta_m kl). auto.
Qed.

Lemma kleislim_unit: forall D, kleislim (@eta_m D) =-= Id.
intros D. refine (fmon_eq_intro _) => d. simpl.
by rewrite kleisli_point_unit.
Qed.

Lemma kleisli_unit: forall D, kleisli (@eta D) =-= Id.
intros D. refine (fmon_eq_intro _) => d. unlock kleisli. simpl. by rewrite kleisli_point_unit.
Qed.

Lemma kleisli_comp2: forall D E F (f:D =-> E) (g:E =-> F _BOT),
         kleisli (g << f) =-= kleisli g << kleisli (eta << f).
intros D E F f g.
refine (fmon_eq_intro _) => d.
refine (kleisli_eq _ _).
intros dd dv. exists (f dd). split ; last by  auto.
rewrite -> dv. by rewrite -> (kleisliVal dd (eta << f)).

intros ee kl.
destruct (kleisliValVal  kl) as [dd P]. exists dd.
split. destruct P ; auto. case: P => _ P.
simpl in P. apply: (fmon_stable g). by apply (vinj P).
Qed.

Definition mu D := @kleisli (D _BOT) D Id.

Lemma mu_natural D E (f:D =-> E) :
   kleisli (eta << f) << mu _ =-= mu _ << kleisli (eta << (kleisli (eta << f))).
intros D E f.
unfold mu. rewrite <- kleisli_comp2. rewrite -> kleisli_comp.
rewrite -> comp_idR. by rewrite comp_idL.
Qed.

Lemma mumu D : mu _ << kleisli (eta << mu _) =-= mu D << mu _.
move => D. unfold mu.
rewrite <- kleisli_comp2. rewrite kleisli_comp. rewrite comp_idL. by rewrite comp_idR.
Qed.

Lemma mukl D : mu D << kleisli (eta << eta) =-= Id.
intros D. unfold mu.
rewrite <- kleisli_comp2. rewrite comp_idL. by rewrite kleisli_unit.
Qed.

Definition SWAP (C:prodCat) (X Y : C) : (X * Y) =-> (Y * X) := <| pi2, pi1 |>.
Implicit Arguments SWAP [C X Y].

Definition Application := fun (D0 D1:cpoType) => exp_fun ((uncurry (@KLEISLI (D0 -=> D1 _BOT) D1)) <<
                                       <| exp_fun ((uncurry KLEISLI) << SWAP) << pi2, pi1 |>).

Definition Operator2 := fun A B C (F: A * B =-> C _BOT) =>
  locked ((Application _ _) << (kleisli (eta << (exp_fun F)))).

Definition Smash := fun A B => @Operator2 _ _ (A * B) eta.

Definition LStrength := fun A B => (uncurry  (Smash A B)) << eta >< Id.
Definition RStrength := fun A B => (uncurry (Smash A B)) << Id >< eta.

Definition KLEISLIR := fun A B C (f: A * B =-> C _BOT) => locked (kleisli f << LStrength A B).
Definition KLEISLIL := fun A B C (f: A * B =-> C _BOT) => locked (kleisli f << RStrength A B).

Lemma Operator2Val: forall (D E F:cpoType) (h:D * E =-> F _BOT) d e f,
     Operator2 h d e =-= Val f -> exists d', exists e', d =-= Val d' /\ e =-= Val e' /\ h (d',e') =-= Val f.
intros D E F h d e f. unlock Operator2.
move => X.
destruct (kleisliValVal X) as [f' [cc1 cc2]]. clear X.
destruct (kleisliValVal cc2) as [e' [eeq feeq]]. clear cc2.
destruct (kleisliValVal cc1) as [d' [deq deeq]]. clear cc1. simpl in eeq, feeq.
exists d'. exists e'. split ; first by []. split ; first by []. rewrite <- feeq.
by apply (fmon_eq_elim (vinj deeq) e').
Qed.

Lemma Operator2_simpl: forall (E F D:cpoType) (f:E * F =-> D _BOT) v1 v2,
          Operator2 f (Val v1) (Val v2) =-= f (v1,v2).
move => E F D f v1 v2. unlock Operator2. simpl. rewrite kleisliVal. simpl.
rewrite kleisliVal. simpl. rewrite kleisliVal. by simpl.
Qed.

Lemma strength_proj D E: kleisli (eta << pi2) << LStrength E D =-= pi2.
intros D E. apply: fmon_eq_intro. case => e d. unfold LStrength. unfold Smash. unlock Operator2.
simpl.
repeat (rewrite kleisliVal ; simpl). unfold id.
apply Oeq_trans with (y:=(kleisli (eta << pi2) << kleisli (eta << PAIR D e)) d) ; first by [].
rewrite kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
have ee:pi2 << PAIR D e =-= Id by apply: fmon_eq_intro. rewrite <- comp_assoc. rewrite ee.
rewrite comp_idR. by rewrite kleisli_unit.
Qed.

Hint Resolve tset_refl.

Lemma const_post_comp (X Y Z : cpoType) (f:Y =-> Z) e : f << const X e =-= const X (f e).
move => X Y Z f e. by apply: fmon_eq_intro.
Qed.

Lemma strength_assoc D E F :
  LStrength _ _ << <| pi1 , LStrength _ _ << pi2 |> << prod_assoc D E (F _BOT) =-=
  kleisli (eta << prod_assoc _ _ _) << LStrength _ _.
intros D E F. unfold LStrength. unfold Smash. do 3 rewrite  <- comp_assoc.
rewrite (comp_assoc (prod_assoc _ _ _)). rewrite prod_map_prod_fun. do 2 rewrite comp_idL.
refine (fmon_eq_intro _). case => p df. case: p => d e. simpl. unlock Operator2. simpl.
repeat rewrite kleisli_Val. unfold id. rewrite (kleisliVal d). simpl.
repeat (rewrite kleisliVal ; simpl).
apply (@Oeq_trans _ _ ((kleisli (eta << PAIR _ d) << (kleisli (eta << PAIR _ e))) df)) ; first by [].
apply Oeq_trans with (y:=(kleisli (eta << prod_assoc _ _ _) << kleisli (eta << PAIR _ (d,e))) df) ; last by [].
rewrite -> kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
rewrite -> kleisli_comp. rewrite comp_assoc. rewrite kleisli_eta_com.
apply: (fmon_eq_elim _ df). apply: kleisli_eq_compat.
do 2 rewrite <- comp_assoc. refine (comp_eq_compat (tset_refl eta) _). by apply: fmon_eq_intro.
Qed.

Lemma strength_eta D E : LStrength D E << <| pi1, eta << pi2 |> =-= eta.
move => D E. apply: fmon_eq_intro. case => d e. unfold LStrength. unfold Smash. simpl.
by rewrite Operator2_simpl.
Qed.

Lemma KLEISLIL_eq (A A' B B' C:cpoType) : forall (f:A * B =-> C _BOT) (f': A' * B' =-> C _BOT)
            a b a' b',
    (forall aa aa', a =-= Val aa -> a' =-= Val aa' -> f (aa,b) =-= f' (aa',b')) ->
    (forall aa, a =-= Val aa -> exists aa', a' =-= Val aa') ->
    (forall aa', a' =-= Val aa' -> exists aa, a =-= Val aa) ->
  @KLEISLIL A B C f (a,b) =-= @KLEISLIL A' B' C f' (a',b').
Proof.
intros A A' B B' C f f' a b a' b' V1 V2 V3. unlock KLEISLIL. simpl. unfold Smash, id.
refine (kleisli_eq _ _).
intros aa sa.
destruct (Operator2Val sa) as [a1 [b1 [Pa1 [Pb1 pv]]]].
destruct (V2 _ Pa1) as [aa' Paa].
exists (aa', b'). specialize (V1 a1 aa' Pa1 Paa). rewrite <- V1.
split. rewrite -> Paa.
by rewrite Operator2_simpl. have X:=Oeq_sym (vinj pv). rewrite -> X. by rewrite (vinj Pb1).

intros bb ob. destruct (Operator2Val ob) as [aa' [bb' [av P]]].
specialize (V3 _ av). destruct V3 as [aa va].
specialize (V1 _ _ va av).
exists (aa,b).
split. rewrite -> va.
rewrite Operator2_simpl. rewrite eta_val. by auto.
refine (Oeq_trans V1 _). case: P => P1 P2. rewrite <- (vinj P2). by rewrite (vinj P1).
Qed.

Lemma KLEISLIR_eq (A A' B B' C:cpoType) : forall (f:A * B =-> C _BOT) (f': A' * B' =-> C _BOT)
            a b a' b',
    (forall aa aa', b =-= Val aa -> b' =-= Val aa' -> f (a,aa) =-= f' (a',aa')) ->
    (forall aa, b =-= Val aa -> exists aa', b' =-= Val aa') ->
    (forall aa', b' =-= Val aa' -> exists aa, b =-= Val aa) ->
  @KLEISLIR A B C f (a,b) =-= @KLEISLIR A' B' C f' (a',b').
Proof.
intros A A' B B' C f f' a b a' b' V1 V2 V3. unlock KLEISLIR.
unfold LStrength. unfold Smash. simpl. unfold id.
refine (kleisli_eq _ _).
intros aa sa.
destruct (Operator2Val sa) as [a1 [b1 [Pa1 [Pb1 pv]]]].
destruct (V2 _ Pb1) as [aa' Paa].
exists (a',aa'). specialize (V1 _ aa' Pb1 Paa). rewrite <- V1.
split. rewrite -> Paa.
by rewrite Operator2_simpl. rewrite <- (vinj pv). by rewrite -> (vinj Pa1).

intros bb ob. destruct (Operator2Val ob) as [aa' [bb' [av [bv P]]]].
specialize (V3 _ bv). destruct V3 as [aa va].
specialize (V1 _ _ va bv).
exists (a,aa).
split. rewrite -> va.
rewrite Operator2_simpl. by auto.
refine (Oeq_trans V1 _). rewrite <- (vinj P). by rewrite (vinj av).
Qed.

Add Parametric Morphism (D E F:cpoType) : (@KLEISLIL D E F)
with signature (@tset_eq (D * E =-> F _BOT)) ==> (@tset_eq (D _BOT * E =-> F _BOT))
as KLEISLIL_eq_compat.
intros f0 f1 feq.
apply: fmon_eq_intro. intros de. unlock KLEISLIL. simpl. by rewrite -> feq.
Qed.

Add Parametric Morphism (D E F:cpoType) : (@KLEISLIR D E F)
with signature (@tset_eq (D * E =-> F _BOT)) ==> (@tset_eq (D * (E _BOT) =-> F _BOT))
as KLEISLIR_eq_compat.
intros f0 f1 feq.
apply: fmon_eq_intro. intros de. unlock KLEISLIR. simpl. by rewrite -> feq.
Qed.

Lemma KLEISLIL_comp D E F G (f:D * E =-> F _BOT) (g:G =-> D _BOT) h :
        KLEISLIL f << <| g, h|> =-= KLEISLIL (f << Id >< h ) << <|g, Id|>.
move => D E F G f g h.
apply: fmon_eq_intro. simpl. move => gg. unfold id. refine (KLEISLIL_eq _ _ _).
intros d0 d1 vd0 vd1. rewrite -> vd0 in vd1. by rewrite (vinj vd1).
intros d0 vd0. by exists d0. intros aa vv. by eexists ; apply vv.
Qed.

Lemma KLEISLIL_comp2 D E F G H (f:D * E =-> F _BOT) (g:G =-> D) (h:H =-> E) :
        KLEISLIL f << kleisli (eta << g) >< h =-= KLEISLIL (f << g >< h).
move => D E F G H f g h.
apply: fmon_eq_intro. case => gg hh. simpl. apply: KLEISLIL_eq.
- intros d0 d1 vd0 vd1. simpl. rewrite -> vd1 in vd0. rewrite -> kleisliVal in vd0.
  by rewrite -> (vinj vd0).
intros d0 vd0.
destruct (kleisliValVal vd0) as [g0 [ggl P]]. by exists g0.
intros d0 vd0.
exists (g d0). simpl. simpl in vd0. rewrite -> vd0. by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_comp: forall D E F G (f:D * E =-> F _BOT) (g:G =-> E _BOT) h,
        KLEISLIR f << <|h, g|> =-= KLEISLIR (f << h >< Id) << <|Id, g|>.
move => D E F G f g h.
apply: fmon_eq_intro.
intros gg.
refine (KLEISLIR_eq _ _ _).
intros d0 d1 vd0 vd1. simpl. unfold id. rewrite -> vd0 in vd1. by rewrite (vinj vd1).
intros d0 vd0. by exists d0. intros aa vv. by eexists ; apply vv.
Qed.

Lemma KLEISLIL_unit: forall D E F G (f: D * E =-> F _BOT) (g:G =-> D) h,
    KLEISLIL f << <| eta << g, h |> =-= f << <| g,  h |>.
intros.
refine (fmon_eq_intro _). intros gg. unlock KLEISLIL. simpl.  unfold id. unfold Smash. rewrite Operator2_simpl.
simpl. by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_unit: forall D E F G (f:E * D =-> F _BOT) (g:G =-> D) h,
    KLEISLIR f << <| h, eta << g|> =-= f << <| h, g|>.
intros.
refine (fmon_eq_intro _). intros gg. unlock KLEISLIR. simpl. unfold Smash. rewrite Operator2_simpl.
by rewrite kleisliVal.
Qed.

Lemma KLEISLIR_ValVal: forall D E F (f:D * E =-> F _BOT) e d r, KLEISLIR f (d,e) =-= Val r ->
             exists ee, e =-= Val ee /\ f (d,ee) =-= Val r.
intros D E F f e d r. unlock KLEISLIR. simpl. unfold Smash. unfold id.
intros klv. destruct (kleisliValVal klv) as [dd [Pdd PP]].
destruct (Operator2Val Pdd) as [d1 [e1 [Pd1 [Pe1 XX]]]]. exists e1.
split. by auto. rewrite <- (vinj Pd1) in XX. by rewrite -> (vinj XX).
Qed.

Lemma KLEISLIL_ValVal: forall D E F (f: D * E =-> F _BOT) e d r, KLEISLIL f (d,e) =-= Val r ->
             exists dd, d =-= Val dd /\ f (dd,e) =-= Val r.
intros D E F f e d r. simpl. unlock KLEISLIL. simpl. unfold Smash. unfold id.
intros klv. destruct (kleisliValVal klv) as [dd [Pdd PP]].
destruct (Operator2Val Pdd) as [d1 [e1 [Pd1 [Pe1 XX]]]]. exists d1. split ; first by [].
rewrite <- (vinj Pe1) in XX. by rewrite (vinj XX).
Qed.

Lemma Operator2_Valeq D E F (f:D * E =-> F _BOT) d dl e el :
   dl =-= Val d -> el =-= Val e -> Operator2 f dl el =-= f (d,e).
move => D E F f d dl e el X Y. rewrite -> X. rewrite -> Y. by rewrite Operator2_simpl.
Qed.

Lemma KLEISLIL_Valeq D E F (g:D * E =-> F _BOT) dl d e : dl =-= Val d -> KLEISLIL g (dl,e) =-= g (d,e).
move => D E F g dl d e X. unlock KLEISLIL. simpl. unfold Smash. unfold id. rewrite -> X. rewrite Operator2_simpl.
by rewrite kleisliVal.
Qed.

Lemma KLEISLIL_simpl D E F (g:D * E =-> F _BOT) d e : KLEISLIL g (Val d,e) =-= g (d,e).
intros. refine (KLEISLIL_Valeq g _ (Oeq_refl _)).
Qed.

Lemma KLEISLIL_comp3 D E F G (g : F =-> G _BOT) (f:D * E =-> F) : KLEISLIL (g << f) =-= kleisli g << KLEISLIL (eta << f).
move => D E F G f g. apply:fmon_eq_intro => x. case: x => dl e. simpl.
split ;  apply: DLless_cond.
- intros gg kl. destruct (KLEISLIL_ValVal kl) as [d [Pdl P]]. rewrite -> (pair_eq_compat Pdl (tset_refl e)).
  do 2 rewrite KLEISLIL_simpl. simpl. by rewrite kleisliVal.
- move => gg k. destruct (kleisliValVal k) as [ff [Pk P]].
  destruct (KLEISLIL_ValVal Pk) as [d [dlv Pd]]. rewrite -> (pair_eq_compat dlv (tset_refl e)).
  do 2 rewrite KLEISLIL_simpl. simpl. by rewrite kleisliVal.
Qed.

Lemma KLEISLIL_comp4 D E F G H (f:E * G =-> H _BOT) (g:D =-> E _BOT) (h:F =-> G) :
     KLEISLIL (KLEISLIL f << g >< h) =-= KLEISLIL f << kleisli g >< h.
intros. apply: fmon_eq_intro => x. case: x => dl df.
split ; simpl ; apply: DLless_cond ; unfold id, Smash.
intros hh kh. destruct (KLEISLIL_ValVal kh) as [d0 [dlv Pd]].
destruct (KLEISLIL_ValVal Pd) as [e0 [elv Pe]]. unlock KLEISLIL.
simpl. rewrite -> dlv. rewrite Operator2_simpl. by do 2 rewrite kleisliVal.

intros hh hv. destruct (KLEISLIL_ValVal hv) as [e0 [elv Pe]].
destruct (kleisliValVal elv) as [d0 [dlv Pd]]. unlock KLEISLIL. simpl. rewrite -> dlv. rewrite Operator2_simpl.
do 2 rewrite kleisliVal. simpl. rewrite -> Pd. by rewrite Operator2_simpl.
Qed.

Definition liftCppoType (D:cpoType) := Eval hnf in CppoType (Pointed.class (@liftOrdPointedType D)).

Lemma strictVal: forall D E (f: D _BOT =-> E _BOT), (forall d e, f d =-= Val e -> exists dd, d =-= Val dd) -> strict f.
intros. unfold strict. split ; last by apply: leastP.
simpl. apply: DLless_cond.
intros xxx Fx. specialize (H _ _ Fx). destruct H as [d incon].
simpl in incon.
assert (yy := eqValpred incon).
destruct yy as [n [dd [pp _]]]. have F:False ; last by [].
move: pp. clear. elim: n ; unfold Pointed.least ; simpl.
- by rewrite DL_bot_eq.
- move => n IH X. apply IH. by apply X.
Qed.

Lemma kleisli_bot: forall D E (f:D =-> E _BOT), kleisli f PBot =-= PBot.
intros.
refine (strictVal (f:=kleisli f) _).
intros d e.
intros kl. destruct (kleisliValVal kl) as [dd [P _]]. by exists dd.
Qed.


Require Import Foundations.Generalities.uuu.
Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.
Require Import RezkCompletion.auxiliary_lemmas_HoTT.
Require Import RezkCompletion.precategories.

Require Import RezkCompletion.limits.aux_lemmas_HoTT.
Require Import RezkCompletion.limits.terminal.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).
Local Notation "f ;; g" := (compose f g)(at level 50).

Section def_pb.

Variable C : precategory.

Definition isPullback {a b c d : C} (f : b --> a) (g : c --> a)
        (p1 : d --> b) (p2 : d --> c) (H : p1 ;; f == p2;; g) : UU :=
   forall e (h : e --> b) (k : e --> c)(H : h ;; f == k ;; g ),
      iscontr (total2 (fun hk : e --> d => dirprod (hk ;; p1 == h)(hk ;; p2 == k))).

Lemma isaprop_isPullback {a b c d : C} (f : b --> a) (g : c --> a)
        (p1 : d --> b) (p2 : d --> c) (H : p1 ;; f == p2 ;; g) :
       isaprop (isPullback f g p1 p2 H).
Proof.
  repeat (apply impred; intro).
  apply isapropiscontr.
Qed.

Lemma PullbackArrowUnique {a b c d : C} (f : b --> a) (g : c --> a)
        (p1 : d --> b) (p2 : d --> c) (H : p1 ;; f == p2;; g)
     (P : isPullback f g p1 p2 H) e (h : e --> b) (k : e --> c)
     (Hcomm : h ;; f == k ;; g)
     (w : e --> d)
     (H1 : w ;; p1 == h) (H2 : w ;; p2 == k) :
     w == (pr1 (pr1 (P e h k Hcomm))).
Proof.
  set (T := tpair (fun hk : e --> d => dirprod (hk ;; p1 == h)(hk ;; p2 == k))
                    w (dirprodpair H1 H2)).
  set (T' := pr2 (P e h k Hcomm) T).
  exact (base_paths _ _ T').
Qed.

Definition Pullback {a b c : C} (f : b --> a)(g : c --> a) :=
     total2 (fun pfg : total2 (fun p : C => dirprod (p --> b) (p --> c)) =>
         total2 (fun H : pr1 (pr2 pfg) ;; f == pr2 (pr2 pfg) ;; g =>
        isPullback f g (pr1 (pr2 pfg)) (pr2 (pr2 pfg)) H)).

Definition Pullbacks := forall (a b c : C)(f : b --> a)(g : c --> a),
       Pullback f g.

Definition hasPullbacks := forall (a b c : C) (f : b --> a) (g : c --> a),
         ishinh (Pullback f g).

Definition PullbackObject {a b c : C} {f : b --> a} {g : c --> a}:
   Pullback f g -> C := fun H => pr1 (pr1 H).
Coercion PullbackObject : Pullback >-> ob.

Definition PullbackPr1 {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) : Pb --> b := pr1 (pr2 (pr1 Pb)).

Definition PullbackPr2 {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) : Pb --> c := pr2 (pr2 (pr1 Pb)).

Definition PullbackSqrCommutes {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) :
    PullbackPr1 Pb ;; f == PullbackPr2 Pb ;; g .
Proof.
  exact (pr1 (pr2 Pb)).
Qed.

Definition isPullback_Pullback {a b c : C} {f : b --> a}{g : c --> a}
   (P : Pullback f g) :
  isPullback f g (PullbackPr1 P) (PullbackPr2 P) (PullbackSqrCommutes P).
Proof.
  exact (pr2 (pr2 P)).
Qed.

Definition PullbackArrow {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) e (h : e --> b) (k : e --> c)(H : h ;; f == k ;; g) : e --> Pb :=
   pr1 (pr1 (isPullback_Pullback Pb e h k H)).

Lemma PullbackArrow_PullbackPr1 {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) e (h : e --> b) (k : e --> c)(H : h ;; f == k ;; g) :
   PullbackArrow Pb e h k H ;; PullbackPr1 Pb == h.
Proof.
  exact (pr1 (pr2 (pr1 (isPullback_Pullback Pb e h k H)))).
Qed.

Lemma PullbackArrow_PullbackPr2 {a b c : C} {f : b --> a} {g : c --> a}
   (Pb : Pullback f g) e (h : e --> b) (k : e --> c)(H : h ;; f == k ;; g) :
   PullbackArrow Pb e h k H ;; PullbackPr2 Pb == k.
Proof.
  exact (pr2 (pr2 (pr1 (isPullback_Pullback Pb e h k H)))).
Qed.

Definition identity_is_Pullback_input {a b c : C}{f : b --> a} {g : c --> a} (Pb : Pullback f g) :
 total2 (fun hk : Pb --> Pb =>
   dirprod (hk ;; PullbackPr1 Pb == PullbackPr1 Pb)(hk ;; PullbackPr2 Pb == PullbackPr2 Pb)).
Proof.
  exists (identity Pb).
  apply dirprodpair; apply id_left.
Defined.

Lemma PullbackEndo_is_identity {a b c : C}{f : b --> a} {g : c --> a}
   (Pb : Pullback f g) (k : Pb --> Pb) (kH1 : k ;; PullbackPr1 Pb == PullbackPr1 Pb)
                                       (kH2 : k ;; PullbackPr2 Pb == PullbackPr2 Pb) :
       identity Pb == k.
Proof.
  set (H1 := tpair ((fun hk : Pb --> Pb => dirprod (hk ;; _ == _)(hk ;; _ == _))) k (dirprodpair kH1 kH2)).
  assert (H2 : identity_is_Pullback_input Pb == H1).
  - apply proofirrelevance.
    apply isapropifcontr.
    apply (isPullback_Pullback Pb).
    apply PullbackSqrCommutes.
  - apply (base_paths _ _ H2).
Qed.

Definition from_Pullback_to_Pullback {a b c : C}{f : b --> a} {g : c --> a}
   (Pb Pb': Pullback f g) : Pb --> Pb'.
Proof.
  apply (PullbackArrow Pb' Pb (PullbackPr1 _ ) (PullbackPr2 _)).
  exact (PullbackSqrCommutes _ ).
Defined.

Lemma are_inverses_from_Pullback_to_Pullback {a b c : C}{f : b --> a} {g : c --> a}
   (Pb Pb': Pullback f g) :
is_inverse_in_precat (from_Pullback_to_Pullback Pb Pb')
  (from_Pullback_to_Pullback Pb' Pb).
Proof.
  split; apply pathsinv0;
  apply PullbackEndo_is_identity;
  rewrite <- assoc;
  unfold from_Pullback_to_Pullback;
  repeat rewrite PullbackArrow_PullbackPr1;
  repeat rewrite PullbackArrow_PullbackPr2;
  auto.
Qed.

Lemma isiso_from_Pullback_to_Pullback {a b c : C}{f : b --> a} {g : c --> a}
   (Pb Pb': Pullback f g) :
      is_isomorphism (from_Pullback_to_Pullback Pb Pb').
Proof.
  exists (from_Pullback_to_Pullback Pb' Pb).
  apply are_inverses_from_Pullback_to_Pullback.
Defined.

Definition iso_from_Pullback_to_Pullback {a b c : C}{f : b --> a} {g : c --> a}
   (Pb Pb': Pullback f g) : iso Pb Pb' :=
  tpair _ _ (isiso_from_Pullback_to_Pullback Pb Pb').

(** pullback lemma *)

Section pullback_lemma.

Variables a b c d e x : C.
Variables (f : b --> a) (g : c --> a) (h : e --> b) (k : e --> c)
          (i : d --> b) (j : x --> e) (m : x --> d).
Hypothesis H1 : h ;; f == k ;; g.
Hypothesis H2 : m ;; i == j ;; h.
Hypothesis P1 : isPullback _ _ _ _ H1.
Hypothesis P2 : isPullback _ _ _ _ H2.

Lemma glueSquares : m ;; (i ;; f) == (j ;; k) ;; g.
Proof.
  rewrite assoc.
  rewrite H2.
  repeat rewrite <- assoc.
  rewrite H1.
  apply idpath.
Qed.

Lemma isPullbackGluedSquare : isPullback (i ;; f) g m (j ;; k) glueSquares.
Proof.
  unfold isPullback.
  intros y p q.
  intro Hrt.
  assert (ex : (p;; i);; f == q;; g).
   { rewrite <- Hrt.
     rewrite assoc; apply idpath.
   }
  set (rt := P1 _ (p ;; i) q ex).
  set (Ppiq := pr1 (pr1 (rt))).
  assert (owiej : p ;; i == Ppiq ;; h).
   { apply pathsinv0. apply (pr1 (pr2 (pr1 rt))). }
  set (rt' := P2 _ p Ppiq owiej).
  set (awe := pr1 (pr1 rt')).
  assert (Hawe1 : awe ;; m == p).
   { exact (pr1 (pr2 (pr1 rt'))). }
  assert (Hawe2 : awe ;; (j ;; k) == q).
   { rewrite assoc.
     set (X := pr2 (pr2 (pr1 rt'))). simpl in X.
           unfold awe. rewrite X.
           exact (pr2 (pr2 (pr1 rt))).
   }
  exists (tpair _ awe (dirprodpair Hawe1 Hawe2)).
  intro t.
  apply total2_paths_hProp.
  - intro a0. apply isapropdirprod;
    apply (pr2 (_ --> _)).
  - simpl. destruct t as [t [Ht1 Ht2]].
    simpl in *.
    apply PullbackArrowUnique.
    + assumption.
    + apply PullbackArrowUnique.
      * rewrite <- Ht1.
        repeat rewrite <- assoc.
        rewrite H2.
        apply idpath.
      * rewrite <- assoc.
        assumption.
Qed.

End pullback_lemma.

Section Universal_Unique.

Hypothesis H : is_category C.

Lemma isaprop_Pullbacks: isaprop Pullbacks.
Proof.
  apply impred; intro a;
  apply impred; intro b;
  apply impred; intro c;
  apply impred; intro f;
  apply impred; intro g;
  apply invproofirrelevance.
  intros Pb Pb'.
  apply total2_paths_hProp.
  - intro; apply isofhleveltotal2.
    + apply (pr2 (_ --> _)).
    + intros; apply isaprop_isPullback.
  - apply (total2_paths  (isotoid _ H (iso_from_Pullback_to_Pullback Pb Pb' ))).
    rewrite transportf_dirprod, transportf_isotoid.
    change (inv_from_iso (iso_from_Pullback_to_Pullback Pb Pb'))
         with (from_Pullback_to_Pullback Pb' Pb).
    rewrite transportf_isotoid.
    change (inv_from_iso (iso_from_Pullback_to_Pullback Pb Pb'))
         with (from_Pullback_to_Pullback Pb' Pb).
    destruct Pb as [Cone bla];
    destruct Pb' as [Cone' bla'];
    simpl in *.
    destruct Cone as [p [h k]];
    destruct Cone' as [p' [h' k']];
    simpl in *.
    unfold from_Pullback_to_Pullback;
    rewrite PullbackArrow_PullbackPr2, PullbackArrow_PullbackPr1.
    apply idpath.
Qed.

End Universal_Unique.

End def_pb.


From Hammer Require Import Hammer.

From Topology Require Export RTopology.
From Topology Require Export SeparatednessAxioms.
From Topology Require Import RFuncContinuity.
From Topology Require Import UniformTopology.
Require Import Description.
Require Import Max.
Require Import Psatz.

Section Tietze_extension_construction.

Variable X:TopologicalSpace.
Variable F:Ensemble (point_set X).
Hypothesis F_closed: closed F.
Variable f:point_set (SubspaceTopology F) -> point_set RTop.
Hypothesis f_continuous: continuous f.
Hypothesis f_bound: forall x:point_set (SubspaceTopology F),
-1 <= f x <= 1.
Hypothesis X_nonempty: inhabited (point_set X).

Variable Urysohns_lemma_function:
forall F G:Ensemble (point_set X),
closed F -> closed G -> Intersection F G = Empty_set ->
{ f:point_set X -> point_set RTop |
continuous f /\ (forall x:point_set X, 0 <= f x <= 1) /\
(forall x:point_set X, In F x -> f x = 0) /\
(forall x:point_set X, In G x -> f x = 1) }.

Lemma subspace_inc_takes_closed_to_closed:
forall G:Ensemble (point_set (SubspaceTopology F)),
closed G -> closed (Im G (subspace_inc F)).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.subspace_inc_takes_closed_to_closed".
intros.
destruct (subspace_topology_topology _ _ _ H) as [U []].
replace (Im G (subspace_inc F)) with
(Intersection F (Complement U)).
apply closed_intersection2; trivial.
red; rewrite Complement_Complement; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
exists (exist _ x H2); trivial.
apply NNPP; intro.
change (In (Complement G) (exist (In F) x H2)) in H4.
rewrite H1 in H4.
destruct H4.
simpl in H4.
contradiction H3.

destruct H2 as [[y]].
rewrite H3; clear y0 H3.
constructor.
trivial.
intro.
absurd (In (Complement G) (exist (fun x => In F x) y i)).
intro.
contradiction H4.
rewrite H1.
constructor.
trivial.
Qed.

Lemma Rle_order: order Rle.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Rle_order".
constructor.
red; intros; apply Rle_refl.
red; intros; eapply Rle_trans; [ apply H | apply H0 ].
red; intros; apply Rle_antisym; trivial.
Qed.

Section extension_approximation.

Variable f0:point_set (SubspaceTopology F) -> point_set RTop.
Hypothesis f0_cont: continuous f0.
Hypothesis f0_bound: forall x:point_set (SubspaceTopology F),
-1 <= f0 x <= 1.

Definition extension_approximation: point_set X -> point_set RTop.
refine (
let F0:=Im [ x:point_set (SubspaceTopology F) | f0 x <= -1/3 ]
(subspace_inc F) in
let G0:=Im [ x:point_set (SubspaceTopology F) | f0 x >= 1/3 ]
(subspace_inc F) in
let g:=proj1_sig (Urysohns_lemma_function F0 G0 _ _ _) in
fun x:point_set X => -1/3 + 2/3 * g x).
apply subspace_inc_takes_closed_to_closed.
replace ([ x:point_set (SubspaceTopology F) | f0 x <= -1/3 ]) with
(inverse_image f0 [ y:point_set RTop | y <= -1/3 ]).
red.
rewrite <- inverse_image_complement.
apply f0_cont.
apply lower_closed_interval_closed.
apply Rle_order.
intros.
destruct (total_order_T x y) as [[|]|]; auto with real.
apply Extensionality_Ensembles; split; red; intros.
destruct H as [[]]; constructor; trivial.
destruct H; constructor; constructor; trivial.
apply subspace_inc_takes_closed_to_closed.
replace ([ x:point_set (SubspaceTopology F) | f0 x >= 1/3 ]) with
(inverse_image f0 [ y:point_set RTop | 1/3 <= y ]).
red.
rewrite <- inverse_image_complement.
apply f0_cont.
apply upper_closed_interval_closed.
apply Rle_order.
intros; destruct (total_order_T x y) as [[|]|]; auto with real.
apply Extensionality_Ensembles; split; red; intros.
destruct H as [[]]; constructor; auto with real.
destruct H; constructor; constructor; auto with real.
apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H.
destruct H as [[y] []].
simpl in H1.
destruct H0 as [[z] []].
simpl in H2.
destruct H1; destruct H2.
destruct (proof_irrelevance _ i i0).
lra.
Defined.

Lemma extension_approximation_bound: forall x:point_set X,
-1/3 <= extension_approximation x <= 1/3.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_bound".
intros.
unfold extension_approximation.
destruct Urysohns_lemma_function as [g].
simpl.
destruct a as [? [? []]].
destruct (H0 x).
split; lra.
Qed.

Lemma extension_approximation_diff_bound:
forall x:point_set (SubspaceTopology F),
-2/3 <= f0 x - extension_approximation (subspace_inc F x) <= 2/3.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_diff_bound".
intros.
unfold extension_approximation; destruct Urysohns_lemma_function as
[g [? [? []]]]; simpl.
destruct (f0_bound x).
destruct (Rle_or_lt (f0 x) (-1/3)).
replace (g (subspace_inc F x)) with 0.
split; lra.
symmetry; apply e.
econstructor; trivial.
constructor; trivial.

destruct (Rle_or_lt (1/3) (f0 x)).
replace (g (subspace_inc F x)) with 1.
split; lra.
symmetry; apply e0.
econstructor; trivial.
constructor; auto with real.

destruct (a (subspace_inc F x)).
split; lra.
Qed.

Lemma extension_approximation_continuous:
continuous extension_approximation.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_continuous".
unfold extension_approximation; destruct Urysohns_lemma_function as
[g [? [? []]]]; simpl.
apply pointwise_continuity; intros.
apply sum_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere; trivial.
Qed.

End extension_approximation.

Lemma missing_pow_mult: forall (x y:R) (n:nat),
(x*y)^n = x^n * y^n.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.missing_pow_mult".
induction n.
simpl; ring.
simpl.
rewrite IHn; ring.
Qed.

Definition extension_approximation_seq: forall n:nat,
{ g0:point_set X -> point_set RTop |
continuous g0 /\
(forall x:point_set X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
(forall x:point_set (SubspaceTopology F),
-(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) }.
simple refine (fix g (n:nat) {struct n} := match n return
{ g0:point_set X -> point_set RTop |
continuous g0 /\
(forall x:point_set X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
(forall x:point_set (SubspaceTopology F),
-(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) } with
| O => exist _ (fun _ => 0) _
| S m => match g m with
| exist gm y =>
let H := _ in
let approx := extension_approximation
(fun x:point_set (SubspaceTopology F) =>
(3/2)^m * (f x - gm (subspace_inc F x))) H in
exist _ (fun x:point_set X => gm x + (2/3)^m * approx x) _
end
end); clear g; [ | | clearbody H ].
-
simpl.
split.
apply continuous_constant.
split.
intros; split; ring_simplify; auto with real.
intros.
destruct (f_bound x).
split; lra.
-
apply pointwise_continuity; intros.
apply const_multiple_continuous.
apply diff_continuous.
apply continuous_func_continuous_everywhere; trivial.
apply continuous_composition_at.
destruct y.
apply continuous_func_continuous_everywhere; trivial.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.
-
assert (H023m: 0 <= (2/3)^m).
{
apply pow_le; lra.
}
assert (H032m: 0 <= (3/2)^m).
{
apply pow_le; lra.
}
assert (forall x:point_set (SubspaceTopology F),
-1 <= (3/2)^m * (f x - gm (subspace_inc F x)) <= 1).
{
intros.
destruct y as [? []].
destruct (H2 x).
assert ((3/2)^m * (2/3)^m = 1).
{
rewrite <- missing_pow_mult.
replace (3/2*(2/3)) with 1 by field.
apply pow1.
}
replace (-1) with ((3/2)^m * (- (2/3)^m)).
pattern 1 at 0, 1; replace 1 with ((3/2)^m * (2/3)^m).
split; apply Rmult_le_compat_l; trivial.
replace ((3/2)^m * -(2/3)^m) with (- ((3/2)^m * (2/3)^m)) by ring.
rewrite H5. auto with real.
}
assert (forall x:point_set X, -1/3 <= approx x <= 1/3).
{
apply extension_approximation_bound.
}
assert (forall x:point_set (SubspaceTopology F),
-2/3 <= (3/2)^m * (f x - gm (subspace_inc F x)) -
approx (subspace_inc F x) <= 2/3).
{
apply extension_approximation_diff_bound; trivial.
}
destruct y as [? []].
split.
+
apply pointwise_continuity; intros.
apply sum_continuous.
apply continuous_func_continuous_everywhere; trivial.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere.
apply extension_approximation_continuous.
+
split; intros.
*
destruct (H4 x).
simpl.
destruct (H1 x).
assert (0 <= (2/3)^m).
apply pow_le; lra.
assert ((2/3)^m * (-1/3) <= (2/3)^m * approx x <= (2/3)^m * (1/3)).
{
split; apply Rmult_le_compat_l; trivial.
}
destruct H11.
split; lra.
*
simpl.
replace (-(2/3*(2/3)^m)) with ((2/3)^m * (-2/3)) by field.
replace (2/3*(2/3)^m) with ((2/3)^m * (2/3)) by ring.
replace (f x - (gm (subspace_inc F x) + (2/3)^m * approx (subspace_inc F x)))
with ((2/3)^m * ((3/2)^m * (f x - gm (subspace_inc F x)) -
approx (subspace_inc F x))).
destruct (H2 x).
split; apply Rmult_le_compat_l; trivial.
ring_simplify.
replace ((2/3)^m*(3/2)^m) with 1.
ring.
rewrite <- missing_pow_mult.
replace (2/3*(3/2)) with 1 by field.
symmetry; apply pow1.
Defined.

Lemma extension_approximation_seq_diff: forall (n:nat) (x:point_set X),
-(1/3 * (2/3)^n) <= proj1_sig (extension_approximation_seq (S n)) x -
proj1_sig (extension_approximation_seq n) x
<= 1/3*(2/3)^n.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_seq_diff".
intros.
simpl extension_approximation_seq.
destruct extension_approximation_seq; simpl.
match goal with |- context [extension_approximation ?A ?B x] =>
cut (-1/3 <= extension_approximation A B x <= 1/3);
[ generalize (extension_approximation A B x) |
apply extension_approximation_bound ] end.
intros.
assert (0 <= (2/3)^n).
apply pow_le; lra.
replace (-(1/3*(2/3)^n)) with ((2/3)^n*(-1/3)) by field.
replace (1/3*(2/3)^n) with ((2/3)^n*(1/3)) by ring.
replace (x0 x + (2/3)^n*p - x0 x) with ((2/3)^n*p) by ring.
destruct H.
split; apply Rmult_le_compat_l; trivial.
Qed.

Global Opaque extension_approximation_seq.
Opaque extension_approximation_seq.

Lemma Rle_R1_pow: forall (x:R) (m n:nat), 0 <= x <= 1 -> (m <= n)%nat ->
x^n <= x^m.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Rle_R1_pow".
induction 2.
auto with real.
simpl.
replace (x^m) with (1*x^m) by auto with real.
destruct H.
apply Rmult_le_compat; trivial.
apply pow_le; trivial.
Qed.

Lemma extension_approximation_seq_cauchy_aux:
forall (m n:nat) (x:point_set X),
Rabs (proj1_sig (extension_approximation_seq m) x -
proj1_sig (extension_approximation_seq n) x) <=
Rabs ((2/3)^m - (2/3)^n).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_seq_cauchy_aux".
cut (forall (m n:nat) (x:point_set X), (m <= n)%nat ->
Rabs (proj1_sig (extension_approximation_seq m) x -
proj1_sig (extension_approximation_seq n) x) <=
(2/3)^m - (2/3)^n).
intros.
destruct (le_or_lt m n).
rewrite (Rabs_right ((2/3)^m - (2/3)^n)).
apply H; trivial.
apply Rge_minus.
cut ((2/3)^n <= (2/3)^m); auto with real.
apply Rle_R1_pow; trivial.
split; lra.
apply lt_le_weak in H0.
rewrite (Rabs_left1 ((2/3)^m - (2/3)^n)).
replace (- ((2/3)^m - (2/3)^n)) with ((2/3)^n - (2/3)^m) by ring.
rewrite Rabs_minus_sym.
apply H; trivial.
apply Rle_minus.
apply Rle_R1_pow; trivial.
split; lra.

induction 1.
repeat match goal with |- context [ ?y - ?y ] =>
replace (y-y) with 0 by ring end.
rewrite Rabs_R0; apply Rle_refl.

simpl pow.
apply Rle_trans with
(Rabs (proj1_sig (extension_approximation_seq m) x -
proj1_sig (extension_approximation_seq m0) x) +
Rabs (proj1_sig (extension_approximation_seq m0) x -
proj1_sig (extension_approximation_seq (S m0)) x)).
rewrite Rplus_comm.
apply R_metric_is_metric.
pose proof (extension_approximation_seq_diff m0 x).
assert (Rabs (proj1_sig (extension_approximation_seq m0) x -
proj1_sig (extension_approximation_seq (S m0)) x) <=
1/3 * (2/3)^m0).
destruct H0.
unfold Rabs.
destruct Rcase_abs; lra.
lra.
Qed.

Definition convert_approx_to_uniform_space:
nat -> uniform_space R_metric (fun _:point_set X => 0).
refine (fun n:nat => exist _ (proj1_sig (extension_approximation_seq n)) _).
destruct extension_approximation_seq as [g [? []]].
simpl.
unfold R_metric.
exists (1 - (2/3)^n).
red; intros.
destruct H.
rewrite H0; clear y H0.
destruct (a x).
unfold Rabs; destruct Rcase_abs; lra.
Defined.

Lemma extension_approximation_seq_cauchy:
cauchy (uniform_metric R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty)
convert_approx_to_uniform_space.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.extension_approximation_seq_cauchy".
red; intros.
assert (Rabs (2/3) < 1).
rewrite Rabs_right; lra.
assert (0 < eps/2) by lra.
destruct (pow_lt_1_zero (2/3) H0 (eps/2) H1) as [N].
exists N.
intros.
apply Rle_lt_trans with (Rabs ((2/3)^m - (2/3)^n)).
unfold uniform_metric; unfold convert_approx_to_uniform_space;
destruct sup; simpl.
apply i.
red; intros.
destruct H5.
rewrite H6; clear y H6.
rewrite metric_sym.
apply extension_approximation_seq_cauchy_aux.
exact R_metric_is_metric.
apply Rle_lt_trans with (Rabs ((2/3)^m) + Rabs((2/3)^n)).
rewrite <- (Rabs_Ropp ((2/3)^n)).
unfold Rminus.
apply Rabs_triang.
replace eps with (eps/2 + eps/2) by field.
apply Rplus_lt_compat; apply H2; trivial.
Qed.

Definition Tietze_extension_func : point_set X -> point_set RTop.
refine (proj1_sig (proj1_sig (constructive_definite_description
(fun f:point_set (UniformTopology R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty) =>
net_limit convert_approx_to_uniform_space f
(I:=nat_DS) (X:=UniformTopology R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty)) _))).
apply -> unique_existence; split.
assert (complete (uniform_metric R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty)
(uniform_metric_is_metric _ _ _ _ _ _)).
apply uniform_metric_complete.
exact R_metric_complete.
apply H.
exact extension_approximation_seq_cauchy.
apply Hausdorff_impl_net_limit_unique.
apply T3_sep_impl_Hausdorff.
apply normal_sep_impl_T3_sep.
apply metrizable_impl_normal_sep.
exists (uniform_metric R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty).
apply (uniform_metric_is_metric _ _ R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty).
apply MetricTopology_metrizable.
Defined.

Lemma Tietze_extension_func_bound: forall x:point_set X,
-1 <= Tietze_extension_func x <= 1.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Tietze_extension_func_bound".
intros.
cut (Rabs (Tietze_extension_func x) <= 1).
intros.
unfold Rabs in H; destruct Rcase_abs in H;
split; lra.

unfold Tietze_extension_func;
destruct constructive_definite_description as [[g]].
simpl.
assert (bound (Im Full_set (fun x:point_set X => R_metric 0 0))).
exists 0.
red; intros.
destruct H.
right.
rewrite H0; apply R_metric_is_metric.
apply Rle_trans with (uniform_metric _ _ R_metric_is_metric X_nonempty
(exist _ (fun _:point_set X => 0) H)
(exist _ g b)).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
exists x.
constructor.
unfold R_metric; f_equal; auto with real.

apply lt_plus_epsilon_le; intros.
unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n eps H0 in _); [ | | clearbody H1 ]; shelve_unifiable.
apply MetricTopology_metrizable.
destruct H1 as [N].
refine (Rle_lt_trans _ _ _
(triangle_inequality _ _ _ _ (convert_approx_to_uniform_space N) _) _).
apply uniform_metric_is_metric.
apply Rplus_lt_compat.
apply Rle_lt_trans with (1 - (2/3)^N).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
red; intros.
destruct H2.
rewrite H3; clear y H3.
unfold R_metric.
destruct extension_approximation_seq as [h [? []]].
destruct (a x1).
simpl.
unfold Rabs; destruct Rcase_abs; lra.
assert ((2/3)^N > 0).
apply pow_lt; lra.
lra.
rewrite metric_sym; try apply uniform_metric_is_metric.
apply H1.
unfold DS_ord; constructor.
Qed.

Lemma Tietze_extension_func_is_extension:
forall x:point_set (SubspaceTopology F),
Tietze_extension_func (subspace_inc F x) = f x.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Tietze_extension_func_is_extension".
intros.
apply R_metric_is_metric.
apply Rle_antisym; try (apply Rge_le; apply R_metric_is_metric).
apply lt_plus_epsilon_le; intros.
unfold Tietze_extension_func;
destruct constructive_definite_description as [[g]]; simpl.
assert (eps/2 > 0) by lra.
unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n (eps/2) H0
in _); [ | | clearbody H1 ]; shelve_unifiable.
apply MetricTopology_metrizable.
destruct H1 as [N1].
assert (Rabs (2/3) < 1).
rewrite Rabs_right; lra.

destruct (pow_lt_1_zero (2/3) H2 (eps/2) H0) as [N2].
pose (N := max N1 N2).
apply Rle_lt_trans with (R_metric (g (subspace_inc F x))
(proj1_sig (extension_approximation_seq N) (subspace_inc F x)) +
R_metric (proj1_sig (extension_approximation_seq N) (subspace_inc F x))
(f x)).
apply triangle_inequality; apply R_metric_is_metric.
replace (0+eps) with (eps/2+eps/2) by field.
apply Rplus_lt_compat.
rewrite metric_sym; try apply R_metric_is_metric.
assert (DS_ord N1 N) by apply le_max_l.
apply Rle_lt_trans with (2:=H1 N H4).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
exists (subspace_inc F x).
constructor.
apply R_metric_is_metric.

assert ((N >= N2)%nat) by apply le_max_r.
apply Rle_lt_trans with (2:=H3 N H4).
rewrite Rabs_right.
destruct extension_approximation_seq as [h [? []]]; simpl.
unfold R_metric.
destruct (a0 x).
unfold Rabs; destruct Rcase_abs; lra.
apply Rle_ge.
apply pow_le; lra.
Qed.

Let convert_continuity: forall h:point_set X -> R,
continuous h (Y:=RTop) <-> continuous h (Y:=MetricTopology R_metric
R_metric_is_metric).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Tietze_extension_construction.convert_continuity".
assert (continuous (fun x:R => x)
(X:=RTop) (Y:=MetricTopology R_metric R_metric_is_metric)).
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric; intros.
apply RTop_metrization.
apply MetricTopology_metrizable.
exists eps; split; trivial.
assert (continuous (fun x:R => x)
(X:=MetricTopology R_metric R_metric_is_metric) (Y:=RTop)).
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric; intros.
apply MetricTopology_metrizable.
apply RTop_metrization.
exists eps; split; trivial.

intros; split; intros.
apply continuous_composition with (1:=H) (2:=H1).
apply continuous_composition with (1:=H0) (2:=H1).
Qed.

Lemma Tietze_extension_func_continuous: continuous Tietze_extension_func.
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Tietze_extension_func_continuous".
unfold Tietze_extension_func;
destruct constructive_definite_description as [g];
simpl.
apply net_limit_in_closure with
(S:=fun h:point_set (UniformTopology R_metric (fun _:point_set X => 0)
R_metric_is_metric X_nonempty) =>
continuous (proj1_sig h)
(Y:=MetricTopology R_metric R_metric_is_metric)) in n.
rewrite closure_fixes_closed in n.
unfold In in n.
apply <- convert_continuity; trivial.
apply continuous_functions_closed_in_uniform_metric.
red; intros.
exists i; split.
simpl; constructor.
red.
unfold convert_approx_to_uniform_space; simpl.
destruct extension_approximation_seq as [h [? []]]; simpl.
apply -> convert_continuity; trivial.
Qed.

End Tietze_extension_construction.

Require Import ClassicalChoice.
From Topology Require Import UrysohnsLemma.

Lemma bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
(F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
point_set RTop),
normal_sep X -> closed F -> continuous f ->
(forall x:point_set (SubspaceTopology F), -1 <= f x <= 1) ->
exists g:point_set X -> point_set RTop,
continuous g /\ (forall x:point_set (SubspaceTopology F),
g (subspace_inc F x) = f x) /\
(forall x:point_set X, -1 <= g x <= 1).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.bounded_Tietze_extension_theorem".
intros.
destruct (classic (inhabited (point_set X))) as [Hinh|Hempty].
destruct (choice (fun
(FG:{FG:Ensemble (point_set X) * Ensemble (point_set X) | let (F,G):=FG in
closed F /\ closed G /\ Intersection F G = Empty_set})
(phi:point_set X -> point_set RTop) =>
let (F,G):=proj1_sig FG in
continuous phi /\ (forall x:point_set X, 0 <= phi x <= 1) /\
(forall x:point_set X, In F x -> phi x = 0) /\
(forall x:point_set X, In G x -> phi x = 1))) as [choice_fun].
intros.
destruct x as [[F' G] [? []]].
simpl.
apply UrysohnsLemma; trivial.
pose (Urysohns_lemma_function := fun (F G:Ensemble (point_set X))
(HF:closed F) (HG:closed G) (Hdisj:Intersection F G = Empty_set) =>
exist (fun (f:point_set X -> point_set RTop) =>
continuous f /\ (forall x:point_set X, 0 <= f x <= 1) /\
(forall x:point_set X, In F x -> f x = 0) /\
(forall x:point_set X, In G x -> f x = 1))
(choice_fun (exist _ (F,G) (conj HF (conj HG Hdisj))))
(H3 (exist _ (F,G) (conj HF (conj HG Hdisj))))).
clearbody Urysohns_lemma_function; clear choice_fun H3.
exists (Tietze_extension_func X F H0 f H1 H2 Hinh
Urysohns_lemma_function).
split.
apply Tietze_extension_func_continuous.
split; intros.
apply Tietze_extension_func_is_extension.
apply Tietze_extension_func_bound.

exists (fun x:point_set X => False_rect _ (Hempty (inhabits x))).
split.
apply pointwise_continuity.
intros.
destruct (Hempty (inhabits x)).
split.
intros.
destruct x.
destruct (Hempty (inhabits x)).
intros.
destruct (Hempty (inhabits x)).
Qed.

Lemma open_bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
(F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
point_set RTop),
normal_sep X -> closed F -> continuous f ->
(forall x:point_set (SubspaceTopology F), -1 < f x < 1) ->
exists g:point_set X -> point_set RTop,
continuous g /\ (forall x:point_set (SubspaceTopology F),
g (subspace_inc F x) = f x) /\
(forall x:point_set X, -1 < g x < 1).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.open_bounded_Tietze_extension_theorem".
intros.
destruct (bounded_Tietze_extension_theorem _ F f) as [g0 [? []]]; trivial.
intros; split; left; apply H2.

pose (G := characteristic_function_to_ensemble (fun x:point_set X =>
g0 x = 1 \/ g0 x = -1)).
destruct (UrysohnsLemma _ H G F) as [phi [? [? []]]]; trivial.
replace G with (inverse_image g0 (Union (Singleton 1) (Singleton (-1)))).
red; rewrite <- inverse_image_complement.
apply H3.
apply (closed_union2 (X:=RTop)); apply Hausdorff_impl_T1_sep;
apply T3_sep_impl_Hausdorff; apply normal_sep_impl_T3_sep;
apply metrizable_impl_normal_sep; exists R_metric;
(apply R_metric_is_metric || apply RTop_metrization).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
constructor.
destruct H6.
left; destruct H6; trivial.
right; destruct H6; trivial.
destruct H6.
constructor.
destruct H6; [ left | right ]; rewrite H6; constructor.

apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H6.
destruct H6.
assert (-1 < g0 x < 1).
replace x with (subspace_inc F (exist _ x H7)) by reflexivity.
rewrite H4.
apply H2.
destruct H8.
destruct H6.
absurd (1 < 1); [ apply Rlt_irrefl | congruence ].
absurd (-1 < -1); [ apply Rlt_irrefl | congruence ].

exists (fun x:point_set X => phi x * g0 x).
split.
apply pointwise_continuity; intros.
apply product_continuous; apply continuous_func_continuous_everywhere;
trivial.
split.
intros.
rewrite H9.
replace (1*g0 (subspace_inc F x)) with (g0 (subspace_inc F x)) by
auto with real.
apply H4.
destruct x; trivial.

intros.
apply and_comm; apply Rabs_def2.
rewrite Rabs_mult.
rewrite (Rabs_right (phi x)); try (apply Rle_ge; apply H7).
destruct (classic (In G x)).
rewrite H8; trivial.
replace (0*Rabs (g0 x)) with 0; auto with real.
assert (Rabs (g0 x) < 1).
assert (Rabs (g0 x) <= 1).
destruct (H5 x).
unfold Rabs; destruct Rcase_abs; lra.
destruct H11; trivial.
contradiction H10.
unfold Rabs in H11; destruct Rcase_abs in H11.
constructor; right.
replace (g0 x) with (- -(g0 x)) by auto with real.
change (-1) with (Ropp 1).
f_equal; trivial.
constructor; left; trivial.
destruct (H7 x).
apply Rle_lt_trans with (Rabs (g0 x)); trivial.
pattern (Rabs (g0 x)) at 2; replace (Rabs (g0 x)) with (1*Rabs (g0 x)) by
auto with real.
apply Rmult_le_compat_r; trivial.
apply Rabs_pos.
Qed.

From Topology Require Import ContinuousFactorization.
From ZornsLemma Require Import Proj1SigInjective.

Theorem Tietze_extension_theorem: forall (X:TopologicalSpace)
(F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
point_set RTop),
normal_sep X -> closed F -> continuous f ->
exists g:point_set X -> point_set RTop,
continuous g /\ (forall x:point_set (SubspaceTopology F),
g (subspace_inc F x) = f x).
Proof. hammer_hook "TietzeExtension" "TietzeExtension.Tietze_extension_theorem".
intros.
pose (U := characteristic_function_to_ensemble
(fun x:point_set RTop => -1 < x < 1)).
pose proof (open_interval_homeomorphic_to_real_line).
fold U in H2.
simpl in H2.
destruct H2 as [a [b]].
pose (f0 := fun x:point_set (SubspaceTopology F) => subspace_inc U (a (f x))).
destruct (open_bounded_Tietze_extension_theorem X F f0) as [g0 [? []]];
trivial. unfold f0.
apply continuous_composition.
apply subspace_inc_continuous.
apply continuous_composition; trivial.

intros.
unfold f0.
destruct (a (f x)).
destruct i; trivial.

assert (forall x:point_set X, In U (g0 x)).
intros.
constructor; apply H8.
pose (g0_U := continuous_factorization g0 U H9).
assert (continuous g0_U).
apply factorization_is_continuous; trivial.

exists (fun x:point_set X => b (g0_U x)).
split.
apply continuous_composition; trivial.
intros.
unfold g0_U; unfold continuous_factorization.
generalize (H9 (subspace_inc F x)).
rewrite H7.
intros.
replace (exist _ (f0 x) i) with (a (f x)).
apply H4.
apply (proj1_sig_injective (In U)).
simpl.
reflexivity.
Qed.


Set Implicit Arguments.

Require Import domains.
Require Import kstyle.

CoInductive reaches (x : kcfg) (P : kcfg -> Prop) : Prop :=
  | done : P x -> reaches x P
  | step : forall y, kstep x y -> reaches y P -> reaches x P
  .

Definition steps x y := reaches x (kequiv y).

Definition RRel : Type := kcfg -> (kcfg -> Prop) -> Prop.
Definition subrel (kcfg B : RRel) : Prop := forall x P, kcfg x P -> B x P.

Definition sound (X : RRel) : Prop := subrel X reaches.

(* Base functor of the path predicate *)
Inductive stepF (X : RRel) (x : kcfg) (P : kcfg -> Prop) : Prop :=
  | DoneF : P x -> stepF X x P
  | StepF : forall y, kstep x y -> X y P -> stepF X x P.

Definition stable (X : RRel) : Prop := subrel X (stepF X).

CoFixpoint stable_sound X (Hstable : stable X) : sound X :=
  fun x P HxP =>
  match Hstable _ _ HxP with
  | DoneF Px => done _ _ Px
  | StepF y Rxy XyP => step Rxy (@stable_sound _ Hstable _ _ XyP)
  end.

Definition F_stable (F : RRel -> RRel) (X : RRel) : Prop := subrel X (stepF (F X)).

(* Focused version of transitivity,
   assuming we only want to apply transitivity
   on assumed circularities. *)
Inductive trans (X : RRel) (x : kcfg) (P : kcfg -> Prop) : Prop :=
  | tdone : P x -> trans X x P
  | tstep : forall y, kstep x y -> trans X y P -> trans X x P
  | tcirc : forall Q, X x Q -> (forall t, Q t -> trans X t P) -> trans X x P
  .

Lemma ttrans : forall X x P Q,
   trans X x Q -> (forall t, Q t -> trans X t P) -> trans X x P.
Proof.
induction 1;eauto using trans.
Qed.

Lemma step_mono : forall (X : RRel) x (P Q : kcfg -> Prop),
   (forall x, P x -> stepF X x Q) ->
   (forall x, X x P -> X x Q) ->
   stepF X x P -> stepF X x Q.
destruct 3;eauto using stepF.
Qed.

Lemma trans_derived (X : RRel) (trans_stable : F_stable trans X) : stable (trans X).
induction 1;eauto using stepF,step_mono,ttrans.
Qed.

Definition trans_sound (X : RRel) (trans_stable : F_stable trans X) : sound X.
intros x P HxP; apply (@stable_sound (trans X)).
exact (trans_derived trans_stable).
eauto using trans.
Qed.

(* some tactics for execution *)