(*  Title:      HOL/Hahn_Banach/Hahn_Banach_Ext_Lemmas.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Extending non-maximal functions\<close>

theory Hahn_Banach_Ext_Lemmas
imports Function_Norm
begin

text \<open>
  In this section the following context is presumed.  Let @{text E} be
  a real vector space with a seminorm @{text q} on @{text E}. @{text
  F} is a subspace of @{text E} and @{text f} a linear function on
  @{text F}. We consider a subspace @{text H} of @{text E} that is a
  superspace of @{text F} and a linear form @{text h} on @{text
  H}. @{text H} is a not equal to @{text E} and @{text "x\<^sub>0"} is
  an element in @{text "E - H"}.  @{text H} is extended to the direct
  sum @{text "H' = H + lin x\<^sub>0"}, so for any @{text "x \<in> H'"}
  the decomposition of @{text "x = y + a \<cdot> x"} with @{text "y \<in> H"} is
  unique. @{text h'} is defined on @{text H'} by @{text "h' x = h y +
  a \<cdot> \<xi>"} for a certain @{text \<xi>}.

  Subsequently we show some properties of this extension @{text h'} of
  @{text h}.

  \medskip This lemma will be used to show the existence of a linear
  extension of @{text f} (see page \pageref{ex-xi-use}). It is a
  consequence of the completeness of @{text \<real>}. To show
  \begin{center}
  \begin{tabular}{l}
  @{text "\<exists>\<xi>. \<forall>y \<in> F. a y \<le> \<xi> \<and> \<xi> \<le> b y"}
  \end{tabular}
  \end{center}
  \noindent it suffices to show that
  \begin{center}
  \begin{tabular}{l}
  @{text "\<forall>u \<in> F. \<forall>v \<in> F. a u \<le> b v"}
  \end{tabular}
  \end{center}
\<close>

lemma ex_xi:
  assumes "vectorspace F"
  assumes r: "\<And>u v. u \<in> F \<Longrightarrow> v \<in> F \<Longrightarrow> a u \<le> b v"
  shows "\<exists>xi::real. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y"
proof -
  interpret vectorspace F by fact
  txt \<open>From the completeness of the reals follows:
    The set @{text "S = {a u. u \<in> F}"} has a supremum, if it is
    non-empty and has an upper bound.\<close>

  let ?S = "{a u | u. u \<in> F}"
  have "\<exists>xi. lub ?S xi"
  proof (rule real_complete)
    have "a 0 \<in> ?S" by blast
    then show "\<exists>X. X \<in> ?S" ..
    have "\<forall>y \<in> ?S. y \<le> b 0"
    proof
      fix y assume y: "y \<in> ?S"
      then obtain u where u: "u \<in> F" and y: "y = a u" by blast
      from u and zero have "a u \<le> b 0" by (rule r)
      with y show "y \<le> b 0" by (simp only:)
    qed
    then show "\<exists>u. \<forall>y \<in> ?S. y \<le> u" ..
  qed
  then obtain xi where xi: "lub ?S xi" ..
  {
    fix y assume "y \<in> F"
    then have "a y \<in> ?S" by blast
    with xi have "a y \<le> xi" by (rule lub.upper)
  } moreover {
    fix y assume y: "y \<in> F"
    from xi have "xi \<le> b y"
    proof (rule lub.least)
      fix au assume "au \<in> ?S"
      then obtain u where u: "u \<in> F" and au: "au = a u" by blast
      from u y have "a u \<le> b y" by (rule r)
      with au show "au \<le> b y" by (simp only:)
    qed
  } ultimately show "\<exists>xi. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y" by blast
qed

text \<open>
  \medskip The function @{text h'} is defined as a @{text "h' x = h y
  + a \<cdot> \<xi>"} where @{text "x = y + a \<cdot> \<xi>"} is a linear extension of
  @{text h} to @{text H'}.
\<close>

lemma h'_lf:
  assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
      SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
    and H'_def: "H' \<equiv> H + lin x0"
    and HE: "H \<unlhd> E"
  assumes "linearform H h"
  assumes x0: "x0 \<notin> H"  "x0 \<in> E"  "x0 \<noteq> 0"
  assumes E: "vectorspace E"
  shows "linearform H' h'"
proof -
  interpret linearform H h by fact
  interpret vectorspace E by fact
  show ?thesis
  proof
    note E = \<open>vectorspace E\<close>
    have H': "vectorspace H'"
    proof (unfold H'_def)
      from \<open>x0 \<in> E\<close>
      have "lin x0 \<unlhd> E" ..
      with HE show "vectorspace (H + lin x0)" using E ..
    qed
    {
      fix x1 x2 assume x1: "x1 \<in> H'" and x2: "x2 \<in> H'"
      show "h' (x1 + x2) = h' x1 + h' x2"
      proof -
        from H' x1 x2 have "x1 + x2 \<in> H'"
          by (rule vectorspace.add_closed)
        with x1 x2 obtain y y1 y2 a a1 a2 where
          x1x2: "x1 + x2 = y + a \<cdot> x0" and y: "y \<in> H"
          and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
          and x2_rep: "x2 = y2 + a2 \<cdot> x0" and y2: "y2 \<in> H"
          unfolding H'_def sum_def lin_def by blast

        have ya: "y1 + y2 = y \<and> a1 + a2 = a" using E HE _ y x0
        proof (rule decomp_H') text_raw \<open>\label{decomp-H-use}\<close>
          from HE y1 y2 show "y1 + y2 \<in> H"
            by (rule subspace.add_closed)
          from x0 and HE y y1 y2
          have "x0 \<in> E"  "y \<in> E"  "y1 \<in> E"  "y2 \<in> E" by auto
          with x1_rep x2_rep have "(y1 + y2) + (a1 + a2) \<cdot> x0 = x1 + x2"
            by (simp add: add_ac add_mult_distrib2)
          also note x1x2
          finally show "(y1 + y2) + (a1 + a2) \<cdot> x0 = y + a \<cdot> x0" .
        qed

        from h'_def x1x2 E HE y x0
        have "h' (x1 + x2) = h y + a * xi"
          by (rule h'_definite)
        also have "\<dots> = h (y1 + y2) + (a1 + a2) * xi"
          by (simp only: ya)
        also from y1 y2 have "h (y1 + y2) = h y1 + h y2"
          by simp
        also have "\<dots> + (a1 + a2) * xi = (h y1 + a1 * xi) + (h y2 + a2 * xi)"
          by (simp add: distrib_right)
        also from h'_def x1_rep E HE y1 x0
        have "h y1 + a1 * xi = h' x1"
          by (rule h'_definite [symmetric])
        also from h'_def x2_rep E HE y2 x0
        have "h y2 + a2 * xi = h' x2"
          by (rule h'_definite [symmetric])
        finally show ?thesis .
      qed
    next
      fix x1 c assume x1: "x1 \<in> H'"
      show "h' (c \<cdot> x1) = c * (h' x1)"
      proof -
        from H' x1 have ax1: "c \<cdot> x1 \<in> H'"
          by (rule vectorspace.mult_closed)
        with x1 obtain y a y1 a1 where
            cx1_rep: "c \<cdot> x1 = y + a \<cdot> x0" and y: "y \<in> H"
          and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
          unfolding H'_def sum_def lin_def by blast

        have ya: "c \<cdot> y1 = y \<and> c * a1 = a" using E HE _ y x0
        proof (rule decomp_H')
          from HE y1 show "c \<cdot> y1 \<in> H"
            by (rule subspace.mult_closed)
          from x0 and HE y y1
          have "x0 \<in> E"  "y \<in> E"  "y1 \<in> E" by auto
          with x1_rep have "c \<cdot> y1 + (c * a1) \<cdot> x0 = c \<cdot> x1"
            by (simp add: mult_assoc add_mult_distrib1)
          also note cx1_rep
          finally show "c \<cdot> y1 + (c * a1) \<cdot> x0 = y + a \<cdot> x0" .
        qed

        from h'_def cx1_rep E HE y x0 have "h' (c \<cdot> x1) = h y + a * xi"
          by (rule h'_definite)
        also have "\<dots> = h (c \<cdot> y1) + (c * a1) * xi"
          by (simp only: ya)
        also from y1 have "h (c \<cdot> y1) = c * h y1"
          by simp
        also have "\<dots> + (c * a1) * xi = c * (h y1 + a1 * xi)"
          by (simp only: distrib_left)
        also from h'_def x1_rep E HE y1 x0 have "h y1 + a1 * xi = h' x1"
          by (rule h'_definite [symmetric])
        finally show ?thesis .
      qed
    }
  qed
qed

text \<open>\medskip The linear extension @{text h'} of @{text h}
  is bounded by the seminorm @{text p}.\<close>

lemma h'_norm_pres:
  assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
      SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
    and H'_def: "H' \<equiv> H + lin x0"
    and x0: "x0 \<notin> H"  "x0 \<in> E"  "x0 \<noteq> 0"
  assumes E: "vectorspace E" and HE: "subspace H E"
    and "seminorm E p" and "linearform H h"
  assumes a: "\<forall>y \<in> H. h y \<le> p y"
    and a': "\<forall>y \<in> H. - p (y + x0) - h y \<le> xi \<and> xi \<le> p (y + x0) - h y"
  shows "\<forall>x \<in> H'. h' x \<le> p x"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  interpret seminorm E p by fact
  interpret linearform H h by fact
  show ?thesis
  proof
    fix x assume x': "x \<in> H'"
    show "h' x \<le> p x"
    proof -
      from a' have a1: "\<forall>ya \<in> H. - p (ya + x0) - h ya \<le> xi"
        and a2: "\<forall>ya \<in> H. xi \<le> p (ya + x0) - h ya" by auto
      from x' obtain y a where
          x_rep: "x = y + a \<cdot> x0" and y: "y \<in> H"
        unfolding H'_def sum_def lin_def by blast
      from y have y': "y \<in> E" ..
      from y have ay: "inverse a \<cdot> y \<in> H" by simp

      from h'_def x_rep E HE y x0 have "h' x = h y + a * xi"
        by (rule h'_definite)
      also have "\<dots> \<le> p (y + a \<cdot> x0)"
      proof (rule linorder_cases)
        assume z: "a = 0"
        then have "h y + a * xi = h y" by simp
        also from a y have "\<dots> \<le> p y" ..
        also from x0 y' z have "p y = p (y + a \<cdot> x0)" by simp
        finally show ?thesis .
      next
        txt \<open>In the case @{text "a < 0"}, we use @{text "a\<^sub>1"}
          with @{text ya} taken as @{text "y / a"}:\<close>
        assume lz: "a < 0" then have nz: "a \<noteq> 0" by simp
        from a1 ay
        have "- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y) \<le> xi" ..
        with lz have "a * xi \<le>
          a * (- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
          by (simp add: mult_left_mono_neg order_less_imp_le)

        also have "\<dots> =
          - a * (p (inverse a \<cdot> y + x0)) - a * (h (inverse a \<cdot> y))"
          by (simp add: right_diff_distrib)
        also from lz x0 y' have "- a * (p (inverse a \<cdot> y + x0)) =
          p (a \<cdot> (inverse a \<cdot> y + x0))"
          by (simp add: abs_homogenous)
        also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
          by (simp add: add_mult_distrib1 mult_assoc [symmetric])
        also from nz y have "a * (h (inverse a \<cdot> y)) =  h y"
          by simp
        finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
        then show ?thesis by simp
      next
        txt \<open>In the case @{text "a > 0"}, we use @{text "a\<^sub>2"}
          with @{text ya} taken as @{text "y / a"}:\<close>
        assume gz: "0 < a" then have nz: "a \<noteq> 0" by simp
        from a2 ay
        have "xi \<le> p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y)" ..
        with gz have "a * xi \<le>
          a * (p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
          by simp
        also have "\<dots> = a * p (inverse a \<cdot> y + x0) - a * h (inverse a \<cdot> y)"
          by (simp add: right_diff_distrib)
        also from gz x0 y'
        have "a * p (inverse a \<cdot> y + x0) = p (a \<cdot> (inverse a \<cdot> y + x0))"
          by (simp add: abs_homogenous)
        also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
          by (simp add: add_mult_distrib1 mult_assoc [symmetric])
        also from nz y have "a * h (inverse a \<cdot> y) = h y"
          by simp
        finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
        then show ?thesis by simp
      qed
      also from x_rep have "\<dots> = p x" by (simp only:)
      finally show ?thesis .
    qed
  qed
qed

end


theory Homotopy
  imports Main
          SimplicialSet
          "Category3.FunctorCategory"
          SmashProduct
begin

lemma (in curried_functor')
  map_simp':
  assumes "A2.arr f2"
  shows "map f2 = A1_B.Abs_arr (Some (\<lambda>f1. F (f1, f2), \<lambda>f1. F (f1, A2.dom f2), \<lambda>f1. F (f1, A2.cod f2)))"
  unfolding map_simp [OF \<open>A2.arr f2\<close>]
  unfolding A1_B.mkArr_def
  using F.fixing_arr_gives_natural_transformation_2 [OF \<open>A2.arr f2\<close>]
  by simp

context begin

interpretation Delta : simplex.
interpretation sSet : functor_category Delta.comp pointed_set.pointed_set_comp
  unfolding functor_category_def
  by (simp add: Delta.is_category pointed_set.is_category)

interpretation eval : evaluation_functor Delta.comp pointed_set.pointed_set_comp
  unfolding evaluation_functor_def
  unfolding functor_category_def product_category_def
  by (simp add: sSet.is_category Delta.is_category pointed_set.is_category)

interpretation eval_cur : curried_functor'
     sSet.comp Delta.comp pointed_set.pointed_set_comp
     eval.map
  unfolding curried_functor'_def
  unfolding currying_def binary_functor_def functor_category_def
            product_category_def
  apply (simp add: sSet.is_category Delta.is_category pointed_set.is_category)
  using eval.is_functor.

definition D0 where
  "D0 = Some (1, [0])"

lemma ide_D0: "sSet.A.ide D0"
  unfolding D0_def
  using Delta.ide_D0.

lemma arr_D0: "sSet.A.arr D0"
  using ide_D0 by simp

lemma ide_D0I : "(Some (fin_set.Id' (Suc 0))) = D0"
  unfolding D0_def fin_set.Id'_def by simp

definition ev_0_arr where
  "ev_0_arr = eval_cur.map D0"

interpretation sSet_set : functor_category sSet.comp pointed_set.pointed_set_comp
  unfolding functor_category_def
  by (simp add: sSet.is_category pointed_set.is_category)

lemma ide_ev_0: "sSet_set.ide (eval_cur.map D0)"
  apply (rule_tac functor.preserves_ide [OF eval_cur.is_functor])
  using ide_D0.

definition ev_0_functor where
  "ev_0_functor = sSet_set.Fun (eval_cur.map D0)"

lemma ev_0_functor: "functor sSet.comp pointed_set.pointed_set_comp ev_0_functor"
  unfolding ev_0_functor_def
  using ide_ev_0
  unfolding sSet_set.ide_char
  by blast

lemma ev_0_functor_simp: assumes arr_c: "sSet.arr c"
  shows "(ev_0_functor c) = (sSet.Fun c D0)"
  unfolding ev_0_functor_def
  unfolding eval_cur.map_simp' [OF arr_D0]
  unfolding sSet_set.Fun_def
  apply (subst sSet_set.Abs_arr_inverse)
   apply simp_all
  apply (subst eval.map_simp)
   apply (simp add: arr_c ide_D0)
  by simp

lemma sSet_arr_dom_eq:
  assumes arr_f : "sSet.arr f"
  and arr_x : "sSet.A.arr x"
shows "fst (snd (the (sSet.Dom f x))) = fst (snd (the (sSet.Fun f x)))"
proof-
  interpret nat_f : natural_transformation Delta.comp pointed_set.pointed_set_comp
       "sSet.Dom f" "sSet.Cod f" "sSet.Fun f"
    using arr_f
    unfolding sSet.arr_char by simp
  have "sSet.B.dom (sSet.Dom f x) = sSet.B.dom (sSet.Fun f x)"
    unfolding nat_f.preserves_dom [OF arr_x]
    unfolding nat_f.F.preserves_dom [OF arr_x]
    by simp
  then show "fst (snd (the (sSet.Dom f x))) = fst (snd (the (sSet.Fun f x)))"
    unfolding P.dom_char [OF nat_f.F.preserves_arr [OF arr_x]]
    unfolding P.dom_char [OF nat_f.preserves_arr [OF arr_x]]
    by (simp add: P.Id'_def)
qed

lemma sSet_arr_cod_eq:
  assumes arr_f : "sSet.arr f"
  and ide_x : "sSet.A.ide x"
shows "fst (snd (the (sSet.Cod f x))) = snd (snd (the (sSet.Fun f x)))"
proof-
  have arr_x : "sSet.A.arr x"
    using ide_x by simp
  interpret nat_f : natural_transformation Delta.comp pointed_set.pointed_set_comp
       "sSet.Dom f" "sSet.Cod f" "sSet.Fun f"
    using arr_f
    unfolding sSet.arr_char by simp
  have "sSet.A.dom x = sSet.A.cod x"
    using ide_x by simp
  then have "sSet.B.dom (sSet.Cod f x) = sSet.B.cod (sSet.Fun f x)"
    unfolding nat_f.preserves_cod [OF arr_x]
    unfolding nat_f.G.preserves_dom [OF arr_x]
    by simp
  then show cod_eq : "fst (snd (the (sSet.Cod f x))) = snd (snd (the (sSet.Fun f x)))"
    unfolding P.dom_char [OF nat_f.G.preserves_arr [OF arr_x]]
    unfolding P.cod_char [OF nat_f.preserves_arr [OF arr_x]]
    by (simp add: P.Id'_def)
qed

lemma pi0_restrict :
  assumes arr_f : "sSet.arr f"
  and x_in_dom: "x \<in> snd (fst (snd (the (ev_0_functor f))))"
  and y_in_dom: "y \<in> snd (fst (snd (the (ev_0_functor f))))"
  and Rxy: "pointed_simplicial_set.pi0prerelation (sSet.Fun (sSet.dom f)) x y"
  shows "pointed_simplicial_set.pi0prerelation (sSet.Fun (sSet.cod f)) (fst (the (ev_0_functor f)) x)
        (fst (the (ev_0_functor f)) y)"
  unfolding sSet.Fun_dom [OF arr_f]
  unfolding sSet.Fun_cod [OF arr_f]
proof-
  interpret nat_f : natural_transformation Delta.comp pointed_set.pointed_set_comp
       "sSet.Dom f" "sSet.Cod f" "sSet.Fun f"
    using arr_f
    unfolding sSet.arr_char by simp
  interpret Dom: pointed_simplicial_set "sSet.Dom f"
    unfolding pointed_simplicial_set_def
    using nat_f.F.functor_axioms.
  interpret Cod: pointed_simplicial_set "sSet.Cod f"
    unfolding pointed_simplicial_set_def
    using nat_f.G.functor_axioms.
  show "Cod.pi0prerelation (fst (the (ev_0_functor f)) x) (fst (the (ev_0_functor f)) y)"
    unfolding Cod.pi0prerelation_def
    apply safe
  proof-
    show "fst (the (ev_0_functor f)) x \<in> snd (Cod.simplices 0)"
      unfolding ev_0_functor_simp [OF arr_f]
      apply (simp add: Cod.simplices_def ide_D0I)
      unfolding sSet_arr_cod_eq [OF arr_f ide_D0]
      apply (rule_tac P.arr_x_in_dom)
       apply (rule_tac nat_f.preserves_arr [OF arr_D0])
      using x_in_dom
      unfolding ev_0_functor_simp [OF arr_f].
    show "fst (the (ev_0_functor f)) y \<in> snd (Cod.simplices 0)"
      unfolding ev_0_functor_simp [OF arr_f]
      apply (simp add: Cod.simplices_def ide_D0I)
      unfolding sSet_arr_cod_eq [OF arr_f ide_D0]
      apply (rule_tac P.arr_x_in_dom)
       apply (rule_tac nat_f.preserves_arr [OF arr_D0])
      using y_in_dom
      unfolding ev_0_functor_simp [OF arr_f].

    from Rxy have "(\<exists>z\<in>snd (Dom.simplices 1).
      fst (the (sSet.Dom f (Delta.d 1 0))) z = x \<and> fst (the (sSet.Dom f (Delta.d 1 1))) z = y)"
      unfolding sSet.Fun_dom [OF arr_f]
      unfolding Dom.pi0prerelation_def by simp
    then obtain z where z_def: "z\<in>snd (Dom.simplices 1) \<and>
      fst (the (sSet.Dom f (Delta.d 1 0))) z = x \<and> fst (the (sSet.Dom f (Delta.d 1 1))) z = y"
      by auto
    from z_def have xz_eq : "x = fst (the (sSet.Dom f (Delta.d 1 0))) z" by simp
    from z_def have yz_eq : "y = fst (the (sSet.Dom f (Delta.d 1 1))) z" by simp
    show "\<exists>z\<in>snd (Cod.simplices 1).
       fst (the (sSet.Cod f (Delta.d 1 0))) z = fst (the (ev_0_functor f)) x \<and>
       fst (the (sSet.Cod f (Delta.d 1 1))) z = fst (the (ev_0_functor f)) y"
    proof
      define D1 where "D1 = Some (fin_set.Id' (Suc (Suc 0)))"
      have ide_D1 : "sSet.A.ide D1"
        unfolding D1_def
        apply (rule_tac Delta.ide_Dn)
        by simp

      define fz where "fz = fst (the (sSet.Fun f D1)) z"
      show "fz \<in> snd (Cod.simplices 1)"
        unfolding fz_def
        apply (simp add: Cod.simplices_def)
        unfolding reverse_equality [OF D1_def]
        unfolding sSet_arr_cod_eq [OF arr_f ide_D1]
        apply (rule_tac P.arr_x_in_dom)
         apply (rule_tac nat_f.preserves_arr)
        using ide_D1 apply simp
        using z_def
        unfolding Dom.simplices_def
        using sSet_arr_dom_eq [OF arr_f sSet.A.ideD(1) [OF ide_D1]]
        unfolding D1_def by simp

      have dom_eq0 : "(Some (fin_set.Id' (Suc (Suc 0)))) =
                      sSet.A.dom (Delta.d 1 0)"
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
        by simp_all
      have dom_eq1 : "(Some (fin_set.Id' (Suc (Suc 0)))) =
                      sSet.A.dom (Delta.d 1 1)"
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
        by simp_all

      have cod_eq0 : "D0 = sSet.A.cod (Delta.d 1 0)"
        unfolding D0_def
        apply (subst sSet.A.in_hom_cod [OF Delta.d_in_hom])
        by (simp_all add: fin_set.Id'_def)
      have cod_eq1 : "D0 = sSet.A.cod (Delta.d 1 1)"
        unfolding D0_def
        apply (subst sSet.A.in_hom_cod [OF Delta.d_in_hom])
        by (simp_all add: fin_set.Id'_def)

      have "1 = Suc 0" by simp
      have "0 < Suc 0" by simp
      have arr_d0 : "sSet.A.arr (Delta.d 1 0)"
        apply (rule_tac sSet.A.in_homE [OF Delta.d_in_hom [OF \<open>0 < Suc 0\<close>]])
        unfolding \<open>1 = Suc 0\<close> by blast
      have arr_d1 : "sSet.A.arr (Delta.d 1 1)"
        apply (rule_tac sSet.A.in_homE [OF Delta.d_in_hom [OF \<open>0 < Suc 0\<close>]])
        unfolding \<open>1 = Suc 0\<close> by blast

      have seq0 : "sSet.B.seq (sSet.Cod f (Delta.d 1 0)) (sSet.Fun f (sSet.A.dom (Delta.d 1 0)))"
        apply (rule_tac sSet.B.seqI')
         apply (rule_tac nat_f.preserves_hom)
        using sSet.A.ide_dom [OF arr_d0]
        unfolding sSet.A.ide_in_hom apply blast
        apply (rule_tac nat_f.G.preserves_hom)
        apply (rule_tac sSet.A.in_homI [OF arr_d0])
        by simp_all

      have seq1 : "sSet.B.seq (sSet.Cod f (Delta.d 1 1)) (sSet.Fun f (sSet.A.dom (Delta.d 1 1)))"
        apply (rule_tac sSet.B.seqI')
         apply (rule_tac nat_f.preserves_hom)
        using sSet.A.ide_dom [OF arr_d1]
        unfolding sSet.A.ide_in_hom apply blast
        apply (rule_tac nat_f.G.preserves_hom)
        apply (rule_tac sSet.A.in_homI [OF arr_d1])
        by simp_all

      have seq0' :"sSet.B.seq (sSet.Fun f (sSet.A.cod (Delta.d 1 0))) (sSet.Dom f (Delta.d 1 0))"
        apply (rule_tac sSet.B.seqI')
         apply (rule_tac nat_f.F.preserves_hom)
         apply (rule_tac Delta.d_in_hom)
         apply simp
        apply (rule_tac nat_f.preserves_hom)
        apply (subst reverse_equality [OF sSet.A.in_hom_cod [OF Delta.d_in_hom]])
         apply simp
        apply (subst reverse_equality [OF sSet.A.ide_in_hom])
        by (rule_tac sSet.A.ide_cod [OF arr_d0])
      have seq1' :"sSet.B.seq (sSet.Fun f (sSet.A.cod (Delta.d 1 1))) (sSet.Dom f (Delta.d 1 1))"
        apply (rule_tac sSet.B.seqI')
         apply (rule_tac nat_f.F.preserves_hom)
         apply (rule_tac Delta.d_in_hom)
         apply simp
        apply (rule_tac nat_f.preserves_hom)
        apply (subst reverse_equality [OF sSet.A.in_hom_cod [OF Delta.d_in_hom]])
         apply simp
        apply (subst reverse_equality [OF sSet.A.ide_in_hom])
        by (rule_tac sSet.A.ide_cod [OF arr_d1])

      have z_in_dom0 : "z \<in> snd (fst (snd (the (sSet.Fun f (sSet.A.dom (Delta.d 1 0))))))"
        apply (subst reverse_equality [OF sSet_arr_dom_eq [OF arr_f]])
        using sSet.A.ide_dom [OF arr_d0] apply simp
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
        apply simp
        using z_def by (simp add: Dom.simplices_def)

      have z_in_dom1 : "z \<in> snd (fst (snd (the (sSet.Fun f (sSet.A.dom (Delta.d 1 1))))))"
        apply (subst reverse_equality [OF sSet_arr_dom_eq [OF arr_f]])
        using sSet.A.ide_dom [OF arr_d1] apply simp
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
        apply simp
        using z_def by (simp add: Dom.simplices_def)

      have "z \<in> snd (fst (snd (the (sSet.B.dom (sSet.Dom f (Delta.d 1 0))))))"
        unfolding nat_f.F.preserves_dom [OF arr_d0]
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
         apply simp
        using z_def by (simp add: Dom.simplices_def)
      then have z_in_dom0' : "z \<in> snd (fst (snd (the (sSet.Dom f (Delta.d 1 0)))))"
        unfolding P.dom_char [OF nat_f.F.preserves_arr [OF arr_d0]]
        by (simp add: pointed_set.Id'_def)

      have "z \<in> snd (fst (snd (the (sSet.B.dom (sSet.Dom f (Delta.d 1 1))))))"
        unfolding nat_f.F.preserves_dom [OF arr_d1]
        apply (subst sSet.A.in_hom_dom [OF Delta.d_in_hom])
         apply simp
        using z_def by (simp add: Dom.simplices_def)
      then have z_in_dom1' : "z \<in> snd (fst (snd (the (sSet.Dom f (Delta.d 1 1)))))"
        unfolding P.dom_char [OF nat_f.F.preserves_arr [OF arr_d1]]
        by (simp add: pointed_set.Id'_def)

      show "fst (the (sSet.Cod f (Delta.d 1 0)))
     (fst (the (sSet.Fun f (Some (fin_set.Id' (Suc (Suc 0)))))) z) =
    fst (the (ev_0_functor f)) x \<and>
    fst (the (sSet.Cod f (Delta.d 1 1)))
     (fst (the (sSet.Fun f (Some (fin_set.Id' (Suc (Suc 0)))))) z) =
    fst (the (ev_0_functor f)) y"
      proof
        show "fst (the (sSet.Cod f (Delta.d 1 0)))
     (fst (the (sSet.Fun f (Some (fin_set.Id' (Suc (Suc 0)))))) z) =
    fst (the (ev_0_functor f)) x"
          unfolding ev_0_functor_simp [OF arr_f]
          unfolding xz_eq
          apply (subst dom_eq0)
          apply (subst cod_eq0)
          apply (subst reverse_equality [OF pointed_set.fst_comp_char])
          using seq0 apply simp
          using z_in_dom0 apply simp
          apply (subst reverse_equality [OF nat_f.naturality [OF arr_d0]])
          apply (subst pointed_set.fst_comp_char)
          using seq0' apply simp
          using z_in_dom0' apply simp
          by simp
        show "fst (the (sSet.Cod f (Delta.d 1 1)))
     (fst (the (sSet.Fun f (Some (fin_set.Id' (Suc (Suc 0)))))) z) =
    fst (the (ev_0_functor f)) y"
          unfolding ev_0_functor_simp [OF arr_f]
          unfolding yz_eq
          apply (subst dom_eq1)
          apply (subst cod_eq1)
          apply (subst reverse_equality [OF pointed_set.fst_comp_char])
          using seq1 apply simp
          using z_in_dom1 apply simp
          apply (subst reverse_equality [OF nat_f.naturality [OF arr_d1]])
          apply (subst pointed_set.fst_comp_char)
          using seq1' apply simp
          using z_in_dom1' apply simp
          by simp
      qed
    qed
  qed
qed

interpretation pi0: quotient_functor sSet.comp ev_0_functor
       "(\<lambda>X. pointed_simplicial_set.pi0relation (sSet.Fun X))"
  unfolding quotient_functor_def
  apply (simp add: ev_0_functor)
  unfolding quotient_functor_axioms_def
  apply safe
proof-
  fix c :: "((nat \<times> nat list) option,
       (('a pointed_set.parr) option)) sSet_set.arr"
  assume c_nn: "c \<noteq> sSet.null"
  assume functor_c: "functor Delta.comp pointed_set.pointed_set_comp (sSet.Fun c)"
  assume dom_c: "sSet.Dom c = sSet.Fun c"
  assume cod_c: "sSet.Cod c = sSet.Fun c"
  from functor_c interpret C: pointed_simplicial_set "(sSet.Fun c)"
    unfolding pointed_simplicial_set_def.

  have "sSet.ide c"
    unfolding sSet.ide_char
    by (simp add: c_nn functor_c dom_c cod_c)

  have obj_eq: "(fst (snd (the (ev_0_functor c)))) = C.simplices 0"
    unfolding C.simplices_def
    apply (subst ev_0_functor_simp)
    using \<open>sSet.ide c\<close> apply simp
    unfolding D0_def fin_set.Id'_def
    by simp

  show "equiv (snd (fst (snd (the (ev_0_functor c))))) {(x, y). C.pi0relation x y}"
    unfolding C.pi0relation_def
    unfolding obj_eq
    apply (rule_tac generated_equiv_rel_equiv)
    unfolding C.pi0prerelation_def
    by auto
next
  fix f :: "((nat \<times> nat list) option,
       (('a \<Rightarrow> 'a) \<times> ('a \<times> 'a set) \<times> 'a \<times> 'a set) option) sSet_set.arr"
  fix x y
  assume arr_f: "sSet.arr f"
  then interpret f_nat: natural_transformation Delta.comp pointed_set.pointed_set_comp
           "(sSet.Dom f)" "(sSet.Cod f)" "(sSet.Fun f)"
    unfolding sSet.arr_char by simp

  assume x_in_dom : "x \<in> snd (fst (snd (the (ev_0_functor f))))"
  assume y_in_dom : "y \<in> snd (fst (snd (the (ev_0_functor f))))"

  have arr_f0 : "sSet.B.arr (sSet.Fun f (Some (fin_set.Id' 1)))"
    unfolding f_nat.preserves_reflects_arr
    unfolding fin_set.Id'_def
    using Delta.ide_D0 by simp

  interpret Dom : pointed_simplicial_set "sSet.Fun (sSet.dom f)"
    unfolding pointed_simplicial_set_def
    using sSet.ide_dom [OF arr_f]
    unfolding sSet.ide_char
    by simp
  interpret Cod : pointed_simplicial_set "sSet.Fun (sSet.cod f)"
    unfolding pointed_simplicial_set_def
    using sSet.ide_cod [OF arr_f]
    unfolding sSet.ide_char
    by simp
  assume Rxy: "Dom.pi0relation x y"
  show "Cod.pi0relation (fst (the (ev_0_functor f)) x)
                        (fst (the (ev_0_functor f)) y)"
    unfolding Cod.pi0relation_def
    unfolding generated_equiv_rel_def Cod.simplices_def
    apply auto
  proof-
    fix Q
    assume Q_equiv : "equiv (snd (fst (snd (the (sSet.Fun (sSet.cod f) (Some (fin_set.Id' (Suc 0))))))))
          {(x, y). Q x y}"
    assume RQ : "\<forall>x y. Cod.pi0prerelation x y \<longrightarrow> Q x y"
    then have RQ_rule : "\<And>x y. Cod.pi0prerelation x y \<Longrightarrow> Q x y" by simp
    define dom where "dom = (snd (fst (snd (the (sSet.Fun (sSet.dom f) (Some (fin_set.Id' (Suc 0))))))))"

    have arr_dom_f0 : "sSet.B.arr (sSet.Fun (sSet.dom f) (Some (fin_set.Id' 1)))"
      unfolding sSet.Fun_dom [OF arr_f]
      apply (rule_tac f_nat.F.preserves_arr)
      using Delta.ide_D0 by (simp add: fin_set.Id'_def)
    have "sSet.B.dom (sSet.Fun f (Some (fin_set.Id' 1))) =
          sSet.B.dom (sSet.Fun (sSet.dom f) (Some (fin_set.Id' 1)))"
      using Delta.ide_D0 apply (simp add: fin_set.Id'_def)
      unfolding sSet.dom_char
      apply (simp add: arr_f)
      unfolding sSet.mkArr_def
      apply (simp add: functor_is_transformation [OF f_nat.F.functor_axioms])
      unfolding sSet.Fun_def
      by (simp add: sSet.Abs_arr_inverse)
    then have dom_eq : "fst (snd (the (sSet.Fun f (Some (fin_set.Id' 1))))) =
                   fst (snd (the (sSet.Fun (sSet.dom f) (Some (fin_set.Id' (Suc 0))))))"
      unfolding P.dom_char [OF arr_f0]
      unfolding P.dom_char [OF arr_dom_f0]
      by (simp add: pointed_set.Id'_def)
    have arr_cod_f0 : "sSet.B.arr (sSet.Fun (sSet.cod f) (Some (fin_set.Id' (Suc 0))))"
      unfolding sSet.Fun_cod [OF arr_f]
      apply (rule_tac f_nat.G.preserves_arr)
      using Delta.ide_D0 by (simp add: fin_set.Id'_def)

    have "sSet.A.cod (Some (fin_set.Id' 1)) = sSet.A.dom (Some (fin_set.Id' 1))"
      using Delta.ide_D0
      by (simp add: fin_set.Id'_def)
    then have "sSet.B.cod (sSet.Fun f (Some (fin_set.Id' 1))) =
          sSet.B.dom (sSet.Fun (sSet.cod f) (Some (fin_set.Id' (Suc 0))))"
      unfolding sSet.Fun_cod [OF arr_f]
      apply (subst f_nat.preserves_cod)
      using Delta.ide_D0 apply (simp add: fin_set.Id'_def)
      apply (subst f_nat.G.preserves_dom)
      using Delta.ide_D0 apply (simp add: fin_set.Id'_def)
      by simp
    then have cod_eq : "(snd (snd (the (sSet.Fun f (Some (fin_set.Id' 1)))))) =
               (fst (snd (the (sSet.Fun (sSet.cod f) (Some (fin_set.Id' (Suc 0)))))))"
      unfolding P.cod_char [OF arr_f0]
      using P.dom_char [OF arr_cod_f0]
      by (simp add: pointed_set.Id'_def)

    define fQ where "fQ = (\<lambda>x y. x \<in> dom \<and> y \<in> dom \<and> Q (fst (the (ev_0_functor f)) x) (fst (the (ev_0_functor f)) y))"
    have fQ_equiv : "equiv dom {(x, y). fQ x y}"
      unfolding fQ_def
      apply (rule_tac equiv_preimage)
      using Q_equiv apply simp
      unfolding dom_def apply auto
      unfolding ev_0_functor_simp [OF arr_f]
      using P.arr_x_in_dom [OF arr_f0]
      unfolding dom_eq cod_eq
      unfolding D0_def fin_set.Id'_def by simp

    have RfQ : "\<forall>x y. Dom.pi0prerelation x y \<longrightarrow> fQ x y"
      unfolding fQ_def apply auto
    proof-
      fix x y
      assume Rxy: "Dom.pi0prerelation x y"
      from Rxy have xy_in_0: "x \<in> snd (Dom.simplices 0) \<and>
                 y \<in> snd (Dom.simplices 0)"
        unfolding Dom.pi0prerelation_def by simp
      show "x \<in> dom"
        using xy_in_0
        unfolding dom_def Dom.simplices_def by simp
      show "y \<in> dom"
        using xy_in_0
        unfolding dom_def Dom.simplices_def by simp
      show "Q (fst (the (ev_0_functor f)) x) (fst (the (ev_0_functor f)) y)"
        apply (rule_tac RQ_rule)
        apply (rule_tac pi0_restrict)
        using arr_f apply simp
        unfolding ev_0_functor_simp [OF arr_f]
        using dom_eq \<open>x \<in> dom\<close>
        unfolding dom_def D0_def fin_set.Id'_def
          apply simp
        using dom_eq \<open>y \<in> dom\<close>
        unfolding dom_def D0_def fin_set.Id'_def
         apply simp
        using Rxy.
    qed

    have "equiv (snd (Dom.simplices 0)) {(x, y). fQ x y} \<longrightarrow> (\<forall>x y. Dom.pi0prerelation x y \<longrightarrow> fQ x y) \<longrightarrow> fQ x y"
      using Rxy
      unfolding Dom.pi0relation_def generated_equiv_rel_def by blast
    then have "fQ x y"
      using fQ_equiv RfQ  unfolding dom_def
      by (simp add: Dom.simplices_def)

    show "Q (fst (the (ev_0_functor f)) x) (fst (the (ev_0_functor f)) y)"
      using \<open>fQ x y\<close>
      unfolding fQ_def by simp
  qed
qed

definition pi0 where
  "pi0 = pi0.quotient_functor"

lemma pi0_functor : "functor sSet.comp pointed_set.pointed_set_comp pi0"
  unfolding pi0_def
  using pi0.is_functor.

end

end


theory FutureCardinality
imports CallFutures CardinalityAnalysis Cardinality-Domain-Lists
begin

locale FutureAnalysis =
 fixes Texp :: "exp \<Rightarrow> Arity \<rightarrow> future set"
begin

fun FBinds :: "heap \<Rightarrow> AEnv \<rightarrow> (var \<Rightarrow> future set)"
  where "FBinds [] = (\<Lambda> ae. \<bottom>)"
      | "FBinds ((x,e)#\<Gamma>) = (\<Lambda> ae. (\<lambda> x'. (if x' = x then fup\<cdot>(Texp e)\<cdot>(ae x) else (FBinds \<Gamma>\<cdot>ae) x)))"

lemma FBinds_Nil_simp[simp]: "FBinds []\<cdot>ae = \<bottom>" by simp

lemma FBinds_Cons[simp]:
  "FBinds ((x,e)#\<Gamma>)\<cdot>ae = (\<lambda> x'. (if x' = x then fup\<cdot>(Texp e)\<cdot>(ae x) else (FBinds \<Gamma>\<cdot>ae) x))" by simp

lemmas FBinds.simps[simp del]

lemma FBinds_cong:
  assumes "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
  shows "FBinds \<Gamma>\<cdot>ae = FBinds \<Gamma>\<cdot>ae'"
using env_restr_eqD[OF assms]
by (induction \<Gamma> rule: FBinds.induct) (auto split: if_splits)

fun unstack :: "stack \<Rightarrow> exp \<Rightarrow> exp" where
  "unstack [] e = e"
| "unstack (Upd x # S) e = unstack S e"
| "unstack (Arg x # S) e = unstack S (App e x)"
| "unstack (Dummy x # S) e = unstack S e"

fun Fstack :: "stack \<Rightarrow> future set"
  where "Fstack [] = \<bottom>"
  | "Fstack (Upd x # S) = Fstack S"
  | "Fstack (Arg x # S) = may_call x (Fstack S)"
  | "Fstack (Dummy x # S) = Fstack S"

fun prognosis :: "AEnv \<Rightarrow> Arity \<Rightarrow> conf \<Rightarrow> var \<Rightarrow> two"
   where "prognosis ae a (\<Gamma>, e, S) = pathsCard (paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp e\<cdot>a) (Fstack S)))"
end

locale FutureAnalysisSafe = FutureAnalysis +
  assumes Texp_App: "Texp (App e x)\<cdot>a = may_call x ((Texp e)\<cdot>(inc\<cdot>a))"
  assumes Texp_Lam: "without y ` (Texp e \<cdot>(pred\<cdot>n)) = Texp (Lam [y]. e) \<cdot> n"
  assumes Texp_subst: "Texp (e[y::=x])\<cdot>a = may_call x (without y ` ((Texp e)\<cdot>a))"
begin

  sublocale CardinalityPrognosisSafe prognosis
  proof
    fix \<Gamma> :: heap and ae ae' :: AEnv and u e S
    assume "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
    from FBinds_cong[OF this]
    show "prognosis ae u (\<Gamma>, e, S) = prognosis ae' u (\<Gamma>, e, S)" by simp
  next
    fix ae a \<Gamma> e S
    show "const_on (prognosis ae a (\<Gamma>, e, S)) (ap S) many"
    proof
      fix x
      assume "x \<in> ap S"
      hence "\<exists> f \<in> Fstack S. f x > 1"
        by(induction S rule: Fstack.induct)(auto simp add: may_call_multiple_calls)
      hence "\<exists> f \<in> future_add (Texp e\<cdot>a) (Fstack S). f x > 1"
        using future_add_subset2 by auto
      hence "[x,x] \<in> paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp e\<cdot>a) (Fstack S))"
        apply -
        apply (erule bexE)
        apply (rule paths_intros)
        apply assumption
        apply (simp add: possible_def)
        apply (rule paths_intros)
        apply (rule set_mp[OF future_add_subset1])
        apply simp
        apply (simp add: possible_def after_def)
        apply rule
        done
      hence "pathCard [x,x] x \<sqsubseteq> pathsCard (paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp e\<cdot>a) (Fstack S))) x"
        by (metis fun_belowD paths_Card_above)
      also have "pathCard [x,x] x = many" by (auto simp add: pathCard_def)
      finally
      show "prognosis ae a (\<Gamma>, e, S) x = many"
        by (auto intro: below_antisym)
    qed
  next
    fix ae a \<Gamma> e x S
    have "future_add (Texp e\<cdot>(inc\<cdot>a)) (may_call x (Fstack S)) = future_add (may_call x (Texp e\<cdot>(inc\<cdot>a))) (Fstack S)"
      by (rule future_add_may_call_twist)
    hence "(future_add (Texp e\<cdot>(inc\<cdot>a)) (may_call x (Fstack S))) = future_add (Texp (App e x)\<cdot>a) (Fstack S)"
      by (simp add: Texp_App)
    thus "prognosis ae (inc\<cdot>a) (\<Gamma>, e, Arg x # S) \<sqsubseteq> prognosis ae a (\<Gamma>, App e x, S)"
      by simp
  next
    fix ae a \<Gamma> e y x S
    have "Texp e[y::=x]\<cdot>(pred\<cdot>a) = may_call x (Texp (Lam [y]. e)\<cdot>a)"
      by (simp add: Texp_Lam Texp_subst)
    hence "future_add (Texp e[y::=x]\<cdot>(pred\<cdot>a)) (Fstack S) = future_add (Texp (Lam [y]. e)\<cdot>a) (may_call x (Fstack S))"
      by (metis future_add_may_call_twist)
    thus "prognosis ae (pred\<cdot>a) (\<Gamma>, e[y::=x], S) \<sqsubseteq> prognosis ae a (\<Gamma>, Lam [y]. e, Arg x # S)"
      by simp
  next
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"
    assume "a \<sqsubseteq> u"

    have "paths (FBinds (delete x \<Gamma>)\<cdot>ae) (future_add (Texp e\<cdot>u) (Fstack S)) \<subseteq> {tl p |p. p \<in> paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp (Var x)\<cdot>a) (Fstack S)) \<and> hd p = x}"
    proof
      fix p
      assume "p \<in> paths (FBinds (delete x \<Gamma>)\<cdot>ae) (future_add (Texp e\<cdot>u) (Fstack S))"

      have "x# p \<in>paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp (Var x)\<cdot>a) (Fstack S))"
      proof

      qed
      thus "p \<in> {tl p |p. p \<in> paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp (Var x)\<cdot>a) (Fstack S)) \<and> hd p = x}" by force
    qed
    hence "pathsCard (paths (FBinds (delete x \<Gamma>)\<cdot>ae) (future_add (Texp e\<cdot>u) (Fstack S))) \<sqsubseteq> pathsCard {tl p |p. p \<in> paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp (Var x)\<cdot>a) (Fstack S)) \<and> hd p = x}"
      by (rule pathsCard_mono)
    hence "pathsCard (paths (FBinds (delete x \<Gamma>)\<cdot>ae) (future_add (Texp e\<cdot>u) (Fstack S))) \<sqsubseteq> record_call x\<cdot>(pathsCard (paths (FBinds \<Gamma>\<cdot>ae) (future_add (Texp (Var x)\<cdot>a) (Fstack S))))"
      by (rule below_trans[OF _ record_call_pathsCard])
    thus "prognosis ae u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x\<cdot>(prognosis ae a (\<Gamma>, Var x, S))" by simp
  oops

end

end