section \<open> Incubator \<close>

theory Incubator_locales
  imports "Z_Machines.Z_Machine" "HOL-Library.Code_Target_Int"
begin

consts MAX_TEMP :: \<nat>
consts MIN_TEMP :: \<nat>

definition "TEMP = {MIN_TEMP..MAX_TEMP}"

def_consts
  MAX_TEMP = 30
  MIN_TEMP = 15

zstore IncubatorMonitor =
  temp :: \<nat>
  where mintemp: "MIN_TEMP \<le> temp" maxtemp: "temp \<le> MAX_TEMP"

zoperation Increment =
  over IncubatorMonitor
  pre "temp < MAX_TEMP"
  update "[temp\<Zprime> = temp + 1]"

lemma Increment_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} Increment() \<^bold>{IncubatorMonitor_inv\<^bold>}"
proof zpog
  fix temp
  assume pres: "temp < MAX_TEMP" and inv: "IncubatorMonitor temp"
  then interpret IncubatorMonitor temp
    by simp
  show "IncubatorMonitor (Suc temp )"
  proof
    show "MIN_TEMP \<le> Suc temp"
      using mintemp by auto
    show "Suc temp \<le> MAX_TEMP"
      using pres by auto
  qed
qed

zoperation Decrement =
  over IncubatorMonitor
  pre "temp > MIN_TEMP" \<comment> \<open> Change to @{term "(temp \<ge> MIN_TEMP)\<^sub>e"} to break the invariant \<close>
  update "[temp\<Zprime> = temp - 1]"

lemma Decrement_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} Decrement() \<^bold>{IncubatorMonitor_inv\<^bold>}"
  by (zpog_full; simp)

zoperation GetTemp =
  over IncubatorMonitor
  params currentTemp \<in> TEMP
  where "temp = currentTemp"

lemma GetTemp_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} GetTemp v \<^bold>{IncubatorMonitor_inv\<^bold>}"
  by zpog_full

zmachine Incubator =
  init "[temp \<leadsto> 20]"
  operations Increment Decrement GetTemp

animate Incubator

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_list_nat_Interleave
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

(*fun did not finish the proof*)
function interleave :: "'a list => 'a list => 'a list" where
"interleave (nil2) y = y"
| "interleave (cons2 z xs) y = cons2 z (interleave y xs)"
by pat_completeness auto

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((interleave (evens xs) (odds xs)) = xs)"
  oops

end


theory T121
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Padding
imports Main
begin

definition padup :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "padup align n \<equiv> (align - n mod align) mod align"

lemma padup_dvd:
  "0 < b \<Longrightarrow> (padup b n = 0) = (b dvd n)"
  unfolding padup_def
  apply(subst dvd_eq_mod_eq_0)
  apply(subst mod_if [where m="b - n mod b"])
  apply clarsimp
  apply(insert mod_less_divisor [of b n])
  apply arith
  done

lemma dvd_padup_add:
  "0 < x \<Longrightarrow> x dvd y + padup x y"
  apply(clarsimp simp: padup_def)
  apply(subst mod_if [where m="x - y mod x"])
  apply(clarsimp split: if_split_asm)
  apply(rule conjI)
   apply clarsimp
   apply(subst ac_simps)
   apply(subst diff_add_assoc)
    apply(rule mod_less_eq_dividend)
   apply(rule dvd_add)
    apply simp
   apply(subst minus_div_mult_eq_mod[symmetric])
   apply(subst diff_diff_right)
    apply(subst ac_simps)
    apply(subst minus_mod_eq_mult_div[symmetric])
    apply simp
   apply simp
  apply(auto simp: dvd_eq_mod_eq_0)
  done

end


theory padic_field_polynomials
  imports domain_poly padic_field_sequences

begin

context padic_num_poly
begin

type_synonym padic_field_poly = "nat \<Rightarrow> padic_number"

(*type for function on Qp*)

type_synonym padic_field_fun = "padic_number \<Rightarrow> padic_number"

(**************************************************************************************************)
lemma monom_term_car:
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "x \<in> carrier Q\<^sub>p"
  shows "c \<otimes>\<^bsub>Q\<^sub>p\<^esub>  x[^]\<^bsub>Q\<^sub>p\<^esub>(n::nat) \<in> carrier Q\<^sub>p"
  using assms  monoid.nat_pow_closed
  by (metis Group.comm_monoid_def Group.monoid_def Qp_is_comm_monoid)
(*Univariate polynomial ring over Q\<^sub>p*)

abbreviation Q\<^sub>p_x where
"Q\<^sub>p_x \<equiv> UP Q\<^sub>p"

lemma Q\<^sub>p_x_is_UP_ring[simp]:
"UP_ring Q\<^sub>p_x"
  by (meson Qp_is_domain UP_ring.UP_ring UP_ring.intro cring_def domain_def)

lemma Q\<^sub>p_x_is_UP_cring[simp]:
"UP_cring Q\<^sub>p"
  by (simp add: UP_cring_def domain.axioms(1))

lemma Q\<^sub>p_x_is_UP_domain[simp]:
"UP_domain Q\<^sub>p"
  by (simp add: UP_domain_def)

lemma Q\<^sub>p_x_ring[simp]:
"ring Q\<^sub>p_x "
  by (simp add: UP_ring.axioms)

lemma Q\<^sub>p_x_cring[simp]:
"cring Q\<^sub>p_x "
  by (simp add: UP_cring.UP_cring)

lemma Q\<^sub>p_x_domain[simp]:
"domain Q\<^sub>p_x "
  by (simp add: UP_domain.UP_domain)

(*Basic simp rules to streaminline computation*)
lemma Q\<^sub>p_pow_closedP[simp]:
  assumes "f \<in> carrier Q\<^sub>p_x"
  shows "f[^]\<^bsub>Q\<^sub>p_x\<^esub>(n::nat) \<in> carrier Q\<^sub>p_x "
  by (meson Q\<^sub>p_x_ring assms monoid.nat_pow_closed ring_def)

lemma Qp_pow_closed[simp]:
  assumes "a \<in> carrier Q\<^sub>p"
  shows "a[^]\<^bsub>Q\<^sub>p\<^esub>(n::nat) \<in> carrier Q\<^sub>p"
  by (meson Qp_is_domain assms cring_def domain_def monoid.nat_pow_closed ring_def)

lemma Qp_pow_zero[simp]:
  assumes "(n::nat)>0"
  shows "\<zero>\<^bsub>Q\<^sub>p\<^esub> [^]\<^bsub>Q\<^sub>p\<^esub> n = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
  using assms ring.pow_zero[of Q\<^sub>p n]
  by (simp add: cring.axioms(1) domain.axioms(1))

lemma Qp_pow_zeroP[simp]:
  assumes "n >0"
  shows "\<zero>\<^bsub>Q\<^sub>p_x\<^esub> [^]\<^bsub>Q\<^sub>p_x\<^esub>(n::nat) = \<zero>\<^bsub>Q\<^sub>p_x\<^esub>"
  using assms ring.pow_zero[of Q\<^sub>p_x] by simp

lemma Qp_sum_closedP[simp]:
  assumes "f \<in> carrier Q\<^sub>p_x"
  assumes "g \<in> carrier Q\<^sub>p_x"
  shows "f \<oplus>\<^bsub>Q\<^sub>p_x\<^esub>g \<in>  carrier Q\<^sub>p_x"
  by (simp add: assms(1) assms(2) cring.cring_simprules(1))

lemma Qp_sum_closed[simp]:
  assumes "f \<in> carrier Q\<^sub>p"
  assumes "g \<in> carrier Q\<^sub>p"
  shows "f \<oplus>\<^bsub>Q\<^sub>p\<^esub> g \<in>  carrier Q\<^sub>p"
  by (meson Qp_is_domain assms(1) assms(2) cring.cring_simprules(1) domain.axioms(1))

lemma Qp_mult_zero[simp]:
  assumes "f \<in> carrier Q\<^sub>p"
  shows "f \<otimes>\<^bsub>Q\<^sub>p\<^esub> \<zero>\<^bsub>Q\<^sub>p\<^esub> = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
        "\<zero>\<^bsub>Q\<^sub>p\<^esub> \<otimes>\<^bsub>Q\<^sub>p\<^esub> f = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
  apply (simp add: assms cring.cring_simprules(27) domain.axioms(1))
  by (simp add: assms cring.cring_simprules(26) domain.axioms(1))

lemma Qp_mult_zeroP[simp]:
  assumes "f \<in> carrier Q\<^sub>p_x"
  shows "f \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> \<zero>\<^bsub>Q\<^sub>p_x\<^esub> = \<zero>\<^bsub>Q\<^sub>p_x\<^esub>"
        "\<zero>\<^bsub>Q\<^sub>p_x\<^esub> \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> f = \<zero>\<^bsub>Q\<^sub>p_x\<^esub>"
  apply (simp add: assms cring.cring_simprules(27))
  apply (simp add: assms cring.cring_simprules(26))
  done

lemma Qp_add_zero[simp]:
  assumes "f \<in> carrier Q\<^sub>p"
  shows "f \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<zero>\<^bsub>Q\<^sub>p\<^esub> = f"
        "\<zero>\<^bsub>Q\<^sub>p\<^esub> \<oplus>\<^bsub>Q\<^sub>p\<^esub> f = f"
  apply (meson Qp_is_domain assms cring.cring_simprules(16) domain_def)
  by (meson Qp_is_domain assms cring.cring_simprules(8) domain_def)

lemma Qp_add_zeroP[simp]:
  assumes "f \<in> carrier Q\<^sub>p_x "
  shows "f \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> \<zero>\<^bsub>Q\<^sub>p_x\<^esub> = f"
        "\<zero>\<^bsub>Q\<^sub>p_x\<^esub> \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> f = f"
   apply (simp add: assms cring.cring_simprules)
   apply (simp add: assms cring.cring_simprules)
   done

(*Degree function*)
abbreviation degree:: "padic_field_poly \<Rightarrow> nat" where
"degree f \<equiv>  deg Q\<^sub>p f"

(*Coefficient function*)
abbreviation cf :: "padic_field_poly \<Rightarrow> nat \<Rightarrow> padic_number" where
"cf  \<equiv> coeff (UP Q\<^sub>p)"

(*Leading term function*)
abbreviation lt  where
"lt \<equiv> leading_term Q\<^sub>p"

(*Leading coefficient function*)
abbreviation lc where
"lc \<equiv> leading_coefficient Q\<^sub>p"

(*Truncation function, which sends a polynomial f \<Longrightarrow> (f - leading_term (f)), which has strictly
smaller degree in the case where degree f > 0*)
abbreviation trunc where
"trunc \<equiv> truncate Q\<^sub>p"

(*Turning a padic polynomial into a function on Q\<^sub>p*)
abbreviation fun_of :: "padic_field_poly \<Rightarrow> padic_number \<Rightarrow> padic_number" (infixl "\<^emph>" 70) where
"fun_of f a \<equiv> function_of Q\<^sub>p f a"

(*predicate for monomial polynomials*)
abbreviation is_monom where
"is_monom \<equiv> is_monom_poly Q\<^sub>p"

(*technical lemmas for reasoning about fun_of*)
lemma id_is_hom:
"ring_hom_cring Q\<^sub>p Q\<^sub>p (\<lambda>x. x)"
proof(rule ring_hom_cringI)
  show "cring Q\<^sub>p"
    by (simp add: domain.axioms(1))
  show "cring Q\<^sub>p"
     using \<open>cring Q\<^sub>p\<close> by auto
  show "(\<lambda>x. x) \<in> ring_hom Q\<^sub>p Q\<^sub>p"
    unfolding ring_hom_def
    apply(auto)
    done
qed

lemma UP_pre_univ_prop_fact:
"UP_pre_univ_prop Q\<^sub>p Q\<^sub>p (\<lambda>x. x)"
  unfolding UP_pre_univ_prop_def
  by (simp add: id_is_hom)

(*Q\<^sub>p_x addition commutes with evaluation addition*)
lemma fun_of_fun_sum:
  assumes "f \<in> carrier Q\<^sub>p_x"
  assumes "g \<in> carrier Q\<^sub>p_x"
  assumes "h = f \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> g"
  shows "(fun_sum (fun_of f) (fun_of g)) \<doteq> (fun_of h)"
  unfolding eq_on_Qp_def
proof
  fix x
  show " x \<in> carrier Q\<^sub>p \<longrightarrow> fun_sum ((\<^emph>) f) ((\<^emph>) g) x = h \<^emph> x"
  proof
    assume A: "x \<in> carrier Q\<^sub>p"
    show "fun_sum (fun_of f) (fun_of g) x = fun_of h x "
      unfolding fun_sum_def
      unfolding function_of_def
    proof-
      have "(eval Q\<^sub>p Q\<^sub>p (\<lambda>x. x)) x \<in> (ring_hom Q\<^sub>p_x Q\<^sub>p)"
        using UP_pre_univ_prop_fact A UP_pre_univ_prop.eval_ring_hom[of Q\<^sub>p Q\<^sub>p "(\<lambda>x. x)" x]
        by auto
      then show "eval Q\<^sub>p Q\<^sub>p (\<lambda>x. x) x f \<oplus>\<^bsub>Q\<^sub>p\<^esub> eval Q\<^sub>p Q\<^sub>p (\<lambda>x. x) x g = eval Q\<^sub>p Q\<^sub>p (\<lambda>x. x) x h "
        using assms ring_hom_add   by (simp add: \<open>f \<in> carrier Q\<^sub>p_x\<close> ring_hom_def)
    qed
  qed
qed

(*monomial functions are monomials*)
lemma fun_of_monom_is_monom0:
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "c \<noteq>\<zero>\<^bsub>Q\<^sub>p\<^esub>"
  assumes "f = monom Q\<^sub>p_x c n"
  assumes "x \<in> carrier Q\<^sub>p"
  shows "f\<^emph>x = mon c n x"
proof-
  have 1: "f\<^emph>x = c \<otimes>\<^bsub>Q\<^sub>p\<^esub> x [^]\<^bsub>Q\<^sub>p\<^esub> n"
    using UP_domain.fun_of_monom assms Q\<^sub>p_x_is_UP_domain
    by (simp add: UP_domain.fun_of_monom)
  show ?thesis
    unfolding mon_def scalar_mult_def X_Qp_pow_def function_of_def
    by (smt Qp_is_domain Qp_one_car UP_pre_univ_prop.eval_const UP_pre_univ_prop.eval_monom
        UP_pre_univ_prop_fact assms(1) assms(3) assms(4) cring.cring_simprules(12)
        cring.cring_simprules(14) domain.axioms(1) fun_scalar_mult_def)
qed

lemma fun_of_monom_is_monom:
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "f = monom Q\<^sub>p_x c n"
  shows "fun_of f \<doteq> mon c n"
proof(cases "c = \<zero>\<^bsub>Q\<^sub>p\<^esub>")
  case True
    have "monom Q\<^sub>p_x \<zero>\<^bsub>Q\<^sub>p\<^esub> n = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
      by (simp add: UP_cring.is_UP_ring UP_ring.monom_zero)
    then have "f = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
      by (simp add: True assms(2))
    then have T0: "\<And>x. x \<in> carrier Q\<^sub>p \<Longrightarrow> fun_of f x = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
      unfolding function_of_def
      by (metis Q\<^sub>p_x_is_UP_cring True UP_cring.is_UP_ring UP_pre_univ_prop.eval_const
          UP_pre_univ_prop_fact UP_ring.monom_zero assms(1))
    have "\<And>x. x \<in> carrier Q\<^sub>p \<Longrightarrow> mon c n x = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
      using True Qp_mult_zero(2) X_pow_Qp_is_closed fun_scalar_mult_def is_closed_fun_simp mon_def
      by presburger
    then show ?thesis
      using T0
      unfolding eq_on_Qp_def
      by blast
next
  case False
  then show ?thesis
    unfolding eq_on_Qp_def
    using assms(1) assms(2) fun_of_monom_is_monom0
    by blast
qed

lemma fun_of_monom_is_monom':
  assumes "is_monom f"
  shows "fun_of f \<doteq> mon (lc f) (degree f)"
  using Q\<^sub>p_x_is_UP_domain assms
    UP_domain.is_monom_id[of Q\<^sub>p f]
    fun_of_monom_is_monom[of "lc f" f "degree f"]
    UP_domain.lc_closed[of Q\<^sub>p f]
  unfolding   is_monom_poly_def
  by blast

(*monomials are continuous*)

lemma monom_poly_is_continuous:
  assumes "c \<in> carrier Q\<^sub>p"
  assumes "f = monom Q\<^sub>p_x c n"
  shows "is_continuous (fun_of f)"
proof-
  have 0: "is_continuous (mon c n)"
    unfolding mon_def using assms(1)
    by (simp add: X_Qp_pow_Qp_is_continuous fun_scalar_mult_is_continuous)
  have 1: "fun_of f \<doteq> mon c n"
    by (simp add: assms(1) assms(2) fun_of_monom_is_monom)
  show ?thesis using 0 1 is_continuous_eq eq_on_Qp_def
    by auto
qed

lemma monom_poly_is_continuous':
  assumes "is_monom f"
  shows "is_continuous (fun_of f)"
  using Q\<^sub>p_x_is_UP_domain UP_domain.is_monom_id[of Q\<^sub>p f]
        monom_poly_is_continuous[of "lc f" f "degree f"]
        assms UP_domain.lc_closed[of Q\<^sub>p f]
  unfolding is_monom_poly_def
  by blast

lemma degree_0_is_constant:
  assumes "f \<in> carrier Q\<^sub>p_x"
  assumes "degree f = 0"
  obtains g where "is_constant_fun g" and "g \<doteq> fun_of f"
proof-
  obtain c where c0: "c \<in> carrier Q\<^sub>p" and  c1: "\<And>x.  x \<in> carrier Q\<^sub>p \<Longrightarrow> (fun_of f) x = c"
    using Q\<^sub>p_x_is_UP_domain UP_domain.degree_0_imp_constant0  assms(1) assms(2) by blast
  obtain g where g_def: "g = to_const_fun c"
    by simp
  have 0: "is_constant_fun g"
    by (simp add: \<open>g = to_const_fun c\<close> c0 to_const_fun_is_const)
  have 1: "g \<doteq> fun_of f"
    unfolding eq_on_Qp_def
  proof
    fix x
    show "x \<in> carrier Q\<^sub>p \<longrightarrow> g x = f \<^emph> x"
    proof
      assume A: "x \<in> carrier Q\<^sub>p"
      show "g x = f\<^emph>x "
      proof-
        have LHS: "g x = c"
          using g_def using to_const_fun_def by simp
        have RHS: "f\<^emph>x = c"
          apply(auto simp: A c1)
          done
        then show ?thesis
          using RHS LHS by auto
      qed
    qed
  qed
  show ?thesis
    using 0 1  that by auto
qed

(*degree 0 polynomials induce continuous functions*)
lemma degree_0_is_continuous:
  assumes "f \<in> carrier Q\<^sub>p_x"
  assumes "degree f = 0"
  shows "is_continuous (fun_of f)"
proof-
  obtain g where 0: "is_constant_fun g" and 1: "g \<doteq> fun_of f"
    using assms degree_0_is_constant by auto
  have "is_continuous g"
    using 0 by (simp add: constant_is_continuous)
  then show ?thesis
    using 1 is_continuous_eq by blast
qed

(*all polynomials induce continuous functions*)
lemma polynomial_is_continuous_induct:
  fixes n::nat
  shows "\<And>f. f \<in> carrier Q\<^sub>p_x \<Longrightarrow> degree f \<le> n \<Longrightarrow> is_continuous (fun_of f)"
proof(induction n)
case 0
  then show ?case
    using degree_0_is_continuous by blast
next
  case (Suc n)
  fix n
  assume IH: "\<And>f. f \<in> carrier Q\<^sub>p_x \<Longrightarrow> (degree f \<le> n \<Longrightarrow> is_continuous (fun_of f))"
  show "\<And>f. f \<in> carrier Q\<^sub>p_x \<Longrightarrow> degree f \<le> Suc n \<Longrightarrow> is_continuous (fun_of f) "
  proof-
    fix f
    assume A0:"f \<in> carrier Q\<^sub>p_x"
    assume D: "degree f \<le> Suc n"
    show "is_continuous (fun_of f)"
    proof(cases "degree f < Suc n")
      case True
      then show ?thesis
        using IH A0 by simp
    next
      case False
      then have E: "degree f = Suc n"
        using D by auto
      then have E0: "degree f > (0::nat)"
        by auto
      obtain g where g_def: "g \<in> carrier Q\<^sub>p_x \<and> (f = g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> (lt f)) \<and> degree g < degree f"
        using E0 A0 Q\<^sub>p_x_is_UP_domain UP_domain.lt_decomp[of Q\<^sub>p f] by auto
      have g0: "g \<in> carrier Q\<^sub>p_x"
        using g_def by auto
      have g1: "f = g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> (lt f)"
        using g_def by auto
      have g2: "degree g < degree f"
        using g_def by auto
      have LS: "is_continuous (fun_of g)"
        using E g0 g1 g2 IH by auto
      have RS: "is_continuous (fun_of (lt f))"
        using monom_poly_is_continuous leading_term_def A0
            Q\<^sub>p_x_is_UP_ring Q\<^sub>p_x_is_UP_domain
        by (metis UP_domain.cfs_closed)
      have "fun_of f \<doteq>  fun_sum (fun_of g) (fun_of (lt f))"
        using  fun_of_fun_sum g0 A0 g1  eq_on_Qp_def UP_domain.lt_closed
        by (metis (mono_tags, lifting) Q\<^sub>p_x_is_UP_domain)
      then show ?thesis
        using LS RS sum_of_cont_is_cont
        by (metis (no_types, lifting) Qp_complete' converges_to_def eq_on_Qp_def
            is_closed_fun_def is_continuous_def push_forward_eq)
    qed
  qed
qed

lemma polynomial_is_continuous:
  assumes "f \<in> carrier Q\<^sub>p_x"
  shows "is_continuous (fun_of f)"
proof-
  obtain n where n_def: "n = degree f"
    by simp
  then show ?thesis
    using assms polynomial_is_continuous_induct by auto
qed

(**************************************************************************************************)
(**************************************************************************************************)
(**********************************    Polynomial Substitution   **********************************)
(**************************************************************************************************)
(**************************************************************************************************)

(*The inclusion of Q\<^sub>p into Q\<^sub>p_x*)

abbreviation to_poly :: "padic_number \<Rightarrow> padic_field_poly" where
"to_poly \<equiv> to_polynomial Q\<^sub>p"

lemma to_poly_is_ring_hom:
"to_poly \<in> ring_hom Q\<^sub>p Q\<^sub>p_x"
  by (simp add: UP_domain.to_poly_is_ring_hom)

abbreviation sub :: "padic_field_poly \<Rightarrow> padic_field_poly \<Rightarrow> padic_field_poly" (infixl "of" 70)where
"sub \<equiv> compose Q\<^sub>p"

abbreviation rev_sub :: "padic_field_poly \<Rightarrow> padic_field_poly \<Rightarrow> padic_field_poly" where
"rev_sub \<equiv> rev_compose Q\<^sub>p"

lemma sub_rev_sub:
"sub f g = rev_sub g f"
  by (simp add:  UP_domain.sub_rev_sub)

(*The polynomial X*)
abbreviation X where
"X \<equiv> X_poly Q\<^sub>p"

(*Translates of X*)
abbreviation X_plus where
"X_plus \<equiv> X_poly_plus  Q\<^sub>p"

abbreviation X_minus where
"X_minus \<equiv> X_poly_minus  Q\<^sub>p"

(*Powers of X*)
abbreviation X_pow where
"X_pow n \<equiv> X[^]\<^bsub>Q\<^sub>p_x\<^esub>n"

(*The Taylor expansion*)

abbreviation Taylor ("T\<^bsub>_\<^esub>") where
"Taylor \<equiv> taylor_expansion Q\<^sub>p"

(*Derivative function*)

abbreviation deriv   where
"deriv \<equiv> derivative Q\<^sub>p"

(*Zero coefficient function*)
abbreviation cf0 where
"cf0 \<equiv> zero_coefficient"

(*The horner shift function. Satisfies the equation:       f = a0 + X(poly_shift f)      *)
abbreviation poly_shift where
"poly_shift \<equiv> polynomial_shift Q\<^sub>p"

(*The iterated shift function. Satisfies   f = a0 + a1*X + ...+ (an-1)*X^(n-1) + X^n(shift n f) *)
abbreviation shift where
"shift \<equiv> poly_shift_iter Q\<^sub>p"

(*The "first n+1 terms" function*)
abbreviation deg_leq where
"deg_leq \<equiv> degree_n_or_less_terms Q\<^sub>p"

(*The linear part function*)
abbreviation lin_part where
"lin_part \<equiv> linear_part Q\<^sub>p"

(*the derivative operator*)

abbreviation pderiv where
"pderiv \<equiv> poly_deriv Q\<^sub>p"

end
end


(*  Title:      HOL/Hoare/Heap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Pointers, heaps and heap abstractions.
See the paper by Mehta and Nipkow.
*)

theory Heap imports Main begin

subsection "References"

datatype 'a ref = Null | Ref 'a

lemma not_Null_eq [iff]: "(x ~= Null) = (EX y. x = Ref y)"
  by (induct x) auto

lemma not_Ref_eq [iff]: "(ALL y. x ~= Ref y) = (x = Null)"
  by (induct x) auto

primrec addr :: "'a ref \<Rightarrow> 'a" where
  "addr (Ref a) = a"

section "The heap"

subsection "Paths in the heap"

primrec Path :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> 'a ref \<Rightarrow> bool" where
  "Path h x [] y \<longleftrightarrow> x = y"
| "Path h x (a#as) y \<longleftrightarrow> x = Ref a \<and> Path h (h a) as y"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by(induct as, simp+)

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by(induct as, simp, simp add:eq_sym_conv)

lemma Path_snoc:
 "Path (f(a := q)) p as (Ref a) \<Longrightarrow> Path (f(a := q)) p (as @ [a]) q"
by simp

subsection "Non-repeating paths"

definition distPath :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> 'a ref \<Rightarrow> bool"
  where "distPath h x as y \<longleftrightarrow> Path h x as y \<and> distinct as"

text{* The term @{term"distPath h x as y"} expresses the fact that a
non-repeating path @{term as} connects location @{term x} to location
@{term y} by means of the @{term h} field. In the case where @{text "x
= y"}, and there is a cycle from @{term x} to itself, @{term as} can
be both @{term "[]"} and the non-repeating list of nodes in the
cycle. *}

lemma neq_dP: "p \<noteq> q \<Longrightarrow> Path h p Ps q \<Longrightarrow> distinct Ps \<Longrightarrow>
 EX a Qs. p = Ref a & Ps = a#Qs & a \<notin> set Qs"
by (case_tac Ps, auto)

lemma neq_dP_disp: "\<lbrakk> p \<noteq> q; distPath h p Ps q \<rbrakk> \<Longrightarrow>
 EX a Qs. p = Ref a \<and> Ps = a#Qs \<and> a \<notin> set Qs"
apply (simp only:distPath_def)
by (case_tac Ps, auto)

subsection "Lists on the heap"

subsubsection "Relational abstraction"

definition List :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> bool"
  where "List h x as = Path h x as Null"

lemma [simp]: "List h x [] = (x = Null)"
by(simp add:List_def)

lemma [simp]: "List h x (a#as) = (x = Ref a \<and> List h (h a) as)"
by(simp add:List_def)

lemma [simp]: "List h Null as = (as = [])"
by(case_tac as, simp_all)

lemma List_Ref[simp]: "List h (Ref a) as = (\<exists>bs. as = a#bs \<and> List h (h a) bs)"
by(case_tac as, simp_all, fast)

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by(blast intro:List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List h (h a) as \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
apply(induct as, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma Path_is_List:
  "\<lbrakk>Path h b Ps (Ref a); a \<notin> set Ps\<rbrakk> \<Longrightarrow> List (h(a := Null)) b (Ps @ [a])"
apply (induct Ps arbitrary: b)
apply (auto simp add:fun_upd_apply)
done

subsection "Functional abstraction"

definition islist :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> bool"
  where "islist h p \<longleftrightarrow> (\<exists>as. List h p as)"

definition list :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list"
  where "list h p = (SOME as. List h p as)"

lemma List_conv_islist_list: "List h p as = (islist h p \<and> as = list h p)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst some1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply(rule someI_ex)
apply fast
done

lemma [simp]: "islist h Null"
by(simp add:islist_def)

lemma [simp]: "islist h (Ref a) = islist h (h a)"
by(simp add:islist_def)

lemma [simp]: "list h Null = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "islist h (h a) \<Longrightarrow> list h (Ref a) = a # list h (h a)"
apply(insert List_Ref[of h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist h (h a) \<Longrightarrow> a \<notin> set(list h (h a))"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> list (h(y := q)) p = list h p"
apply(drule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> islist (h(y := q)) p"
apply(frule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

end


theory Tangle_Moves
imports Tangles Tangle_Algebra tangle_relation
begin

text{* Two Links diagrams represent the same link if and only if the diagrams can be related by a
set of moves called the reidemeister moves. For links defined through Tangles, addition set of moves
are needed to account for different tangle representations of the same link diagram.

We formalise these 'moves' in terms of relations. Each move is defined as a relation on diagrams.
Two diagrams are then stated to be equivalent if the reflexive-symmetric-transitive closure of the
disjunction of above relations holds true. A Link is defined as an element of the quotient type of
diagrams modulo equivalence relations. We formalise the definition of framed links on similar lines.

In terms of formalising the moves, there is a trade off between choosing a small number of moves
from which all other moves can be obtained, which is conducive to probe invariance of a function
on diagrams. However, such an approach might not be conducive to establish equivalence of two
diagrams. We opt for the former approach of minimising the number of tangle moves.
However, the moves that would be useful in practise are proved as theorems in
  *}

type_synonym relation = "wall \<Rightarrow> wall \<Rightarrow> bool"

text{* Link uncross*}

abbreviation right_over::"wall"
where
"right_over \<equiv>   ((basic [vert,cup]) \<circ> (basic [over,vert])\<circ>(basic [vert,cap]))"

abbreviation left_over::"wall"
where
" left_over \<equiv> ((basic (cup#vert#[])) \<circ> (basic (vert#over#[]))
\<circ> (basic (cap#vert#[])))"

abbreviation right_under::"wall"
where
"right_under \<equiv>   ((basic (vert#cup#[])) \<circ> (basic (under#vert#[]))
\<circ> (basic (vert#cap#[])))"

abbreviation left_under::"wall"
where
" left_under \<equiv> ((basic (cup#vert#[])) \<circ> (basic (vert#under#[]))
\<circ> (basic (cap#vert#[])))"

abbreviation straight_line::"wall"
where
"straight_line \<equiv> (basic (vert#[])) \<circ> (basic (vert#[])) \<circ> (basic (vert#[]))"

definition uncross_positive_flip::relation
where
"uncross_positive_flip x y \<equiv> ((x = right_over)\<and>(y =  left_over))"

definition uncross_positive_straighten::relation
where
"uncross_positive_straighten x y \<equiv> ((x = right_over)\<and>(y = straight_line))"

definition uncross_negative_flip::relation
where
"uncross_negative_flip x y \<equiv> ((x = right_under)\<and>(y =  left_under))"

definition uncross_negative_straighten::relation
where
"uncross_negative_straighten x y \<equiv> ((x = left_under)\<and>(y = straight_line))"

(*The relation uncross*)
definition uncross
where
"uncross x y \<equiv> ((uncross_positive_straighten x y)\<or>(uncross_positive_flip x y)
                \<or>(uncross_negative_straighten x y)\<or> (uncross_negative_flip x y))"

text{*swing begins*}

abbreviation r_over_braid::"wall"
where
"r_over_braid  \<equiv>  ((basic ((over#vert#[]))\<circ>(basic ((vert#over#[])))
                 \<circ>(basic (over# vert#[]))))"

abbreviation l_over_braid::"wall"
where
"l_over_braid  \<equiv>   (basic (vert#over#[]))\<circ>(basic (over#vert#[]))
                    \<circ>(basic (vert#over#[]))"

abbreviation r_under_braid::"wall"
where
"r_under_braid  \<equiv>   ((basic ((under#vert#[]))\<circ>(basic ((vert#under#[])))
                 \<circ>(basic (under# vert#[]))))"

abbreviation l_under_braid::"wall"
where
"l_under_braid  \<equiv>   (basic (vert#under#[]))\<circ>(basic (under#vert#[]))
                    \<circ>(basic (vert#under#[]))"

definition swing_pos::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"swing_pos x y \<equiv> (x = r_over_braid)\<and>(y = l_over_braid)"

definition swing_neg::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"swing_neg x y \<equiv>(x = r_under_braid)\<and>(y=l_under_braid)"

definition swing::relation
where
"swing x y \<equiv> (swing_pos x y)\<or>(swing_neg x y)"

text{*pull begins*}

definition pull_posneg::relation
where
"pull_posneg x y \<equiv>  ((x = ((basic (over#[]))\<circ>(basic  (under#[]))))
                            \<and>(y = ((basic (vert#vert#[])))
                                   \<circ>(basic ((vert#vert#[])))))"

definition pull_negpos::relation
where
"pull_negpos x y \<equiv>  ((x = ((basic (under#[]))\<circ>(basic  (over#[]))))
                          \<and>(y = ((basic (vert#vert#[])))
                                   \<circ>(basic ((vert#vert#[])))))"

text{* pull definition*}
definition pull::relation
where
"pull x y \<equiv> ((pull_posneg x y) \<or> (pull_negpos x y))"

text{*linkrel-pull ends*}
text{*linkrel-straighten*}

definition straighten_topdown::relation
where
"straighten_topdown x y \<equiv>  ((x =((basic ((vert#cup#[])))
                                         \<circ>(basic ((cap#vert#[])))))
                                   \<and>(y = ((basic (vert#[]))\<circ>(basic (vert#[])))))"

definition straighten_downtop::relation
where
"straighten_downtop x y \<equiv>  ((x =((basic ((cup# vert#[])))
                                         \<circ>(basic ((vert# cap#[])))))
                                   \<and>(y = ((basic (vert#[]))\<circ>(basic (vert#[])))))"

text{*definition straighten*}
definition straighten::relation
where
"straighten x y \<equiv> ((straighten_topdown x y) \<or> (straighten_downtop x y))"

text{*straighten ends*}
text{* rotate moves*}

definition rotate_toppos::relation
where
"rotate_toppos x y \<equiv>  ((x = ((basic ((vert #over#[])))
                                     \<circ>(basic ((cap# vert#[])))))
                             \<and> (y = ((basic ((under#vert#[]))
                                     \<circ>(basic ((vert#cap#[])))))))"

definition rotate_topneg::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"rotate_topneg x y \<equiv>  ((x = ((basic ((vert #under#[])))
                                     \<circ>(basic ((cap# vert#[])))))
                             \<and> (y = ((basic ((over#vert#[]))
                                     \<circ>(basic ((vert#cap#[])))))))"

definition rotate_downpos::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"rotate_downpos x y \<equiv>  ((x = ((basic (cup#vert#[]))
                                     \<circ>(basic (vert#over#[]))))
                             \<and> (y = ((basic ((vert#cup#[])))
                                    \<circ>(basic ((under#vert#[]))))))"

definition rotate_downneg::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"rotate_downneg x y \<equiv>  ((x = ((basic (cup#vert#[]))
                                     \<circ>(basic (vert#under#[]))))
                             \<and> (y = ((basic ((vert#cup#[])))
                                    \<circ>(basic ((over#vert#[]))))))"

text{*rotate definition*}

definition rotate::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"rotate x y \<equiv> ((rotate_toppos x y) \<or> (rotate_topneg x y)
\<or> (rotate_downpos x y) \<or> (rotate_downneg x y))"

text{*rotate ends*}

text{*Compress -  Compress has two levels of equivalences. It is a composition of Compress-null, compbelow
and compabove. compbelow and compabove are further written as disjunction of many other relations.
Compbelow refers to when the bottom row is extended or compressed. Compabove refers to when the
row above is extended or compressed*}

definition compress_top1::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"compress_top1 x y \<equiv>  \<exists>B.((x = (basic (make_vert_block (nat (domain_wall B))))\<circ> B)
                              \<and>(y = B)\<and>(codomain_wall B \<noteq> 0)
                               \<and>(is_tangle_diagram B))"

definition compress_bottom1::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"compress_bottom1 x y \<equiv>  \<exists>B.((x = B \<circ> (basic (make_vert_block (nat (codomain_wall B)))))
                              \<and>(y =  B))\<and>(domain_wall B \<noteq> 0)
                               \<and>(is_tangle_diagram B)"

definition compress_bottom::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"compress_bottom x y \<equiv>   \<exists>B.((x = B \<circ> (basic (make_vert_block (nat (codomain_wall B)))))
                              \<and>(y = ((basic ([]) \<circ> B)))\<and>(domain_wall B = 0)
                               \<and>(is_tangle_diagram B))"

definition compress_top::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"compress_top x y \<equiv>  \<exists>B.((x = (basic (make_vert_block (nat (domain_wall B))))\<circ> B)
                              \<and>(y = (B \<circ> (basic ([]))))\<and>(codomain_wall B = 0)
                               \<and>(is_tangle_diagram B))"

(*compress*)
definition compress::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"compress x y = ((compress_top x y) \<or> (compress_bottom x y))"
(*(compress_top1 x y) \<or> (compress_bottom1 x y))*)
text{*slide relation refer to the relation where a crossing is slided over a vertical strand*}
definition slide::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"slide x y \<equiv>  \<exists>B.((x = ((basic (make_vert_block (nat (domain_block B))))\<circ>(basic B)))
               \<and>(y = ((basic B)\<circ>(basic (make_vert_block (nat (codomain_block B))))))
\<and> ((domain_block B) \<noteq> 0))"
(*can integrate slide and compress using domain-codomain fundas.
ALSO check for domain and codomain in the above equations*)
text{*linkrel-definition*}

definition linkrel::"wall =>wall \<Rightarrow>bool"
where
"linkrel x y = ((uncross x y) \<or> (pull x y) \<or> (straighten x y)
\<or>(swing x y)\<or>(rotate x y) \<or> (compress x y) \<or> (slide x y))"

definition framed_uncross::"wall \<Rightarrow> wall \<Rightarrow> bool"
where
"framed_uncross x y \<equiv> ((uncross_positive_flip x y)\<or>(uncross_negative_flip x y))"

definition framed_linkrel::"wall =>wall \<Rightarrow>bool"
where
"framed_linkrel x y = ((framed_uncross x y) \<or> (pull x y) \<or> (straighten x y)
\<or>(swing x y)\<or>(rotate x y) \<or> (compress x y) \<or> (slide x y))"

lemma framed_uncross_implies_uncross: "(framed_uncross x y)\<Longrightarrow>(uncross x y)"
apply (simp add: framed_uncross_def uncross_def)
apply(auto)
done

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Streams
imports
  HOLCF
  Nats
  WorkerWrapper
begin
(*>*)

section\<open>Memoisation using streams.\<close>

text \<open>
\label{sec:memoisation-example}\<close>

subsection\<open>Streams.\<close>

text\<open>The type of infinite streams.\<close>

domain 'a Stream = stcons (lazy sthead :: "'a") (lazy sttail :: "'a Stream") (infixr "&&" 65)

(*<*)
lemma Stream_bisimI[intro]:
  "(\<And>xs ys. R xs ys
     \<Longrightarrow> (xs = \<bottom> \<and> ys = \<bottom>)
       \<or> (\<exists>h t t'. R t t' \<and> xs = h && t \<and> ys = h && t'))
  \<Longrightarrow> Stream_bisim R"
  unfolding Stream.bisim_def by auto
(*>*)

fixrec smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a Stream \<rightarrow> 'b Stream"
where
  "smap\<cdot>f\<cdot>(x && xs) = f\<cdot>x && smap\<cdot>f\<cdot>xs"

(*<*)
lemma smap_strict[simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp
(*>*)

lemma smap_smap: "smap\<cdot>f\<cdot>(smap\<cdot>g\<cdot>xs) = smap\<cdot>(f oo g)\<cdot>xs"
(*<*) by (induct xs, simp_all) (*>*)

fixrec i_th :: "'a Stream \<rightarrow> Nat \<rightarrow> 'a"
where
  "i_th\<cdot>(x && xs) = Nat_case\<cdot>x\<cdot>(i_th\<cdot>xs)"

abbreviation
  i_th_syn :: "'a Stream \<Rightarrow> Nat \<Rightarrow> 'a" (infixl "!!" 100) where
  "s !! i \<equiv> i_th\<cdot>s\<cdot>i"

(*<*)
lemma i_th_strict1[simp]: "\<bottom> !! i = \<bottom>"
by fixrec_simp

lemma i_th_strict2[simp]: "s !! \<bottom> = \<bottom>" by (subst i_th.unfold, cases s, simp_all)
lemma i_th_0[simp]: "(s !! 0) = sthead\<cdot>s" by (subst i_th.unfold, cases s, simp_all)
lemma i_th_suc[simp]: "i \<noteq> \<bottom> \<Longrightarrow> (x && xs) !! (i + 1) = xs !! i" by (subst i_th.unfold, simp)
(*>*)

text\<open>The infinite stream of natural numbers.\<close>

fixrec nats :: "Nat Stream"
where
  "nats = 0 && smap\<cdot>(\<Lambda> x. 1 + x)\<cdot>nats"

(*<*)
declare nats.simps[simp del]
(*>*)

subsection\<open>The wrapper/unwrapper functions.\<close>

definition
  unwrapS' :: "(Nat \<rightarrow> 'a) \<rightarrow> 'a Stream" where
  "unwrapS' \<equiv> \<Lambda> f . smap\<cdot>f\<cdot>nats"

lemma unwrapS'_unfold: "unwrapS'\<cdot>f = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats"
(*<*)by (unfold unwrapS'_def, subst nats.unfold, simp add: smap_smap)(*>*)

fixrec unwrapS :: "(Nat \<rightarrow> 'a) \<rightarrow> 'a Stream"
where
  "unwrapS\<cdot>f = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))"

(*<*)
declare unwrapS.simps[simp del]
(*>*)

text\<open>The two versions of @{term "unwrapS"} are equivalent. We could
try to fold some definitions here but it's easier if the stream
constructor is manifest.\<close>

lemma unwrapS_unwrapS'_eq: "unwrapS = unwrapS'" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix f show "?lhs\<cdot>f = ?rhs\<cdot>f"
  proof(coinduct rule: Stream.coinduct)
    let ?R = "\<lambda>s s'. (\<exists>f. s = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))
                        \<and> s' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)"
    show "Stream_bisim ?R"
    proof
      fix s s' assume "?R s s'"
      then obtain f where fs:  "s = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))"
                      and fs': "s' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats"
        by blast
      have "?R (unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))) (smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)"
        by ( rule exI[where x="f oo (\<Lambda> x. 1 + x)"]
           , subst unwrapS.unfold, subst nats.unfold, simp add: smap_smap)
      with fs fs'
      show "(s = \<bottom> \<and> s' = \<bottom>)
          \<or> (\<exists>h t t'.
              (\<exists>f. t = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))
                 \<and> t' = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats)
                 \<and> s = h && t \<and> s' = h && t')" by best
    qed
    show "?R (?lhs\<cdot>f) (?rhs\<cdot>f)"
    proof -
      have lhs: "?lhs\<cdot>f = f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))" by (subst unwrapS.unfold, simp)
      have rhs: "?rhs\<cdot>f = f\<cdot>0 && smap\<cdot>(f oo (\<Lambda> x. 1 + x))\<cdot>nats" by (rule unwrapS'_unfold)
      from lhs rhs show ?thesis by best
    qed
  qed
qed

definition
  wrapS :: "'a Stream \<rightarrow> Nat \<rightarrow> 'a" where
  "wrapS \<equiv> \<Lambda> s i . s !! i"

text\<open>Note the identity requires that @{term "f"} be
strict. \citet[\S6.1]{GillHutton:2009} do not make this requirement,
an oversight on their part.

In practice all functions worth memoising are strict in the memoised
argument.\<close>

lemma wrapS_unwrapS_id':
  assumes strictF: "(f::Nat \<rightarrow> 'a)\<cdot>\<bottom> = \<bottom>"
  shows "unwrapS\<cdot>f !! n = f\<cdot>n"
using strictF
proof(induct n arbitrary: f rule: Nat_induct)
  case bottom with strictF show ?case by simp
next
  case zero thus ?case by (subst unwrapS.unfold, simp)
next
  case (Suc i f)
  have "unwrapS\<cdot>f !! (i + 1) = (f\<cdot>0 && unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x))) !! (i + 1)"
    by (subst unwrapS.unfold, simp)
  also from Suc have "\<dots> = unwrapS\<cdot>(f oo (\<Lambda> x. 1 + x)) !! i" by simp
  also from Suc have "\<dots> = (f oo (\<Lambda> x. 1 + x))\<cdot>i" by simp
  also have "\<dots> = f\<cdot>(i + 1)" by (simp add: plus_commute)
  finally show ?case .
qed

lemma wrapS_unwrapS_id: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> (wrapS oo unwrapS)\<cdot>f = f"
  by (rule cfun_eqI, simp add: wrapS_unwrapS_id' wrapS_def)

subsection\<open>Fibonacci example.\<close>

definition
  fib_body :: "(Nat \<rightarrow> Nat) \<rightarrow> Nat \<rightarrow> Nat" where
  "fib_body \<equiv> \<Lambda> r. Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n. r\<cdot>n + r\<cdot>(n + 1)))"

(*<*)
lemma fib_body_strict[simp]: "fib_body\<cdot>r\<cdot>\<bottom> = \<bottom>" by (simp add: fib_body_def)
(*>*)

definition
  fib :: "Nat \<rightarrow> Nat" where
  "fib \<equiv> fix\<cdot>fib_body"

(*<*)
lemma fib_strict[simp]: "fib\<cdot>\<bottom> = \<bottom>"
  by (unfold fib_def, subst fix_eq, fold fib_def, simp add: fib_body_def)
(*>*)

text\<open>Apply worker/wrapper.\<close>

definition
  fib_work :: "Nat Stream" where
  "fib_work \<equiv> fix\<cdot>(unwrapS oo fib_body oo wrapS)"

definition
  fib_wrap :: "Nat \<rightarrow> Nat" where
  "fib_wrap \<equiv> wrapS\<cdot>fib_work"

lemma wrapS_unwrapS_fib_body: "wrapS oo unwrapS oo fib_body = fib_body"
proof(rule cfun_eqI)
  fix r show "(wrapS oo unwrapS oo fib_body)\<cdot>r = fib_body\<cdot>r"
    using wrapS_unwrapS_id[where f="fib_body\<cdot>r"] by simp
qed

lemma fib_ww_eq: "fib = fib_wrap"
  using worker_wrapper_body[OF wrapS_unwrapS_fib_body]
  by (simp add: fib_def fib_wrap_def fib_work_def)

text\<open>Optimise.\<close>

fixrec
  fib_work_final :: "Nat Stream"
and
  fib_f_final :: "Nat \<rightarrow> Nat"
where
  "fib_work_final = smap\<cdot>fib_f_final\<cdot>nats"
| "fib_f_final = Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n'. fib_work_final !! n' + fib_work_final !! (n' + 1)))"

declare fib_f_final.simps[simp del] fib_work_final.simps[simp del]

definition
  fib_final :: "Nat \<rightarrow> Nat" where
  "fib_final \<equiv> \<Lambda> n. fib_work_final !! n"

text\<open>

This proof is only fiddly due to the way mutual recursion is encoded:
we need to use Beki\'{c}'s Theorem \citep{Bekic:1969}\footnote{The
interested reader can find some historical commentary in
\citet{Harel:1980, DBLP:journals/toplas/Sangiorgi09}.} to massage the
definitions into their final form.

\<close>

lemma fib_work_final_fib_work_eq: "fib_work_final = fib_work" (is "?lhs = ?rhs")
proof -
  let ?wb = "\<Lambda> r. Nat_case\<cdot>1\<cdot>(Nat_case\<cdot>1\<cdot>(\<Lambda> n'. r !! n' + r !! (n' + 1)))"
  let ?mr = "\<Lambda> (fwf :: Nat Stream, fff). (smap\<cdot>fff\<cdot>nats, ?wb\<cdot>fwf)"
  have "?lhs = fst (fix\<cdot>?mr)"
    by (simp add: fib_work_final_def split_def csplit_def)
  also have "\<dots> = (\<mu> fwf. fst (?mr\<cdot>(fwf, \<mu> fff. snd (?mr\<cdot>(fwf, fff)))))"
    using fix_cprod[where F="?mr"] by simp
  also have "\<dots> = (\<mu> fwf. smap\<cdot>(\<mu> fff. ?wb\<cdot>fwf)\<cdot>nats)" by simp
  also have "\<dots> = (\<mu> fwf. smap\<cdot>(?wb\<cdot>fwf)\<cdot>nats)" by (simp add: fix_const)
  also have "\<dots> = ?rhs"
    unfolding fib_body_def fib_work_def unwrapS_unwrapS'_eq unwrapS'_def wrapS_def
    by (simp add: cfcomp1)
  finally show ?thesis .
qed

lemma fib_final_fib_eq: "fib_final = fib" (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<Lambda> n. fib_work_final !! n)" by (simp add: fib_final_def)
  also have "\<dots> = (\<Lambda> n. fib_work !! n)" by (simp only: fib_work_final_fib_work_eq)
  also have "\<dots> = fib_wrap" by (simp add: fib_wrap_def wrapS_def)
  also have "\<dots> = ?rhs" by (simp only: fib_ww_eq)
  finally show ?thesis .
qed

(*<*)
end
(*>*)


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Variants of Regular Algebra\<close>

theory Regular_Algebra_Variants
  imports Regular_Algebras Pratts_Counterexamples
begin

text \<open>Replacing Kozen's induction axioms by Boffa's leads to incompleteness.\<close>

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x. x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
  shows "\<And>x y. (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
(*  nitpick [expect=genuine] --"5-element counterexample"*)
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x. x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
  shows "\<And>x y. x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
(*  nitpick [expect=genuine] --"5-element counterexample"*)
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x \<le> y \<and> y \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. 1 + x \<le> x\<^sup>\<star>"
  by (metis add_iso_r assms(1) mult_oner subdistl)

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x \<le> y \<and> y \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. x\<^sup>\<star> = (1 + x)\<^sup>\<star>"
oops \<comment> \<open>need to reconsider this\<close>

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y z. x \<cdot> y = y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y = y \<cdot> z\<^sup>\<star>"
  shows "1\<^sup>\<star> = 1"
(*  nitpick -- "3-element counterexample"*)
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y z. x \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"
  and "\<And>x y z. y \<cdot> x \<le> z \<cdot> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> y"
  shows "1\<^sup>\<star> = 1"
(*  nitpick [expect=genuine] -- "3-element counterexample"*)
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. x = y \<cdot> x \<Longrightarrow> x = y\<^sup>\<star> \<cdot> x"
  and "\<And>x y. x = x \<cdot> y \<Longrightarrow> x = x \<cdot> y\<^sup>\<star>"
  shows "\<And>x y. y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
oops

class C3l_var = conway_dioid +
  assumes C3l_var: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"

class C3r_var = conway_dioid +
  assumes C3r_var: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

class C3_var = C3l_var + C3r_var

sublocale C3l_var \<subseteq> C3l_algebra
  apply unfold_locales
  by (simp add: local.C3l_var)

sublocale C3l_algebra \<subseteq> C3l_var
  by (unfold_locales, metis star_inductl_var)

sublocale C3_var \<subseteq> C3_algebra
  apply unfold_locales
  by (simp add: local.C3r_var)

sublocale C3_algebra \<subseteq> C3_var
  by (unfold_locales, metis star_inductr_var)

class Brtc_algebra = star_dioid +
  assumes rtc1: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and rtc2: "1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"

sublocale B2_algebra \<subseteq> Brtc_algebra
proof
  fix x y
  show "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
    by (simp add: local.star_ext)
  show "1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis B23 local.join.le_sup_iff eq_iff mult_1_right subdistl)
qed

sublocale Brtc_algebra \<subseteq> B2_algebra
proof
  fix x y
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis rtc1 join.le_sup_iff)
  show "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  proof (rule antisym)
    show "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by (metis rtc1 join.le_sup_iff)
    show "x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>"
      by (metis rtc1 add.commute join.le_sup_iff less_eq_def mult_isor mult_onel)
  qed
  show "\<lbrakk> 1 + x \<le> y; y \<cdot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis rtc2 eq_refl less_eq_def)
qed

class wB1_algebra = conway_dioid +
  assumes wR: "x \<cdot> x \<le> x \<Longrightarrow> x\<^sup>\<star> = 1 + x"

sublocale wB1_algebra \<subseteq> B1_algebra
  by (unfold_locales, metis order_refl wR)

lemma (in B1_algebra) one_plus_star:  "x\<^sup>\<star> = (1 + x)\<^sup>\<star>"
  by (metis C11_var R add_idem' mult_onel mult_oner)

sublocale B1_algebra \<subseteq> wB1_algebra
proof unfold_locales
  fix x :: 'a
  assume "x \<cdot> x \<le> x"
  hence "x \<cdot> (1 + x) = x"
    by (simp add: local.distrib_left local.join.sup_absorb1)
  hence "(1 + x) \<cdot> (1 + x) = 1 + x"
    using add.left_commute distrib_right' by simp
  thus "x\<^sup>\<star> = 1 + x"
    by (metis R add_assoc' add_idem' one_plus_star)
qed

end


(*
  File:     Non_Regular_Languages.thy
  Author:   Manuel Eberl <manuel@pruvisto.org>

  This file provides some tools for showing the non-regularity of a language, either
  via an infinite set of equivalence classes or via the Pumping Lemma.
*)
section \<open>Tools for showing non-regularity of a language\<close>
theory Non_Regular_Languages
  imports Myhill
begin

subsection \<open>Auxiliary material\<close>

lemma bij_betw_image_quotient:
  "bij_betw (\<lambda>y. f -` {y}) (f ` A) (A // {(a,b). f a = f b})"
  by (force simp: bij_betw_def inj_on_def image_image quotient_def)

lemma regular_Derivs_finite:
  fixes r :: "'a :: finite rexp"
  shows "finite (range (\<lambda>w. Derivs w (lang r)))"
proof -
  have "?thesis \<longleftrightarrow> finite (UNIV // \<approx>lang r)"
    unfolding str_eq_conv_Derivs by (rule bij_betw_finite bij_betw_image_quotient)+
  also have "\<dots>" by (subst Myhill_Nerode [symmetric]) auto
  finally show ?thesis .
qed

lemma Nil_in_Derivs_iff: "[] \<in> Derivs w A \<longleftrightarrow> w \<in> A"
  by (auto simp: Derivs_def)

(* TODO: Move to distribution? *)
text \<open>
  The following operation repeats a list $n$ times (usually written as $w ^ n$).
\<close>
primrec repeat :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "repeat 0 xs = []"
| "repeat (Suc n) xs = xs @ repeat n xs"

lemma repeat_Cons_left: "repeat (Suc n) xs = xs @ repeat n xs" by simp

lemma repeat_Cons_right: "repeat (Suc n) xs = repeat n xs @ xs"
  by (induction n) simp_all

(* TODO: Move to distribution? *)
lemma nth_prefixes [simp]: "n \<le> length xs \<Longrightarrow> prefixes xs ! n = take n xs"
  by (induction xs arbitrary: n) (auto simp: nth_Cons split: nat.splits)

lemma nth_suffixes [simp]: "n \<le> length xs \<Longrightarrow> suffixes xs ! n = drop (length xs - n) xs"
  by (subst suffixes_conv_prefixes) (simp_all add: rev_take)

lemma length_take_prefixes:
  assumes "xs \<in> set (take n (prefixes ys))"
  shows   "length xs < n"
proof (cases "n \<le> Suc (length ys)")
  case True
  with assms obtain i where "i < n" "xs = take i ys"
    by (subst (asm) nth_image [symmetric]) auto
  thus ?thesis by simp
next
  case False
  with assms have "prefix xs ys" by simp
  hence "length xs \<le> length ys" by (rule prefix_length_le)
  also from False have "\<dots> < n" by simp
  finally show ?thesis .
qed

subsection \<open>Non-regularity by giving an infinite set of equivalence classes\<close>

text \<open>
  Non-regularity can be shown by giving an infinite set of non-equivalent words (w.r.t. the
  Myhill--Nerode relation).
\<close>
lemma not_regular_langI:
  assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(x @ w \<in> A \<longleftrightarrow> y @ w \<in> A)"
  shows   "\<not>regular_lang (A :: 'a :: finite list set)"
proof -
  have "(\<lambda>w. Derivs w A) ` B \<subseteq> range (\<lambda>w. Derivs w A)" by blast
  moreover from assms(2) have "inj_on (\<lambda>w. Derivs w A) B"
    by (auto simp: inj_on_def Derivs_def)
  with assms(1) have "infinite ((\<lambda>w. Derivs w A) ` B)"
    by (blast dest: finite_imageD)
  ultimately have "infinite (range (\<lambda>w. Derivs w A))" by (rule infinite_super)
  with regular_Derivs_finite show ?thesis by blast
qed

lemma not_regular_langI':
  assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(f x @ w \<in> A \<longleftrightarrow> f y @ w \<in> A)"
  shows   "\<not>regular_lang (A :: 'a :: finite list set)"
proof (rule not_regular_langI)
  from assms(2) have "inj_on f B" by (force simp: inj_on_def)
  with \<open>infinite B\<close> show "infinite (f ` B)" by (simp add: finite_image_iff)
qed (insert assms, auto)

subsection \<open>The Pumping Lemma\<close>

text \<open>
  The Pumping lemma can be shown very easily from the Myhill--Nerode theorem: if we have
  a word whose length is more than the (finite) number of equivalence classes, then it must
  have two different prefixes in the same class and the difference between these two
  prefixes can then be ``pumped''.
\<close>
lemma pumping_lemma_aux:
  fixes A :: "'a list set"
  defines "\<delta> \<equiv> \<lambda>w. Derivs w A"
  defines "n \<equiv> card (range \<delta>)"
  assumes "z \<in> A" "finite (range \<delta>)" "length z \<ge> n"
  shows "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> A)"
proof -
  define P where "P = set (take (Suc n) (prefixes z))"
  from \<open>length z \<ge> n\<close> have [simp]: "card P = Suc n"
    unfolding P_def by (subst distinct_card) (auto intro!: distinct_take)
  have length_le: "length y \<le> n" if "y \<in> P" for y
    using length_take_prefixes[OF that [unfolded P_def]] by simp

  have "card (\<delta> ` P) \<le> card (range \<delta>)" by (intro card_mono assms) auto
  also from assms have "\<dots> < card P" by simp
  finally have "\<not>inj_on \<delta> P" by (rule pigeonhole)
  then obtain a b where ab: "a \<in> P" "b \<in> P" "a \<noteq> b" "Derivs a A = Derivs b A"
    by (auto simp: inj_on_def \<delta>_def)
  from ab have prefix_ab: "prefix a z" "prefix b z" by (auto simp: P_def dest: in_set_takeD)
  from ab have length_ab: "length a \<le> n" "length b \<le> n"
    by (simp_all add: length_le)

  have *: ?thesis
    if uz': "prefix u z'" "prefix z' z" "length z' \<le> n"
            "u \<noteq> z'" "Derivs z' A = Derivs u A" for u z'
  proof -
    from \<open>prefix u z'\<close> and \<open>u \<noteq> z'\<close>
      obtain v where v [simp]: "z' = u @ v" "v \<noteq> []"
      by (auto simp: prefix_def)
    from \<open>prefix z' z\<close> obtain w where [simp]: "z = u @ v @ w"
      by (auto simp: prefix_def)

    hence [simp]: "Derivs (repeat i v) (Derivs u A) = Derivs u A" for i
      by (induction i) (use uz' in simp_all)
    have "Derivs z A = Derivs (u @ repeat i v @ w) A" for i
      using uz' by simp
    with \<open>z \<in> A\<close> and uz' have "\<forall>i. u @ repeat i v @ w \<in> A"
      by (simp add: Nil_in_Derivs_iff [of _ A, symmetric])
    moreover have "z = u @ v @ w" by simp
    moreover from \<open>length z' \<le> n\<close> have "length (u @ v) \<le> n" by simp
    ultimately show ?thesis using \<open>v \<noteq> []\<close> by blast
  qed

  from prefix_ab have "prefix a b \<or> prefix b a" by (rule prefix_same_cases)
  with *[of a b] and *[of b a] and ab and prefix_ab and length_ab show ?thesis by blast
qed

theorem pumping_lemma:
  fixes r :: "'a :: finite rexp"
  obtains n where
    "\<And>z. z \<in> lang r \<Longrightarrow> length z \<ge> n \<Longrightarrow>
            \<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
proof -
  let ?n = "card (range (\<lambda>w. Derivs w (lang r)))"
  have "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> ?n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
    if "z \<in> lang r" and "length z \<ge> ?n" for z
    by (intro pumping_lemma_aux[of z] that regular_Derivs_finite)
  thus ?thesis by (rule that)
qed

corollary pumping_lemma_not_regular_lang:
  fixes A :: "'a :: finite list set"
  assumes "\<And>n. length (z n) \<ge> n" and "\<And>n. z n \<in> A"
  assumes "\<And>n u v w. z n = u @ v @ w \<Longrightarrow> length (u @ v) \<le> n \<Longrightarrow> v \<noteq> [] \<Longrightarrow>
             u @ repeat (i n u v w) v @ w \<notin> A"
  shows   "\<not>regular_lang A"
proof
  assume "regular_lang A"
  then obtain r where r: "lang r = A" by blast
  from pumping_lemma[of r] obtain n
    where "z n \<in> lang r \<Longrightarrow> n \<le> length (z n) \<Longrightarrow>
      \<exists>u v w. z n = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
    by metis
  from this and assms[of n] obtain u v w
    where "z n = u @ v @ w" and "length (u @ v) \<le> n" and "v \<noteq> []" and
          "\<And>i. u @ repeat i v @ w \<in> lang r" by (auto simp: r)
  with assms(3)[of n u v w] show False by (auto simp: r)
qed

subsection \<open>Examples\<close>

text \<open>
  The language of all words containing the same number of $a$s and $b$s is not regular.
\<close>
lemma "\<not>regular_lang {w. length (filter id w) = length (filter Not w)}" (is "\<not>regular_lang ?A")
proof (rule not_regular_langI')
  show "infinite (UNIV :: nat set)" by simp
next
  fix m n :: nat assume "m \<noteq> n"
  hence "replicate m True @ replicate m False \<in> ?A" and
        "replicate n True @ replicate m False \<notin> ?A" by simp_all
  thus "\<exists>w. \<not>(replicate m True @ w \<in> ?A \<longleftrightarrow> replicate n True @ w \<in> ?A)" by blast
qed

text \<open>
  The language $\{a^i b^i\ |\ i \in \mathbb{N}\}$ is not regular.
\<close>
lemma eq_replicate_iff:
  "xs = replicate n x \<longleftrightarrow> set xs \<subseteq> {x} \<and> length xs = n"
  using replicate_length_same[of xs x] by (subst eq_commute) auto

lemma replicate_eq_appendE:
  assumes "xs @ ys = replicate n x"
  obtains i j where "n = i + j" "xs = replicate i x" "ys = replicate j x"
proof -
  have "n = length (replicate n x)" by simp
  also note assms [symmetric]
  finally have "n = length xs + length ys" by simp
  moreover have "xs = replicate (length xs) x" and "ys = replicate (length ys) x"
    using assms by (auto simp: eq_replicate_iff)
  ultimately show ?thesis using that[of "length xs" "length ys"] by auto
qed

lemma "\<not>regular_lang (range (\<lambda>i. replicate i True @ replicate i False))" (is "\<not>regular_lang ?A")
proof (rule pumping_lemma_not_regular_lang)
  fix n :: nat
  show "length (replicate n True @ replicate n False) \<ge> n" by simp
  show "replicate n True @ replicate n False \<in> ?A" by simp
next
  fix n :: nat and u v w :: "bool list"
  assume decomp: "replicate n True @ replicate n False = u @ v @ w"
     and length_le: "length (u @ v) \<le> n" and v_ne: "v \<noteq> []"
  define w1 w2 where "w1 = take (n - length (u@v)) w" and "w2 = drop (n - length (u@v)) w"
  have w_decomp: "w = w1 @ w2" by (simp add: w1_def w2_def)

  have "replicate n True = take n (replicate n True @ replicate n False)" by simp
  also note decomp
  also have "take n (u @ v @ w) = u @ v @ w1" using length_le by (simp add: w1_def)
  finally have "u @ v @ w1 = replicate n True" by simp
  then obtain i j k
    where uvw1: "n = i + j + k" "u = replicate i True" "v = replicate j True" "w1 = replicate k True"
    by (elim replicate_eq_appendE) auto

  have "replicate n False = drop n (replicate n True @ replicate n False)" by simp
  also note decomp
  finally have [simp]: "w2 = replicate n False" using length_le by (simp add: w2_def)

  have "u @ repeat (Suc (Suc 0)) v @ w = replicate (n + j) True @ replicate n False"
    by (simp add: uvw1 w_decomp replicate_add [symmetric])
  also have "\<dots> \<notin> ?A"
  proof safe
    fix m assume *: "replicate (n + j) True @ replicate n False =
                       replicate m True @ replicate m False" (is "?lhs = ?rhs")
    have "n = length (filter Not ?lhs)" by simp
    also note *
    also have "length (filter Not ?rhs) = m" by simp
    finally have [simp]: "m = n" by simp
    from * have "v = []" by (simp add: uvw1)
    with \<open>v \<noteq> []\<close> show False by contradiction
  qed
  finally show "u @ repeat (Suc (Suc 0)) v @ w \<notin> ?A" .
qed

end


(*  Title:      HOL/Analysis/Continuous_Extension.thy
    Authors:    LC Paulson, based on material from HOL Light
*)

section \<open>Continuous extensions of functions: Urysohn's lemma, Dugundji extension theorem, Tietze\<close>

theory Continuous_Extension
imports Convex_Euclidean_Space
begin

subsection\<open>Partitions of unity subordinate to locally finite open coverings\<close>

text\<open>A difference from HOL Light: all summations over infinite sets equal zero,
   so the "support" must be made explicit in the summation below!\<close>

proposition subordinate_partition_of_unity:
  fixes S :: "'a :: euclidean_space set"
  assumes "S \<subseteq> \<Union>\<C>" and opC: "\<And>T. T \<in> \<C> \<Longrightarrow> open T"
      and fin: "\<And>x. x \<in> S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. U \<inter> V \<noteq> {}}"
  obtains F :: "['a set, 'a] \<Rightarrow> real"
    where "\<And>U. U \<in> \<C> \<Longrightarrow> continuous_on S (F U) \<and> (\<forall>x \<in> S. 0 \<le> F U x)"
      and "\<And>x U. \<lbrakk>U \<in> \<C>; x \<in> S; x \<notin> U\<rbrakk> \<Longrightarrow> F U x = 0"
      and "\<And>x. x \<in> S \<Longrightarrow> supp_sum (\<lambda>W. F W x) \<C> = 1"
      and "\<And>x. x \<in> S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. F U x \<noteq> 0}"
proof (cases "\<exists>W. W \<in> \<C> \<and> S \<subseteq> W")
  case True
    then obtain W where "W \<in> \<C>" "S \<subseteq> W" by metis
    then show ?thesis
      apply (rule_tac F = "\<lambda>V x. if V = W then 1 else 0" in that)
      apply (auto simp: continuous_on_const supp_sum_def support_on_def)
      done
next
  case False
    have nonneg: "0 \<le> supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>" for x
      by (simp add: supp_sum_def sum_nonneg)
    have sd_pos: "0 < setdist {x} (S - V)" if "V \<in> \<C>" "x \<in> S" "x \<in> V" for V x
    proof -
      have "closedin (subtopology euclidean S) (S - V)"
        by (simp add: Diff_Diff_Int Diff_subset closedin_def opC openin_open_Int \<open>V \<in> \<C>\<close>)
      with that False setdist_eq_0_closedin [of S "S-V" x] setdist_pos_le [of "{x}" "S - V"]
        show ?thesis
          by (simp add: order_class.order.order_iff_strict)
    qed
    have ss_pos: "0 < supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>" if "x \<in> S" for x
    proof -
      obtain U where "U \<in> \<C>" "x \<in> U" using \<open>x \<in> S\<close> \<open>S \<subseteq> \<Union>\<C>\<close>
        by blast
      obtain V where "open V" "x \<in> V" "finite {U \<in> \<C>. U \<inter> V \<noteq> {}}"
        using \<open>x \<in> S\<close> fin by blast
      then have *: "finite {A \<in> \<C>. \<not> S \<subseteq> A \<and> x \<notin> closure (S - A)}"
        using closure_def that by (blast intro: rev_finite_subset)
      have "x \<notin> closure (S - U)"
        by (metis \<open>U \<in> \<C>\<close> \<open>x \<in> U\<close> less_irrefl sd_pos setdist_eq_0_sing_1 that)
      then show ?thesis
        apply (simp add: setdist_eq_0_sing_1 supp_sum_def support_on_def)
        apply (rule ordered_comm_monoid_add_class.sum_pos2 [OF *, of U])
        using \<open>U \<in> \<C>\<close> \<open>x \<in> U\<close> False
        apply (auto simp: setdist_pos_le sd_pos that)
        done
    qed
    define F where
      "F \<equiv> \<lambda>W x. if x \<in> S then setdist {x} (S - W) / supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>
                 else 0"
    show ?thesis
    proof (rule_tac F = F in that)
      have "continuous_on S (F U)" if "U \<in> \<C>" for U
      proof -
        have *: "continuous_on S (\<lambda>x. supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>)"
        proof (clarsimp simp add: continuous_on_eq_continuous_within)
          fix x assume "x \<in> S"
          then obtain X where "open X" and x: "x \<in> S \<inter> X" and finX: "finite {U \<in> \<C>. U \<inter> X \<noteq> {}}"
            using assms by blast
          then have OSX: "openin (subtopology euclidean S) (S \<inter> X)" by blast
          have sumeq: "\<And>x. x \<in> S \<inter> X \<Longrightarrow>
                     (\<Sum>V | V \<in> \<C> \<and> V \<inter> X \<noteq> {}. setdist {x} (S - V))
                     = supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>"
            apply (simp add: supp_sum_def)
            apply (rule sum.mono_neutral_right [OF finX])
            apply (auto simp: setdist_eq_0_sing_1 support_on_def subset_iff)
            apply (meson DiffI closure_subset disjoint_iff_not_equal subsetCE)
            done
          show "continuous (at x within S) (\<lambda>x. supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>)"
            apply (rule continuous_transform_within_openin
                     [where f = "\<lambda>x. (sum (\<lambda>V. setdist {x} (S - V)) {V \<in> \<C>. V \<inter> X \<noteq> {}})"
                        and S ="S \<inter> X"])
            apply (rule continuous_intros continuous_at_setdist continuous_at_imp_continuous_at_within OSX x)+
            apply (simp add: sumeq)
            done
        qed
        show ?thesis
          apply (simp add: F_def)
          apply (rule continuous_intros *)+
          using ss_pos apply force
          done
      qed
      moreover have "\<lbrakk>U \<in> \<C>; x \<in> S\<rbrakk> \<Longrightarrow> 0 \<le> F U x" for U x
        using nonneg [of x] by (simp add: F_def divide_simps setdist_pos_le)
      ultimately show "\<And>U. U \<in> \<C> \<Longrightarrow> continuous_on S (F U) \<and> (\<forall>x\<in>S. 0 \<le> F U x)"
        by metis
    next
      show "\<And>x U. \<lbrakk>U \<in> \<C>; x \<in> S; x \<notin> U\<rbrakk> \<Longrightarrow> F U x = 0"
        by (simp add: setdist_eq_0_sing_1 closure_def F_def)
    next
      show "supp_sum (\<lambda>W. F W x) \<C> = 1" if "x \<in> S" for x
        using that ss_pos [OF that]
        by (simp add: F_def divide_simps supp_sum_divide_distrib [symmetric])
    next
      show "\<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. F U x \<noteq> 0}" if "x \<in> S" for x
        using fin [OF that] that
        by (fastforce simp: setdist_eq_0_sing_1 closure_def F_def elim!: rev_finite_subset)
    qed
qed

subsection\<open>Urysohn's lemma (for Euclidean spaces, where the proof is easy using distances)\<close>

lemma Urysohn_both_ne:
  assumes US: "closedin (subtopology euclidean U) S"
      and UT: "closedin (subtopology euclidean U) T"
      and "S \<inter> T = {}" "S \<noteq> {}" "T \<noteq> {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::real_normed_vector"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
proof -
  have S0: "\<And>x. x \<in> U \<Longrightarrow> setdist {x} S = 0 \<longleftrightarrow> x \<in> S"
    using \<open>S \<noteq> {}\<close>  US setdist_eq_0_closedin  by auto
  have T0: "\<And>x. x \<in> U \<Longrightarrow> setdist {x} T = 0 \<longleftrightarrow> x \<in> T"
    using \<open>T \<noteq> {}\<close>  UT setdist_eq_0_closedin  by auto
  have sdpos: "0 < setdist {x} S + setdist {x} T" if "x \<in> U" for x
  proof -
    have "~ (setdist {x} S = 0 \<and> setdist {x} T = 0)"
      using assms by (metis IntI empty_iff setdist_eq_0_closedin that)
    then show ?thesis
      by (metis add.left_neutral add.right_neutral add_pos_pos linorder_neqE_linordered_idom not_le setdist_pos_le)
  qed
  define f where "f \<equiv> \<lambda>x. a + (setdist {x} S / (setdist {x} S + setdist {x} T)) *\<^sub>R (b - a)"
  show ?thesis
  proof (rule_tac f = f in that)
    show "continuous_on U f"
      using sdpos unfolding f_def
      by (intro continuous_intros | force)+
    show "f x \<in> closed_segment a b" if "x \<in> U" for x
        unfolding f_def
      apply (simp add: closed_segment_def)
      apply (rule_tac x="(setdist {x} S / (setdist {x} S + setdist {x} T))" in exI)
      using sdpos that apply (simp add: algebra_simps)
      done
    show "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
      using S0 \<open>a \<noteq> b\<close> f_def sdpos by force
    show "(f x = b \<longleftrightarrow> x \<in> T)" if "x \<in> U" for x
    proof -
      have "f x = b \<longleftrightarrow> (setdist {x} S / (setdist {x} S + setdist {x} T)) = 1"
        unfolding f_def
        apply (rule iffI)
         apply (metis  \<open>a \<noteq> b\<close> add_diff_cancel_left' eq_iff_diff_eq_0 pth_1 real_vector.scale_right_imp_eq, force)
        done
      also have "...  \<longleftrightarrow> setdist {x} T = 0 \<and> setdist {x} S \<noteq> 0"
        using sdpos that
        by (simp add: divide_simps) linarith
      also have "...  \<longleftrightarrow> x \<in> T"
        using \<open>S \<noteq> {}\<close> \<open>T \<noteq> {}\<close> \<open>S \<inter> T = {}\<close> that
        by (force simp: S0 T0)
      finally show ?thesis .
    qed
  qed
qed

proposition Urysohn_local_strong:
  assumes US: "closedin (subtopology euclidean U) S"
      and UT: "closedin (subtopology euclidean U) T"
      and "S \<inter> T = {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
proof (cases "S = {}")
  case True show ?thesis
  proof (cases "T = {}")
    case True show ?thesis
    proof (rule_tac f = "\<lambda>x. midpoint a b" in that)
      show "continuous_on U (\<lambda>x. midpoint a b)"
        by (intro continuous_intros)
      show "midpoint a b \<in> closed_segment a b"
        using csegment_midpoint_subset by blast
      show "(midpoint a b = a) = (x \<in> S)" for x
        using \<open>S = {}\<close> \<open>a \<noteq> b\<close> by simp
      show "(midpoint a b = b) = (x \<in> T)" for x
        using \<open>T = {}\<close> \<open>a \<noteq> b\<close> by simp
    qed
  next
    case False
    show ?thesis
    proof (cases "T = U")
      case True with \<open>S = {}\<close> \<open>a \<noteq> b\<close> show ?thesis
        by (rule_tac f = "\<lambda>x. b" in that) (auto simp: continuous_on_const)
    next
      case False
      with UT closedin_subset obtain c where c: "c \<in> U" "c \<notin> T"
        by fastforce
      obtain f where f: "continuous_on U f"
                "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment (midpoint a b) b"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = midpoint a b \<longleftrightarrow> x = c)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
        apply (rule Urysohn_both_ne [of U "{c}" T "midpoint a b" "b"])
        using c \<open>T \<noteq> {}\<close> assms apply simp_all
        done
      show ?thesis
        apply (rule_tac f=f in that)
        using \<open>S = {}\<close> \<open>T \<noteq> {}\<close> f csegment_midpoint_subset notin_segment_midpoint [OF \<open>a \<noteq> b\<close>]
        apply force+
        done
    qed
  qed
next
  case False
  show ?thesis
  proof (cases "T = {}")
    case True show ?thesis
    proof (cases "S = U")
      case True with \<open>T = {}\<close> \<open>a \<noteq> b\<close> show ?thesis
        by (rule_tac f = "\<lambda>x. a" in that) (auto simp: continuous_on_const)
    next
      case False
      with US closedin_subset obtain c where c: "c \<in> U" "c \<notin> S"
        by fastforce
      obtain f where f: "continuous_on U f"
                "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a (midpoint a b)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = midpoint a b \<longleftrightarrow> x = c)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
        apply (rule Urysohn_both_ne [of U S "{c}" a "midpoint a b"])
        using c \<open>S \<noteq> {}\<close> assms apply simp_all
        apply (metis midpoint_eq_endpoint)
        done
      show ?thesis
        apply (rule_tac f=f in that)
        using \<open>S \<noteq> {}\<close> \<open>T = {}\<close> f  \<open>a \<noteq> b\<close>
        apply simp_all
        apply (metis (no_types) closed_segment_commute csegment_midpoint_subset midpoint_sym subset_iff)
        apply (metis closed_segment_commute midpoint_sym notin_segment_midpoint)
        done
    qed
  next
    case False
    show ?thesis
      using Urysohn_both_ne [OF US UT \<open>S \<inter> T = {}\<close> \<open>S \<noteq> {}\<close> \<open>T \<noteq> {}\<close> \<open>a \<noteq> b\<close>] that
      by blast
  qed
qed

lemma Urysohn_local:
  assumes US: "closedin (subtopology euclidean U) S"
      and UT: "closedin (subtopology euclidean U) T"
      and "S \<inter> T = {}"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> S \<Longrightarrow> f x = a"
          "\<And>x. x \<in> T \<Longrightarrow> f x = b"
proof (cases "a = b")
  case True then show ?thesis
    by (rule_tac f = "\<lambda>x. b" in that) (auto simp: continuous_on_const)
next
  case False
  then show ?thesis
    apply (rule Urysohn_local_strong [OF assms])
    apply (erule that, assumption)
    apply (meson US closedin_singleton closedin_trans)
    apply (meson UT closedin_singleton closedin_trans)
    done
qed

lemma Urysohn_strong:
  assumes US: "closed S"
      and UT: "closed T"
      and "S \<inter> T = {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on UNIV f"
          "\<And>x. f x \<in> closed_segment a b"
          "\<And>x. f x = a \<longleftrightarrow> x \<in> S"
          "\<And>x. f x = b \<longleftrightarrow> x \<in> T"
apply (rule Urysohn_local_strong [of UNIV S T])
using assms
apply (auto simp: closed_closedin)
done

proposition Urysohn:
  assumes US: "closed S"
      and UT: "closed T"
      and "S \<inter> T = {}"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on UNIV f"
          "\<And>x. f x \<in> closed_segment a b"
          "\<And>x. x \<in> S \<Longrightarrow> f x = a"
          "\<And>x. x \<in> T \<Longrightarrow> f x = b"
apply (rule Urysohn_local [of UNIV S T a b])
using assms
apply (auto simp: closed_closedin)
done

subsection\<open> The Dugundji extension theorem, and Tietze variants as corollaries.\<close>

text\<open>J. Dugundji. An extension of Tietze's theorem. Pacific J. Math. Volume 1, Number 3 (1951), 353-367.
http://projecteuclid.org/euclid.pjm/1103052106\<close>

theorem Dugundji:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_inner"
  assumes "convex C" "C \<noteq> {}"
      and cloin: "closedin (subtopology euclidean U) S"
      and contf: "continuous_on S f" and "f ` S \<subseteq> C"
  obtains g where "continuous_on U g" "g ` U \<subseteq> C"
                  "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
proof (cases "S = {}")
  case True then show thesis
    apply (rule_tac g="\<lambda>x. @y. y \<in> C" in that)
      apply (rule continuous_intros)
     apply (meson all_not_in_conv \<open>C \<noteq> {}\<close> image_subsetI someI_ex, simp)
    done
next
  case False
  then have sd_pos: "\<And>x. \<lbrakk>x \<in> U; x \<notin> S\<rbrakk> \<Longrightarrow> 0 < setdist {x} S"
    using setdist_eq_0_closedin [OF cloin] le_less setdist_pos_le by fastforce
  define \<B> where "\<B> = {ball x (setdist {x} S / 2) |x. x \<in> U - S}"
  have [simp]: "\<And>T. T \<in> \<B> \<Longrightarrow> open T"
    by (auto simp: \<B>_def)
  have USS: "U - S \<subseteq> \<Union>\<B>"
    by (auto simp: sd_pos \<B>_def)
  obtain \<C> where USsub: "U - S \<subseteq> \<Union>\<C>"
       and nbrhd: "\<And>U. U \<in> \<C> \<Longrightarrow> open U \<and> (\<exists>T. T \<in> \<B> \<and> U \<subseteq> T)"
       and fin: "\<And>x. x \<in> U - S
                     \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U. U \<in> \<C> \<and> U \<inter> V \<noteq> {}}"
    using paracompact [OF USS] by auto
  have "\<exists>v a. v \<in> U \<and> v \<notin> S \<and> a \<in> S \<and>
              T \<subseteq> ball v (setdist {v} S / 2) \<and>
              dist v a \<le> 2 * setdist {v} S" if "T \<in> \<C>" for T
  proof -
    obtain v where v: "T \<subseteq> ball v (setdist {v} S / 2)" "v \<in> U" "v \<notin> S"
      using \<open>T \<in> \<C>\<close> nbrhd by (force simp: \<B>_def)
    then obtain a where "a \<in> S" "dist v a < 2 * setdist {v} S"
      using setdist_ltE [of "{v}" S "2 * setdist {v} S"]
      using False sd_pos by force
    with v show ?thesis
      apply (rule_tac x=v in exI)
      apply (rule_tac x=a in exI, auto)
      done
  qed
  then obtain \<V> \<A> where
    VA: "\<And>T. T \<in> \<C> \<Longrightarrow> \<V> T \<in> U \<and> \<V> T \<notin> S \<and> \<A> T \<in> S \<and>
              T \<subseteq> ball (\<V> T) (setdist {\<V> T} S / 2) \<and>
              dist (\<V> T) (\<A> T) \<le> 2 * setdist {\<V> T} S"
    by metis
  have sdle: "setdist {\<V> T} S \<le> 2 * setdist {v} S" if "T \<in> \<C>" "v \<in> T" for T v
    using setdist_Lipschitz [of "\<V> T" S v] VA [OF \<open>T \<in> \<C>\<close>] \<open>v \<in> T\<close> by auto
  have d6: "dist a (\<A> T) \<le> 6 * dist a v" if "T \<in> \<C>" "v \<in> T" "a \<in> S" for T v a
  proof -
    have "dist (\<V> T) v < setdist {\<V> T} S / 2"
      using that VA mem_ball by blast
    also have "... \<le> setdist {v} S"
      using sdle [OF \<open>T \<in> \<C>\<close> \<open>v \<in> T\<close>] by simp
    also have vS: "setdist {v} S \<le> dist a v"
      by (simp add: setdist_le_dist setdist_sym \<open>a \<in> S\<close>)
    finally have VTV: "dist (\<V> T) v < dist a v" .
    have VTS: "setdist {\<V> T} S \<le> 2 * dist a v"
      using sdle that vS by force
    have "dist a (\<A> T) \<le> dist a v + dist v (\<V> T) + dist (\<V> T) (\<A> T)"
      by (metis add.commute add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
    also have "... \<le> dist a v + dist a v + dist (\<V> T) (\<A> T)"
      using VTV by (simp add: dist_commute)
    also have "... \<le> 2 * dist a v + 2 * setdist {\<V> T} S"
      using VA [OF \<open>T \<in> \<C>\<close>] by auto
    finally show ?thesis
      using VTS by linarith
  qed
  obtain H :: "['a set, 'a] \<Rightarrow> real"
    where Hcont: "\<And>Z. Z \<in> \<C> \<Longrightarrow> continuous_on (U-S) (H Z)"
      and Hge0: "\<And>Z x. \<lbrakk>Z \<in> \<C>; x \<in> U-S\<rbrakk> \<Longrightarrow> 0 \<le> H Z x"
      and Heq0: "\<And>x Z. \<lbrakk>Z \<in> \<C>; x \<in> U-S; x \<notin> Z\<rbrakk> \<Longrightarrow> H Z x = 0"
      and H1: "\<And>x. x \<in> U-S \<Longrightarrow> supp_sum (\<lambda>W. H W x) \<C> = 1"
      and Hfin: "\<And>x. x \<in> U-S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. H U x \<noteq> 0}"
    apply (rule subordinate_partition_of_unity [OF USsub _ fin])
    using nbrhd by auto
  define g where "g \<equiv> \<lambda>x. if x \<in> S then f x else supp_sum (\<lambda>T. H T x *\<^sub>R f(\<A> T)) \<C>"
  show ?thesis
  proof (rule that)
    show "continuous_on U g"
    proof (clarsimp simp: continuous_on_eq_continuous_within)
      fix a assume "a \<in> U"
      show "continuous (at a within U) g"
      proof (cases "a \<in> S")
        case True show ?thesis
        proof (clarsimp simp add: continuous_within_topological)
          fix W
          assume "open W" "g a \<in> W"
          then obtain e where "0 < e" and e: "ball (f a) e \<subseteq> W"
            using openE True g_def by auto
          have "continuous (at a within S) f"
            using True contf continuous_on_eq_continuous_within by blast
          then obtain d where "0 < d"
                        and d: "\<And>x. \<lbrakk>x \<in> S; dist x a < d\<rbrakk> \<Longrightarrow> dist (f x) (f a) < e"
            using continuous_within_eps_delta \<open>0 < e\<close> by force
          have "g y \<in> ball (f a) e" if "y \<in> U" and y: "y \<in> ball a (d / 6)" for y
          proof (cases "y \<in> S")
            case True
            then have "dist (f a) (f y) < e"
              by (metis ball_divide_subset_numeral dist_commute in_mono mem_ball y d)
            then show ?thesis
              by (simp add: True g_def)
          next
            case False
            have *: "dist (f (\<A> T)) (f a) < e" if "T \<in> \<C>" "H T y \<noteq> 0" for T
            proof -
              have "y \<in> T"
                using Heq0 that False \<open>y \<in> U\<close> by blast
              have "dist (\<A> T) a < d"
                using d6 [OF \<open>T \<in> \<C>\<close> \<open>y \<in> T\<close> \<open>a \<in> S\<close>] y
                by (simp add: dist_commute mult.commute)
              then show ?thesis
                using VA [OF \<open>T \<in> \<C>\<close>] by (auto simp: d)
            qed
            have "supp_sum (\<lambda>T. H T y *\<^sub>R f (\<A> T)) \<C> \<in> ball (f a) e"
              apply (rule convex_supp_sum [OF convex_ball])
              apply (simp_all add: False H1 Hge0 \<open>y \<in> U\<close>)
              by (metis dist_commute *)
            then show ?thesis
              by (simp add: False g_def)
          qed
          then show "\<exists>A. open A \<and> a \<in> A \<and> (\<forall>y\<in>U. y \<in> A \<longrightarrow> g y \<in> W)"
            apply (rule_tac x = "ball a (d / 6)" in exI)
            using e \<open>0 < d\<close> by fastforce
        qed
      next
        case False
        obtain N where N: "open N" "a \<in> N"
                   and finN: "finite {U \<in> \<C>. \<exists>a\<in>N. H U a \<noteq> 0}"
          using Hfin False \<open>a \<in> U\<close> by auto
        have oUS: "openin (subtopology euclidean U) (U - S)"
          using cloin by (simp add: openin_diff)
        have HcontU: "continuous (at a within U) (H T)" if "T \<in> \<C>" for T
          using Hcont [OF \<open>T \<in> \<C>\<close>] False  \<open>a \<in> U\<close> \<open>T \<in> \<C>\<close>
          apply (simp add: continuous_on_eq_continuous_within continuous_within)
          apply (rule Lim_transform_within_set)
          using oUS
            apply (force simp: eventually_at openin_contains_ball dist_commute dest!: bspec)+
          done
        show ?thesis
        proof (rule continuous_transform_within_openin [OF _ oUS])
          show "continuous (at a within U) (\<lambda>x. supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C>)"
          proof (rule continuous_transform_within_openin)
            show "continuous (at a within U)
                    (\<lambda>x. \<Sum>T\<in>{U \<in> \<C>. \<exists>x\<in>N. H U x \<noteq> 0}. H T x *\<^sub>R f (\<A> T))"
              by (force intro: continuous_intros HcontU)+
          next
            show "openin (subtopology euclidean U) ((U - S) \<inter> N)"
              using N oUS openin_trans by blast
          next
            show "a \<in> (U - S) \<inter> N" using False \<open>a \<in> U\<close> N by blast
          next
            show "\<And>x. x \<in> (U - S) \<inter> N \<Longrightarrow>
                         (\<Sum>T \<in> {U \<in> \<C>. \<exists>x\<in>N. H U x \<noteq> 0}. H T x *\<^sub>R f (\<A> T))
                         = supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C>"
              by (auto simp: supp_sum_def support_on_def
                       intro: sum.mono_neutral_right [OF finN])
          qed
        next
          show "a \<in> U - S" using False \<open>a \<in> U\<close> by blast
        next
          show "\<And>x. x \<in> U - S \<Longrightarrow> supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C> = g x"
            by (simp add: g_def)
        qed
      qed
    qed
    show "g ` U \<subseteq> C"
      using \<open>f ` S \<subseteq> C\<close> VA
      by (fastforce simp: g_def Hge0 intro!: convex_supp_sum [OF \<open>convex C\<close>] H1)
    show "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
      by (simp add: g_def)
  qed
qed

corollary Tietze:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_inner"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
      and "0 \<le> B"
      and "\<And>x. x \<in> S \<Longrightarrow> norm(f x) \<le> B"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
                  "\<And>x. x \<in> U \<Longrightarrow> norm(g x) \<le> B"
using assms
by (auto simp: image_subset_iff intro: Dugundji [of "cball 0 B" U S f])

corollary Tietze_closed_interval:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
      and "cbox a b \<noteq> {}"
      and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> cbox a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
                  "\<And>x. x \<in> U \<Longrightarrow> g x \<in> cbox a b"
apply (rule Dugundji [of "cbox a b" U S f])
using assms by auto

corollary Tietze_closed_interval_1:
  fixes f :: "'a::euclidean_space \<Rightarrow> real"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
      and "a \<le> b"
      and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> cbox a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
                  "\<And>x. x \<in> U \<Longrightarrow> g x \<in> cbox a b"
apply (rule Dugundji [of "cbox a b" U S f])
using assms by (auto simp: image_subset_iff)

corollary Tietze_open_interval:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
      and "box a b \<noteq> {}"
      and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> box a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
                  "\<And>x. x \<in> U \<Longrightarrow> g x \<in> box a b"
apply (rule Dugundji [of "box a b" U S f])
using assms by auto

corollary Tietze_open_interval_1:
  fixes f :: "'a::euclidean_space \<Rightarrow> real"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
      and "a < b"
      and no: "\<And>x. x \<in> S \<Longrightarrow> f x \<in> box a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
                  "\<And>x. x \<in> U \<Longrightarrow> g x \<in> box a b"
apply (rule Dugundji [of "box a b" U S f])
using assms by (auto simp: image_subset_iff)

corollary Tietze_unbounded:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_inner"
  assumes "continuous_on S f"
      and "closedin (subtopology euclidean U) S"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
apply (rule Dugundji [of UNIV U S f])
using assms by auto

end