section \<open>Partitions Of Unity\<close>
theory Partition_Of_Unity
  imports Bump_Function Differentiable_Manifold
begin

subsection \<open>Regular cover\<close>

context c_manifold begin

text \<open>A cover is regular if, in addition to being countable and locally finite,
  the codomain of every chart is the open ball of radius 3, such that the
  inverse image of open balls of radius 1 also cover the manifold.\<close>
definition "regular_cover I (\<psi>::'i\<Rightarrow>('a, 'b) chart) \<longleftrightarrow>
  countable I \<and>
  carrier = (\<Union>i\<in>I. domain (\<psi> i)) \<and>
  locally_finite_on carrier I (domain o \<psi>) \<and>
  (\<forall>i\<in>I. codomain (\<psi> i) = ball 0 3) \<and>
  carrier = (\<Union>i\<in>I. inv_chart (\<psi> i) ` ball 0 1)"

text \<open>Every covering has a refinement that is a regular cover.\<close>
lemma reguler_refinementE:
  fixes \<X>::"'i \<Rightarrow> 'a set"
  assumes cover: "carrier \<subseteq> (\<Union>i\<in>I. \<X> i)" and open_cover: "\<And>i. i \<in> I \<Longrightarrow> open (\<X> i)"
  obtains N::"nat set" and \<psi>::"nat \<Rightarrow> ('a, 'b) chart"
  where "\<And>i. i \<in> N \<Longrightarrow> \<psi> i \<in> atlas" "(domain o \<psi>) ` N refines \<X> ` I" "regular_cover N \<psi>"
proof -
  from precompact_locally_finite_open_coverE
  obtain V::"nat\<Rightarrow>_" where V:
    "carrier = (\<Union>i. V i)"
    "\<And>i. open (V i)"
    "\<And>i. compact (closure (V i))"
    "\<And>i. closure (V i) \<subseteq> carrier"
    "locally_finite_on carrier UNIV V"
    by auto

  define intersecting where "intersecting v = {i. V i \<inter> v \<noteq> {}}" for v
  have intersecting_closure: "intersecting (closure x) = intersecting x" for x
    using open_Int_closure_eq_empty[OF V(2), of _ x]
    by (auto simp: intersecting_def)
  from locally_finite_compactD[OF V(5) V(3) V(4)]
  have "finite (intersecting (closure (V x)))" for x
    by (simp add: intersecting_def)
  then have finite_intersecting: "finite (intersecting (V x))" for x
    by (simp add: intersecting_closure)

  have "\<exists>\<psi>::('a, 'b) chart.
    \<psi> \<in> atlas \<and>
    codomain \<psi> = ball 0 3 \<and>
    (\<exists>c\<in>I. domain \<psi> \<subseteq> \<X> c) \<and>
     (\<forall>j. p \<in> V j \<longrightarrow> domain \<psi> \<subseteq> V j) \<and>
      p \<in> domain \<psi> \<and>
      \<psi> p = 0"
    if "p \<in> carrier" for p
  proof -
    from cover that open_cover obtain c where c: "p \<in> \<X> c" "open (\<X> c)" "c \<in> I"
      by force
    define VS where "VS = {U. p \<in> V U}"
    have open_VS: "\<And>T. T \<in> VS \<Longrightarrow> open (V T)"
      by (auto simp: VS_def V)
    from locally_finite_onD[OF V(5) that]
    have "finite VS" by (simp add: VS_def)
    from atlasE[OF that] obtain \<psi>' where \<psi>': "\<psi>' \<in> atlas" "p \<in> domain \<psi>'" .
    define W where  "W = (\<Inter>i\<in>VS. V i) \<inter> domain \<psi>' \<inter> \<X> c"
    have "open W"
      by (force simp: W_def open_VS intro!: c \<open>finite VS\<close>)
    have "p \<in> W" by (auto simp: W_def c \<psi>' VS_def)
    have "W \<subseteq> carrier"
      using \<psi>'
      by (auto simp: W_def)
    have "0 < (3::real)" by auto
    from open_centered_ball_chartE[OF \<open>p \<in> W\<close> \<open>open W\<close> \<open>W \<subseteq> carrier\<close> \<open>0 < 3\<close>]
    obtain \<psi> where \<psi>: "\<psi> \<in> atlas" "p \<in> domain \<psi>" "\<psi> p = 0" "domain \<psi> \<subseteq> W" "codomain \<psi> = ball 0 3"
      by auto
    moreover have "\<exists>x\<in>I. domain \<psi> \<subseteq> \<X> x"
      using c \<psi> by (auto simp: W_def)
    moreover have "p \<in> V j \<Longrightarrow> domain \<psi> \<subseteq> V j" for j
      using c \<psi> by (auto simp: W_def VS_def)
    ultimately show ?thesis
      by (intro exI[where x=\<psi>]) auto
  qed
  then have "\<forall>p2 \<in> carrier.
    \<exists>\<psi>::('a, 'b) chart. \<psi> \<in> atlas \<and> codomain \<psi> = ball 0 3 \<and>
         (\<exists>c\<in>I. domain \<psi> \<subseteq> \<X> c) \<and> (\<forall>j. p2 \<in> V j \<longrightarrow> domain \<psi> \<subseteq> V j) \<and> p2 \<in> domain \<psi> \<and>
         apply_chart \<psi> p2 = 0"
    by blast
  then obtain \<psi>::"'a \<Rightarrow> ('a, 'b) chart" where \<psi>:
    "\<And>p. p \<in> carrier \<Longrightarrow> codomain (\<psi> p) = ball 0 3"
    "\<And>p. p \<in> carrier \<Longrightarrow> (\<exists>c\<in>I. domain (\<psi> p) \<subseteq> \<X> c)"
    "\<And>p j. p \<in> V j \<Longrightarrow> domain (\<psi> p) \<subseteq> V j"
    "\<And>p j. p \<in> carrier \<Longrightarrow> p \<in> domain (\<psi> p)"
    "\<And>p. p \<in> carrier \<Longrightarrow> (\<psi> p) p = 0"
    "\<And>p. p \<in> carrier \<Longrightarrow> \<psi> p \<in> atlas"
    unfolding bchoice_iff
    apply atomize_elim
    apply auto
    subgoal for f
      apply (rule exI[where x=f])
      using V
      by auto
    done

  define U where "U p = inv_chart (\<psi> p) ` ball 0 1" for p
  have U_open: "open (U p)" if "p \<in> carrier" for p
    using that \<psi>
    by (auto simp: U_def)
  have U_subset_domain: "x \<in> U p \<Longrightarrow> x \<in> domain (\<psi> p)" if "p \<in> carrier" for x p
    using \<psi>(1) that
    by (auto simp: U_def)

  have "\<exists>M. M \<subseteq> closure (V l) \<and> finite M \<and> closure (V l) \<subseteq> \<Union>(U ` M)" for l
  proof -
    have clcover: "closure (V l) \<subseteq> \<Union>(U ` closure (V l))"
      using \<psi>
      apply (auto simp: U_def)
      apply (rule bexI)
       prefer 2 apply assumption
      apply (rule image_eqI)
       apply (rule inv_chart_inverse[symmetric])
       apply (rule \<psi>)
       apply auto
      using V(4) apply force
      by (metis V(4) less_irrefl norm_numeral norm_one norm_zero one_less_numeral_iff subsetCE
          zero_less_norm_iff zero_neq_numeral)
    have "B \<in> U ` closure (V l) \<Longrightarrow> open B" for B
      using V(4) by (auto intro!: U_open)
    from compactE[OF V(3) clcover this]
    obtain Um where Um: "Um \<subseteq> U ` closure (V l)" "finite Um" "closure (V l) \<subseteq> \<Union>Um"
      by auto
    from Um(1) have "\<forall>t\<in>Um. \<exists>p\<in>closure (V l). t = U p"
      by auto
    then obtain p_of where p_of: "\<And>t. t \<in> Um \<Longrightarrow> p_of t \<in> closure (V l)"
      "\<And>t. t \<in> Um \<Longrightarrow> t = U (p_of t)"
      by metis
    have "p_of ` Um \<subseteq> closure (V l)"
      using p_of
      by auto
    moreover have "finite (p_of ` Um)" using \<open>finite Um\<close> by auto
    moreover have "closure (V l) \<subseteq> \<Union>(U ` p_of ` Um)"
      using Um p_of by auto
    ultimately show ?thesis by blast
  qed
  then obtain M' where M': "\<And>l. M' l \<subseteq> closure (V l)" "\<And>l. finite (M' l)" "\<And>l. closure (V l) \<subseteq> \<Union>(U ` M' l)"
    by metis
  define M where "M v = M' (LEAST l. V l = v)" for v
  have V_Least: "V (LEAST la. V la = V l) = V l" for l
    by (rule LeastI_ex) auto
  have M: "M (V l) \<subseteq> closure (V l)" "finite (M v)" "closure (V l) \<subseteq> \<Union>(U ` M (V l))" for v l
    subgoal
      unfolding M_def
      apply (rule order_trans)
       apply (rule M')
      by (auto simp: V_Least)
    subgoal using M' by (auto simp: M_def)
    subgoal
      unfolding M_def
      apply (subst V_Least[symmetric])
      by (rule M')
    done

  from M(1) V(4) have M_carrier: "x \<in> M (V l) \<Longrightarrow> x \<in> carrier" for x l by auto

  have "countable (\<Union>l. M (V l))"
    using M(2) by (auto simp: countable_finite)
  from countableE_bij[OF this]
  obtain m and N::"nat set" where n: "bij_betw m N (\<Union>l. M (V l))" .
  define m' where "m' = the_inv_into N m"
  have m_inverse[simp]: "\<And>i. i \<in> N \<Longrightarrow> m' (m i) = i"
    and m'_inverse[simp]: "\<And>x l. x \<in> M (V l) \<Longrightarrow> m (m' x) = x"
    using n
    by (force simp: bij_betw_def m'_def the_inv_into_f_f)+

  have m_in: "m i \<in> (\<Union>l. M (V l))" if "i \<in> N" for i
    using n that
    by (auto dest!: bij_betwE)
  have m'_in: "m' x \<in> N" if "x \<in> M (V l)" for x l
    using that n
    by (auto simp: m'_def bij_betw_def intro!: the_inv_into_into)

  from m_in have m_in_carrier: "m i \<in> carrier" if "i \<in> N" for i
    using that M_carrier
    by auto
  then have "\<And>i. i \<in> N \<Longrightarrow> \<psi> (m i) \<in> atlas"
    by (rule \<psi>(6))
  moreover
  have "(domain o (\<lambda>i. (\<psi> (m i)))) ` N refines \<X> ` I"
    by (auto simp: refines_def dest!: m_in_carrier \<psi>(2))
  moreover
  have "regular_cover N (\<lambda>i. \<psi> (m i))"
  proof -
    have "countable N" by simp
    moreover
    have carrier_subset: "carrier \<subseteq> (\<Union>i \<in> N. inv_chart (\<psi> (m i)) ` ball 0 1)"
      unfolding V
    proof safe
      fix x i
      assume "x \<in> V i"
      with M obtain p where p: "p \<in> M (V i)" "x \<in> U p" by blast
      from p show "x \<in> (\<Union>i\<in>N. inv_chart (\<psi> (m i)) ` ball 0 1)"
        by (auto simp: U_def intro!: bexI[where x="m' p"] m'_in)
    qed
    have carrier_eq_W:  "carrier = (\<Union>i\<in>N. domain (\<psi> (m i)))" (is "_ = ?W")
    proof (rule antisym)
      note carrier_subset
      also have "\<dots> \<subseteq> ?W"
        using U_subset_domain \<psi>(1) M_carrier m_in
        by (force simp: V)
      finally show "carrier \<subseteq> ?W"
        by auto
      show "?W \<subseteq> carrier" using M_carrier \<psi>(6)
        by (auto dest!: m_in)
    qed
    moreover have "locally_finite_on carrier N (\<lambda>i. domain (\<psi> (m i)))"
    proof (rule locally_finite_on_open_coverI)
      show "open (domain (\<psi> (m i)))" for i by auto
      show "carrier \<subseteq> (\<Union>i\<in>N. domain (\<psi> (m i)))"
        unfolding carrier_eq_W by auto
      fix ki
      assume "ki \<in> N"
      from m_in[OF this]
      obtain k where k: "m ki \<in> M (V k)" by auto
      have pkc: "m ki \<in> closure (V k)"
        using k M(1) by force
      obtain j where j: "m ki \<in> V j"
        using M_carrier[of "m ki" k] V(1) k by force
      have kj: "V k \<inter> V j \<noteq> {}"
        using open_Int_closure_eq_empty[OF V(2)]
        using pkc j by auto
      then have jinterk: "j \<in> intersecting (V k)" by (auto simp: intersecting_def)

      have 1: "compact (closure (V k))" by (rule V)
      have 2: "closure (V k) \<subseteq> \<Union>(range V)" unfolding V(1)[symmetric] by (rule V)
      have 3: "B \<in> range V \<Longrightarrow> open B" for B by (auto simp: V)
      from compactE[OF 1 2 3]
      obtain Vj where "Vj \<subseteq> range V" "finite Vj" "closure (V k) \<subseteq> \<Union>Vj" by auto
      then obtain J where "finite J" "closure (V k) \<subseteq> \<Union>(V ` J)"
        apply atomize_elim
        by (metis finite_subset_image)

      {
        fix ki' assume "ki' \<in> N"
        assume H: "domain (\<psi> (m ki')) \<inter> domain (\<psi> (m ki)) \<noteq> {}"
        obtain k' where ki': "m ki' \<in> M (V k')" using m_in[OF \<open>ki' \<in> N\<close>] by auto
        have k': "domain (\<psi> (m ki')) \<inter> domain (\<psi> (m ki)) \<noteq> {}" "m ki' \<in> M (V k')"
          using ki'  H by auto
        have pkc': "m ki' \<in> closure (V k')"
          using k' M(1) by force
        obtain j' where j': "m ki' \<in> V j'"
          using M_carrier V(1) k' by force
        have kj': "(V k') \<inter> V j' \<noteq> {}"
          using open_Int_closure_eq_empty[OF V(2)]
          using pkc' j' by auto
        then have j'interk': "k' \<in> intersecting (V j')" by (auto simp: intersecting_def)

        have j'interj: "j' \<in> intersecting (V j)"
          using k' \<psi>(3)[OF j'] \<psi>(3)[OF j]
          by (auto simp: intersecting_def)
        have "k' \<in> \<Union>(intersecting ` V ` \<Union>(intersecting ` V ` intersecting (V k)))"
          using jinterk j'interk' j'interj
          by blast
        then have "m ki' \<in> \<Union>((\<lambda>x. M (V x)) ` \<Union>(intersecting ` V ` \<Union>(intersecting ` V ` intersecting (V k))))"
          using ki'
          by auto
        from m_inverse[symmetric] this have "ki' \<in> m' ` \<Union>((\<lambda>x. M (V x)) ` \<Union>(intersecting ` V ` \<Union>(intersecting ` V ` intersecting (V k))))"
          by (rule image_eqI) fact
      } note * = this
      show "finite {i \<in> N. domain (\<psi> (m i)) \<inter> domain (\<psi> (m ki)) \<noteq> {}}"
        apply (rule finite_subset[where B="m' ` \<Union>((\<lambda>x. M (V x)) ` \<Union>(intersecting ` V ` \<Union>(intersecting ` V ` intersecting (V k))))"])
         apply clarsimp
        subgoal by (drule *, assumption, force)
        using finite_intersecting intersecting_def M by auto
    qed
    moreover have "(\<forall>i \<in> N. codomain (\<psi> (m i)) = ball 0 3)"
      using \<psi>(1) M_carrier m_in
      by force
    moreover have "carrier = (\<Union>i \<in> N. inv_chart (\<psi> (m i)) ` ball 0 1)"
    proof (rule antisym)
      show "(\<Union>i\<in>N. inv_chart (\<psi> (m i)) ` ball 0 1) \<subseteq> carrier"
        using \<psi>(6)[OF M_carrier] M_carrier m_in
        by (force simp: \<psi>(1))
    qed (rule carrier_subset)
    ultimately show ?thesis
      by (auto simp: regular_cover_def o_def)
  qed
  ultimately
  show ?thesis ..
qed

lemma diff_apply_chart:
  "diff k (charts_submanifold (domain \<psi>)) charts_eucl \<psi>" if "\<psi> \<in> atlas"
proof -
  interpret submanifold charts k "domain \<psi>"
    by unfold_locales auto
  show ?thesis
  proof (unfold_locales)
    fix x assume x: "x \<in> sub.carrier"
    show "\<exists>c1\<in>sub.atlas.
            \<exists>c2\<in>manifold_eucl.dest.atlas.
               x \<in> domain c1 \<and> \<psi> ` domain c1 \<subseteq> domain c2 \<and> k-smooth_on (codomain c1) (c2 \<circ> \<psi> \<circ> inv_chart c1)"
      apply (rule bexI[where x = "restrict_chart (domain \<psi>) \<psi>"])
       apply (rule bexI[where x = "chart_eucl"])
      subgoal
      proof safe
        show "x \<in> domain (restrict_chart (domain \<psi>) \<psi>)"
          using x \<open>\<psi> \<in> atlas\<close>
          by auto
        show "k-smooth_on (codomain (restrict_chart (domain \<psi>) \<psi>)) (chart_eucl \<circ> \<psi> \<circ> inv_chart (restrict_chart (domain \<psi>) \<psi>))"
          apply (auto simp: o_def)
          apply (rule smooth_on_cong[where g="\<lambda>x. x"])
          by (auto intro!: open_continuous_vimage' continuous_on_codomain)
      qed simp
      subgoal by auto
      subgoal by (rule submanifold_atlasI) fact
      done
  qed
qed

lemma diff_inv_chart:
  "diff k (manifold_eucl.charts_submanifold (codomain c)) charts (inv_chart c)" if "c \<in> atlas"
proof -
  interpret submanifold charts_eucl k "codomain c"
    by unfold_locales auto
  show ?thesis
  proof (unfold_locales)
    fix x assume x: "x \<in> sub.carrier"
    show "\<exists>c1\<in>sub.atlas.
            \<exists>c2\<in>atlas.
               x \<in> domain c1 \<and> inv_chart c ` domain c1 \<subseteq> domain c2 \<and>
               k-smooth_on (codomain c1) (c2 \<circ> inv_chart c \<circ> inv_chart c1)"
      apply (rule bexI[where x = "restrict_chart (codomain c) chart_eucl"])
       apply (rule bexI[where x = c])
      subgoal
      proof safe
        show "x \<in> domain (restrict_chart (codomain c) chart_eucl)"
          using x \<open>c \<in> atlas\<close>
          by auto
        show "k-smooth_on (codomain (restrict_chart (codomain c) chart_eucl)) (c \<circ> inv_chart c \<circ> inv_chart (restrict_chart (codomain c) chart_eucl))"
          apply (auto simp: o_def)
          apply (rule smooth_on_cong[where g="\<lambda>x. x"])
          by (auto intro!: open_continuous_vimage' continuous_on_codomain)
      qed simp
      subgoal using that by simp
      subgoal
        by (rule submanifold_atlasI) auto
      done
  qed
qed

lemma chart_inj_on [simp]:
  fixes c :: "('a, 'b) chart"
  assumes "x \<in> domain c" "y \<in> domain c"
  shows "c x = c y \<longleftrightarrow> x = y"
proof -
  have "inj_on c (domain c)" by (rule inj_on_apply_chart)
  with assms show ?thesis by (auto simp: inj_on_def)
qed

subsection \<open>Partition of unity by smooth functions\<close>

text\<open>
  Given any open cover \<open>X\<close> indexed by a set \<open>A\<close>, there exists a family of
  smooth functions \<open>\<phi>\<close> indexed by \<open>A\<close>, such that \<open>0 \<le> \<phi> \<le> 1\<close>, the (closed) support
  of each \<open>\<phi> i\<close> is contained in \<open>X i\<close>, the supports are locally finite, and the
  sum of \<open>\<phi> i\<close> is the constant function \<open>1\<close>.\<close>
theorem partitions_of_unityE:
  fixes A::"'i set" and X::"'i \<Rightarrow> 'a set"
  assumes "carrier \<subseteq> (\<Union>i\<in>A. X i)"
  assumes "\<And>i. i \<in> A \<Longrightarrow> open (X i)"
  obtains \<phi>::"'i \<Rightarrow> 'a \<Rightarrow> real"
  where "\<And>i. i \<in> A \<Longrightarrow> diff_fun k charts (\<phi> i)"
    and "\<And>i x. i \<in> A \<Longrightarrow> x \<in> carrier \<Longrightarrow> 0 \<le> \<phi> i x"
    and "\<And>i x. i \<in> A \<Longrightarrow> x \<in> carrier \<Longrightarrow> \<phi> i x \<le> 1"
    and "\<And>x. x \<in> carrier \<Longrightarrow> (\<Sum>i\<in>{i\<in>A. \<phi> i x \<noteq> 0}. \<phi> i x) = 1"
    and "\<And>i. i \<in> A \<Longrightarrow> csupport_on carrier (\<phi> i) \<inter> carrier \<subseteq> X i"
    and "locally_finite_on carrier A (\<lambda>i. csupport_on carrier (\<phi> i))"
proof -
  from reguler_refinementE[OF assms]
  obtain N and \<psi>::"nat \<Rightarrow> ('a, 'b) chart" where \<psi>:
    "\<And>i. i \<in> N \<Longrightarrow> \<psi> i \<in> atlas"
    "(domain o \<psi>) ` N refines X ` A"
    "regular_cover N \<psi>" by blast

  define U where "U i = inv_chart (\<psi> i) ` ball 0 1" for i::nat
  define V where "V i = inv_chart (\<psi> i) ` ball 0 2" for i::nat
  define W where "W i = inv_chart (\<psi> i) ` ball 0 3" for i::nat

  from \<open>regular_cover N \<psi>\<close> have regular_cover:
    "countable N"
    "(\<Union>i\<in>N. U i) = (\<Union>i\<in>N. domain (\<psi> i))"
    "locally_finite_on carrier N (domain \<circ> \<psi>)"
    "\<And>i. i \<in> N \<Longrightarrow> codomain (\<psi> i) = ball 0 3"
    "carrier = (\<Union>i\<in>N. U i)"
    by (auto simp: regular_cover_def U_def)

  have open_W: "open (W i)" if "i \<in> N" for i
    using that
    by (auto simp: W_def regular_cover)
  have W_eq: "domain (\<psi> i) = W i" if "i \<in> N" for i
    using W_def regular_cover(4) that by force

  have carrier_W: "carrier = (\<Union>i\<in>N. W i)"
    by (auto simp: regular_cover W_eq)

  have V_subset_W: "closure (V i) \<subseteq> W i" if "i \<in> N" for i
  proof -
    have "closure (V i) \<subseteq> closure (inv_chart (\<psi> i) ` cball 0 2)"
      unfolding V_def
      by (rule closure_mono) auto
    also have "\<dots> = inv_chart (\<psi> i) ` cball 0 2"
      apply (rule closure_closed)
      apply (rule compact_imp_closed)
      apply (rule compact_continuous_image)
      by (auto intro!: continuous_intros simp: regular_cover that)
    also have "\<dots> \<subseteq> W i"
      by (auto simp: W_def)
    finally show ?thesis .
  qed

  have carrier_V: "carrier = (\<Union>i\<in>N. V i)"
    apply (rule antisym)
    subgoal unfolding regular_cover(5) by (auto simp: U_def V_def)
    subgoal unfolding carrier_W using V_subset_W by auto
    done

  define f where "f i x = (if x \<in> W i then H (\<psi> i x) else 0)" for i x
  have f_simps: "x \<in> W i \<Longrightarrow> f i x = H (\<psi> i x)"
    "x \<notin> W i \<Longrightarrow> f i x = 0"
    for i x
    by (auto simp: f_def)

  have f_eq_one: "f j y = 1" if "j \<in> N" "y \<in> U j" for j y
  proof -
    from that have "y \<in> W j" by (auto simp: U_def W_def)
    from \<open>y \<in> U j\<close> have "norm (\<psi> j y) \<le> 1"
      by (auto simp: U_def W_eq[symmetric] \<open>j \<in> N\<close> regular_cover(4))
    then show ?thesis
      by (auto simp: f_def \<open>y \<in> W j\<close> intro!: H_eq_one)
  qed

  have f_diff: "diff_fun k charts (f i)" if i: "i \<in> N" for i
  proof (rule manifold_eucl.diff_open_Un, unfold diff_fun_def[symmetric])
    note W_eq = W_eq[OF that]
    have "W i \<subseteq> carrier"
      unfolding W_eq[symmetric] regular_cover using that by auto
    interpret W: submanifold _ _ "W i"
      by unfold_locales (auto simp: open_W i)

    have "diff_fun k (charts_submanifold (W i)) (H \<circ> (\<psi> i))"
      apply (rule diff_fun_compose[where ?M2.0 = charts_eucl])
       apply (rule diff_apply_chart[of "\<psi> i", unfolded W_eq])
      subgoal using \<psi> \<open>i \<in> N\<close> by auto
      apply (rule diff_fun_charts_euclI)
      by (rule H_smooth_on)
    then show "diff_fun k (charts_submanifold (W i)) (f i)"
      by (rule diff_fun.diff_fun_cong) (auto simp: f_def)

    interpret V': submanifold _ _ "carrier - closure (V i)"
      by unfold_locales auto

    have "diff_fun k (charts_submanifold (carrier - closure (V i))) 0"
      by (rule V'.sub.diff_fun_zero)
    then show "diff_fun k (charts_submanifold (carrier - closure (V i))) (f i)"
      apply (rule diff_fun.diff_fun_cong)
      unfolding f_def
      apply auto
      apply (rule H_eq_zero)
      unfolding V_def by (metis W_eq image_eqI in_closureI inv_chart_inverse)
    show "open (W i)" by (auto simp: W_def regular_cover i)
    show "open (carrier - closure (V i))" by auto
    show "carrier \<subseteq> W i \<union> (carrier - closure (V i))"
      using V_subset_W[OF i] by auto
  qed

  define g where "g \<psi> x = f \<psi> x / (\<Sum>i\<in>{j\<in>N. x \<in> W j}. f i x)" for \<psi> x

  have "\<forall>p\<in>carrier. \<exists>I. p \<in> I \<and> open I \<and>finite {i \<in> N. W i \<inter> I \<noteq> {}}"
    (is "\<forall>p\<in>carrier. ?P p")
  proof (rule ballI)
    fix p assume "p \<in> carrier"
    from locally_finite_onE[OF regular_cover(3) this]
    obtain I where "p \<in> I" "open I" "finite {i \<in> N. (domain \<circ> \<psi>) i \<inter> I \<noteq> {}}".
    moreover have "{i \<in> N. (domain \<circ> \<psi>) i \<inter> I \<noteq> {}} = {i \<in> N. W i \<inter> I \<noteq> {}}"
      by (auto simp: W_eq)
    ultimately show "?P p" by auto
  qed
  from bchoice[OF this] obtain I where I:
    "\<And>x. x \<in> carrier \<Longrightarrow> x \<in> I x"
    "\<And>x. x \<in> carrier \<Longrightarrow> open (I x)"
    "\<And>x. x \<in> carrier \<Longrightarrow> finite {i \<in> N. W i \<inter> I x \<noteq> {}}"
    by blast

  have subset_W: "{j \<in> N. y \<in> W j} \<subseteq> {j \<in> N. W j \<inter> I x \<noteq> {}}" if "y \<in> I x" "x \<in> carrier" for x y
    by (auto simp: that W_eq)
  have finite_W: "finite {j \<in> N. y \<in> W j}" if "y \<in> carrier" for y
    apply (rule finite_subset)
     apply (rule subset_W[OF _ that])
     apply (rule I[OF that])
    apply (rule I[unfolded o_def, OF that])
    done

  have g: "diff_fun k charts (g i)" if i: "i \<in> N" for i
  proof (rule manifold_eucl.diff_localI, unfold diff_fun_def[symmetric])
    fix x assume x: "x \<in> carrier"
    show "open (I x)" "x \<in> I x" using I x by auto
    then interpret submanifold _ _ "I x"
      by unfold_locales
    interpret df: diff_fun k charts "f i" by (rule f_diff) fact
    have "diff_fun k (charts_submanifold (I x)) (\<lambda>y. f i y / (\<Sum>j\<in>{j\<in>N. W j \<inter> I x \<noteq> {}}. f j y))"
      apply (rule sub.diff_fun_divide)
      subgoal
        apply (rule df.diff_submanifold[folded diff_fun_def])
        by (rule I) fact
      subgoal
      proof (rule sub.diff_fun_sum, clarsimp)
        fix j assume "j \<in> N" "W j \<inter> I x \<noteq> {}"
        interpret df': diff_fun k charts "f j" by (rule f_diff) fact
        show "diff_fun k (charts_submanifold (I x)) (f j)"
          apply (rule df'.diff_fun_submanifold)
          by (rule I) fact
      qed
      subgoal for y
        apply (subst sum_nonneg_eq_0_iff)
        subgoal using I(3)[OF x] by auto
        subgoal using H_range by (auto simp: f_def)
        subgoal
        proof clarsimp
          assume y: "y \<in> I x" "y \<in> carrier"
          then obtain j where "j \<in> N" "y \<in> U j"
            unfolding regular_cover(5) by auto
          then have "y \<in> W j"
            by (auto simp: U_def W_def)
          moreover
          have "W j \<inter> I x \<noteq> {}"
            using W_eq \<open>j \<in> N\<close> \<open>open (I x)\<close> \<open>y \<in> W j\<close> \<open>y \<in> carrier\<close> \<open>y \<in> I x\<close>
            by auto
          moreover
          note f_eq_one[OF \<open>j \<in> N\<close> \<open>y \<in> U j\<close>]
          ultimately show "\<exists>xa. xa \<in> N \<and> W xa \<inter> I x \<noteq> {} \<and> f xa y \<noteq> 0"
            by (intro exI[where x=j]) (auto simp: \<open>j \<in> N\<close>)
        qed
        done
      done
    then show "diff_fun k (charts_submanifold (I x)) (g i)"
      apply (rule diff_fun.diff_fun_cong)
      unfolding g_def
      apply simp
      apply (rule disjI2)
      apply (rule sum.mono_neutral_right)
      subgoal using I[OF \<open>x \<in> carrier\<close>] unfolding o_def by simp
      subgoal for y
        apply (rule subset_W)
        using carrier_submanifold I \<open>x \<in> carrier\<close> by auto
      subgoal by (auto simp: f_def)
      done
  qed

  have f_nonneg: "0 \<le> f i x" for i x
    by (auto simp: f_def H_range intro!: sum_nonneg)

  have U_sub_W: "x \<in> U i \<Longrightarrow> x \<in> W i" for x i
    by (auto simp: U_def W_def)

  have sumf_pos: "(\<Sum>i\<in>{j \<in> N. x \<in> W j}. f i x) > 0" if "x \<in> carrier" for x
    (* and this sum is smooth, use to simplify earlier reasoning! *)
    using that
    apply (auto simp: regular_cover(5))
    subgoal for i
      apply (rule sum_pos2[where i=i])
      using finite_W[OF that]
      by (auto simp: f_nonneg f_eq_one U_sub_W )
    done

  have sumf_nonneg: "(\<Sum>i\<in>{j \<in> N. x \<in> W j}. f i x) \<ge> 0" for x
    by (auto simp: f_nonneg intro!: sum_nonneg)

  have g_nonneg: "0 \<le> g i x" if "i \<in> N" "x \<in> carrier" for i x
    by (auto simp: g_def intro!: divide_nonneg_nonneg sumf_nonneg f_nonneg)

  have g_le_one: "g i x \<le> 1" if "i \<in> N" "x \<in> carrier" for i x
    apply (auto simp add: g_def) (*sumf is positive*)
    apply (cases "(\<Sum>i\<in>{j \<in> N. x \<in> W j}. f i x) = 0")
    subgoal by simp
    apply (subst divide_le_eq_1_pos)
    subgoal using sumf_nonneg[of x] by auto
    apply (cases "x \<in> W i")
    subgoal
      apply (rule member_le_sum)
      subgoal using \<open>i \<in> N\<close> by simp
      subgoal by (rule f_nonneg)
      using sum.infinite by blast
    subgoal by (simp add: f_simps sum_nonneg H_range)
    done
  have sum_g: "(\<Sum>i | i \<in> N \<and> x \<in> W i. g i x) = 1" if "x \<in> carrier" for x
    unfolding g_def
    apply (subst sum_divide_distrib[symmetric])
    using sumf_pos[OF that]
    by auto

  have "\<exists>a. \<forall>i\<in>N. W i \<subseteq> X (a i) \<and> a i \<in> A"
    using \<psi>(2) by (intro bchoice) (auto simp: refines_def W_eq)
  then obtain a where a: "\<And>i. i \<in> N \<Longrightarrow> W i \<subseteq> X (a i)" "\<And>i. i \<in> N \<Longrightarrow> a i \<in> A"
    by force

  define \<phi> where "\<phi> \<alpha> x = (\<Sum>i | i \<in> N \<and> a i = \<alpha> \<and> x \<in> W i. g i x)" for \<alpha> x

  have "diff_fun k charts (\<phi> \<alpha>)" if "\<alpha> \<in> A" for \<alpha>
  proof (rule manifold_eucl.diff_localI, unfold diff_fun_def[symmetric])
    (* extract the lemma here?! *)
    fix x assume x: "x \<in> carrier"
    show "open (I x)" "x \<in> I x" using I x by auto
    then interpret submanifold _ _ "I x"
      by unfold_locales
    have "diff_fun k (charts_submanifold (I x)) (\<lambda>y. (\<Sum>i | i \<in> N \<and> a i = \<alpha> \<and> W i \<inter> I x \<noteq> {}. g i y))"
      apply (rule sub.diff_fun_sum, clarsimp)
      subgoal premises prems for i
      proof -
        interpret dg: diff_fun k charts "g i" by (rule g) fact
        show ?thesis
          apply (rule dg.diff_fun_submanifold)
          by (rule I) fact
      qed
      done
    then show "diff_fun k (charts_submanifold (I x)) (\<phi> \<alpha>)"
      apply (rule diff_fun.diff_fun_cong)
      unfolding \<phi>_def
      apply (rule sum.mono_neutral_right)
      subgoal using _ I(3)[OF \<open>x \<in> carrier\<close>] by (rule finite_subset) (auto simp:)
      subgoal using \<open>open (I x)\<close> carrier_submanifold by auto
      subgoal by (auto simp: g_def f_def)
      done
  qed
  moreover
  have "0 \<le> \<phi> \<alpha> x" if "x \<in> carrier" for \<alpha> x
    by (auto simp: \<phi>_def intro!: sum_nonneg g_nonneg that)
  moreover
  have "\<phi> \<alpha> x \<le> 1" if "\<alpha> \<in> A" "x \<in> carrier" for \<alpha> x
  proof -
    have "\<phi> \<alpha> x \<le> (\<Sum>i | i \<in> N \<and> x \<in> W i. g i x)"
      unfolding \<phi>_def
      by (rule sum_mono2[OF finite_W]) (auto simp: intro!: g_nonneg \<open>x \<in> carrier\<close>)
    also have "\<dots> = 1"
      by (rule sum_g) fact
    finally show ?thesis .
  qed
  moreover
  have "(\<Sum>\<alpha>\<in>{\<alpha>\<in>A. \<phi> \<alpha> x \<noteq> 0}. \<phi> \<alpha> x) = 1" if "x \<in> carrier" for x
  proof -
    have "(\<Sum>\<alpha> | \<alpha> \<in> A \<and> \<phi> \<alpha> x \<noteq> 0. \<phi> \<alpha> x) =
      (\<Sum>\<alpha> | \<alpha> \<in> A \<and> \<phi> \<alpha> x \<noteq> 0. \<Sum>i | i \<in> N \<and> a i = \<alpha> \<and> x \<in> W i. g i x)"
      unfolding \<phi>_def ..
    also have "\<dots> = (\<Sum>(\<alpha>, i)\<in>(SIGMA xa:{\<alpha> \<in> A. \<phi> \<alpha> x \<noteq> 0}. {i \<in> N. a i = xa \<and> x \<in> W i}). g i x)"
      apply (rule sum.Sigma)
      subgoal
        apply (rule finite_subset[where B="a ` {j \<in> N. x \<in> W j}"])
        subgoal
          apply (auto simp: \<phi>_def)
          apply (subst (asm) sum_nonneg_eq_0_iff)
          subgoal using _ finite_W[OF \<open>x \<in> carrier\<close>] by (rule finite_subset) auto
          subgoal by (rule g_nonneg[OF _ \<open>x \<in> carrier\<close>]) auto
          subgoal by auto
          done
        subgoal
          using finite_W[OF \<open>x \<in> carrier\<close>] by (rule finite_imageI)
        done
      subgoal
        apply (auto)
        using _ finite_W[OF \<open>x \<in> carrier\<close>]
        by (rule finite_subset) auto
      done
    also have "\<dots> = (\<Sum>i\<in>snd ` (SIGMA xa:{\<alpha> \<in> A. \<phi> \<alpha> x \<noteq> 0}. {i \<in> N. a i = xa \<and> x \<in> W i}). g i x)"
      apply (rule sum.reindex_cong[where l="\<lambda>i. (a i, i)"])
      subgoal by (auto simp: inj_on_def)
      subgoal
        apply (auto simp: a)
        apply (auto simp: \<phi>_def)
        apply (subst (asm) sum_nonneg_eq_0_iff)
        subgoal
          using _ finite_W[OF \<open>x \<in> carrier\<close>]
          by (rule finite_subset) auto
        subgoal by (auto intro!: g_nonneg \<open>x \<in> carrier\<close>)
        subgoal for i
          apply auto
          subgoal for yy
            apply (rule imageI)
            apply (rule image_eqI[where x="(a i, i)"])
             apply (auto intro!: a)
            apply (subst (asm) sum_nonneg_eq_0_iff)
            subgoal using _ finite_W[OF \<open>x \<in> carrier\<close>] by (rule finite_subset) auto
            subgoal by (rule g_nonneg[OF _ \<open>x \<in> carrier\<close>]) auto
            subgoal by auto
            done
          done
        done
      subgoal by auto
      done
    also have "\<dots> = (\<Sum>i | i \<in> N \<and> x \<in> W i. g i x)"
      apply (rule sum.mono_neutral_left)
      subgoal by (rule finite_W) fact
      subgoal by auto
      subgoal
        apply (auto simp: Sigma_def image_iff a)
        apply (auto simp: \<phi>_def)
        subgoal
          apply (subst (asm) sum_nonneg_eq_0_iff)
          subgoal using _ finite_W[OF \<open>x \<in> carrier\<close>] by (rule finite_subset) auto
          subgoal by (rule g_nonneg[OF _ \<open>x \<in> carrier\<close>]) auto
          subgoal by auto
          done
        done
      done
    also have "\<dots> = 1" by (rule sum_g) fact
    finally show ?thesis .
  qed
  moreover
  have g_supp_le_V: "support_on carrier (g i) \<subseteq> V i" if "i \<in> N" for i
    apply (auto simp: support_on_def g_def f_def V_def dest!: H_neq_zeroD)
    apply (rule image_eqI[OF ])
     apply (rule inv_chart_inverse[symmetric])
     apply (simp add: W_eq that)
    apply simp
    done
  then have clsupp_g_le_W: "closure (support_on carrier (g i)) \<subseteq> W i" if "i \<in> N" for i
    unfolding csupport_on_def
    using V_subset_W closure_mono that
    by blast
  then have csupp_g_le_W: "csupport_on carrier (g i) \<subseteq> W i" if "i \<in> N" for i
    using that
    by (auto simp: csupport_on_def)
  have *: "{i \<in> N. domain (\<psi> i) \<inter> Na \<noteq> {}} = {i \<in> N. W i \<inter> Na \<noteq> {}}" for Na
    by (auto simp: W_eq)
  then have lfW: "locally_finite_on carrier N W"
    using regular_cover(3) by (simp add: locally_finite_on_def)
  then have lf_supp_g: "locally_finite_on carrier {i \<in> N. a i = \<alpha>} (\<lambda>i. support_on carrier (g i))" if "\<alpha> \<in> A" for \<alpha>
    apply (rule locally_finite_on_subset)
    using g_supp_le_V V_subset_W
    by force+
  have "csupport_on carrier (\<phi> \<alpha>) \<inter> carrier \<subseteq> X \<alpha>" if "\<alpha> \<in> A" for \<alpha>
  proof -
    have *: "closure (\<Union>i\<in>{i \<in> N. a i = \<alpha>}. support_on carrier (g i)) \<subseteq> closure (\<Union>i\<in>N. V i)"
      by (rule closure_mono) (use g_supp_le_V in auto)
    have "support_on carrier (\<phi> \<alpha>) \<subseteq> (\<Union>i\<in>{i \<in> N. a i = \<alpha>}. support_on carrier (g i))"
      unfolding \<phi>_def[abs_def]
      apply (rule order_trans)
       apply (rule support_on_nonneg_sum_subset')
      using g_supp_le_V
      by (auto simp: carrier_V)
    then have "csupport_on carrier (\<phi> \<alpha>) \<inter> carrier \<subseteq> closure \<dots> \<inter> carrier"
      unfolding csupport_on_def using closure_mono by auto
    also have "\<dots> = (\<Union>i\<in>{i \<in> N. a i = \<alpha>}. closure (support_on carrier (g i)))"
      apply (rule locally_finite_on_closure_Union[OF lf_supp_g[OF that], symmetric])
      using closure_mono[OF g_supp_le_V] V_subset_W
      by (force simp: carrier_W)
    also have "\<dots> \<subseteq> (\<Union>i\<in>{i \<in> N. a i = \<alpha>}. W i)"
      apply (rule UN_mono)
      using clsupp_g_le_W
      by auto
    also have "\<dots> \<subseteq> X \<alpha>"
      using a
      by auto
    finally show ?thesis .
  qed
  moreover
  have "locally_finite_on carrier A (\<lambda>i. support_on carrier (\<phi> i))"
  proof (rule locally_finite_onI)
    fix p assume "p \<in> carrier"
    from locally_finite_onE[OF lfW this] obtain Nhd where Nhd: "p \<in> Nhd" "open Nhd" "finite {i \<in> N. W i \<inter> Nhd \<noteq> {}}" .
    show "\<exists>Nhd. p \<in> Nhd \<and> open Nhd \<and> finite {i \<in> A. support_on carrier (\<phi> i) \<inter> Nhd \<noteq> {}}"
      apply (rule exI[where x=Nhd])
      apply (auto simp: Nhd)
      apply (rule finite_subset[where B="a ` {i \<in> N. W i \<inter> Nhd \<noteq> {}}"])
      subgoal
        apply (auto simp: support_on_def \<phi>_def)
        apply (subst (asm) sum_nonneg_eq_0_iff)
          apply (auto simp: intro!: g_nonneg)
        using _ finite_W by (rule finite_subset) auto
      by (rule finite_imageI) fact
  qed
  then have "locally_finite_on carrier A (\<lambda>i. csupport_on carrier (\<phi> i))"
    unfolding csupport_on_def
    by (rule locally_finite_on_closure)
  ultimately show ?thesis ..
qed

text \<open>Given \<open>A \<subseteq> U \<subseteq> carrier\<close>, where \<open>A\<close> is closed and \<open>U\<close> is open, there exists
  a differentiable function \<open>\<psi>\<close> such that \<open>0 \<le> \<psi> \<le> 1\<close>, \<open>\<psi> = 1\<close> on \<open>A\<close>, and the
  support of \<open>\<psi>\<close> is contained in \<open>U\<close>.\<close>
lemma smooth_bump_functionE:
  assumes "closedin (top_of_set carrier) A"
    and "A \<subseteq> U" "U \<subseteq> carrier" "open U"
  obtains \<psi>::"'a \<Rightarrow> real" where
    "diff_fun k charts \<psi>"
    "\<And>x. x \<in> carrier \<Longrightarrow> 0 \<le> \<psi> x"
    "\<And>x. x \<in> carrier \<Longrightarrow> \<psi> x \<le> 1"
    "\<And>x. x \<in> A \<Longrightarrow> \<psi> x = 1"
    "csupport_on carrier \<psi> \<inter> carrier \<subseteq> U"
proof -
  define V where "V x = (if x = 0 then U else carrier - A)" for x::nat
  have "open (carrier - A)"
    using assms
    by (metis closedin_def open_Int open_carrier openin_open topspace_euclidean_subtopology)
  then have V: "carrier \<subseteq> (\<Union>i\<in>{0, 1}. V i)" "i \<in> {0, 1} \<Longrightarrow> open (V i)" for i
    using assms
    by (auto simp: V_def)
  obtain \<phi>::"nat \<Rightarrow> 'a \<Rightarrow> real" where \<phi>:
    "(\<And>i. i \<in> {0, 1} \<Longrightarrow> diff_fun k charts (\<phi> i))"
    "(\<And>i x. i \<in> {0, 1} \<Longrightarrow> x \<in> carrier \<Longrightarrow> 0 \<le> \<phi> i x)"
    "(\<And>i x. i \<in> {0, 1} \<Longrightarrow> x \<in> carrier \<Longrightarrow> \<phi> i x \<le> 1)"
    "(\<And>x. x \<in> carrier \<Longrightarrow> (\<Sum>i | i \<in> {0, 1} \<and> \<phi> i x \<noteq> 0. \<phi> i x) = 1)"
    "(\<And>i. i \<in> {0, 1} \<Longrightarrow> csupport_on carrier (\<phi> i) \<inter> carrier \<subseteq> V i)"
    "locally_finite_on carrier {0, 1} (\<lambda>i. csupport_on carrier (\<phi> i))"
    by (rule partitions_of_unityE[OF V]) auto
  from this(1-3,5)[of 0] this(6)
  have "diff_fun k charts (\<phi> 0)"
    "\<And>x. x \<in> carrier \<Longrightarrow> 0 \<le> \<phi> 0 x"
    "\<And>x. x \<in> carrier \<Longrightarrow> \<phi> 0 x \<le> 1"
    "csupport_on carrier (\<phi> 0) \<inter> carrier \<subseteq> U"
    by (auto simp: V_def)
  moreover have "\<phi> 0 x = 1" if "x \<in> A" for x
  proof -
    from that have "x \<in> carrier" using assms by auto
    from \<phi>(4)[OF this]
    have "1 = (\<Sum>i | i \<in> {0, 1} \<and> \<phi> i x \<noteq> 0. \<phi> i x)"
      by auto
    moreover have "{i. i \<in> {0, 1} \<and> \<phi> i x \<noteq> 0} =
      (if \<phi> 0 x \<noteq> 0 then {0} else {}) \<union> (if \<phi> 1 x \<noteq> 0 then {1} else {})"
      apply auto
      using neq0_conv by blast
    moreover have "x \<notin> V 1"
      using that
      by (auto simp: V_def)
    then have "\<phi> (Suc 0) x = 0"
      using \<phi>(5)[of 1] assms that
      by (auto simp: support_on_def csupport_on_def)
    ultimately show ?thesis by (auto split: if_splits)
  qed
  ultimately show ?thesis by (blast intro: that)
qed

definition "diff_fun_on A f \<longleftrightarrow>
  (\<exists>W. A \<subseteq> W \<and> W \<subseteq> carrier \<and> open W \<and>
    (\<exists>f'. diff_fun k (charts_submanifold W) f' \<and> (\<forall>x\<in>A. f x = f' x)))"

lemma diff_fun_onE:
  assumes "diff_fun_on A f"
  obtains W f' where
    "A \<subseteq> W" "W \<subseteq> carrier" "open W" "diff_fun k (charts_submanifold W) f'"
    "\<And>x. x \<in> A \<Longrightarrow> f x = f' x"
  using assms by (auto simp: diff_fun_on_def)

lemma diff_fun_onI:
  assumes  "A \<subseteq> W" "W \<subseteq> carrier" "open W" "diff_fun k (charts_submanifold W) f'"
    "\<And>x. x \<in> A \<Longrightarrow> f x = f' x"
  shows "diff_fun_on A f"
  using assms by (auto simp: diff_fun_on_def)

text \<open>Extension lemma:

  Given \<open>A \<subseteq> U \<subseteq> carrier\<close>, where \<open>A\<close> is closed and \<open>U\<close> is open, and a differentiable
  function \<open>f\<close> on \<open>A\<close>, there exists a differentiable function \<open>f'\<close> agreeing with \<open>f\<close>
  on \<open>A\<close>, and where the support of \<open>f'\<close> is contained in \<open>U\<close>.\<close>
lemma extension_lemmaE:
  fixes f::"'a \<Rightarrow> 'e::euclidean_space"
  assumes "closedin (top_of_set carrier) A"
  assumes "diff_fun_on A f" "A \<subseteq> U" "U \<subseteq> carrier" "open U"
  obtains f' where
    "diff_fun k charts f'"
    "\<And>x. x \<in> A \<Longrightarrow> f' x = f x"
    "csupport_on carrier f' \<inter> carrier \<subseteq> U"
proof -
  from diff_fun_onE[OF assms(2)]
  obtain W' f' where W': "A \<subseteq> W'" "W' \<subseteq> carrier" "open W'" "diff_fun k (charts_submanifold W') f'"
    "(\<And>x. x \<in> A \<Longrightarrow> f x = f' x)"
    by blast
  define W where "W = W' \<inter> U"

  interpret W': diff_fun k "charts_submanifold W'" f' using W' by auto
  have *: "open (W' \<inter> U)"
    using W' assms by auto
  with W'.diff_fun_submanifold[of W]
  have "diff_fun k (W'.src.charts_submanifold (W' \<inter> U)) f'"
    by (auto simp: W_def)
  also have "W'.src.charts_submanifold (W' \<inter> U) = charts_submanifold (W' \<inter> U)"
    unfolding W'.src.charts_submanifold_def
    unfolding charts_submanifold_def
    using W' *
    by (auto simp: image_image restrict_chart_restrict_chart ac_simps)
  finally have "diff_fun k (charts_submanifold (W' \<inter> U)) f'" .
  with W' assms
  have W: "A \<subseteq> W" "W \<subseteq> carrier" "open W" "diff_fun k (charts_submanifold W) f'"
    "(\<And>x. x \<in> A \<Longrightarrow> f x = f' x)"
    by (auto simp: W_def)

  interpret submanifold _ _ W by unfold_locales fact
  interpret W: diff_fun k "(charts_submanifold W)" f' using W by auto
  have [simp]: "sub.carrier = W" using \<open>W \<subseteq> carrier\<close> by auto
  have "W \<subseteq> U" by (auto simp: W_def)

  from smooth_bump_functionE[OF assms(1) \<open>A \<subseteq> W\<close> \<open>W \<subseteq> carrier\<close> \<open>open W\<close>]
  obtain \<phi>::"'a\<Rightarrow>real" where \<phi>: "diff_fun k charts \<phi>"
    "(\<And>x. x \<in> carrier \<Longrightarrow> 0 \<le> \<phi> x)" "(\<And>x. x \<in> carrier \<Longrightarrow> \<phi> x \<le> 1)" "(\<And>x. x \<in> A \<Longrightarrow> \<phi> x = 1)"
    "csupport_on carrier \<phi> \<inter> carrier \<subseteq> W" by blast

  interpret \<phi>: diff_fun k charts \<phi> by fact

  define g where "g p = (if p \<in> W then \<phi> p *\<^sub>R f' p else 0)" for p

  thm sub.diff_fun_scaleR
  have "diff_fun k charts g"
  proof (rule manifold_eucl.diff_open_Un, unfold diff_fun_def[symmetric])
    have "diff_fun k (charts_submanifold W) (\<lambda>p. \<phi> p *\<^sub>R f' p)"
      by (auto intro!: sub.diff_fun_scaleR \<phi>.diff_fun_submanifold W)
    then show "diff_fun k (charts_submanifold W) g"
      by (rule diff_fun.diff_fun_cong) (auto simp: g_def)
    interpret C: submanifold _ _ "carrier - csupport_on carrier \<phi>"
      by unfold_locales auto

    have sub_carrier[simp]: "C.sub.carrier = carrier - csupport_on carrier \<phi>"
      by auto

    have "diff_fun k (charts_submanifold (carrier - csupport_on carrier \<phi>)) 0"
      by (rule C.sub.diff_fun_zero)
    then show "diff_fun k (charts_submanifold (carrier - csupport_on carrier \<phi>)) g"
      by (rule diff_fun.diff_fun_cong) (auto simp: g_def not_in_csupportD)
    show "open W" by fact
    show "open (carrier - csupport_on carrier \<phi>)"
      by (auto)
    show "carrier \<subseteq> W \<union> (carrier - csupport_on carrier \<phi>)"
      using \<phi>
      by auto
  qed
  moreover have "\<And>x. x \<in> A \<Longrightarrow> g x = f x"
    using \<open>A \<subseteq> W\<close>
    by (auto simp: g_def \<phi> W')
  moreover have "csupport_on carrier g \<inter> carrier  \<subseteq> U"
  proof -
    have "csupport_on carrier g \<subseteq> csupport_on carrier \<phi>"
      by (rule csupport_on_mono) (auto simp: g_def[abs_def] split: if_splits)
    also have "\<dots>  \<inter> carrier \<subseteq> U"
      using \<phi>(5) \<open>W \<subseteq> U\<close> \<open>W \<subseteq> carrier\<close> \<open>U \<subseteq> carrier\<close>
      by auto
    finally show ?thesis by auto
  qed
  ultimately show ?thesis ..
qed

end

end


(* Title:      Generalised Hoare Logic for Kleene Algebra
   Author:     Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Propositional Hoare Logic for Conway and Kleene Algebra\<close>

theory PHL_KA
  imports Kleene_Algebra

begin

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

text \<open>This is a minimalist Hoare logic developed in the context of pre-dioids. In near-dioids, the sequencing rule would not be derivable.
 Iteration is modelled by a function that needs to satisfy a simulation law.

The main assumtions on pre-dioid elements needed to derive the Hoare rules are preservation properties; an additional distributivity propery is needed
for the conditional rule.

This Hoare logic can be instantated in various ways. It covers notions of
finite and possibly infinite iteration. In this theory, it it specialised to Conway and Kleene algebras.\<close>

class it_pre_dioid = pre_dioid_one +
  fixes it :: "'a \<Rightarrow> 'a"
  assumes it_simr: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> y \<cdot> it x \<le> it x \<cdot> y"

begin

lemma phl_while:
  assumes "p \<cdot> s \<le> s \<cdot> p \<cdot> s" and "p \<cdot> w \<le> w \<cdot> p \<cdot> w"
  and  "(p \<cdot> s) \<cdot> x \<le> x \<cdot> p"
  shows "p \<cdot> (it (s \<cdot> x) \<cdot> w)  \<le> it (s \<cdot> x) \<cdot> w \<cdot> (p \<cdot> w)"
proof -
  have "p \<cdot> s \<cdot> x \<le> s \<cdot> x \<cdot> p"
    by (metis assms(1) assms(3) mult.assoc phl_export1)
  hence "p \<cdot> it (s \<cdot> x) \<le> it (s \<cdot> x) \<cdot> p"
    by (simp add: it_simr mult.assoc)
  thus ?thesis
    using assms(2) phl_export2 by blast
qed

end

text \<open>Next we define a Hoare triple to make the format of the rules more explicit.\<close>

context pre_dioid_one
begin

abbreviation (in near_dioid) ht :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("\<lbrace>_\<rbrace>_\<lbrace>_\<rbrace>") where
  "\<lbrace>x\<rbrace> y \<lbrace>z\<rbrace> \<equiv> x \<cdot> y \<le> y \<cdot> z"

lemma ht_phl_skip: "\<lbrace>x\<rbrace> 1 \<lbrace>x\<rbrace>"
  by simp

lemma ht_phl_cons1: "x \<le> w \<Longrightarrow> \<lbrace>w\<rbrace> y \<lbrace>z\<rbrace> \<Longrightarrow> \<lbrace>x\<rbrace> y \<lbrace>z\<rbrace>"
  by (fact phl_cons1)

lemma ht_phl_cons2: "w \<le> x \<Longrightarrow> \<lbrace>z\<rbrace> y \<lbrace>w\<rbrace> \<Longrightarrow> \<lbrace>z\<rbrace> y \<lbrace>x\<rbrace>"
  by (fact phl_cons2)

lemma ht_phl_seq: "\<lbrace>p\<rbrace> x \<lbrace>r\<rbrace> \<Longrightarrow> \<lbrace>r\<rbrace> y \<lbrace>q\<rbrace> \<Longrightarrow> \<lbrace>p\<rbrace> x \<cdot> y \<lbrace>q\<rbrace>"
  by (fact phl_seq)

lemma ht_phl_cond:
assumes "u \<cdot> v \<le> v \<cdot> u \<cdot> v" and "u \<cdot> w \<le> w \<cdot> u \<cdot> w"
and "\<And>x y. u \<cdot> (x + y) \<le> u \<cdot> x + u \<cdot> y"
and "\<lbrace>u \<cdot> v\<rbrace> x \<lbrace>z\<rbrace>" and "\<lbrace>u \<cdot> w\<rbrace> y \<lbrace>z\<rbrace>"
shows "\<lbrace>u\<rbrace> (v \<cdot> x + w \<cdot> y) \<lbrace>z\<rbrace>"
  using assms by (fact phl_cond)

lemma  ht_phl_export1:
assumes "x \<cdot> y \<le> y \<cdot> x \<cdot> y"
and "\<lbrace>x \<cdot> y\<rbrace> z \<lbrace>w\<rbrace>"
shows "\<lbrace>x\<rbrace> y \<cdot> z \<lbrace>w\<rbrace>"
  using assms by (fact phl_export1)

lemma ht_phl_export2:
assumes "z \<cdot> w \<le> w \<cdot> z \<cdot> w"
and "\<lbrace>x\<rbrace> y \<lbrace>z\<rbrace>"
shows "\<lbrace>x\<rbrace> y \<cdot> w \<lbrace>z \<cdot> w\<rbrace>"
  using assms by (fact phl_export2)

end

context it_pre_dioid begin

lemma ht_phl_while:
assumes "p \<cdot> s \<le> s \<cdot> p \<cdot> s" and "p \<cdot> w \<le> w \<cdot> p \<cdot> w"
and  "\<lbrace>p \<cdot> s\<rbrace> x \<lbrace>p\<rbrace>"
shows "\<lbrace>p\<rbrace> it (s \<cdot> x) \<cdot> w \<lbrace>p \<cdot> w\<rbrace>"
  using assms by (fact phl_while)

end

sublocale pre_conway < phl: it_pre_dioid where it = dagger
  by standard (simp add: local.dagger_simr)

sublocale kleene_algebra < phl: it_pre_dioid where it = star ..

end


theory Exe3p3
  imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_post: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(auto simp add: refl step)
  done

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(auto simp add: step)
  done

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma "star' r x y \<Longrightarrow> star r x y"
  apply(induction rule: star'.induct)
   apply(auto simp add: refl step star_post)
  done

thm step'

lemma star'_one: "r x y \<Longrightarrow> star' r x y"
  apply(rule step'[where ?y = "x" and ?z = "y"])
  by (auto simp add: refl')

lemma "star' r xa y \<Longrightarrow>
       r y z \<Longrightarrow>
       (r x xa \<Longrightarrow> star' r x y) \<Longrightarrow> r x xa \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
   apply(auto simp add: refl' step')
  done

lemma star'_pre: "r x y \<Longrightarrow> star' r y z \<Longrightarrow> star' r x z"
  oops

lemma star'_trans: "star' r x y \<Longrightarrow> star' r y z \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
   apply(assumption)
  oops

lemma "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
   apply(auto simp add: refl' step')
  oops

end


subsection\<open>Rivest Commitment Scheme\<close>

text\<open>The Rivest commitment scheme was first introduced in \cite{rivest1999}. We note however the original
scheme did not allow for perfect hiding. This was pointed out by Blundo and Masucci in \cite{DBLP:journals/dcc/BlundoMSW02}
who alightly ammended the commitment scheme so that is provided perfect hiding.

The Rivest commitment scheme uses a trusted initialiser to provide correlated randomness to the two parties
before an execution of the protocol. In our framework we set these as keys that held by the respective parties.\<close>

theory Rivest imports
  Commitment_Schemes
  "HOL-Number_Theory.Cong"
  CryptHOL.CryptHOL
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
begin

locale rivest =
  fixes q :: nat
  assumes prime_q: "prime q"
begin

lemma q_gt_0 [simp]: "q > 0"
  by (simp add: prime_q prime_gt_0_nat)

type_synonym ck = "nat \<times> nat"
type_synonym vk = "nat \<times> nat"
type_synonym plain = "nat"
type_synonym commit = "nat"
type_synonym opening = "nat \<times> nat"

definition key_gen :: "(ck \<times> vk) spmf"
  where
    "key_gen = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    x1 :: nat \<leftarrow> sample_uniform q;
    let y1 = (a * x1 + b) mod q;
    return_spmf ((a,b), (x1,y1))}"

definition commit :: "ck \<Rightarrow> plain \<Rightarrow> (commit \<times> opening) spmf"
  where
    "commit ck m = do {
  let (a,b) = ck;
  return_spmf ((m + a) mod q, (a,b))}"

fun verify :: "vk \<Rightarrow> plain \<Rightarrow> commit \<Rightarrow> opening \<Rightarrow> bool"
  where
    "verify (x1,y1) m c (a,b) = (((c = (m + a) mod q)) \<and> (y1 = (a * x1 + b) mod q))"

definition valid_msg :: "plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> msg \<in> {..< q}"

sublocale rivest_commit: abstract_commitment key_gen commit verify valid_msg .

lemma abstract_correct: "rivest_commit.correct"
  unfolding abstract_commitment.correct_def abstract_commitment.correct_game_def
  by(simp add: key_gen_def commit_def bind_spmf_const lossless_weight_spmfD)

lemma rivest_hiding: "(spmf (rivest_commit.hiding_game_ind_cpa \) True - 1/2 = 0)"
  including monad_normalisation
proof-
  note [simp] = Let_def split_def
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  have "rivest_commit.hiding_game_ind_cpa (\1, \2) = TRY do {
    a :: nat \<leftarrow> sample_uniform q;
    x1 :: nat \<leftarrow> sample_uniform q;
    y1 \<leftarrow> map_spmf (\<lambda> b. (a * x1 + b) mod q) (sample_uniform q);
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x1,y1);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    d \<leftarrow> coin_spmf;
    let c = ((if d then m0 else m1) + a) mod q;
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = d)} ELSE coin_spmf"
    unfolding abstract_commitment.hiding_game_ind_cpa_def
    by(simp add: commit_def key_gen_def o_def bind_map_spmf)
  also have "... = TRY do {
    a :: nat \<leftarrow> sample_uniform q;
    x1 :: nat \<leftarrow> sample_uniform q;
    y1 \<leftarrow> sample_uniform q;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x1,y1);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    d \<leftarrow> coin_spmf;
    let c = ((if d then m0 else m1) + a) mod q;
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = d)} ELSE coin_spmf"
    by(simp add: samp_uni_plus_one_time_pad)
  also have "... = TRY do {
    x1 :: nat \<leftarrow> sample_uniform q;
    y1 \<leftarrow> sample_uniform q;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x1,y1);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    d \<leftarrow> coin_spmf;
    c \<leftarrow> map_spmf (\<lambda> a. ((if d then m0 else m1) + a) mod q) (sample_uniform q);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = d)} ELSE coin_spmf"
    by(simp add: o_def bind_map_spmf)
  also have "... = TRY do {
    x1 :: nat \<leftarrow> sample_uniform q;
    y1 \<leftarrow> sample_uniform q;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x1,y1);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    d \<leftarrow> coin_spmf;
    c \<leftarrow> sample_uniform q;
    b' :: bool \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = d)} ELSE coin_spmf"
    by(simp add: samp_uni_plus_one_time_pad)
  also have "... = TRY do {
    x1 :: nat \<leftarrow> sample_uniform q;
    y1 \<leftarrow> sample_uniform q;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x1,y1);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    c :: nat \<leftarrow> sample_uniform q;
    guess :: bool \<leftarrow> \2 c \<sigma>;
    map_spmf((=) guess) coin_spmf} ELSE coin_spmf"
    by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
    by(simp add: map_eq_const_coin_spmf bind_spmf_const try_bind_spmf_lossless2'
        scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis
    by(simp add: spmf_of_set)
qed

lemma rivest_perfect_hiding: "rivest_commit.perfect_hiding_ind_cpa \"
  unfolding abstract_commitment.perfect_hiding_ind_cpa_def abstract_commitment.hiding_advantage_ind_cpa_def
  by(simp add: rivest_hiding)

lemma samp_uni_break':
  assumes fst_cond: "m \<noteq> m' \<and> valid_msg m \<and> valid_msg m'"
    and c: "c = (m + a) mod q \<and> y1 = (a * x1 + b) mod q"
    and  c': "c = (m' + a') mod q \<and> y1 = (a' * x1 + b') mod q"
    and x1: "x1 < q"
  shows "x1 = (if (a mod q > a' mod q) then nat ((int b'- int b) * (inverse (nat ((int a mod q - int a' mod q) mod q)) q) mod q)  else
          nat ((int b- int b') * (inverse (nat ((int a' mod q - int a mod q) mod q)) q) mod q))"
proof-
  have m: "m < q \<and> m' < q" using fst_cond valid_msg_def by simp
  have a_a': "\<not> [a = a'] (mod q)"
  proof-
    have "[m + a = m' + a'] (mod q)"
      using assms cong_def by blast
    thus ?thesis
      by (metis m fst_cond c c' add.commute cong_less_modulus_unique_nat cong_add_rcancel_nat cong_mod_right)
  qed
  have cong_y1: "[int a * int x1 + int b = int a' * int x1 + int b'] (mod q)"
    by (metis c c' cong_def Num.of_nat_simps(4) Num.of_nat_simps(5) cong_int_iff)
  show ?thesis
  proof(cases "a mod q > a' mod q")
    case True
    hence gcd: "gcd (nat ((int a mod q - int a' mod q) mod q)) q = 1"
    proof-
      have "((int a mod q - int a' mod q) mod q) \<noteq> 0"
        by (metis True comm_monoid_add_class.add_0 diff_add_cancel mod_add_left_eq mod_diff_eq nat_mod_as_int order_less_irrefl)
      moreover have "((int a mod q - int a' mod q) mod q) < q" by simp
      ultimately show ?thesis
        using prime_field[of q "nat ((int a mod int q - int a' mod int q) mod int q)"] prime_q
        by (smt Euclidean_Division.pos_mod_sign coprime_imp_gcd_eq_1 int_nat_eq nat_less_iff of_nat_0_less_iff q_gt_0)
    qed
    hence "[int a * int x1 - int a' * int x1 = int b'- int b] (mod q)"
      by (smt cong_diff_iff_cong_0 cong_y1 cong_diff cong_diff)
    hence "[int a mod q * int x1 - int a' mod q * int x1 = int b'- int b] (mod q)"
    proof -
      have "[int x1 * (int a mod int q - int a' mod int q) = int x1 * (int a - int a')] (mod int q)"
        by (meson cong_def cong_mult cong_refl mod_diff_eq)
      then show ?thesis
        by (metis (no_types, hide_lams) Groups.mult_ac(2) \<open>[int a * int x1 - int a' * int x1 = int b' - int b] (mod int q)\<close> cong_def mod_diff_left_eq mod_diff_right_eq mod_mult_right_eq)
    qed
    hence "[int x1 * (int a mod q - int a' mod q) = int b'- int b] (mod q)"
      by(metis int_distrib(3) mult.commute)
    hence "[int x1 * (int a mod q - int a' mod q) mod q = int b'- int b] (mod q)"
      using cong_def by simp
    hence "[int x1 * nat ((int a mod q - int a' mod q) mod q) = int b'- int b] (mod q)"
      by (simp add: True cong_def mod_mult_right_eq)
    hence "[int x1 * nat ((int a mod q - int a' mod q) mod q) * inverse (nat ((int a mod q - int a' mod q) mod q)) q
              = (int b'- int b) * inverse (nat ((int a mod q - int a' mod q) mod q)) q] (mod q)"
      using cong_scalar_right by blast
    hence "[int x1 * (nat ((int a mod q - int a' mod q) mod q) * inverse (nat ((int a mod q - int a' mod q) mod q)) q)
              = (int b'- int b) * inverse (nat ((int a mod q - int a' mod q) mod q)) q] (mod q)"
      by (simp add: more_arith_simps(11))
    hence "[int x1 * 1 = (int b'- int b) * inverse (nat ((int a mod q - int a' mod q) mod q)) q] (mod q)"
      using inverse gcd
      by (meson cong_scalar_left cong_sym_eq cong_trans)
    hence "[int x1 = (int b'- int b) * inverse (nat ((int a mod q - int a' mod q) mod q)) q] (mod q)"
      by simp
    hence "int x1 mod q = ((int b'- int b) * inverse (nat ((int a mod q - int a' mod q) mod q)) q) mod q"
      using cong_def by fast
    thus ?thesis using x1 True by simp
  next
    case False
    hence aa': "a mod q < a' mod q"
      using a_a' cong_refl nat_neq_iff
      by (simp add: cong_def)
    hence gcd: "gcd (nat ((int a' mod q - int a mod q) mod q)) q = 1"
    proof-
      have "((int a' mod q - int a mod q) mod q) \<noteq> 0"
        by (metis aa' comm_monoid_add_class.add_0 diff_add_cancel mod_add_left_eq mod_diff_eq nat_mod_as_int order_less_irrefl)
      moreover have "((int a' mod q - int a mod q) mod q) < q" by simp
      ultimately show ?thesis
        using prime_field[of q "nat ((int a' mod int q - int a mod int q) mod int q)"] prime_q
        by (smt Euclidean_Division.pos_mod_sign coprime_imp_gcd_eq_1 int_nat_eq nat_less_iff of_nat_0_less_iff q_gt_0)
    qed
    have "[int b - int b' = int a' * int x1 - int a * int x1] (mod q)"
      by (smt cong_diff_iff_cong_0 cong_y1 cong_diff cong_diff)
    hence "[int b - int b' = int x1 * (int a' - int a)] (mod q)"
      using int_distrib mult.commute by metis
    hence "[int b - int b' = int x1 * (int a' mod q - int a mod q)] (mod q)"
      by (metis (no_types, lifting) cong_def mod_diff_eq mod_mult_right_eq)
    hence "[int b - int b' = int x1 * (int a' mod q - int a mod q) mod q] (mod q)"
      using cong_def by simp
    hence "[(int b - int b') * inverse (nat ((int a' mod q - int a mod q) mod q)) q
               = int x1 * (int a' mod q - int a mod q) mod q *  inverse (nat ((int a' mod q - int a mod q) mod q)) q ] (mod q)"
      using cong_scalar_right by blast
    hence "[(int b - int b') * inverse (nat ((int a' mod q - int a mod q) mod q)) q
               = int x1 * ((int a' mod q - int a mod q) mod q *  inverse (nat ((int a' mod q - int a mod q) mod q)) q)] (mod q)"
      by (metis (mono_tags, lifting) cong_def mod_mult_left_eq mod_mult_right_eq more_arith_simps(11))
    hence *: "[int x1 * ((int a' mod q - int a mod q) mod q * inverse (nat ((int a' mod q - int a mod q) mod q)) q)
              = (int b - int b') * inverse (nat ((int a' mod q - int a mod q) mod q)) q] (mod q)"
      using cong_sym_eq by auto
    hence "[int x1 * 1 = (int b - int b') * inverse (nat ((int a' mod q - int a mod q) mod q)) q] (mod q)"
    proof -
      have "[(int a' mod int q - int a mod int q) mod int q * Number_Theory_Aux.inverse (nat ((int a' mod int q - int a mod int q) mod int q)) q = 1] (mod int q)"
        by (metis (no_types) Euclidean_Division.pos_mod_sign inverse gcd int_nat_eq of_nat_0_less_iff q_gt_0)
      then show ?thesis
        by (meson * cong_scalar_left cong_sym_eq cong_trans)
    qed
    hence "[int x1 = (int b - int b') * inverse (nat ((int a' mod q - int a mod q) mod q)) q] (mod q)"
      by simp
    hence "int x1 mod q = (int b - int b') * (inverse (nat ((int a' mod q - int a mod q) mod q)) q) mod q"
      using cong_def by auto
    thus ?thesis using x1 aa' by simp
  qed
qed

lemma samp_uni_spmf_mod_q:
  shows "spmf (sample_uniform q) (x mod q) = 1/q"
proof-
  have "indicator {..< q} (x mod q) = 1"
    using q_gt_0 by auto
  moreover have "real (card {..< q}) = q" by simp
  ultimately show ?thesis
    by(auto simp add: spmf_of_set sample_uniform_def)
qed

lemma spmf_samp_uni_eq_return_bool_mod:
  shows "spmf (do {
          x1 \<leftarrow> sample_uniform q;
          return_spmf (int x1 = y mod q)}) True = 1/q"
proof-
  have "spmf (do {
          x1 \<leftarrow> sample_uniform q;
          return_spmf (x1 = y mod q)}) True = spmf (sample_uniform q \<bind> (\<lambda> x1. return_spmf x1)) (y mod q)"
    apply(simp only: spmf_bind)
    apply(rule Bochner_Integration.integral_cong[OF refl])+
  proof -
    fix x :: nat
    have "y mod q = x \<longrightarrow> indicator {True} (x = (y mod q)) = (indicator {(y mod q)} x::real)"
      by simp
    then have "indicator {True} (x = y mod q) = (indicator {y mod q} x::real)"
      by fastforce
    then show "spmf (return_spmf (x = y mod q)) True = spmf (return_spmf x) (y mod q)"
      by (metis pmf_return spmf_of_pmf_return_pmf spmf_spmf_of_pmf)
  qed
  thus ?thesis using samp_uni_spmf_mod_q by simp
qed

lemma rivest_bind:
  shows "rivest_commit.bind_advantage \ \<le> 1 / q"
  using bind_game_le_inv_q rivest_commit.bind_advantage_def by simp

end

locale rivest_asymp =
  fixes q :: "nat \<Rightarrow> nat"
  assumes rivest: "\<And>\<eta>. rivest (q \<eta>)"
begin

sublocale rivest "q \<eta>" for \<eta> by(simp add: rivest)

theorem rivest_correct:
  shows "rivest_commit.correct n"
  using abstract_correct by simp

theorem rivest_perfect_hiding_asym:
  assumes lossless_\: "rivest_commit.lossless (\ n)"
  shows "rivest_commit.perfect_hiding_ind_cpa n (\ n)"
  by (simp add: lossless_\ rivest_perfect_hiding)

theorem rivest_binding_asym:
  assumes "negligible (\<lambda>n. 1 / (q n))"
  shows "negligible (\<lambda>n. rivest_commit.bind_advantage n (\ n))"
  using negligible_le rivest_bind assms rivest_commit.bind_advantage_def by auto

end

end


(*  Title:      Sequents/LK/Nat.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge
*)

section {* Theory of the natural numbers: Peano's axioms, primitive recursion *}

theory Nat
imports "../LK"
begin

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat      ("0") and
  Suc :: "nat=>nat" and
  rec :: "[nat, 'a, [nat,'a]=>'a] => 'a"
where
  induct:  "[| $H |- $E, P(0), $F;
              !!x. $H, P(x) |- $E, P(Suc(x)), $F |] ==> $H |- $E, P(n), $F" and

  Suc_inject:  "|- Suc(m)=Suc(n) --> m=n" and
  Suc_neq_0:   "|- Suc(m) ~= 0" and
  rec_0:       "|- rec(0,a,f) = a" and
  rec_Suc:     "|- rec(Suc(m), a, f) = f(m, rec(m,a,f))"

definition add :: "[nat, nat] => nat"  (infixl "+" 60)
  where "m + n == rec(m, n, %x y. Suc(y))"

declare Suc_neq_0 [simp]

lemma Suc_inject_rule: "$H, $G, m = n |- $E \<Longrightarrow> $H, Suc(m) = Suc(n), $G |- $E"
  by (rule L_of_imp [OF Suc_inject])

lemma Suc_n_not_n: "|- Suc(k) ~= k"
  apply (rule_tac n = k in induct)
  apply simp
  apply (fast add!: Suc_inject_rule)
  done

lemma add_0: "|- 0+n = n"
  apply (unfold add_def)
  apply (rule rec_0)
  done

lemma add_Suc: "|- Suc(m)+n = Suc(m+n)"
  apply (unfold add_def)
  apply (rule rec_Suc)
  done

declare add_0 [simp] add_Suc [simp]

lemma add_0_right: "|- m+0 = m"
  apply (rule_tac n = "m" in induct)
  apply simp_all
  done

lemma add_Suc_right: "|- m+Suc(n) = Suc(m+n)"
  apply (rule_tac n = "m" in induct)
  apply simp_all
  done

lemma "(!!n. |- f(Suc(n)) = Suc(f(n))) ==> |- f(i+j) = i+f(j)"
  apply (rule_tac n = "i" in induct)
  apply simp_all
  done

end


theory BBI
  imports Quantale Fixpoint
begin

notation
  times (infixl "*" 70) and
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  Sup ("\<Squnion>_" [900] 900) and
  Inf ("\<Sqinter>_" [900] 900) and
  top ("\<top>") and
  bot ("\<bottom>") and
  one_class.one ("1")

class bbi = comm_quantale_unital + complete_boolean_algebra
begin

lemma qiso: "\<lbrakk>x \<le> z; y \<le> w\<rbrakk> \<Longrightarrow> x * y \<le> z * w"
  by (metis Sup.qisol Sup.qisor dual_order.trans)

lemma qmeet_subdistr: "(x \<sqinter> y) * z \<le> (x * z) \<sqinter> (y * z)"
  by (metis Sup.qisor inf_le1 inf_le2 le_inf_iff)

lemma qmeet_subdistl: "x * (y \<sqinter> z) \<le> (x * y) \<sqinter> (x * z)"
  by (metis mult_commute qmeet_subdistr)

lemma "(x * z) \<sqinter> (y * z) \<le> (x \<sqinter> y) * z"
  (* nitpick *) oops

lemma "x \<sqinter> (y * z) \<le> (x \<sqinter> y) * (x \<sqinter> z)"
  (* nitpick *) oops

lemma "(x * y) \<sqinter> z \<le> (x \<sqinter> z) * (y \<sqinter> z)"
  (* nitpick *) oops

lemma "(x \<sqinter> y) * (x \<sqinter> z) \<le> x \<sqinter> (y * z)"
  (* nitpick *) oops

lemma sep_conj_topl: "x \<le> \<top> * x"
  by (metis mult_1_left Sup.qisor top_greatest)

lemma sep_conj_topr: "x \<le> x * \<top>"
  by (metis mult_1_right Sup.qisol top_greatest)

lemma sep_conj_top [simp]: "\<top> * \<top> = \<top>"
  by (metis sep_conj_topl top_le)

definition sep_impl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "-*" 55) where
  "(op -*) x \<equiv> THE f. endo_galois_connection ((op * x)) f"

lemma equality_by_ineq: "\<forall>x. x \<le> f \<longleftrightarrow> x \<le> g \<Longrightarrow> f = g"
  by (metis Sup.ineq order_refl)

lemma ex_sep_conj_conn: "\<exists>!x. endo_galois_connection (op * y) x"
  apply auto
  apply (fold endo_lower_adjoint_def)
  apply (subst endo_lower_is_jp)
  apply (simp add: endo_join_preserving_def)
  apply (metis Sup.SUP_def local.Sup.Join_distl)
  apply (unfold endo_galois_connection_def)
  apply (subgoal_tac "\<forall>b a. (a \<le> x b) = (a \<le> ya b)")
  prefer 2
  apply simp
  apply (rule ext)
  apply (erule_tac x=xa in allE) back back
  apply (rule equality_by_ineq)
  by simp

lemma sep_impl: "x * y \<le> z \<longleftrightarrow> x \<le> y -* z"
  apply (simp add: sep_impl_def)
  apply (rule the1I2 [of "endo_galois_connection (op * y)"])
  apply (metis ex_sep_conj_conn)
  by (metis endo_galois_connection_def mult_commute)

lemma sep_implI1: "x * y \<le> z \<Longrightarrow> x \<le> y -* z"
  by (simp add: sep_impl)

lemma sep_implI2: "x * y \<le> z \<Longrightarrow> y \<le> x -* z"
  by (metis mult_commute sep_implI1)

lemma sep_implE1: "x \<le> y -* z \<Longrightarrow> x * y \<le> z"
  by (simp add: sep_impl)

lemma sep_implE2: "x \<le> y -* z \<Longrightarrow> y * x \<le> z"
  by (simp add: sep_impl mult_commute)

lemma sep_impl_isoE: "\<lbrakk>x \<le> y -* z; w \<le> y\<rbrakk> \<Longrightarrow> x * w \<le> z"
  by (metis dual_order.trans sep_implE1 sep_implI2)

lemma sep_impl_annil1: "y * ( y -* x) \<le> x"
  by (metis eq_refl sep_implE2)

lemma sep_impl_annil2: "(y -* x) * y \<le> x"
  by (metis mult_commute sep_impl_annil1)

lemma sep_impl_annir1: "y \<le> (x -* (x * y))"
  by (metis order_refl sep_implI2)

lemma sep_impl_annir2: "y \<le> (x -* (y * x))"
  by (metis mult_commute sep_impl_annir1)

lemma sep_impl_annir2_iso: "x * z \<le> x * (y -* (y * z))"
  by (metis order_refl qiso sep_impl_annir1)

lemma reynolds28: "\<lbrakk>x \<le> y -* z; x' \<le> z -* w\<rbrakk> \<Longrightarrow> x' * x \<le> y -* w"
  by (metis mult_assoc sep_implE1 sep_implI1 sep_impl_isoE)

lemma sep_impl_cut: "(z -* y) * (y -* x) \<le> z -* x"
  by (metis order_refl reynolds28 mult_commute)

lemma sep_impl_iso: "\<lbrakk>x' \<le> x; y \<le> y'\<rbrakk> \<Longrightarrow> x -* y \<le> x' -* y'"
  by (metis (full_types) order_trans sep_implE1 sep_implI2 sep_impl_annil1)

lemma sep_impl_iso_var: "x \<le> y \<Longrightarrow> z -* x \<le> z -* y"
  by (metis order_refl sep_impl_iso)

lemma sep_impl_antitone: "x \<le> y \<Longrightarrow> y -* z \<le> x -* z"
  by (metis eq_refl sep_impl_iso)

lemma sep_impl_to_meet: "y * (y -* x) \<le> (y * \<top>) \<sqinter> x"
  by (metis le_inf_iff sep_impl_annil1 sep_impl_annir2 sep_impl_isoE top_greatest)

lemma sep_impl_top [simp]: "x -* \<top> = \<top>"
  by (metis sep_implI2 top_greatest top_le)

lemma sep_impl_top_x: "\<top> -* x \<le> x"
  by (metis order_trans sep_conj_topl sep_impl_annil1)

lemma sep_impl_bot [simp]: "\<bottom> -* x = \<top>"
  by (metis Sup.qannir bot_least sep_implI2 top_le)

lemma sep_impl_top_bot [simp]: "\<top> -* \<bottom> = \<bottom>"
  by (metis le_bot sep_impl_top_x)

lemma sep_impl_join_subdistr: "(x \<squnion> y) -* z \<le> (x -* z) \<squnion> (y -* z)"
  by (metis sep_impl_antitone sup.coboundedI1 sup_ge1)

lemma sep_impl_join_subdistl: "(x -* y) \<squnion> (x -* z) \<le> x -* (y \<squnion> z)"
  by (metis sep_impl_iso_var sup_ge1 sup_ge2 sup_least)

lemma sep_impl_meet_subdistr: "(x -* z) \<sqinter> (y -* z) \<le> (x \<sqinter> y) -* z"
  by (metis inf_le1 le_infI1 sep_impl_antitone)

lemma sep_impl_meet_subdistl: "x -* (y \<sqinter> z) \<le> (x -* y) \<sqinter> (x -* z)"
  by (metis inf_le1 inf_le2 le_infI sep_impl_iso_var)

(* Algebraic characterization of pure assertion by Dang *)
definition pure :: "'a \<Rightarrow> bool" where
  "pure x \<equiv> \<forall>y z. x * \<top> \<le> x \<and> (y * z) \<sqinter> x \<le> (y \<sqinter> x) * (z \<sqinter> x)"

lemma pure_top [simp]: "pure \<top>"
  by (metis inf_le1 inf_top_right pure_def top_greatest)

lemma pure_bot [simp]: "pure \<bottom>"
  by (metis Sup.qannir eq_refl inf_bot_left inf_commute pure_def)

lemma pure_upward_closure [simp]: "pure x \<Longrightarrow> x * \<top> = x"
  apply (rule antisym, metis pure_def)
  by (metis sep_conj_topr)

lemma pure_upward_closure_var: "pure x \<Longrightarrow> x * y \<le> x"
  by (metis (full_types) eq_refl pure_upward_closure qiso top_greatest)

lemma pure_meet_distl: "pure x \<Longrightarrow> (y * z) \<sqinter> x = (y \<sqinter> x) * (z \<sqinter> x)"
  apply (rule antisym, metis pure_def)
  by (metis inf_le1 inf_le2 le_inf_iff pure_upward_closure qiso top_greatest)

lemma pure_meet_distr: "pure x \<Longrightarrow> x \<sqinter> (y * z) = (x \<sqinter> y) * (x \<sqinter> z)"
  by (metis inf_commute pure_meet_distl)

lemma pure_downward_closure: "pure x \<Longrightarrow> x = (x \<sqinter> 1) * \<top>"
  by (metis inf.orderE inf_commute inf_top_left pure_meet_distl pure_upward_closure mult_commute qmeet_subdistl mult_1_right)

lemma pure_downward_closure_var: "pure x \<Longrightarrow> x * y = x \<sqinter> (y * \<top>)"
  by (metis inf_absorb2 inf_idem inf_top_right pure_meet_distr pure_upward_closure_var mult_commute)

lemma reynolds_pure1: "pure x \<Longrightarrow> x \<sqinter> y \<le> x * y"
proof -
  assume pure: "pure x"
  hence "x \<sqinter> y \<le> x \<sqinter> (y * \<top>)"
    by (metis (full_types) inf_mono order_refl mult_commute qiso mult_1_left top_greatest)
  thus ?thesis
  by (metis pure pure_downward_closure_var)
qed

lemma reynolds_pure2: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> x * y \<le> x \<sqinter> y"
  by (metis eq_refl pure_downward_closure_var pure_upward_closure)

lemma reynolds_pure2_corollary: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> x * y = x \<sqinter> y"
  by (metis dual_order.antisym reynolds_pure1 reynolds_pure2)

lemma pure_idem [simp]: "pure x \<Longrightarrow> x * x = x"
  by (metis inf_idem reynolds_pure2_corollary)

lemma reynolds_pure3: "pure y \<Longrightarrow> (x \<sqinter> y) * z = (x * z) \<sqinter> y"
  apply (rule antisym)
  apply (metis le_infI1 le_infI2 le_inf_iff pure_upward_closure_var sep_impl_annir2 sep_impl)
  by (metis dual_order.trans inf_le1 pure_meet_distl sep_implE2 sep_impl_annir1)

lemma pure_join_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x \<squnion> x')"
proof (subst pure_def, auto)
  fix y z assume px: "pure x" and py: "pure x'"
  thus "(x \<squnion> x') * \<top> \<le> x \<squnion> x'"
    by (metis Sup.qdistl eq_refl mult_commute pure_upward_closure)
  have "(x \<squnion> x') \<sqinter> (y * z) = (x \<sqinter> (y * z)) \<squnion> (x' \<sqinter> (y * z))"
    by (metis inf_sup_distrib2)
  also have "... \<le> ((x \<sqinter> y) * (x \<sqinter> z)) \<squnion> ((x' \<sqinter> y) * (x' \<sqinter> z))"
    by (metis pure_meet_distr px py sup.bounded_iff sup_ge1 sup_ge2)
  also have "... \<le> (((x \<squnion> x') \<sqinter> y) * ((x \<squnion> x') \<sqinter> z)) \<squnion> (((x \<squnion> x') \<sqinter> y) * ((x \<squnion> x') \<sqinter> z))"
    by (metis inf_mono qiso sup_ge1 sup_ge2 sup_idem sup_least)
  finally show "y * z \<sqinter> (x \<squnion> x') \<le> (y \<sqinter> (x \<squnion> x')) * (z \<sqinter> (x \<squnion> x'))"
    by (metis inf_commute sup_idem)
qed

lemma pure_meet_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x \<sqinter> x')"
proof (subst pure_def, auto)
  fix y z assume px: "pure x" and py: "pure x'"
  thus "(x \<sqinter> x') * \<top> \<le> x"
    by (metis inf_le1 pure_upward_closure reynolds_pure3)
  show "(x \<sqinter> x') * \<top> \<le> x'"
    by (metis inf_le2 py reynolds_pure3)
  show "y * z \<sqinter> (x \<sqinter> x') \<le> (y \<sqinter> (x \<sqinter> x')) * (z \<sqinter> (x \<sqinter> x'))"
    by (metis eq_iff inf_commute inf_left_commute pure_meet_distr px py)
qed

lemma pure_sep_conj_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x * x')"
  by (metis pure_meet_closure reynolds_pure2_corollary)

lemma pure_negation_closure: "pure x \<Longrightarrow> pure (-x)"
proof (subst pure_def, auto)
  fix y z assume px: "pure x"
  hence "(-x * \<top>) \<sqinter> x = \<bottom>"
    by (metis compl_inf_bot pure_bot pure_upward_closure reynolds_pure3)
  thus "- x * \<top> \<le> - x"
    by (metis compl_sup double_compl inf.orderI inf_sup_distrib1 inf_top_right sup_bot_left sup_compl_top)
  have "(y * z) \<sqinter> -x = ((y \<sqinter> x) * (z \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis inf_top_right sup_compl_top inf_sup_distrib1 Sup.qdistr Sup.qdistl sup_assoc sup_commute sup_left_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 inf_absorb1 inf_le2 mult_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (((y \<sqinter> -x) * z) \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 mult_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (((y \<sqinter> -x) * z) \<sqinter> x) \<squnion> (((z \<sqinter> -x) * y) \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 mult_commute)
  finally show "y * z \<sqinter> - x \<le> (y \<sqinter> - x) * (z \<sqinter> - x)"
    by (metis inf_sup_distrib2 inf_assoc inf_compl_bot inf_bot_right sup_bot_left inf_le1)
qed

(* I couldn't prove nor disprove *)
lemma pure_sep_impl_closure: "\<lbrakk>pure p; pure q\<rbrakk> \<Longrightarrow> pure (p -* q)"
  apply (subst pure_def)
  apply auto
  apply (metis eq_refl pure_upward_closure reynolds28 mult_commute sep_impl_annir2)
  oops

lemma pure_annilation [simp]: "pure x \<Longrightarrow> x * (-x) = \<bottom>"
  by (metis inf_compl_bot pure_negation_closure reynolds_pure2_corollary)

lemma indirect_ineq: "(\<And>z. z \<le> x \<longrightarrow> z \<le> y) \<Longrightarrow> x \<le> y"
  by (metis (hide_lams, mono_tags) order_refl)

lemma "x \<squnion> y = y \<Longrightarrow> x \<le> y"
  by (metis le_iff_sup)

lemma join_meet_galois: "x \<sqinter> z \<le> y \<longleftrightarrow> z \<le> -x \<squnion> y"
proof
  assume "x \<sqinter> z \<le> y"
  hence "-x \<squnion> (x \<sqinter> z) \<le> -x \<squnion> y"
    by (metis le_iff_sup sup_idem sup_mono)
  thus "z \<le> -x \<squnion> y"
    by (metis compl_sup_top inf_top_left sup.boundedE sup_commute sup_inf_distrib2)
next
  assume "z \<le> -x \<squnion> y"
  thus "x \<sqinter> z \<le> y"
    by (metis inf_mono order_refl inf_sup_distrib1 inf_compl_bot sup_bot_left le_inf_iff)
qed

(* Reynolds uses implication x \<rightarrow> y \<equiv> - x \<squnion> y *)

lemma reynolds_pure4: "pure x \<Longrightarrow> x -* y \<le> -x \<squnion> y"
  apply (rule indirect_ineq)
  apply (rule impI)
  apply (drule sep_implE1)
  apply (subgoal_tac "x \<sqinter> z \<le> y")
  apply (metis join_meet_galois)
  by (metis order_trans reynolds_pure1 mult_commute)

lemma reynolds_pure5: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> -x \<squnion> y \<le> x -* y"
  apply (rule indirect_ineq)
  apply (rule impI)
  apply (rule sep_implI1)
  apply (subst (asm) join_meet_galois[symmetric])
  by (metis pure_downward_closure_var pure_meet_distr qiso top_greatest pure_upward_closure mult_commute)

definition intuitionistic :: "'a \<Rightarrow> bool" where
  "intuitionistic x \<equiv> x * \<top> \<le> x"

lemma pure_is_intuitionistic: "pure x \<Longrightarrow> intuitionistic x"
  by (metis intuitionistic_def pure_def)

lemma intuitionistic_top [simp]: "intuitionistic \<top>"
  by (metis pure_is_intuitionistic pure_top)

lemma intuitionistic_bot [simp]: "intuitionistic \<bottom>"
  by (metis pure_bot pure_is_intuitionistic)

lemma intuitionistic_upward_closure [simp]: "intuitionistic x \<Longrightarrow> x * \<top> = x"
  by (metis dual_order.antisym intuitionistic_def sep_conj_topr)

lemma intuitionistic_upward_closure_var: "intuitionistic x \<Longrightarrow> x * y \<le> x"
  by (metis (full_types) eq_refl intuitionistic_upward_closure qiso top_greatest)

lemma intuitionistic_downward_closure: "intuitionistic x \<Longrightarrow> (x \<sqinter> I) * \<top> \<le> x"
  by (metis dual_order.trans intuitionistic_def le_infE qmeet_subdistr)

lemma intuitionistic_downward_closure_var: "intuitionistic x \<Longrightarrow> x * y \<le> x \<sqinter> (y * \<top>)"
  by (metis Sup.qisor intuitionistic_upward_closure_var le_infI mult_commute top_greatest)

lemma reynolds_intuitionistic2: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> x * y \<le> x \<sqinter> y"
  by (metis intuitionistic_upward_closure_var le_infI mult_commute)

lemma reynolds_intuitionistic3: "intuitionistic y \<Longrightarrow> (x \<sqinter> y) * z \<le> (x * z) \<sqinter> y"
  by (metis inf_idem inf_le2 intuitionistic_upward_closure le_inf_iff qiso top_greatest)

lemma intuitionistic_sep_conj_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x * y)"
  by (metis eq_refl intuitionistic_def intuitionistic_upward_closure mult_assoc)

lemma intuitionistic_sep_impl_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x -* y)"
  by (metis intuitionistic_def sep_implI2 sep_impl_cut top_le)

lemma intuitionistic_join_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x \<squnion> y)"
  by (metis eq_refl intuitionistic_def intuitionistic_upward_closure Sup.qdistr)

lemma intuitionistic_meet_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x \<sqinter> y)"
  by (metis intuitionistic_def intuitionistic_upward_closure qmeet_subdistr)

lemma intuitionistic_sep_conj_top: "intuitionistic (x * \<top>)"
  by (metis eq_refl intuitionistic_def mult_assoc sep_conj_top)

lemma intuitionistic_sep_impl_top: "intuitionistic (\<top> -* x)"
  by (metis intuitionistic_def mult_commute sep_impl_cut sep_impl_top)

lemma strongest_intuitionistic: "\<not> (\<exists>y. intuitionistic y \<and> y \<le> x * \<top> \<and> y \<noteq> x * \<top> \<and> x \<le> y)"
  by (metis intuitionistic_upward_closure Sup.qdistr sup.orderE sup_absorb2)

lemma weakest_intuitionistic: "\<not> (\<exists>y. intuitionistic y \<and> \<top> -* x \<le> y \<and> y \<noteq> \<top> -* x \<and> y \<le> x)"
  by (metis dual_order.antisym intuitionistic_upward_closure sep_impl)

lemma sep_Sup: "\<Squnion> {x * p | x. x \<in> X} = \<Squnion> X * p"
  apply (rule Sup_eqI)
  apply (smt Sup_upper eq_refl mem_Collect_eq qiso)
  apply (rule sep_implE1)
  by (metis (lifting, full_types) Sup_least mem_Collect_eq sep_implI1)

lemma sep_Sup2: "\<Squnion> {p * x | x. x \<in> X} = p * \<Squnion> X"
  apply (rule Sup_eqI)
  apply (smt Sup_upper eq_refl mem_Collect_eq qiso)
  apply (rule sep_implE2)
oops

definition precise :: "'a \<Rightarrow> bool" where
  "precise p \<equiv> \<forall>X. \<Sqinter> {x * p | x. x \<in> X} = \<Sqinter> X * p"

lemma precise_charac: "precise p \<Longrightarrow> \<Sqinter> {x * p | x. x \<in> X} = \<Sqinter> X * p"
  by (simp add: precise_def)

lemma "precise p \<Longrightarrow> p * \<top> = \<top>"
  apply (simp add: precise_def)
  apply (erule allE [of _ "{}"], auto)
  by (metis mult_commute)

lemma precise_distl: "precise p \<Longrightarrow> (x \<sqinter> y) * p = (x * p) \<sqinter> (y * p)"
  apply (simp add: precise_def)
  apply (erule_tac x="{x, y}" in allE)
  apply auto
  apply (subgoal_tac "\<Sqinter> {xa * p |xa. xa = x \<or> xa = y} = (x * p) \<sqinter> (y * p)")
  apply simp
  apply (rule Inf_eqI)
  by auto

lemma precise_distr: "precise p \<Longrightarrow> p * (x \<sqinter> y) = (p * x) \<sqinter> (p * y)"
  by (metis precise_distl mult_commute)

lemma precise_sep_conj_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p * q)"
proof (subst precise_def, auto)
  fix X assume pp: "precise p" and pq: "precise q"
  have "\<Sqinter> {x * (p * q) |x. x \<in> X} = \<Sqinter> {x * q |x. x \<in> {y * p | y. y \<in> X}}"
    apply (subst mem_Collect_eq)
    by (metis mult_assoc)
  also have "... = \<Sqinter> {y * p | y. y \<in> X} * q"
    by (metis pq precise_charac [of q "{y * p | y. y \<in> X}"])
  finally show "\<Sqinter>{x * (p * q) |x. x \<in> X} = \<Sqinter>X * (p * q)"
    by (metis (lifting, no_types) pp precise_charac mult_assoc)
qed

lemma precise_meet_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p \<sqinter> q)"
  (* nitpick *) oops

lemma precise_join_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p \<squnion> q)"
  (* nitpick *) oops

lemma precise_subset_closure: "\<lbrakk>p \<le> q; precise q\<rbrakk> \<Longrightarrow> precise p"
  (* nitpick *) oops

lemma "\<forall>x \<in> X. intuitionistic x \<Longrightarrow> intuitionistic (\<Squnion> X)"
proof (unfold intuitionistic_def)
  assume assm: "\<forall>x\<in>X. x * \<top> \<le> x"
  have "\<Squnion>X * \<top> = \<Squnion>{x * \<top> | x. x \<in> X}"
    by (metis sep_Sup)
  also have "... \<le> \<Squnion>X"
    apply (rule Sup_least, rule Sup_upper, auto)
    by (metis assm dual_order.antisym sep_conj_topr)
  finally show "\<Squnion>X * \<top> \<le> \<Squnion>X" .
qed

lemma "\<forall>x \<in> X. intuitionistic x \<Longrightarrow> intuitionistic (\<Sqinter> X)"
  by (metis intuitionistic_def Inf_greatest Inf_lower dual_order.antisym qiso sep_conj_top sep_conj_topr)

definition int_neg :: "'a \<Rightarrow> 'a" where
  "int_neg p \<equiv> \<top> -* -p"

lemma int_neg_int: "intuitionistic (int_neg p)"
proof (clarsimp simp: intuitionistic_def int_neg_def)
  have "(\<top> -* - p) * \<top> = (\<top> -* \<top>) * (\<top> -* - p)"
    using mult_commute by auto
  also have "... = (\<top> -* - p)"
    using calculation intuitionistic_sep_impl_top by auto
  finally show "(\<top> -* - p) * \<top> \<le> (\<top> -* - p)"
    by simp
qed

no_notation sep_impl (infix "-*" 55)

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul3_same
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (mul3acc x y z))"
  oops

end


theory DisjunctIPs
imports RoutingRange
begin

definition "alltablesets rtbl = fst ` reduced_ipset_destination rtbl UNIV"

fun allroutingsets :: "prefix_routing list \<Rightarrow> ipv4addr set set" where
  "allroutingsets [] = {UNIV}" |
  "allroutingsets [lasttbl] = alltablesets lasttbl" |
  "allroutingsets (tbl#rest) =
    {a \<inter> b|a b. a \<in> allroutingsets rest \<and> b \<in> alltablesets tbl \<and> a \<inter> b \<noteq> {}}
  "

fun allroutingsets2 :: "prefix_routing list \<Rightarrow> ipv4addr set set" where
  "allroutingsets2 [] = {UNIV}" |
  "allroutingsets2 (tbl#rest) =
    {a \<inter> b|a b. a \<in> allroutingsets2 rest \<and> b \<in> alltablesets tbl \<and> a \<inter> b \<noteq> {}}
  "

lemma "allroutingsets2 t = allroutingsets t"
  using ipset_left_side_nonempty
  apply(induction rule: allroutingsets.induct, simp_all add: alltablesets_def reduced_ipset_destination_def)

  oops

definition "all_valid_prefixes tbls \<equiv> foldr (op \<and>) (map valid_prefixes tbls) True"
lemma all_valid_prefixes_split: "all_valid_prefixes (t#ts) = (valid_prefixes t \<and> all_valid_prefixes ts)"
  unfolding all_valid_prefixes_def by simp
lemma alltablesets_parts:
  assumes "valid_prefixes rtbl"
  shows "x \<in> alltablesets rtbl \<Longrightarrow> a \<in> x \<Longrightarrow> b \<in> x \<Longrightarrow> routing_table_semantics rtbl a = routing_table_semantics rtbl b"
  unfolding alltablesets_def
  by(clarify, metis iffD1[OF reduced_ipset_destination_correct[OF assms UNIV_I, symmetric]] fst_conv in_ipset_rel)

lemma allroutingsets_same_dst: "all_valid_prefixes rtbls \<Longrightarrow>
  x \<in> allroutingsets rtbls \<Longrightarrow>
  rtbl \<in> set rtbls \<Longrightarrow>
  a \<in> x \<Longrightarrow> b \<in> x \<Longrightarrow>
  routing_table_semantics rtbl a = routing_table_semantics rtbl b"
proof(induction arbitrary: x rule: allroutingsets.induct)
  case goal1 thus ?case by simp
next
  case goal2 thus ?case
    using alltablesets_parts all_valid_prefixes_split goal2(1) alltablesets_def alltablesets_def
    by simp blast
next
  case goal3
  have ars_unfold: "allroutingsets (tbl # v # va) = {a \<inter> b |a b. a \<in> allroutingsets (v # va) \<and> b \<in> alltablesets tbl \<and> a \<inter> b \<noteq> {}}" unfolding allroutingsets.simps(3) ..
  note * = alltablesets_parts[OF _ _ goal3(5) goal3(6)]
  { fix c d :: "ipv4addr set"
    let ?int = "c \<inter> d"
    have "(c \<in> allroutingsets (v # va)) \<and> d \<in> alltablesets tbl \<and> c \<inter> d \<noteq> {} \<Longrightarrow> a \<in> ?int \<Longrightarrow> b \<in> ?int \<Longrightarrow> routing_table_semantics rtbl a = routing_table_semantics rtbl b"
      by (metis (full_types) Int_iff all_valid_prefixes_split alltablesets_parts goal3(1) goal3(2) goal3(4) set_ConsD)
      (* I don't even know why I proved this. I didn't even know it when I wrote it down. *)
  }
  then show ?case using goal3 by simp blast
qed

definition "alltablelists rtbl = map fst (reduced_range_destination rtbl ipv4rq_UNIV)"

lemma tablesetslists: "alltablesets rtbl = set (map ipv4rq_to_set (alltablelists rtbl))"
  unfolding alltablelists_def alltablesets_def
  unfolding ipv4rq_UNIV_set_eq[symmetric]
  unfolding reduced_range_destination_eq1[symmetric]
  unfolding set_map by force

fun allroutinglists :: "prefix_routing list \<Rightarrow> ipv4rq list" where
  "allroutinglists [] = [ipv4rq_UNIV]" | (* Debatable, but kills a few annoying assumptions *)
  "allroutinglists [lasttbl] = alltablelists lasttbl" |
  "allroutinglists (tbl#rest) =
    concat (map (\<lambda>foo. filter (\<lambda>x. \<not> ipv4rq_empty x) (map (ipv4rq_intersection foo) (alltablelists tbl))) (allroutinglists rest))
  "

lemma routingsestslists: "allroutingsets rtbls = set (map ipv4rq_to_set (allroutinglists rtbls))"
  proof(induction rule: allroutinglists.induct)
    case goal1 thus ?case by simp
  next
    case goal2 show ?case using tablesetslists by simp
  next
    case goal3
    have mIH: "allroutingsets (v # va) = set (map ipv4rq_to_set (allroutinglists (v # va)))" using goal3(1) by simp
    have ***: "(map (map ipv4rq_to_set)
                  (map (\<lambda>foo. [x\<leftarrow>map (ipv4rq_intersection foo) (alltablelists tbl) . ipv4rq_to_set x \<noteq> {}])
                    (allroutinglists (v # va)))) =
               map (map ipv4rq_to_set \<circ> (\<lambda>foo. [x\<leftarrow>map (ipv4rq_intersection foo) (alltablelists tbl) . ipv4rq_to_set x \<noteq> {}])) (allroutinglists (v # va))" by simp
    have **: "(map (map ipv4rq_to_set)
                  (map (\<lambda>foo. [x\<leftarrow>map (ipv4rq_intersection foo) (alltablelists tbl) . ipv4rq_to_set x \<noteq> {}])
                    (allroutinglists (v # va)))) =
           map (\<lambda>foo. [x\<leftarrow>map (ipv4rq_to_set \<circ> ipv4rq_intersection foo) (alltablelists tbl) . x \<noteq> {}])
      (allroutinglists (v # va))"
      unfolding *** unfolding map_map filter_map unfolding comp_def by simp
    show ?case
      unfolding allroutingsets.simps allroutinglists.simps
      unfolding ipv4rq_empty_set_eq
      unfolding tablesetslists
      unfolding mIH
      unfolding map_concat
      unfolding **
      by fastforce
qed

lemma allroutingsets_UNIV: "\<Union>allroutingsets rtbls = UNIV"
proof(induction rule: allroutingsets.induct)
  case goal1 thus ?case by simp
next
  case goal2 thus ?case
    unfolding allroutingsets.simps(2) alltablesets_def
    unfolding reduced_ipset_destination_def
    unfolding left_reduce_preimage_stable
    using ipset_destination_complete by simp
next
  case goal3
  have mIH: "\<Union>allroutingsets (v # va) = UNIV" using goal3(1) by simp
  moreover
  have "\<Union>(fst ` reduced_ipset_destination tbl UNIV) = UNIV"
    unfolding reduced_ipset_destination_def
    unfolding left_reduce_preimage_stable
    using ipset_destination_complete by simp
  note Union_intersection_helper[OF calculation this]
  then show ?case unfolding allroutingsets.simps alltablesets_def by simp
qed

lemma allroutinglists_same_dst:
  assumes "all_valid_prefixes rtbls"
      and "r \<in> set (allroutinglists rtbls)"
      and "ipv4rq_element x r"
      and "ipv4rq_element y r"
      and "tbl \<in> set rtbls"
    shows "routing_table_semantics tbl x = routing_table_semantics tbl y"
proof -
  note a = allroutingsets_same_dst[OF assms(1)]
  note b = routingsestslists
  from assms(2) have d: "ipv4rq_to_set r \<in> allroutingsets rtbls" unfolding b by simp
  have e: "x \<in> ipv4rq_to_set r" "y \<in> ipv4rq_to_set r" using assms(3) assms(4) unfolding ipv4rq_element_set_eq .
  show ?thesis using a[OF d assms(5) e] .
qed

lemma allroutinglists_UNIV:
  "\<Union>set (map ipv4rq_to_set (allroutinglists rtbls)) = UNIV"
  using allroutingsets_UNIV routingsestslists by simp

definition "covering_iplist \<equiv> map (the \<circ> ipv4rq_lowest_element) \<circ> allroutinglists"

lemma covering_iplists_ex_representative:
  assumes "all_valid_prefixes rtbls"
  shows "(\<exists>y \<in> set (covering_iplist rtbls). \<forall>rtbl \<in> set rtbls. routing_table_semantics rtbl x = routing_table_semantics rtbl y)"
unfolding covering_iplist_def comp_def
proof(clarsimp)
  case goal1
  have "\<exists>r \<in> set (allroutinglists rtbls). x \<in> ipv4rq_to_set r"
    using allroutinglists_UNIV by fastforce
  then guess r .. note rl = this
  have ll: "the (ipv4rq_lowest_element r) \<in> ipv4rq_to_set r"
  proof -
    case goal1
    have "\<not> ipv4rq_empty r" using rl(2) by force
    from ipv4rq_lowest_in[OF this] show ?case unfolding ipv4rq_element_set_eq .
  qed
  note allroutinglists_same_dst[OF assms rl(1), unfolded ipv4rq_element_set_eq, OF rl(2) ll]
  then show "\<exists>y\<in>set (allroutinglists rtbls).
    \<forall>rtbl\<in>set rtbls. routing_table_semantics rtbl x = routing_table_semantics rtbl (the (ipv4rq_lowest_element y))"
    using rl(1) by blast
qed

lemma covering_iplists_ex_representative_set:
  assumes "all_valid_prefixes rtbls"
  shows "(\<exists>S \<in> set (allroutinglists rtbls). ipv4rq_element x S \<and> (\<forall>y \<in> ipv4rq_to_set S. \<forall>rtbl \<in> set rtbls.
    routing_table_semantics rtbl x = routing_table_semantics rtbl y))"
unfolding comp_def
proof -
  case goal1
  have "\<exists>r \<in> set (allroutinglists rtbls). x \<in> ipv4rq_to_set r"
    using allroutinglists_UNIV by fastforce
  then guess r .. note rl = this
  note allroutinglists_same_dst[OF assms rl(1), unfolded ipv4rq_element_set_eq, OF rl(2)]
  then show "?thesis"
    using rl unfolding ipv4rq_element_set_eq by blast
qed

end