(*  Title:      HOL/Multivariate_Analysis/Path_Connected.thy
    Author:     Robert Himmelmann, TU Muenchen
*)

section {* Continuous paths and path-connected sets *}

theory Path_Connected
imports Convex_Euclidean_Space
begin

subsection {* Paths. *}

definition path :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> bool"
  where "path g \<longleftrightarrow> continuous_on {0..1} g"

definition pathstart :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> 'a"
  where "pathstart g = g 0"

definition pathfinish :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> 'a"
  where "pathfinish g = g 1"

definition path_image :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> 'a set"
  where "path_image g = g ` {0 .. 1}"

definition reversepath :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> real \<Rightarrow> 'a"
  where "reversepath g = (\<lambda>x. g(1 - x))"

definition joinpaths :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> 'a"
    (infixr "+++" 75)
  where "g1 +++ g2 = (\<lambda>x. if x \<le> 1/2 then g1 (2 * x) else g2 (2 * x - 1))"

definition simple_path :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> bool"
  where "simple_path g \<longleftrightarrow>
    (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0)"

definition injective_path :: "(real \<Rightarrow> 'a::topological_space) \<Rightarrow> bool"
  where "injective_path g \<longleftrightarrow> (\<forall>x\<in>{0..1}. \<forall>y\<in>{0..1}. g x = g y \<longrightarrow> x = y)"

subsection {* Some lemmas about these concepts. *}

lemma injective_imp_simple_path: "injective_path g \<Longrightarrow> simple_path g"
  unfolding injective_path_def simple_path_def
  by auto

lemma path_image_nonempty: "path_image g \<noteq> {}"
  unfolding path_image_def image_is_empty box_eq_empty
  by auto

lemma pathstart_in_path_image[intro]: "pathstart g \<in> path_image g"
  unfolding pathstart_def path_image_def
  by auto

lemma pathfinish_in_path_image[intro]: "pathfinish g \<in> path_image g"
  unfolding pathfinish_def path_image_def
  by auto

lemma connected_path_image[intro]: "path g \<Longrightarrow> connected (path_image g)"
  unfolding path_def path_image_def
  apply (erule connected_continuous_image)
  apply (rule convex_connected, rule convex_real_interval)
  done

lemma compact_path_image[intro]: "path g \<Longrightarrow> compact (path_image g)"
  unfolding path_def path_image_def
  apply (erule compact_continuous_image)
  apply (rule compact_Icc)
  done

lemma reversepath_reversepath[simp]: "reversepath (reversepath g) = g"
  unfolding reversepath_def
  by auto

lemma pathstart_reversepath[simp]: "pathstart (reversepath g) = pathfinish g"
  unfolding pathstart_def reversepath_def pathfinish_def
  by auto

lemma pathfinish_reversepath[simp]: "pathfinish (reversepath g) = pathstart g"
  unfolding pathstart_def reversepath_def pathfinish_def
  by auto

lemma pathstart_join[simp]: "pathstart (g1 +++ g2) = pathstart g1"
  unfolding pathstart_def joinpaths_def pathfinish_def
  by auto

lemma pathfinish_join[simp]: "pathfinish (g1 +++ g2) = pathfinish g2"
  unfolding pathstart_def joinpaths_def pathfinish_def
  by auto

lemma path_image_reversepath[simp]: "path_image (reversepath g) = path_image g"
proof -
  have *: "\<And>g. path_image (reversepath g) \<subseteq> path_image g"
    unfolding path_image_def subset_eq reversepath_def Ball_def image_iff
    apply rule
    apply rule
    apply (erule bexE)
    apply (rule_tac x="1 - xa" in bexI)
    apply auto
    done
  show ?thesis
    using *[of g] *[of "reversepath g"]
    unfolding reversepath_reversepath
    by auto
qed

lemma path_reversepath [simp]: "path (reversepath g) \<longleftrightarrow> path g"
proof -
  have *: "\<And>g. path g \<Longrightarrow> path (reversepath g)"
    unfolding path_def reversepath_def
    apply (rule continuous_on_compose[unfolded o_def, of _ "\<lambda>x. 1 - x"])
    apply (intro continuous_intros)
    apply (rule continuous_on_subset[of "{0..1}"])
    apply assumption
    apply auto
    done
  show ?thesis
    using *[of "reversepath g"] *[of g]
    unfolding reversepath_reversepath
    by (rule iffI)
qed

lemmas reversepath_simps =
  path_reversepath path_image_reversepath pathstart_reversepath pathfinish_reversepath

lemma path_join[simp]:
  assumes "pathfinish g1 = pathstart g2"
  shows "path (g1 +++ g2) \<longleftrightarrow> path g1 \<and> path g2"
  unfolding path_def pathfinish_def pathstart_def
proof safe
  assume cont: "continuous_on {0..1} (g1 +++ g2)"
  have g1: "continuous_on {0..1} g1 \<longleftrightarrow> continuous_on {0..1} ((g1 +++ g2) \<circ> (\<lambda>x. x / 2))"
    by (intro continuous_on_cong refl) (auto simp: joinpaths_def)
  have g2: "continuous_on {0..1} g2 \<longleftrightarrow> continuous_on {0..1} ((g1 +++ g2) \<circ> (\<lambda>x. x / 2 + 1/2))"
    using assms
    by (intro continuous_on_cong refl) (auto simp: joinpaths_def pathfinish_def pathstart_def)
  show "continuous_on {0..1} g1" and "continuous_on {0..1} g2"
    unfolding g1 g2
    by (auto intro!: continuous_intros continuous_on_subset[OF cont] simp del: o_apply)
next
  assume g1g2: "continuous_on {0..1} g1" "continuous_on {0..1} g2"
  have 01: "{0 .. 1} = {0..1/2} \<union> {1/2 .. 1::real}"
    by auto
  {
    fix x :: real
    assume "0 \<le> x" and "x \<le> 1"
    then have "x \<in> (\<lambda>x. x * 2) ` {0..1 / 2}"
      by (intro image_eqI[where x="x/2"]) auto
  }
  note 1 = this
  {
    fix x :: real
    assume "0 \<le> x" and "x \<le> 1"
    then have "x \<in> (\<lambda>x. x * 2 - 1) ` {1 / 2..1}"
      by (intro image_eqI[where x="x/2 + 1/2"]) auto
  }
  note 2 = this
  show "continuous_on {0..1} (g1 +++ g2)"
    using assms
    unfolding joinpaths_def 01
    apply (intro continuous_on_cases closed_atLeastAtMost g1g2[THEN continuous_on_compose2] continuous_intros)
    apply (auto simp: field_simps pathfinish_def pathstart_def intro!: 1 2)
    done
qed

lemma path_image_join_subset: "path_image (g1 +++ g2) \<subseteq> path_image g1 \<union> path_image g2"
  unfolding path_image_def joinpaths_def
  by auto

lemma subset_path_image_join:
  assumes "path_image g1 \<subseteq> s"
    and "path_image g2 \<subseteq> s"
  shows "path_image (g1 +++ g2) \<subseteq> s"
  using path_image_join_subset[of g1 g2] and assms
  by auto

lemma path_image_join:
  assumes "pathfinish g1 = pathstart g2"
  shows "path_image (g1 +++ g2) = path_image g1 \<union> path_image g2"
  apply rule
  apply (rule path_image_join_subset)
  apply rule
  unfolding Un_iff
proof (erule disjE)
  fix x
  assume "x \<in> path_image g1"
  then obtain y where y: "y \<in> {0..1}" "x = g1 y"
    unfolding path_image_def image_iff by auto
  then show "x \<in> path_image (g1 +++ g2)"
    unfolding joinpaths_def path_image_def image_iff
    apply (rule_tac x="(1/2) *\<^sub>R y" in bexI)
    apply auto
    done
next
  fix x
  assume "x \<in> path_image g2"
  then obtain y where y: "y \<in> {0..1}" "x = g2 y"
    unfolding path_image_def image_iff by auto
  then show "x \<in> path_image (g1 +++ g2)"
    unfolding joinpaths_def path_image_def image_iff
    apply (rule_tac x="(1/2) *\<^sub>R (y + 1)" in bexI)
    using assms(1)[unfolded pathfinish_def pathstart_def]
    apply (auto simp add: add_divide_distrib)
    done
qed

lemma not_in_path_image_join:
  assumes "x \<notin> path_image g1"
    and "x \<notin> path_image g2"
  shows "x \<notin> path_image (g1 +++ g2)"
  using assms and path_image_join_subset[of g1 g2]
  by auto

lemma simple_path_reversepath:
  assumes "simple_path g"
  shows "simple_path (reversepath g)"
  using assms
  unfolding simple_path_def reversepath_def
  apply -
  apply (rule ballI)+
  apply (erule_tac x="1-x" in ballE)
  apply (erule_tac x="1-y" in ballE)
  apply auto
  done

lemma simple_path_join_loop:
  assumes "injective_path g1"
    and "injective_path g2"
    and "pathfinish g2 = pathstart g1"
    and "path_image g1 \<inter> path_image g2 \<subseteq> {pathstart g1, pathstart g2}"
  shows "simple_path (g1 +++ g2)"
  unfolding simple_path_def
proof (intro ballI impI)
  let ?g = "g1 +++ g2"
  note inj = assms(1,2)[unfolded injective_path_def, rule_format]
  fix x y :: real
  assume xy: "x \<in> {0..1}" "y \<in> {0..1}" "?g x = ?g y"
  show "x = y \<or> x = 0 \<and> y = 1 \<or> x = 1 \<and> y = 0"
  proof (cases "x \<le> 1/2", case_tac[!] "y \<le> 1/2", unfold not_le)
    assume as: "x \<le> 1 / 2" "y \<le> 1 / 2"
    then have "g1 (2 *\<^sub>R x) = g1 (2 *\<^sub>R y)"
      using xy(3)
      unfolding joinpaths_def
      by auto
    moreover have "2 *\<^sub>R x \<in> {0..1}" "2 *\<^sub>R y \<in> {0..1}"
      using xy(1,2) as
      by auto
    ultimately show ?thesis
      using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"]
      by auto
  next
    assume as: "x > 1 / 2" "y > 1 / 2"
    then have "g2 (2 *\<^sub>R x - 1) = g2 (2 *\<^sub>R y - 1)"
      using xy(3)
      unfolding joinpaths_def
      by auto
    moreover have "2 *\<^sub>R x - 1 \<in> {0..1}" "2 *\<^sub>R y - 1 \<in> {0..1}"
      using xy(1,2) as
      by auto
    ultimately show ?thesis
      using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] by auto
  next
    assume as: "x \<le> 1 / 2" "y > 1 / 2"
    then have "?g x \<in> path_image g1" "?g y \<in> path_image g2"
      unfolding path_image_def joinpaths_def
      using xy(1,2) by auto
    moreover have "?g y \<noteq> pathstart g2"
      using as(2)
      unfolding pathstart_def joinpaths_def
      using inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(2)
      by (auto simp add: field_simps)
    ultimately have *: "?g x = pathstart g1"
      using assms(4)
      unfolding xy(3)
      by auto
    then have "x = 0"
      unfolding pathstart_def joinpaths_def
      using as(1) and xy(1)
      using inj(1)[of "2 *\<^sub>R x" 0]
      by auto
    moreover have "y = 1"
      using *
      unfolding xy(3) assms(3)[symmetric]
      unfolding joinpaths_def pathfinish_def
      using as(2) and xy(2)
      using inj(2)[of "2 *\<^sub>R y - 1" 1]
      by auto
    ultimately show ?thesis
      by auto
  next
    assume as: "x > 1 / 2" "y \<le> 1 / 2"
    then have "?g x \<in> path_image g2" and "?g y \<in> path_image g1"
      unfolding path_image_def joinpaths_def
      using xy(1,2) by auto
    moreover have "?g x \<noteq> pathstart g2"
      using as(1)
      unfolding pathstart_def joinpaths_def
      using inj(2)[of "2 *\<^sub>R x - 1" 0] and xy(1)
      by (auto simp add: field_simps)
    ultimately have *: "?g y = pathstart g1"
      using assms(4)
      unfolding xy(3)
      by auto
    then have "y = 0"
      unfolding pathstart_def joinpaths_def
      using as(2) and xy(2)
      using inj(1)[of "2 *\<^sub>R y" 0]
      by auto
    moreover have "x = 1"
      using *
      unfolding xy(3)[symmetric] assms(3)[symmetric]
      unfolding joinpaths_def pathfinish_def using as(1) and xy(1)
      using inj(2)[of "2 *\<^sub>R x - 1" 1]
      by auto
    ultimately show ?thesis
      by auto
  qed
qed

lemma injective_path_join:
  assumes "injective_path g1"
    and "injective_path g2"
    and "pathfinish g1 = pathstart g2"
    and "path_image g1 \<inter> path_image g2 \<subseteq> {pathstart g2}"
  shows "injective_path (g1 +++ g2)"
  unfolding injective_path_def
proof (rule, rule, rule)
  let ?g = "g1 +++ g2"
  note inj = assms(1,2)[unfolded injective_path_def, rule_format]
  fix x y
  assume xy: "x \<in> {0..1}" "y \<in> {0..1}" "(g1 +++ g2) x = (g1 +++ g2) y"
  show "x = y"
  proof (cases "x \<le> 1/2", case_tac[!] "y \<le> 1/2", unfold not_le)
    assume "x \<le> 1 / 2" and "y \<le> 1 / 2"
    then show ?thesis
      using inj(1)[of "2*\<^sub>R x" "2*\<^sub>R y"] and xy
      unfolding joinpaths_def by auto
  next
    assume "x > 1 / 2" and "y > 1 / 2"
    then show ?thesis
      using inj(2)[of "2*\<^sub>R x - 1" "2*\<^sub>R y - 1"] and xy
      unfolding joinpaths_def by auto
  next
    assume as: "x \<le> 1 / 2" "y > 1 / 2"
    then have "?g x \<in> path_image g1" and "?g y \<in> path_image g2"
      unfolding path_image_def joinpaths_def
      using xy(1,2)
      by auto
    then have "?g x = pathfinish g1" and "?g y = pathstart g2"
      using assms(4)
      unfolding assms(3) xy(3)
      by auto
    then show ?thesis
      using as and inj(1)[of "2 *\<^sub>R x" 1] inj(2)[of "2 *\<^sub>R y - 1" 0] and xy(1,2)
      unfolding pathstart_def pathfinish_def joinpaths_def
      by auto
  next
    assume as:"x > 1 / 2" "y \<le> 1 / 2"
    then have "?g x \<in> path_image g2" and "?g y \<in> path_image g1"
      unfolding path_image_def joinpaths_def
      using xy(1,2)
      by auto
    then have "?g x = pathstart g2" and "?g y = pathfinish g1"
      using assms(4)
      unfolding assms(3) xy(3)
      by auto
    then show ?thesis using as and inj(2)[of "2 *\<^sub>R x - 1" 0] inj(1)[of "2 *\<^sub>R y" 1] and xy(1,2)
      unfolding pathstart_def pathfinish_def joinpaths_def
      by auto
  qed
qed

lemmas join_paths_simps = path_join path_image_join pathstart_join pathfinish_join

subsection {* Reparametrizing a closed curve to start at some chosen point *}

definition shiftpath :: "real \<Rightarrow> (real \<Rightarrow> 'a::topological_space) \<Rightarrow> real \<Rightarrow> 'a"
  where "shiftpath a f = (\<lambda>x. if (a + x) \<le> 1 then f (a + x) else f (a + x - 1))"

lemma pathstart_shiftpath: "a \<le> 1 \<Longrightarrow> pathstart (shiftpath a g) = g a"
  unfolding pathstart_def shiftpath_def by auto

lemma pathfinish_shiftpath:
  assumes "0 \<le> a"
    and "pathfinish g = pathstart g"
  shows "pathfinish (shiftpath a g) = g a"
  using assms
  unfolding pathstart_def pathfinish_def shiftpath_def
  by auto

lemma endpoints_shiftpath:
  assumes "pathfinish g = pathstart g"
    and "a \<in> {0 .. 1}"
  shows "pathfinish (shiftpath a g) = g a"
    and "pathstart (shiftpath a g) = g a"
  using assms
  by (auto intro!: pathfinish_shiftpath pathstart_shiftpath)

lemma closed_shiftpath:
  assumes "pathfinish g = pathstart g"
    and "a \<in> {0..1}"
  shows "pathfinish (shiftpath a g) = pathstart (shiftpath a g)"
  using endpoints_shiftpath[OF assms]
  by auto

lemma path_shiftpath:
  assumes "path g"
    and "pathfinish g = pathstart g"
    and "a \<in> {0..1}"
  shows "path (shiftpath a g)"
proof -
  have *: "{0 .. 1} = {0 .. 1-a} \<union> {1-a .. 1}"
    using assms(3) by auto
  have **: "\<And>x. x + a = 1 \<Longrightarrow> g (x + a - 1) = g (x + a)"
    using assms(2)[unfolded pathfinish_def pathstart_def]
    by auto
  show ?thesis
    unfolding path_def shiftpath_def *
    apply (rule continuous_on_union)
    apply (rule closed_real_atLeastAtMost)+
    apply (rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a + x)"])
    prefer 3
    apply (rule continuous_on_eq[of _ "g \<circ> (\<lambda>x. a - 1 + x)"])
    defer
    prefer 3
    apply (rule continuous_intros)+
    prefer 2
    apply (rule continuous_intros)+
    apply (rule_tac[1-2] continuous_on_subset[OF assms(1)[unfolded path_def]])
    using assms(3) and **
    apply auto
    apply (auto simp add: field_simps)
    done
qed

lemma shiftpath_shiftpath:
  assumes "pathfinish g = pathstart g"
    and "a \<in> {0..1}"
    and "x \<in> {0..1}"
  shows "shiftpath (1 - a) (shiftpath a g) x = g x"
  using assms
  unfolding pathfinish_def pathstart_def shiftpath_def
  by auto

lemma path_image_shiftpath:
  assumes "a \<in> {0..1}"
    and "pathfinish g = pathstart g"
  shows "path_image (shiftpath a g) = path_image g"
proof -
  { fix x
    assume as: "g 1 = g 0" "x \<in> {0..1::real}" " \<forall>y\<in>{0..1} \<inter> {x. \<not> a + x \<le> 1}. g x \<noteq> g (a + y - 1)"
    then have "\<exists>y\<in>{0..1} \<inter> {x. a + x \<le> 1}. g x = g (a + y)"
    proof (cases "a \<le> x")
      case False
      then show ?thesis
        apply (rule_tac x="1 + x - a" in bexI)
        using as(1,2) and as(3)[THEN bspec[where x="1 + x - a"]] and assms(1)
        apply (auto simp add: field_simps atomize_not)
        done
    next
      case True
      then show ?thesis
        using as(1-2) and assms(1)
        apply (rule_tac x="x - a" in bexI)
        apply (auto simp add: field_simps)
        done
    qed
  }
  then show ?thesis
    using assms
    unfolding shiftpath_def path_image_def pathfinish_def pathstart_def
    by (auto simp add: image_iff)
qed

subsection {* Special case of straight-line paths *}

definition linepath :: "'a::real_normed_vector \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a"
  where "linepath a b = (\<lambda>x. (1 - x) *\<^sub>R a + x *\<^sub>R b)"

lemma pathstart_linepath[simp]: "pathstart (linepath a b) = a"
  unfolding pathstart_def linepath_def
  by auto

lemma pathfinish_linepath[simp]: "pathfinish (linepath a b) = b"
  unfolding pathfinish_def linepath_def
  by auto

lemma continuous_linepath_at[intro]: "continuous (at x) (linepath a b)"
  unfolding linepath_def
  by (intro continuous_intros)

lemma continuous_on_linepath[intro]: "continuous_on s (linepath a b)"
  using continuous_linepath_at
  by (auto intro!: continuous_at_imp_continuous_on)

lemma path_linepath[intro]: "path (linepath a b)"
  unfolding path_def
  by (rule continuous_on_linepath)

lemma path_image_linepath[simp]: "path_image (linepath a b) = closed_segment a b"
  unfolding path_image_def segment linepath_def
  apply (rule set_eqI)
  apply rule
  defer
  unfolding mem_Collect_eq image_iff
  apply (erule exE)
  apply (rule_tac x="u *\<^sub>R 1" in bexI)
  apply auto
  done

lemma reversepath_linepath[simp]: "reversepath (linepath a b) = linepath b a"
  unfolding reversepath_def linepath_def
  by auto

lemma injective_path_linepath:
  assumes "a \<noteq> b"
  shows "injective_path (linepath a b)"
proof -
  {
    fix x y :: "real"
    assume "x *\<^sub>R b + y *\<^sub>R a = x *\<^sub>R a + y *\<^sub>R b"
    then have "(x - y) *\<^sub>R a = (x - y) *\<^sub>R b"
      by (simp add: algebra_simps)
    with assms have "x = y"
      by simp
  }
  then show ?thesis
    unfolding injective_path_def linepath_def
    by (auto simp add: algebra_simps)
qed

lemma simple_path_linepath[intro]: "a \<noteq> b \<Longrightarrow> simple_path (linepath a b)"
  by (auto intro!: injective_imp_simple_path injective_path_linepath)

subsection {* Bounding a point away from a path *}

lemma not_on_path_ball:
  fixes g :: "real \<Rightarrow> 'a::heine_borel"
  assumes "path g"
    and "z \<notin> path_image g"
  shows "\<exists>e > 0. ball z e \<inter> path_image g = {}"
proof -
  obtain a where "a \<in> path_image g" "\<forall>y \<in> path_image g. dist z a \<le> dist z y"
    using distance_attains_inf[OF _ path_image_nonempty, of g z]
    using compact_path_image[THEN compact_imp_closed, OF assms(1)] by auto
  then show ?thesis
    apply (rule_tac x="dist z a" in exI)
    using assms(2)
    apply (auto intro!: dist_pos_lt)
    done
qed

lemma not_on_path_cball:
  fixes g :: "real \<Rightarrow> 'a::heine_borel"
  assumes "path g"
    and "z \<notin> path_image g"
  shows "\<exists>e>0. cball z e \<inter> (path_image g) = {}"
proof -
  obtain e where "ball z e \<inter> path_image g = {}" "e > 0"
    using not_on_path_ball[OF assms] by auto
  moreover have "cball z (e/2) \<subseteq> ball z e"
    using `e > 0` by auto
  ultimately show ?thesis
    apply (rule_tac x="e/2" in exI)
    apply auto
    done
qed

subsection {* Path component, considered as a "joinability" relation (from Tom Hales) *}

definition "path_component s x y \<longleftrightarrow>
  (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"

lemmas path_defs = path_def pathstart_def pathfinish_def path_image_def path_component_def

lemma path_component_mem:
  assumes "path_component s x y"
  shows "x \<in> s" and "y \<in> s"
  using assms
  unfolding path_defs
  by auto

lemma path_component_refl:
  assumes "x \<in> s"
  shows "path_component s x x"
  unfolding path_defs
  apply (rule_tac x="\<lambda>u. x" in exI)
  using assms
  apply (auto intro!: continuous_intros)
  done

lemma path_component_refl_eq: "path_component s x x \<longleftrightarrow> x \<in> s"
  by (auto intro!: path_component_mem path_component_refl)

lemma path_component_sym: "path_component s x y \<Longrightarrow> path_component s y x"
  using assms
  unfolding path_component_def
  apply (erule exE)
  apply (rule_tac x="reversepath g" in exI)
  apply auto
  done

lemma path_component_trans:
  assumes "path_component s x y"
    and "path_component s y z"
  shows "path_component s x z"
  using assms
  unfolding path_component_def
  apply (elim exE)
  apply (rule_tac x="g +++ ga" in exI)
  apply (auto simp add: path_image_join)
  done

lemma path_component_of_subset: "s \<subseteq> t \<Longrightarrow> path_component s x y \<Longrightarrow> path_component t x y"
  unfolding path_component_def by auto

text {* Can also consider it as a set, as the name suggests. *}

lemma path_component_set:
  "{y. path_component s x y} =
    {y. (\<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)}"
  apply (rule set_eqI)
  unfolding mem_Collect_eq
  unfolding path_component_def
  apply auto
  done

lemma path_component_subset: "{y. path_component s x y} \<subseteq> s"
  apply rule
  apply (rule path_component_mem(2))
  apply auto
  done

lemma path_component_eq_empty: "{y. path_component s x y} = {} \<longleftrightarrow> x \<notin> s"
  apply rule
  apply (drule equals0D[of _ x])
  defer
  apply (rule equals0I)
  unfolding mem_Collect_eq
  apply (drule path_component_mem(1))
  using path_component_refl
  apply auto
  done

subsection {* Path connectedness of a space *}

definition "path_connected s \<longleftrightarrow>
  (\<forall>x\<in>s. \<forall>y\<in>s. \<exists>g. path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y)"

lemma path_connected_component: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. \<forall>y\<in>s. path_component s x y)"
  unfolding path_connected_def path_component_def by auto

lemma path_connected_component_set: "path_connected s \<longleftrightarrow> (\<forall>x\<in>s. {y. path_component s x y} = s)"
  unfolding path_connected_component
  apply rule
  apply rule
  apply rule
  apply (rule path_component_subset)
  unfolding subset_eq mem_Collect_eq Ball_def
  apply auto
  done

subsection {* Some useful lemmas about path-connectedness *}

lemma convex_imp_path_connected:
  fixes s :: "'a::real_normed_vector set"
  assumes "convex s"
  shows "path_connected s"
  unfolding path_connected_def
  apply rule
  apply rule
  apply (rule_tac x = "linepath x y" in exI)
  unfolding path_image_linepath
  using assms [unfolded convex_contains_segment]
  apply auto
  done

lemma path_connected_imp_connected:
  assumes "path_connected s"
  shows "connected s"
  unfolding connected_def not_ex
  apply rule
  apply rule
  apply (rule ccontr)
  unfolding not_not
  apply (elim conjE)
proof -
  fix e1 e2
  assume as: "open e1" "open e2" "s \<subseteq> e1 \<union> e2" "e1 \<inter> e2 \<inter> s = {}" "e1 \<inter> s \<noteq> {}" "e2 \<inter> s \<noteq> {}"
  then obtain x1 x2 where obt:"x1 \<in> e1 \<inter> s" "x2 \<in> e2 \<inter> s"
    by auto
  then obtain g where g: "path g" "path_image g \<subseteq> s" "pathstart g = x1" "pathfinish g = x2"
    using assms[unfolded path_connected_def,rule_format,of x1 x2] by auto
  have *: "connected {0..1::real}"
    by (auto intro!: convex_connected convex_real_interval)
  have "{0..1} \<subseteq> {x \<in> {0..1}. g x \<in> e1} \<union> {x \<in> {0..1}. g x \<in> e2}"
    using as(3) g(2)[unfolded path_defs] by blast
  moreover have "{x \<in> {0..1}. g x \<in> e1} \<inter> {x \<in> {0..1}. g x \<in> e2} = {}"
    using as(4) g(2)[unfolded path_defs]
    unfolding subset_eq
    by auto
  moreover have "{x \<in> {0..1}. g x \<in> e1} \<noteq> {} \<and> {x \<in> {0..1}. g x \<in> e2} \<noteq> {}"
    using g(3,4)[unfolded path_defs]
    using obt
    by (simp add: ex_in_conv [symmetric], metis zero_le_one order_refl)
  ultimately show False
    using *[unfolded connected_local not_ex, rule_format,
      of "{x\<in>{0..1}. g x \<in> e1}" "{x\<in>{0..1}. g x \<in> e2}"]
    using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(1)]
    using continuous_open_in_preimage[OF g(1)[unfolded path_def] as(2)]
    by auto
qed

lemma open_path_component:
  fixes s :: "'a::real_normed_vector set"
  assumes "open s"
  shows "open {y. path_component s x y}"
  unfolding open_contains_ball
proof
  fix y
  assume as: "y \<in> {y. path_component s x y}"
  then have "y \<in> s"
    apply -
    apply (rule path_component_mem(2))
    unfolding mem_Collect_eq
    apply auto
    done
  then obtain e where e: "e > 0" "ball y e \<subseteq> s"
    using assms[unfolded open_contains_ball]
    by auto
  show "\<exists>e > 0. ball y e \<subseteq> {y. path_component s x y}"
    apply (rule_tac x=e in exI)
    apply (rule,rule `e>0`)
    apply rule
    unfolding mem_ball mem_Collect_eq
  proof -
    fix z
    assume "dist y z < e"
    then show "path_component s x z"
      apply (rule_tac path_component_trans[of _ _ y])
      defer
      apply (rule path_component_of_subset[OF e(2)])
      apply (rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format])
      using `e > 0` as
      apply auto
      done
  qed
qed

lemma open_non_path_component:
  fixes s :: "'a::real_normed_vector set"
  assumes "open s"
  shows "open (s - {y. path_component s x y})"
  unfolding open_contains_ball
proof
  fix y
  assume as: "y \<in> s - {y. path_component s x y}"
  then obtain e where e: "e > 0" "ball y e \<subseteq> s"
    using assms [unfolded open_contains_ball]
    by auto
  show "\<exists>e>0. ball y e \<subseteq> s - {y. path_component s x y}"
    apply (rule_tac x=e in exI)
    apply rule
    apply (rule `e>0`)
    apply rule
    apply rule
    defer
  proof (rule ccontr)
    fix z
    assume "z \<in> ball y e" "\<not> z \<notin> {y. path_component s x y}"
    then have "y \<in> {y. path_component s x y}"
      unfolding not_not mem_Collect_eq using `e>0`
      apply -
      apply (rule path_component_trans, assumption)
      apply (rule path_component_of_subset[OF e(2)])
      apply (rule convex_imp_path_connected[OF convex_ball, unfolded path_connected_component, rule_format])
      apply auto
      done
    then show False
      using as by auto
  qed (insert e(2), auto)
qed

lemma connected_open_path_connected:
  fixes s :: "'a::real_normed_vector set"
  assumes "open s"
    and "connected s"
  shows "path_connected s"
  unfolding path_connected_component_set
proof (rule, rule, rule path_component_subset, rule)
  fix x y
  assume "x \<in> s" and "y \<in> s"
  show "y \<in> {y. path_component s x y}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    moreover have "{y. path_component s x y} \<inter> s \<noteq> {}"
      using `x \<in> s` path_component_eq_empty path_component_subset[of s x]
      by auto
    ultimately
    show False
      using `y \<in> s` open_non_path_component[OF assms(1)] open_path_component[OF assms(1)]
      using assms(2)[unfolded connected_def not_ex, rule_format,
        of"{y. path_component s x y}" "s - {y. path_component s x y}"]
      by auto
  qed
qed

lemma path_connected_continuous_image:
  assumes "continuous_on s f"
    and "path_connected s"
  shows "path_connected (f ` s)"
  unfolding path_connected_def
proof (rule, rule)
  fix x' y'
  assume "x' \<in> f ` s" "y' \<in> f ` s"
  then obtain x y where x: "x \<in> s" and y: "y \<in> s" and x': "x' = f x" and y': "y' = f y"
    by auto
  from x y obtain g where "path g \<and> path_image g \<subseteq> s \<and> pathstart g = x \<and> pathfinish g = y"
    using assms(2)[unfolded path_connected_def] by fast
  then show "\<exists>g. path g \<and> path_image g \<subseteq> f ` s \<and> pathstart g = x' \<and> pathfinish g = y'"
    unfolding x' y'
    apply (rule_tac x="f \<circ> g" in exI)
    unfolding path_defs
    apply (intro conjI continuous_on_compose continuous_on_subset[OF assms(1)])
    apply auto
    done
qed

lemma homeomorphic_path_connectedness:
  "s homeomorphic t \<Longrightarrow> path_connected s \<longleftrightarrow> path_connected t"
  unfolding homeomorphic_def homeomorphism_def
  apply (erule exE|erule conjE)+
  apply rule
  apply (drule_tac f=f in path_connected_continuous_image)
  prefer 3
  apply (drule_tac f=g in path_connected_continuous_image)
  apply auto
  done

lemma path_connected_empty: "path_connected {}"
  unfolding path_connected_def by auto

lemma path_connected_singleton: "path_connected {a}"
  unfolding path_connected_def pathstart_def pathfinish_def path_image_def
  apply clarify
  apply (rule_tac x="\<lambda>x. a" in exI)
  apply (simp add: image_constant_conv)
  apply (simp add: path_def continuous_on_const)
  done

lemma path_connected_Un:
  assumes "path_connected s"
    and "path_connected t"
    and "s \<inter> t \<noteq> {}"
  shows "path_connected (s \<union> t)"
  unfolding path_connected_component
proof (rule, rule)
  fix x y
  assume as: "x \<in> s \<union> t" "y \<in> s \<union> t"
  from assms(3) obtain z where "z \<in> s \<inter> t"
    by auto
  then show "path_component (s \<union> t) x y"
    using as and assms(1-2)[unfolded path_connected_component]
    apply -
    apply (erule_tac[!] UnE)+
    apply (rule_tac[2-3] path_component_trans[of _ _ z])
    apply (auto simp add:path_component_of_subset [OF Un_upper1] path_component_of_subset[OF Un_upper2])
    done
qed

lemma path_connected_UNION:
  assumes "\<And>i. i \<in> A \<Longrightarrow> path_connected (S i)"
    and "\<And>i. i \<in> A \<Longrightarrow> z \<in> S i"
  shows "path_connected (\<Union>i\<in>A. S i)"
  unfolding path_connected_component
proof clarify
  fix x i y j
  assume *: "i \<in> A" "x \<in> S i" "j \<in> A" "y \<in> S j"
  then have "path_component (S i) x z" and "path_component (S j) z y"
    using assms by (simp_all add: path_connected_component)
  then have "path_component (\<Union>i\<in>A. S i) x z" and "path_component (\<Union>i\<in>A. S i) z y"
    using *(1,3) by (auto elim!: path_component_of_subset [rotated])
  then show "path_component (\<Union>i\<in>A. S i) x y"
    by (rule path_component_trans)
qed

subsection {* Sphere is path-connected *}

lemma path_connected_punctured_universe:
  assumes "2 \<le> DIM('a::euclidean_space)"
  shows "path_connected ((UNIV::'a set) - {a})"
proof -
  let ?A = "{x::'a. \<exists>i\<in>Basis. x \<bullet> i < a \<bullet> i}"
  let ?B = "{x::'a. \<exists>i\<in>Basis. a \<bullet> i < x \<bullet> i}"

  have A: "path_connected ?A"
    unfolding Collect_bex_eq
  proof (rule path_connected_UNION)
    fix i :: 'a
    assume "i \<in> Basis"
    then show "(\<Sum>i\<in>Basis. (a \<bullet> i - 1)*\<^sub>R i) \<in> {x::'a. x \<bullet> i < a \<bullet> i}"
      by simp
    show "path_connected {x. x \<bullet> i < a \<bullet> i}"
      using convex_imp_path_connected [OF convex_halfspace_lt, of i "a \<bullet> i"]
      by (simp add: inner_commute)
  qed
  have B: "path_connected ?B"
    unfolding Collect_bex_eq
  proof (rule path_connected_UNION)
    fix i :: 'a
    assume "i \<in> Basis"
    then show "(\<Sum>i\<in>Basis. (a \<bullet> i + 1) *\<^sub>R i) \<in> {x::'a. a \<bullet> i < x \<bullet> i}"
      by simp
    show "path_connected {x. a \<bullet> i < x \<bullet> i}"
      using convex_imp_path_connected [OF convex_halfspace_gt, of "a \<bullet> i" i]
      by (simp add: inner_commute)
  qed
  obtain S :: "'a set" where "S \<subseteq> Basis" and "card S = Suc (Suc 0)"
    using ex_card[OF assms]
    by auto
  then obtain b0 b1 :: 'a where "b0 \<in> Basis" and "b1 \<in> Basis" and "b0 \<noteq> b1"
    unfolding card_Suc_eq by auto
  then have "a + b0 - b1 \<in> ?A \<inter> ?B"
    by (auto simp: inner_simps inner_Basis)
  then have "?A \<inter> ?B \<noteq> {}"
    by fast
  with A B have "path_connected (?A \<union> ?B)"
    by (rule path_connected_Un)
  also have "?A \<union> ?B = {x. \<exists>i\<in>Basis. x \<bullet> i \<noteq> a \<bullet> i}"
    unfolding neq_iff bex_disj_distrib Collect_disj_eq ..
  also have "\<dots> = {x. x \<noteq> a}"
    unfolding euclidean_eq_iff [where 'a='a]
    by (simp add: Bex_def)
  also have "\<dots> = UNIV - {a}"
    by auto
  finally show ?thesis .
qed

lemma path_connected_sphere:
  assumes "2 \<le> DIM('a::euclidean_space)"
  shows "path_connected {x::'a. norm (x - a) = r}"
proof (rule linorder_cases [of r 0])
  assume "r < 0"
  then have "{x::'a. norm(x - a) = r} = {}"
    by auto
  then show ?thesis
    using path_connected_empty by simp
next
  assume "r = 0"
  then show ?thesis
    using path_connected_singleton by simp
next
  assume r: "0 < r"
  have *: "{x::'a. norm(x - a) = r} = (\<lambda>x. a + r *\<^sub>R x) ` {x. norm x = 1}"
    apply (rule set_eqI)
    apply rule
    unfolding image_iff
    apply (rule_tac x="(1/r) *\<^sub>R (x - a)" in bexI)
    unfolding mem_Collect_eq norm_scaleR
    using r
    apply (auto simp add: scaleR_right_diff_distrib)
    done
  have **: "{x::'a. norm x = 1} = (\<lambda>x. (1/norm x) *\<^sub>R x) ` (UNIV - {0})"
    apply (rule set_eqI)
    apply rule
    unfolding image_iff
    apply (rule_tac x=x in bexI)
    unfolding mem_Collect_eq
    apply (auto split: split_if_asm)
    done
  have "continuous_on (UNIV - {0}) (\<lambda>x::'a. 1 / norm x)"
    unfolding field_divide_inverse
    by (simp add: continuous_intros)
  then show ?thesis
    unfolding * **
    using path_connected_punctured_universe[OF assms]
    by (auto intro!: path_connected_continuous_image continuous_intros)
qed

lemma connected_sphere: "2 \<le> DIM('a::euclidean_space) \<Longrightarrow> connected {x::'a. norm (x - a) = r}"
  using path_connected_sphere path_connected_imp_connected
  by auto

end


(*<*)
theory Bool_nat_list
imports Main
begin
(*>*)

text{*
\vspace{-4ex}
\section{\texorpdfstring{Types @{typ bool}, @{typ nat} and @{text list}}{Types bool, nat and list}}

These are the most important predefined types. We go through them one by one.
Based on examples we learn how to define (possibly recursive) functions and
prove theorems about them by induction and simplification.

\subsection{Type \indexed{@{typ bool}}{bool}}

The type of boolean values is a predefined datatype
@{datatype[display] bool}
with the two values \indexed{@{const True}}{True} and \indexed{@{const False}}{False} and
with many predefined functions:  @{text "\<not>"}, @{text "\<and>"}, @{text "\<or>"}, @{text
"\<longrightarrow>"}, etc. Here is how conjunction could be defined by pattern matching:
*}

fun conj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"conj True True = True" |
"conj _ _ = False"

text{* Both the datatype and function definitions roughly follow the syntax
of functional programming languages.

\subsection{Type \indexed{@{typ nat}}{nat}}

Natural numbers are another predefined datatype:
@{datatype[display] nat}\index{Suc@@{const Suc}}
All values of type @{typ nat} are generated by the constructors
@{text 0} and @{const Suc}. Thus the values of type @{typ nat} are
@{text 0}, @{term"Suc 0"}, @{term"Suc(Suc 0)"}, etc.
There are many predefined functions: @{text "+"}, @{text "*"}, @{text
"\<le>"}, etc. Here is how you could define your own addition:
*}

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

text{* And here is a proof of the fact that @{prop"add m 0 = m"}: *}

lemma add_02: "add m 0 = m"
apply(induction m)
apply(auto)
done
(*<*)
lemma "add m 0 = m"
apply(induction m)
(*>*)
txt{* The \isacom{lemma} command starts the proof and gives the lemma
a name, @{text add_02}. Properties of recursively defined functions
need to be established by induction in most cases.
Command \isacom{apply}@{text"(induction m)"} instructs Isabelle to
start a proof by induction on @{text m}. In response, it will show the
following proof state\ifsem\footnote{See page \pageref{proof-state} for how to
display the proof state.}\fi:
@{subgoals[display,indent=0]}
The numbered lines are known as \emph{subgoals}.
The first subgoal is the base case, the second one the induction step.
The prefix @{text"\<And>m."} is Isabelle's way of saying ``for an arbitrary but fixed @{text m}''. The @{text"\<Longrightarrow>"} separates assumptions from the conclusion.
The command \isacom{apply}@{text"(auto)"} instructs Isabelle to try
and prove all subgoals automatically, essentially by simplifying them.
Because both subgoals are easy, Isabelle can do it.
The base case @{prop"add 0 0 = 0"} holds by definition of @{const add},
and the induction step is almost as simple:
@{text"add\<^latex>\<open>~\<close>(Suc m) 0 = Suc(add m 0) = Suc m"}
using first the definition of @{const add} and then the induction hypothesis.
In summary, both subproofs rely on simplification with function definitions and
the induction hypothesis.
As a result of that final \isacom{done}, Isabelle associates the lemma
just proved with its name. You can now inspect the lemma with the command
*}

thm add_02

txt{* which displays @{thm[show_question_marks,display] add_02} The free
variable @{text m} has been replaced by the \concept{unknown}
@{text"?m"}. There is no logical difference between the two but there is an
operational one: unknowns can be instantiated, which is what you want after
some lemma has been proved.

Note that there is also a proof method @{text induct}, which behaves almost
like @{text induction}; the difference is explained in \autoref{ch:Isar}.

\begin{warn}
Terminology: We use \concept{lemma}, \concept{theorem} and \concept{rule}
interchangeably for propositions that have been proved.
\end{warn}
\begin{warn}
  Numerals (@{text 0}, @{text 1}, @{text 2}, \dots) and most of the standard
  arithmetic operations (@{text "+"}, @{text "-"}, @{text "*"}, @{text"\<le>"},
  @{text"<"}, etc.) are overloaded: they are available
  not just for natural numbers but for other types as well.
  For example, given the goal @{text"x + 0 = x"}, there is nothing to indicate
  that you are talking about natural numbers. Hence Isabelle can only infer
  that @{term x} is of some arbitrary type where @{text 0} and @{text"+"}
  exist. As a consequence, you will be unable to prove the goal.
%  To alert you to such pitfalls, Isabelle flags numerals without a
%  fixed type in its output: @ {prop"x+0 = x"}.
  In this particular example, you need to include
  an explicit type constraint, for example @{text"x+0 = (x::nat)"}. If there
  is enough contextual information this may not be necessary: @{prop"Suc x =
  x"} automatically implies @{text"x::nat"} because @{term Suc} is not
  overloaded.
\end{warn}

\subsubsection{An Informal Proof}

Above we gave some terse informal explanation of the proof of
@{prop"add m 0 = m"}. A more detailed informal exposition of the lemma
might look like this:
\bigskip

\noindent
\textbf{Lemma} @{prop"add m 0 = m"}

\noindent
\textbf{Proof} by induction on @{text m}.
\begin{itemize}
\item Case @{text 0} (the base case): @{prop"add 0 0 = 0"}
  holds by definition of @{const add}.
\item Case @{term"Suc m"} (the induction step):
  We assume @{prop"add m 0 = m"}, the induction hypothesis (IH),
  and we need to show @{text"add (Suc m) 0 = Suc m"}.
  The proof is as follows:\smallskip

  \begin{tabular}{@ {}rcl@ {\quad}l@ {}}
  @{term "add (Suc m) 0"} &@{text"="}& @{term"Suc(add m 0)"}
  & by definition of @{text add}\\
              &@{text"="}& @{term "Suc m"} & by IH
  \end{tabular}
\end{itemize}
Throughout this book, \concept{IH} will stand for ``induction hypothesis''.

We have now seen three proofs of @{prop"add m 0 = 0"}: the Isabelle one, the
terse four lines explaining the base case and the induction step, and just now a
model of a traditional inductive proof. The three proofs differ in the level
of detail given and the intended reader: the Isabelle proof is for the
machine, the informal proofs are for humans. Although this book concentrates
on Isabelle proofs, it is important to be able to rephrase those proofs
as informal text comprehensible to a reader familiar with traditional
mathematical proofs. Later on we will introduce an Isabelle proof language
that is closer to traditional informal mathematical language and is often
directly readable.

\subsection{Type \indexed{@{text list}}{list}}

Although lists are already predefined, we define our own copy for
demonstration purposes:
*}
(*<*)
apply(auto)
done
declare [[names_short]]
(*>*)
datatype 'a list = Nil | Cons 'a "'a list"
(*<*)
for map: map
(*>*)

text{*
\begin{itemize}
\item Type @{typ "'a list"} is the type of lists over elements of type @{typ 'a}. Because @{typ 'a} is a type variable, lists are in fact \concept{polymorphic}: the elements of a list can be of arbitrary type (but must all be of the same type).
\item Lists have two constructors: @{const Nil}, the empty list, and @{const Cons}, which puts an element (of type @{typ 'a}) in front of a list (of type @{typ "'a list"}).
Hence all lists are of the form @{const Nil}, or @{term"Cons x Nil"},
or @{term"Cons x (Cons y Nil)"}, etc.
\item \isacom{datatype} requires no quotation marks on the
left-hand side, but on the right-hand side each of the argument
types of a constructor needs to be enclosed in quotation marks, unless
it is just an identifier (e.g., @{typ nat} or @{typ 'a}).
\end{itemize}
We also define two standard functions, append and reverse: *}

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

text{* By default, variables @{text xs}, @{text ys} and @{text zs} are of
@{text list} type.

Command \indexed{\isacommand{value}}{value} evaluates a term. For example, *}

value "rev(Cons True (Cons False Nil))"

text{* yields the result @{value "rev(Cons True (Cons False Nil))"}. This works symbolically, too: *}

value "rev(Cons a (Cons b Nil))"

text{* yields @{value "rev(Cons a (Cons b Nil))"}.
\medskip

Figure~\ref{fig:MyList} shows the theory created so far.
Because @{text list}, @{const Nil}, @{const Cons}, etc.\ are already predefined,
 Isabelle prints qualified (long) names when executing this theory, for example, @{text MyList.Nil}
 instead of @{const Nil}.
 To suppress the qualified names you can insert the command
 \texttt{declare [[names\_short]]}.
 This is not recommended in general but is convenient for this unusual example.
% Notice where the
%quotations marks are needed that we mostly sweep under the carpet.  In
%particular, notice that \isacom{datatype} requires no quotation marks on the
%left-hand side, but that on the right-hand side each of the argument
%types of a constructor needs to be enclosed in quotation marks.

\begin{figure}[htbp]
\begin{alltt}
\input{MyList.thy}\end{alltt}
\caption{A theory of lists}
\label{fig:MyList}
\index{comment}
\end{figure}

\subsubsection{Structural Induction for Lists}

Just as for natural numbers, there is a proof principle of induction for
lists. Induction over a list is essentially induction over the length of
the list, although the length remains implicit. To prove that some property
@{text P} holds for all lists @{text xs}, i.e., \mbox{@{prop"P(xs)"}},
you need to prove
\begin{enumerate}
\item the base case @{prop"P(Nil)"} and
\item the inductive case @{prop"P(Cons x xs)"} under the assumption @{prop"P(xs)"}, for some arbitrary but fixed @{text x} and @{text xs}.
\end{enumerate}
This is often called \concept{structural induction} for lists.

\subsection{The Proof Process}

We will now demonstrate the typical proof process, which involves
the formulation and proof of auxiliary lemmas.
Our goal is to show that reversing a list twice produces the original
list. *}

theorem rev_rev [simp]: "rev(rev xs) = xs"

txt{* Commands \isacom{theorem} and \isacom{lemma} are
interchangeable and merely indicate the importance we attach to a
proposition. Via the bracketed attribute @{text simp} we also tell Isabelle
to make the eventual theorem a \conceptnoidx{simplification rule}: future proofs
involving simplification will replace occurrences of @{term"rev(rev xs)"} by
@{term"xs"}. The proof is by induction: *}

apply(induction xs)

txt{*
As explained above, we obtain two subgoals, namely the base case (@{const Nil}) and the induction step (@{const Cons}):
@{subgoals[display,indent=0,margin=65]}
Let us try to solve both goals automatically:
*}

apply(auto)

txt{*Subgoal~1 is proved, and disappears; the simplified version
of subgoal~2 becomes the new subgoal~1:
@{subgoals[display,indent=0,margin=70]}
In order to simplify this subgoal further, a lemma suggests itself.

\subsubsection{A First Lemma}

We insert the following lemma in front of the main theorem:
*}
(*<*)
oops
(*>*)
lemma rev_app [simp]: "rev(app xs ys) = app (rev ys) (rev xs)"

txt{* There are two variables that we could induct on: @{text xs} and
@{text ys}. Because @{const app} is defined by recursion on
the first argument, @{text xs} is the correct one:
*}

apply(induction xs)

txt{* This time not even the base case is solved automatically: *}
apply(auto)
txt{*
\vspace{-5ex}
@{subgoals[display,goals_limit=1]}
Again, we need to abandon this proof attempt and prove another simple lemma
first.

\subsubsection{A Second Lemma}

We again try the canonical proof procedure:
*}
(*<*)
oops
(*>*)
lemma app_Nil2 [simp]: "app xs Nil = xs"
apply(induction xs)
apply(auto)
done

text{*
Thankfully, this worked.
Now we can continue with our stuck proof attempt of the first lemma:
*}

lemma rev_app [simp]: "rev(app xs ys) = app (rev ys) (rev xs)"
apply(induction xs)
apply(auto)

txt{*
We find that this time @{text"auto"} solves the base case, but the
induction step merely simplifies to
@{subgoals[display,indent=0,goals_limit=1]}
The missing lemma is associativity of @{const app},
which we insert in front of the failed lemma @{text rev_app}.

\subsubsection{Associativity of @{const app}}

The canonical proof procedure succeeds without further ado:
*}
(*<*)oops(*>*)
lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply(induction xs)
apply(auto)
done
(*<*)
lemma rev_app [simp]: "rev(app xs ys) = app (rev ys)(rev xs)"
apply(induction xs)
apply(auto)
done

theorem rev_rev [simp]: "rev(rev xs) = xs"
apply(induction xs)
apply(auto)
done
(*>*)
text{*
Finally the proofs of @{thm[source] rev_app} and @{thm[source] rev_rev}
succeed, too.

\subsubsection{Another Informal Proof}

Here is the informal proof of associativity of @{const app}
corresponding to the Isabelle proof above.
\bigskip

\noindent
\textbf{Lemma} @{prop"app (app xs ys) zs = app xs (app ys zs)"}

\noindent
\textbf{Proof} by induction on @{text xs}.
\begin{itemize}
\item Case @{text Nil}: \ @{prop"app (app Nil ys) zs = app ys zs"} @{text"="}
  \mbox{@{term"app Nil (app ys zs)"}} \ holds by definition of @{text app}.
\item Case @{text"Cons x xs"}: We assume
  \begin{center} \hfill @{term"app (app xs ys) zs"} @{text"="}
  @{term"app xs (app ys zs)"} \hfill (IH) \end{center}
  and we need to show
  \begin{center} @{prop"app (app (Cons x xs) ys) zs = app (Cons x xs) (app ys zs)"}.\end{center}
  The proof is as follows:\smallskip

  \begin{tabular}{@ {}l@ {\quad}l@ {}}
  @{term"app (app (Cons x xs) ys) zs"}\\
  @{text"= app (Cons x (app xs ys)) zs"} & by definition of @{text app}\\
  @{text"= Cons x (app (app xs ys) zs)"} & by definition of @{text app}\\
  @{text"= Cons x (app xs (app ys zs))"} & by IH\\
  @{text"= app (Cons x xs) (app ys zs)"} & by definition of @{text app}
  \end{tabular}
\end{itemize}
\medskip

\noindent Didn't we say earlier that all proofs are by simplification? But
in both cases, going from left to right, the last equality step is not a
simplification at all! In the base case it is @{prop"app ys zs = app Nil (app
ys zs)"}. It appears almost mysterious because we suddenly complicate the
term by appending @{text Nil} on the left. What is really going on is this:
when proving some equality \mbox{@{prop"s = t"}}, both @{text s} and @{text t} are
simplified until they ``meet in the middle''. This heuristic for equality proofs
works well for a functional programming context like ours. In the base case
both @{term"app (app Nil ys) zs"} and @{term"app Nil (app
ys zs)"} are simplified to @{term"app ys zs"}, the term in the middle.

\subsection{Predefined Lists}
\label{sec:predeflists}

Isabelle's predefined lists are the same as the ones above, but with
more syntactic sugar:
\begin{itemize}
\item @{text "[]"} is \indexed{@{const Nil}}{Nil},
\item @{term"x # xs"} is @{term"Cons x xs"}\index{Cons@@{const Cons}},
\item @{text"[x\<^sub>1, \<dots>, x\<^sub>n]"} is @{text"x\<^sub>1 # \<dots> # x\<^sub>n # []"}, and
\item @{term "xs @ ys"} is @{term"app xs ys"}.
\end{itemize}
There is also a large library of predefined functions.
The most important ones are the length function
@{text"length :: 'a list \<Rightarrow> nat"}\index{length@@{const length}} (with the obvious definition),
and the \indexed{@{const map}}{map} function that applies a function to all elements of a list:
\begin{isabelle}
\isacom{fun} @{const map} @{text"::"} @{typ[source] "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"} \isacom{where}\\
@{text"\""}@{thm list.map(1) [of f]}@{text"\" |"}\\
@{text"\""}@{thm list.map(2) [of f x xs]}@{text"\""}
\end{isabelle}

\ifsem
Also useful are the \concept{head} of a list, its first element,
and the \concept{tail}, the rest of the list:
\begin{isabelle}\index{hd@@{const hd}}
\isacom{fun} @{text"hd :: 'a list \<Rightarrow> 'a"}\\
@{prop"hd(x#xs) = x"}
\end{isabelle}
\begin{isabelle}\index{tl@@{const tl}}
\isacom{fun} @{text"tl :: 'a list \<Rightarrow> 'a list"}\\
@{prop"tl [] = []"} @{text"|"}\\
@{prop"tl(x#xs) = xs"}
\end{isabelle}
Note that since HOL is a logic of total functions, @{term"hd []"} is defined,
but we do now know what the result is. That is, @{term"hd []"} is not undefined
but underdefined.
\fi
%

From now on lists are always the predefined lists.

\subsection*{Exercises}

\begin{exercise}
Use the \isacom{value} command to evaluate the following expressions:
@{term[source] "1 + (2::nat)"}, @{term[source] "1 + (2::int)"},
@{term[source] "1 - (2::nat)"} and @{term[source] "1 - (2::int)"}.
\end{exercise}

\begin{exercise}
Start from the definition of @{const add} given above.
Prove that @{const add} is associative and commutative.
Define a recursive function @{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"}
and prove @{prop"double m = add m m"}.
\end{exercise}

\begin{exercise}
Define a function @{text"count ::"} @{typ"'a \<Rightarrow> 'a list \<Rightarrow> nat"}
that counts the number of occurrences of an element in a list. Prove
@{prop"count x xs \<le> length xs"}.
\end{exercise}

\begin{exercise}
Define a recursive function @{text "snoc ::"} @{typ"'a list \<Rightarrow> 'a \<Rightarrow> 'a list"}
that appends an element to the end of a list. With the help of @{text snoc}
define a recursive function @{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"}
that reverses a list. Prove @{prop"reverse(reverse xs) = xs"}.
\end{exercise}

\begin{exercise}
Define a recursive function @{text "sum_upto ::"} @{typ"nat \<Rightarrow> nat"} such that
\mbox{@{text"sum_upto n"}} @{text"="} @{text"0 + ... + n"} and prove
@{prop" sum_upto (n::nat) = n * (n+1) div 2"}.
\end{exercise}
*}
(*<*)
end
(*>*)


(*  Title:      HOL/Library/Set_Algebras.thy
    Author:     Jeremy Avigad
    Author:     Kevin Donnelly
    Author:     Florian Haftmann, TUM
*)

section \<open>Algebraic operations on sets\<close>

theory Set_Algebras
  imports Main
begin

text \<open>
  This library lifts operations like addition and multiplication to sets. It
  was designed to support asymptotic calculations for the now-obsolete BigO theory,
  but has other uses.
\<close>

instantiation set :: (plus) plus
begin

definition plus_set :: "'a::plus set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_plus_def: "A + B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a + b}"

instance ..

end

instantiation set :: (times) times
begin

definition times_set :: "'a::times set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where set_times_def: "A * B = {c. \<exists>a\<in>A. \<exists>b\<in>B. c = a * b}"

instance ..

end

instantiation set :: (zero) zero
begin

definition set_zero[simp]: "(0::'a::zero set) = {0}"

instance ..

end

instantiation set :: (one) one
begin

definition set_one[simp]: "(1::'a::one set) = {1}"

instance ..

end

definition elt_set_plus :: "'a::plus \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "+o" 70)
  where "a +o B = {c. \<exists>b\<in>B. c = a + b}"

definition elt_set_times :: "'a::times \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "*o" 80)
  where "a *o B = {c. \<exists>b\<in>B. c = a * b}"

abbreviation (input) elt_set_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"  (infix "=o" 50)
  where "x =o A \<equiv> x \<in> A"

instance set :: (semigroup_add) semigroup_add
  by standard (force simp add: set_plus_def add.assoc)

instance set :: (ab_semigroup_add) ab_semigroup_add
  by standard (force simp add: set_plus_def add.commute)

instance set :: (monoid_add) monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (comm_monoid_add) comm_monoid_add
  by standard (simp_all add: set_plus_def)

instance set :: (semigroup_mult) semigroup_mult
  by standard (force simp add: set_times_def mult.assoc)

instance set :: (ab_semigroup_mult) ab_semigroup_mult
  by standard (force simp add: set_times_def mult.commute)

instance set :: (monoid_mult) monoid_mult
  by standard (simp_all add: set_times_def)

instance set :: (comm_monoid_mult) comm_monoid_mult
  by standard (simp_all add: set_times_def)

lemma sumset_empty [simp]: "A + {} = {}" "{} + A = {}"
  by (auto simp: set_plus_def)

lemma Un_set_plus: "(A \<union> B) + C = (A+C) \<union> (B+C)" and set_plus_Un: "C + (A \<union> B) = (C+A) \<union> (C+B)"
  by (auto simp: set_plus_def)

lemma
  fixes A :: "'a::comm_monoid_add set"
  shows insert_set_plus: "(insert a A) + B = (A+B) \<union> (((+)a) ` B)" and set_plus_insert: "B + (insert a A) = (B+A) \<union> (((+)a) ` B)"
  using add.commute by (auto simp: set_plus_def)

lemma set_add_0 [simp]:
  fixes A :: "'a::comm_monoid_add set"
  shows "{0} + A = A"
  by (metis comm_monoid_add_class.add_0 set_zero)

lemma set_add_0_right [simp]:
  fixes A :: "'a::comm_monoid_add set"
  shows "A + {0} = A"
  by (metis add.comm_neutral set_zero)

lemma card_plus_sing:
  fixes A :: "'a::ab_group_add set"
  shows "card (A + {a}) = card A"
proof (rule bij_betw_same_card)
  show "bij_betw ((+) (-a)) (A + {a}) A"
    by (fastforce simp: set_plus_def bij_betw_def image_iff)
qed

lemma set_plus_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a + b \<in> C + D"
  by (auto simp add: set_plus_def)

lemma set_plus_elim:
  assumes "x \<in> A + B"
  obtains a b where "x = a + b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_plus_def by fast

lemma set_plus_intro2 [intro]: "b \<in> C \<Longrightarrow> a + b \<in> a +o C"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_rearrange: "(a +o C) + (b +o D) = (a + b) +o (C + D)"
  for a b :: "'a::comm_monoid_add"
    by (auto simp: elt_set_plus_def set_plus_def; metis group_cancel.add1 group_cancel.add2)

lemma set_plus_rearrange2: "a +o (b +o C) = (a + b) +o C"
  for a b :: "'a::semigroup_add"
  by (auto simp add: elt_set_plus_def add.assoc)

lemma set_plus_rearrange3: "(a +o B) + C = a +o (B + C)"
  for a :: "'a::semigroup_add"
  by (auto simp add: elt_set_plus_def set_plus_def; metis add.assoc)

theorem set_plus_rearrange4: "C + (a +o D) = a +o (C + D)"
  for a :: "'a::comm_monoid_add"
  by (metis add.commute set_plus_rearrange3)

lemmas set_plus_rearranges = set_plus_rearrange set_plus_rearrange2
  set_plus_rearrange3 set_plus_rearrange4

lemma set_plus_mono [intro!]: "C \<subseteq> D \<Longrightarrow> a +o C \<subseteq> a +o D"
  by (auto simp add: elt_set_plus_def)

lemma set_plus_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C + E \<subseteq> D + F"
  for C D E F :: "'a::plus set"
  by (auto simp add: set_plus_def)

lemma set_plus_mono3 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> C + D"
  by (auto simp add: elt_set_plus_def set_plus_def)

lemma set_plus_mono4 [intro]: "a \<in> C \<Longrightarrow> a +o D \<subseteq> D + C"
  for a :: "'a::comm_monoid_add"
  by (auto simp add: elt_set_plus_def set_plus_def ac_simps)

lemma set_plus_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a +o B \<subseteq> C + D"
  using order_subst2 by blast

lemma set_plus_mono_b: "C \<subseteq> D \<Longrightarrow> x \<in> a +o C \<Longrightarrow> x \<in> a +o D"
  using set_plus_mono by blast

lemma set_zero_plus [simp]: "0 +o C = C"
  for C :: "'a::comm_monoid_add set"
  by (auto simp add: elt_set_plus_def)

lemma set_zero_plus2: "0 \<in> A \<Longrightarrow> B \<subseteq> A + B"
  for A B :: "'a::comm_monoid_add set"
  using set_plus_intro by fastforce

lemma set_plus_imp_minus: "a \<in> b +o C \<Longrightarrow> a - b \<in> C"
  for a b :: "'a::ab_group_add"
  by (auto simp add: elt_set_plus_def ac_simps)

lemma set_minus_imp_plus: "a - b \<in> C \<Longrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  by (metis add.commute diff_add_cancel set_plus_intro2)

lemma set_minus_plus: "a - b \<in> C \<longleftrightarrow> a \<in> b +o C"
  for a b :: "'a::ab_group_add"
  by (meson set_minus_imp_plus set_plus_imp_minus)

lemma set_times_intro [intro]: "a \<in> C \<Longrightarrow> b \<in> D \<Longrightarrow> a * b \<in> C * D"
  by (auto simp add: set_times_def)

lemma set_times_elim:
  assumes "x \<in> A * B"
  obtains a b where "x = a * b" and "a \<in> A" and "b \<in> B"
  using assms unfolding set_times_def by fast

lemma set_times_intro2 [intro!]: "b \<in> C \<Longrightarrow> a * b \<in> a *o C"
  by (auto simp add: elt_set_times_def)

lemma set_times_rearrange: "(a *o C) * (b *o D) = (a * b) *o (C * D)"
  for a b :: "'a::comm_monoid_mult"
  by (auto simp add: elt_set_times_def set_times_def; metis mult.assoc mult.left_commute)

lemma set_times_rearrange2: "a *o (b *o C) = (a * b) *o C"
  for a b :: "'a::semigroup_mult"
  by (auto simp add: elt_set_times_def mult.assoc)

lemma set_times_rearrange3: "(a *o B) * C = a *o (B * C)"
  for a :: "'a::semigroup_mult"
  by (auto simp add: elt_set_times_def set_times_def; metis mult.assoc)

theorem set_times_rearrange4: "C * (a *o D) = a *o (C * D)"
  for a :: "'a::comm_monoid_mult"
  by (metis mult.commute set_times_rearrange3)

lemmas set_times_rearranges = set_times_rearrange set_times_rearrange2
  set_times_rearrange3 set_times_rearrange4

lemma set_times_mono [intro]: "C \<subseteq> D \<Longrightarrow> a *o C \<subseteq> a *o D"
  by (auto simp add: elt_set_times_def)

lemma set_times_mono2 [intro]: "C \<subseteq> D \<Longrightarrow> E \<subseteq> F \<Longrightarrow> C * E \<subseteq> D * F"
  for C D E F :: "'a::times set"
  by (auto simp add: set_times_def)

lemma set_times_mono3 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> C * D"
  by (auto simp add: elt_set_times_def set_times_def)

lemma set_times_mono4 [intro]: "a \<in> C \<Longrightarrow> a *o D \<subseteq> D * C"
  for a :: "'a::comm_monoid_mult"
  by (auto simp add: elt_set_times_def set_times_def ac_simps)

lemma set_times_mono5: "a \<in> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> a *o B \<subseteq> C * D"
  by (meson dual_order.trans set_times_mono set_times_mono3)

lemma set_one_times [simp]: "1 *o C = C"
  for C :: "'a::comm_monoid_mult set"
  by (auto simp add: elt_set_times_def)

lemma set_times_plus_distrib: "a *o (b +o C) = (a * b) +o (a *o C)"
  for a b :: "'a::semiring"
  by (auto simp add: elt_set_plus_def elt_set_times_def ring_distribs)

lemma set_times_plus_distrib2: "a *o (B + C) = (a *o B) + (a *o C)"
  for a :: "'a::semiring"
  by (auto simp: set_plus_def elt_set_times_def; metis distrib_left)

lemma set_times_plus_distrib3: "(a +o C) * D \<subseteq> a *o D + C * D"
  for a :: "'a::semiring"
  using distrib_right
  by (fastforce simp add: elt_set_plus_def elt_set_times_def set_times_def set_plus_def)

lemmas set_times_plus_distribs =
  set_times_plus_distrib
  set_times_plus_distrib2

lemma set_neg_intro: "a \<in> (- 1) *o C \<Longrightarrow> - a \<in> C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_neg_intro2: "a \<in> C \<Longrightarrow> - a \<in> (- 1) *o C"
  for a :: "'a::ring_1"
  by (auto simp add: elt_set_times_def)

lemma set_plus_image: "S + T = (\<lambda>(x, y). x + y) ` (S \<times> T)"
  by (fastforce simp: set_plus_def image_iff)

lemma set_times_image: "S * T = (\<lambda>(x, y). x * y) ` (S \<times> T)"
  by (fastforce simp: set_times_def image_iff)

lemma finite_set_plus: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s + t)"
  by (simp add: set_plus_image)

lemma finite_set_times: "finite s \<Longrightarrow> finite t \<Longrightarrow> finite (s * t)"
  by (simp add: set_times_image)

lemma set_sum_alt:
  assumes fin: "finite I"
  shows "sum S I = {sum s I |s. \<forall>i\<in>I. s i \<in> S i}"
    (is "_ = ?sum I")
  using fin
proof induct
  case empty
  then show ?case by simp
next
  case (insert x F)
  have "sum S (insert x F) = S x + ?sum F"
    using insert.hyps by auto
  also have "\<dots> = {s x + sum s F |s. \<forall> i\<in>insert x F. s i \<in> S i}"
    unfolding set_plus_def
  proof safe
    fix y s
    assume "y \<in> S x" "\<forall>i\<in>F. s i \<in> S i"
    then show "\<exists>s'. y + sum s F = s' x + sum s' F \<and> (\<forall>i\<in>insert x F. s' i \<in> S i)"
      using insert.hyps
      by (intro exI[of _ "\<lambda>i. if i \<in> F then s i else y"]) (auto simp add: set_plus_def)
  qed auto
  finally show ?case
    using insert.hyps by auto
qed

lemma sum_set_cond_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes [intro!]: "\<And>A B. P A  \<Longrightarrow> P B  \<Longrightarrow> P (A + B)" "P {0}"
    and f: "\<And>A B. P A  \<Longrightarrow> P B \<Longrightarrow> f (A + B) = f A + f B" "f {0} = {0}"
  assumes all: "\<And>i. i \<in> I \<Longrightarrow> P (S i)"
  shows "f (sum S I) = sum (f \<circ> S) I"
proof (cases "finite I")
  case True
  from this all show ?thesis
  proof induct
    case empty
    then show ?case by (auto intro!: f)
  next
    case (insert x F)
    from \<open>finite F\<close> \<open>\<And>i. i \<in> insert x F \<Longrightarrow> P (S i)\<close> have "P (sum S F)"
      by induct auto
    with insert show ?case
      by (simp, subst f) auto
  qed
next
  case False
  then show ?thesis by (auto intro!: f)
qed

lemma sum_set_linear:
  fixes f :: "'a::comm_monoid_add set \<Rightarrow> 'b::comm_monoid_add set"
  assumes "\<And>A B. f(A) + f(B) = f(A + B)" "f {0} = {0}"
  shows "f (sum S I) = sum (f \<circ> S) I"
  using sum_set_cond_linear[of "\<lambda>x. True" f I S] assms by auto

lemma set_times_Un_distrib:
  "A * (B \<union> C) = A * B \<union> A * C"
  "(A \<union> B) * C = A * C \<union> B * C"
  by (auto simp: set_times_def)

lemma set_times_UNION_distrib:
  "A * \<Union>(M ` I) = (\<Union>i\<in>I. A * M i)"
  "\<Union>(M ` I) * A = (\<Union>i\<in>I. M i * A)"
  by (auto simp: set_times_def)

end


(*  Title:      HOL/Number_Theory/Pocklington.thy
    Author:     Amine Chaieb
*)

section {* Pocklington's Theorem for Primes *}

theory Pocklington
imports Residues
begin

subsection{*Lemmas about previously defined terms*}

lemma prime:
  "prime p \<longleftrightarrow> p \<noteq> 0 \<and> p\<noteq>1 \<and> (\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  {assume "p=0 \<or> p=1" hence ?thesis
    by (metis one_not_prime_nat zero_not_prime_nat)}
  moreover
  {assume p0: "p\<noteq>0" "p\<noteq>1"
    {assume H: "?lhs"
      {fix m assume m: "m > 0" "m < p"
        {assume "m=1" hence "coprime p m" by simp}
        moreover
        {assume "p dvd m" hence "p \<le> m" using dvd_imp_le m by blast with m(2)
          have "coprime p m" by simp}
        ultimately have "coprime p m"
          by (metis H prime_imp_coprime_nat)}
      hence ?rhs using p0 by auto}
    moreover
    { assume H: "\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m"
      obtain q where q: "prime q" "q dvd p"
        by (metis p0(2) prime_factor_nat)
      have q0: "q > 0"
        by (metis prime_gt_0_nat q(1))
      from dvd_imp_le[OF q(2)] p0 have qp: "q \<le> p" by arith
      {assume "q = p" hence ?lhs using q(1) by blast}
      moreover
      {assume "q\<noteq>p" with qp have qplt: "q < p" by arith
        from H qplt q0 have "coprime p q" by arith
       hence ?lhs using q
         by (metis gcd_semilattice_nat.inf_absorb2 one_not_prime_nat)}
      ultimately have ?lhs by blast}
    ultimately have ?thesis by blast}
  ultimately show ?thesis  by (cases"p=0 \<or> p=1", auto)
qed

lemma finite_number_segment: "card { m. 0 < m \<and> m < n } = n - 1"
proof-
  have "{ m. 0 < m \<and> m < n } = {1..<n}" by auto
  thus ?thesis by simp
qed

subsection{*Some basic theorems about solving congruences*}

lemma cong_solve:
  fixes n::nat assumes an: "coprime a n" shows "\<exists>x. [a * x = b] (mod n)"
proof-
  {assume "a=0" hence ?thesis using an by (simp add: cong_nat_def)}
  moreover
  {assume az: "a\<noteq>0"
  from bezout_add_strong_nat[OF az, of n]
  obtain d x y where dxy: "d dvd a" "d dvd n" "a*x = n*y + d" by blast
  from dxy(1,2) have d1: "d = 1"
    by (metis assms coprime_nat)
  hence "a*x*b = (n*y + 1)*b" using dxy(3) by simp
  hence "a*(x*b) = n*(y*b) + b"
    by (auto simp add: algebra_simps)
  hence "a*(x*b) mod n = (n*(y*b) + b) mod n" by simp
  hence "a*(x*b) mod n = b mod n" by (simp add: mod_add_left_eq)
  hence "[a*(x*b) = b] (mod n)" unfolding cong_nat_def .
  hence ?thesis by blast}
ultimately  show ?thesis by blast
qed

lemma cong_solve_unique:
  fixes n::nat assumes an: "coprime a n" and nz: "n \<noteq> 0"
  shows "\<exists>!x. x < n \<and> [a * x = b] (mod n)"
proof-
  let ?P = "\<lambda>x. x < n \<and> [a * x = b] (mod n)"
  from cong_solve[OF an] obtain x where x: "[a*x = b] (mod n)" by blast
  let ?x = "x mod n"
  from x have th: "[a * ?x = b] (mod n)"
    by (simp add: cong_nat_def mod_mult_right_eq[of a x n])
  from mod_less_divisor[ of n x] nz th have Px: "?P ?x" by simp
  {fix y assume Py: "y < n" "[a * y = b] (mod n)"
    from Py(2) th have "[a * y = a*?x] (mod n)" by (simp add: cong_nat_def)
    hence "[y = ?x] (mod n)"
      by (metis an cong_mult_lcancel_nat)
    with mod_less[OF Py(1)] mod_less_divisor[ of n x] nz
    have "y = ?x" by (simp add: cong_nat_def)}
  with Px show ?thesis by blast
qed

lemma cong_solve_unique_nontrivial:
  assumes p: "prime p" and pa: "coprime p a" and x0: "0 < x" and xp: "x < p"
  shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = a] (mod p)"
proof-
  from pa have ap: "coprime a p"
    by (metis gcd_nat.commute)
  have px:"coprime x p"
    by (metis gcd_nat.commute p prime x0 xp)
  obtain y where y: "y < p" "[x * y = a] (mod p)" "\<forall>z. z < p \<and> [x * z = a] (mod p) \<longrightarrow> z = y"
    by (metis cong_solve_unique neq0_conv p prime_gt_0_nat px)
  {assume y0: "y = 0"
    with y(2) have th: "p dvd a"
      by (metis cong_dvd_eq_nat gcd_lcm_complete_lattice_nat.top_greatest mult_0_right)
    have False
      by (metis gcd_nat.absorb1 one_not_prime_nat p pa th)}
  with y show ?thesis unfolding Ex1_def using neq0_conv by blast
qed

lemma cong_unique_inverse_prime:
  assumes p: "prime p" and x0: "0 < x" and xp: "x < p"
  shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = 1] (mod p)"
by (metis cong_solve_unique_nontrivial gcd_lcm_complete_lattice_nat.inf_bot_left gcd_nat.commute assms)

lemma chinese_remainder_coprime_unique:
  fixes a::nat
  assumes ab: "coprime a b" and az: "a \<noteq> 0" and bz: "b \<noteq> 0"
  and ma: "coprime m a" and nb: "coprime n b"
  shows "\<exists>!x. coprime x (a * b) \<and> x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
proof-
  let ?P = "\<lambda>x. x < a * b \<and> [x = m] (mod a) \<and> [x = n] (mod b)"
  from binary_chinese_remainder_unique_nat[OF ab az bz]
  obtain x where x: "x < a * b" "[x = m] (mod a)" "[x = n] (mod b)"
    "\<forall>y. ?P y \<longrightarrow> y = x" by blast
  from ma nb x
  have "coprime x a" "coprime x b"
    by (metis cong_gcd_eq_nat)+
  then have "coprime x (a*b)"
    by (metis coprime_mul_eq_nat)
  with x show ?thesis by blast
qed

subsection{*Lucas's theorem*}

lemma phi_limit_strong: "phi(n) \<le> n - 1"
proof -
  have "phi n = card {x. 0 < x \<and> x < int n \<and> coprime x (int n)}"
    by (simp add: phi_def)
  also have "... \<le> card {0 <..< int n}"
    by (rule card_mono) auto
  also have "... = card {0 <..< n}"
    by (simp add: transfer_nat_int_set_functions)
  also have "... \<le> n - 1"
    by (metis card_greaterThanLessThan le_refl One_nat_def)
  finally show ?thesis .
qed

lemma phi_lowerbound_1: assumes n: "n \<ge> 2"
  shows "phi n \<ge> 1"
proof -
  have "1 \<le> card {0::int <.. 1}"
    by auto
  also have "... \<le> card {x. 0 < x \<and> x < n \<and> coprime x n}"
    apply (rule card_mono) using assms
    by auto (metis dual_order.antisym gcd_1_int gcd_int.commute int_one_le_iff_zero_less)
  also have "... = phi n"
    by (simp add: phi_def)
  finally show ?thesis .
qed

lemma phi_lowerbound_1_nat: assumes n: "n \<ge> 2"
  shows "phi(int n) \<ge> 1"
by (metis n nat_le_iff nat_numeral phi_lowerbound_1)

lemma euler_theorem_nat:
  fixes m::nat
  assumes "coprime a m"
  shows "[a ^ phi m = 1] (mod m)"
by (metis assms le0 euler_theorem [transferred])

lemma lucas_coprime_lemma:
  fixes n::nat
  assumes m: "m\<noteq>0" and am: "[a^m = 1] (mod n)"
  shows "coprime a n"
proof-
  {assume "n=1" hence ?thesis by simp}
  moreover
  {assume "n = 0" hence ?thesis using am m
     by (metis am cong_0_nat gcd_nat.right_neutral power_eq_one_eq_nat)}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    from m obtain m' where m': "m = Suc m'" by (cases m, blast+)
    {fix d
      assume d: "d dvd a" "d dvd n"
      from n have n1: "1 < n" by arith
      from am mod_less[OF n1] have am1: "a^m mod n = 1" unfolding cong_nat_def by simp
      from dvd_mult2[OF d(1), of "a^m'"] have dam:"d dvd a^m" by (simp add: m')
      from dvd_mod_iff[OF d(2), of "a^m"] dam am1
      have "d = 1" by simp }
    hence ?thesis by auto
  }
  ultimately show ?thesis by blast
qed

lemma lucas_weak:
  fixes n::nat
  assumes n: "n \<ge> 2" and an:"[a^(n - 1) = 1] (mod n)"
  and nm: "\<forall>m. 0 <m \<and> m < n - 1 \<longrightarrow> \<not> [a^m = 1] (mod n)"
  shows "prime n"
proof-
  from n have n1: "n \<noteq> 1" "n\<noteq>0" "n - 1 \<noteq> 0" "n - 1 > 0" "n - 1 < n" by arith+
  from lucas_coprime_lemma[OF n1(3) an] have can: "coprime a n" .
  from euler_theorem_nat[OF can] have afn: "[a ^ phi n = 1] (mod n)"
    by auto
  {assume "phi n \<noteq> n - 1"
    with phi_limit_strong phi_lowerbound_1_nat [OF n]
    have c:"phi n > 0 \<and> phi n < n - 1"
      by (metis gr0I leD less_linear not_one_le_zero)
    from nm[rule_format, OF c] afn have False ..}
  hence "phi n = n - 1" by blast
  with prime_phi phi_prime n1(1,2) show ?thesis
    by auto
qed

lemma nat_exists_least_iff: "(\<exists>(n::nat). P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))"
  by (metis ex_least_nat_le not_less0)

lemma nat_exists_least_iff': "(\<exists>(n::nat). P n) \<longleftrightarrow> (P (Least P) \<and> (\<forall>m < (Least P). \<not> P m))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof-
  {assume ?rhs hence ?lhs by blast}
  moreover
  { assume H: ?lhs then obtain n where n: "P n" by blast
    let ?x = "Least P"
    {fix m assume m: "m < ?x"
      from not_less_Least[OF m] have "\<not> P m" .}
    with LeastI_ex[OF H] have ?rhs by blast}
  ultimately show ?thesis by blast
qed

theorem lucas:
  assumes n2: "n \<ge> 2" and an1: "[a^(n - 1) = 1] (mod n)"
  and pn: "\<forall>p. prime p \<and> p dvd n - 1 \<longrightarrow> [a^((n - 1) div p) \<noteq> 1] (mod n)"
  shows "prime n"
proof-
  from n2 have n01: "n\<noteq>0" "n\<noteq>1" "n - 1 \<noteq> 0" by arith+
  from mod_less_divisor[of n 1] n01 have onen: "1 mod n = 1" by simp
  from lucas_coprime_lemma[OF n01(3) an1] cong_imp_coprime_nat an1
  have an: "coprime a n" "coprime (a^(n - 1)) n"
    by (auto simp add: coprime_exp_nat gcd_nat.commute)
  {assume H0: "\<exists>m. 0 < m \<and> m < n - 1 \<and> [a ^ m = 1] (mod n)" (is "EX m. ?P m")
    from H0[unfolded nat_exists_least_iff[of ?P]] obtain m where
      m: "0 < m" "m < n - 1" "[a ^ m = 1] (mod n)" "\<forall>k <m. \<not>?P k" by blast
    {assume nm1: "(n - 1) mod m > 0"
      from mod_less_divisor[OF m(1)] have th0:"(n - 1) mod m < m" by blast
      let ?y = "a^ ((n - 1) div m * m)"
      note mdeq = mod_div_equality[of "(n - 1)" m]
      have yn: "coprime ?y n"
        by (metis an(1) coprime_exp_nat gcd_nat.commute)
      have "?y mod n = (a^m)^((n - 1) div m) mod n"
        by (simp add: algebra_simps power_mult)
      also have "\<dots> = (a^m mod n)^((n - 1) div m) mod n"
        using power_mod[of "a^m" n "(n - 1) div m"] by simp
      also have "\<dots> = 1" using m(3)[unfolded cong_nat_def onen] onen
        by (metis power_one)
      finally have th3: "?y mod n = 1"  .
      have th2: "[?y * a ^ ((n - 1) mod m) = ?y* 1] (mod n)"
        using an1[unfolded cong_nat_def onen] onen
          mod_div_equality[of "(n - 1)" m, symmetric]
        by (simp add:power_add[symmetric] cong_nat_def th3 del: One_nat_def)
      have th1: "[a ^ ((n - 1) mod m) = 1] (mod n)"
        by (metis cong_mult_rcancel_nat mult.commute th2 yn)
      from m(4)[rule_format, OF th0] nm1
        less_trans[OF mod_less_divisor[OF m(1), of "n - 1"] m(2)] th1
      have False by blast }
    hence "(n - 1) mod m = 0" by auto
    then have mn: "m dvd n - 1" by presburger
    then obtain r where r: "n - 1 = m*r" unfolding dvd_def by blast
    from n01 r m(2) have r01: "r\<noteq>0" "r\<noteq>1" by - (rule ccontr, simp)+
    obtain p where p: "prime p" "p dvd r"
      by (metis prime_factor_nat r01(2))
    hence th: "prime p \<and> p dvd n - 1" unfolding r by (auto intro: dvd_mult)
    have "(a ^ ((n - 1) div p)) mod n = (a^(m*r div p)) mod n" using r
      by (simp add: power_mult)
    also have "\<dots> = (a^(m*(r div p))) mod n"
      using div_mult1_eq[of m r p] p(2)[unfolded dvd_eq_mod_eq_0]
      by simp
    also have "\<dots> = ((a^m)^(r div p)) mod n" by (simp add: power_mult)
    also have "\<dots> = ((a^m mod n)^(r div p)) mod n" using power_mod ..
    also have "\<dots> = 1" using m(3) onen by (simp add: cong_nat_def)
    finally have "[(a ^ ((n - 1) div p))= 1] (mod n)"
      using onen by (simp add: cong_nat_def)
    with pn th have False by blast}
  hence th: "\<forall>m. 0 < m \<and> m < n - 1 \<longrightarrow> \<not> [a ^ m = 1] (mod n)" by blast
  from lucas_weak[OF n2 an1 th] show ?thesis .
qed

subsection{*Definition of the order of a number mod n (0 in non-coprime case)*}

definition "ord n a = (if coprime n a then Least (\<lambda>d. d > 0 \<and> [a ^d = 1] (mod n)) else 0)"

(* This has the expected properties.                                         *)

lemma coprime_ord:
  fixes n::nat
  assumes "coprime n a"
  shows "ord n a > 0 \<and> [a ^(ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> [a^ m \<noteq> 1] (mod n))"
proof-
  let ?P = "\<lambda>d. 0 < d \<and> [a ^ d = 1] (mod n)"
  from bigger_prime[of a] obtain p where p: "prime p" "a < p" by blast
  from assms have o: "ord n a = Least ?P" by (simp add: ord_def)
  {assume "n=0 \<or> n=1" with assms have "\<exists>m>0. ?P m"
      by auto}
  moreover
  {assume "n\<noteq>0 \<and> n\<noteq>1" hence n2:"n \<ge> 2" by arith
    from assms have na': "coprime a n"
      by (metis gcd_nat.commute)
    from phi_lowerbound_1_nat[OF n2] euler_theorem_nat [OF na']
    have ex: "\<exists>m>0. ?P m" by - (rule exI[where x="phi n"], auto) }
  ultimately have ex: "\<exists>m>0. ?P m" by blast
  from nat_exists_least_iff'[of ?P] ex assms show ?thesis
    unfolding o[symmetric] by auto
qed

(* With the special value 0 for non-coprime case, it's more convenient.      *)
lemma ord_works:
  fixes n::nat
  shows "[a ^ (ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> ~[a^ m = 1] (mod n))"
apply (cases "coprime n a")
using coprime_ord[of n a]
by (auto simp add: ord_def cong_nat_def)

lemma ord:
  fixes n::nat
  shows "[a^(ord n a) = 1] (mod n)" using ord_works by blast

lemma ord_minimal:
  fixes n::nat
  shows "0 < m \<Longrightarrow> m < ord n a \<Longrightarrow> ~[a^m = 1] (mod n)"
  using ord_works by blast

lemma ord_eq_0:
  fixes n::nat
  shows "ord n a = 0 \<longleftrightarrow> ~coprime n a"
by (cases "coprime n a", simp add: coprime_ord, simp add: ord_def)

lemma divides_rexp:
  "x dvd y \<Longrightarrow> (x::nat) dvd (y^(Suc n))"
  by (simp add: dvd_mult2[of x y])

lemma ord_divides:
  fixes n::nat
  shows "[a ^ d = 1] (mod n) \<longleftrightarrow> ord n a dvd d" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume rh: ?rhs
  then obtain k where "d = ord n a * k" unfolding dvd_def by blast
  hence "[a ^ d = (a ^ (ord n a) mod n)^k] (mod n)"
    by (simp add : cong_nat_def power_mult power_mod)
  also have "[(a ^ (ord n a) mod n)^k = 1] (mod n)"
    using ord[of a n, unfolded cong_nat_def]
    by (simp add: cong_nat_def power_mod)
  finally  show ?lhs .
next
  assume lh: ?lhs
  { assume H: "\<not> coprime n a"
    hence o: "ord n a = 0" by (simp add: ord_def)
    {assume d: "d=0" with o H have ?rhs by (simp add: cong_nat_def)}
    moreover
    {assume d0: "d\<noteq>0" then obtain d' where d': "d = Suc d'" by (cases d, auto)
      from H
      obtain p where p: "p dvd n" "p dvd a" "p \<noteq> 1" by auto
      from lh
      obtain q1 q2 where q12:"a ^ d + n * q1 = 1 + n * q2"
        by (metis H d0 gcd_nat.commute lucas_coprime_lemma)
      hence "a ^ d + n * q1 - n * q2 = 1" by simp
      with dvd_diff_nat [OF dvd_add [OF divides_rexp]]  dvd_mult2  d' p
      have "p dvd 1"
        by metis
      with p(3) have False by simp
      hence ?rhs ..}
    ultimately have ?rhs by blast}
  moreover
  {assume H: "coprime n a"
    let ?o = "ord n a"
    let ?q = "d div ord n a"
    let ?r = "d mod ord n a"
    have eqo: "[(a^?o)^?q = 1] (mod n)"
      by (metis cong_exp_nat ord power_one)
    from H have onz: "?o \<noteq> 0" by (simp add: ord_eq_0)
    hence op: "?o > 0" by simp
    from mod_div_equality[of d "ord n a"] lh
    have "[a^(?o*?q + ?r) = 1] (mod n)" by (simp add: cong_nat_def mult.commute)
    hence "[(a^?o)^?q * (a^?r) = 1] (mod n)"
      by (simp add: cong_nat_def power_mult[symmetric] power_add[symmetric])
    hence th: "[a^?r = 1] (mod n)"
      using eqo mod_mult_left_eq[of "(a^?o)^?q" "a^?r" n]
      apply (simp add: cong_nat_def del: One_nat_def)
      by (simp add: mod_mult_left_eq[symmetric])
    {assume r: "?r = 0" hence ?rhs by (simp add: dvd_eq_mod_eq_0)}
    moreover
    {assume r: "?r \<noteq> 0"
      with mod_less_divisor[OF op, of d] have r0o:"?r >0 \<and> ?r < ?o" by simp
      from conjunct2[OF ord_works[of a n], rule_format, OF r0o] th
      have ?rhs by blast}
    ultimately have ?rhs by blast}
  ultimately  show ?rhs by blast
qed

lemma order_divides_phi:
  fixes n::nat shows "coprime n a \<Longrightarrow> ord n a dvd phi n"
  by (metis ord_divides euler_theorem_nat gcd_nat.commute)

lemma order_divides_expdiff:
  fixes n::nat and a::nat assumes na: "coprime n a"
  shows "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
proof-
  {fix n::nat and a::nat and d::nat and e::nat
    assume na: "coprime n a" and ed: "(e::nat) \<le> d"
    hence "\<exists>c. d = e + c" by presburger
    then obtain c where c: "d = e + c" by presburger
    from na have an: "coprime a n"
      by (metis gcd_nat.commute)
    have aen: "coprime (a^e) n"
      by (metis coprime_exp_nat gcd_nat.commute na)
    have acn: "coprime (a^c) n"
      by (metis coprime_exp_nat gcd_nat.commute na)
    have "[a^d = a^e] (mod n) \<longleftrightarrow> [a^(e + c) = a^(e + 0)] (mod n)"
      using c by simp
    also have "\<dots> \<longleftrightarrow> [a^e* a^c = a^e *a^0] (mod n)" by (simp add: power_add)
    also have  "\<dots> \<longleftrightarrow> [a ^ c = 1] (mod n)"
      using cong_mult_lcancel_nat [OF aen, of "a^c" "a^0"] by simp
    also  have "\<dots> \<longleftrightarrow> ord n a dvd c" by (simp only: ord_divides)
    also have "\<dots> \<longleftrightarrow> [e + c = e + 0] (mod ord n a)"
      using cong_add_lcancel_nat
      by (metis cong_dvd_eq_nat dvd_0_right cong_dvd_modulus_nat cong_mult_self_nat nat_mult_1)
    finally have "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
      using c by simp }
  note th = this
  have "e \<le> d \<or> d \<le> e" by arith
  moreover
  {assume ed: "e \<le> d" from th[OF na ed] have ?thesis .}
  moreover
  {assume de: "d \<le> e"
    from th[OF na de] have ?thesis
    by (metis cong_sym_nat)}
  ultimately show ?thesis by blast
qed

subsection{*Another trivial primality characterization*}

lemma prime_prime_factor:
  "prime n \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>p. prime p \<and> p dvd n \<longrightarrow> p = n)"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof (cases "n=0 \<or> n=1")
  case True
  then show ?thesis
     by (metis bigger_prime dvd_0_right one_not_prime_nat zero_not_prime_nat)
next
  case False
  show ?thesis
  proof
    assume "prime n"
    then show ?rhs
      by (metis one_not_prime_nat prime_nat_def)
  next
    assume ?rhs
    with False show "prime n"
      by (auto simp: prime_def) (metis One_nat_def prime_factor_nat prime_nat_def)
  qed
qed

lemma prime_divisor_sqrt:
  "prime n \<longleftrightarrow> n \<noteq> 1 \<and> (\<forall>d. d dvd n \<and> d\<^sup>2 \<le> n \<longrightarrow> d = 1)"
proof -
  {assume "n=0 \<or> n=1" hence ?thesis
    by (metis dvd.order_refl le_refl one_not_prime_nat power_zero_numeral zero_not_prime_nat)}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    hence np: "n > 1" by arith
    {fix d assume d: "d dvd n" "d\<^sup>2 \<le> n" and H: "\<forall>m. m dvd n \<longrightarrow> m=1 \<or> m=n"
      from H d have d1n: "d = 1 \<or> d=n" by blast
      {assume dn: "d=n"
        have "n\<^sup>2 > n*1" using n by (simp add: power2_eq_square)
        with dn d(2) have "d=1" by simp}
      with d1n have "d = 1" by blast  }
    moreover
    {fix d assume d: "d dvd n" and H: "\<forall>d'. d' dvd n \<and> d'\<^sup>2 \<le> n \<longrightarrow> d' = 1"
      from d n have "d \<noteq> 0"
        by (metis dvd_0_left_iff)
      hence dp: "d > 0" by simp
      from d[unfolded dvd_def] obtain e where e: "n= d*e" by blast
      from n dp e have ep:"e > 0" by simp
      have "d\<^sup>2 \<le> n \<or> e\<^sup>2 \<le> n" using dp ep
        by (auto simp add: e power2_eq_square mult_le_cancel_left)
      moreover
      {assume h: "d\<^sup>2 \<le> n"
        from H[rule_format, of d] h d have "d = 1" by blast}
      moreover
      {assume h: "e\<^sup>2 \<le> n"
        from e have "e dvd n" unfolding dvd_def by (simp add: mult.commute)
        with H[rule_format, of e] h have "e=1" by simp
        with e have "d = n" by simp}
      ultimately have "d=1 \<or> d=n"  by blast}
    ultimately have ?thesis unfolding prime_def using np n(2) by blast}
  ultimately show ?thesis by auto
qed

lemma prime_prime_factor_sqrt:
  "prime n \<longleftrightarrow> n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<^sup>2 \<le> n)"
  (is "?lhs \<longleftrightarrow>?rhs")
proof-
  {assume "n=0 \<or> n=1"
   hence ?thesis
     by (metis one_not_prime_nat zero_not_prime_nat)}
  moreover
  {assume n: "n\<noteq>0" "n\<noteq>1"
    {assume H: ?lhs
      from H[unfolded prime_divisor_sqrt] n
      have ?rhs
        by (metis prime_prime_factor) }
    moreover
    {assume H: ?rhs
      {fix d assume d: "d dvd n" "d\<^sup>2 \<le> n" "d\<noteq>1"
        then obtain p where p: "prime p" "p dvd d"
          by (metis prime_factor_nat)
        from d(1) n have dp: "d > 0"
          by (metis dvd_0_left neq0_conv)
        from mult_mono[OF dvd_imp_le[OF p(2) dp] dvd_imp_le[OF p(2) dp]] d(2)
        have "p\<^sup>2 \<le> n" unfolding power2_eq_square by arith
        with H n p(1) dvd_trans[OF p(2) d(1)] have False  by blast}
      with n prime_divisor_sqrt  have ?lhs by auto}
    ultimately have ?thesis by blast }
  ultimately show ?thesis by (cases "n=0 \<or> n=1", auto)
qed

subsection{*Pocklington theorem*}

lemma pocklington_lemma:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and an: "[a^ (n - 1) = 1] (mod n)"
  and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
  and pp: "prime p" and pn: "p dvd n"
  shows "[p = 1] (mod q)"
proof -
  have p01: "p \<noteq> 0" "p \<noteq> 1" using pp one_not_prime_nat zero_not_prime_nat by auto
  obtain k where k: "a ^ (q * r) - 1 = n*k"
    by (metis an cong_to_1_nat dvd_def nqr)
  from pn[unfolded dvd_def] obtain l where l: "n = p*l" by blast
  {assume a0: "a = 0"
    hence "a^ (n - 1) = 0" using n by (simp add: power_0_left)
    with n an mod_less[of 1 n]  have False by (simp add: power_0_left cong_nat_def)}
  hence a0: "a\<noteq>0" ..
  from n nqr have aqr0: "a ^ (q * r) \<noteq> 0" using a0 by simp
  hence "(a ^ (q * r) - 1) + 1  = a ^ (q * r)" by simp
  with k l have "a ^ (q * r) = p*l*k + 1" by simp
  hence "a ^ (r * q) + p * 0 = 1 + p * (l*k)" by (simp add: ac_simps)
  hence odq: "ord p (a^r) dvd q"
    unfolding ord_divides[symmetric] power_mult[symmetric]
    by (metis an cong_dvd_modulus_nat mult.commute nqr pn)
  from odq[unfolded dvd_def] obtain d where d: "q = ord p (a^r) * d" by blast
  {assume d1: "d \<noteq> 1"
    obtain P where P: "prime P" "P dvd d"
      by (metis d1 prime_factor_nat)
    from d dvd_mult[OF P(2), of "ord p (a^r)"] have Pq: "P dvd q" by simp
    from aq P(1) Pq have caP:"coprime (a^ ((n - 1) div P) - 1) n" by blast
    from Pq obtain s where s: "q = P*s" unfolding dvd_def by blast
    have P0: "P \<noteq> 0" using P(1)
      by (metis zero_not_prime_nat)
    from P(2) obtain t where t: "d = P*t" unfolding dvd_def by blast
    from d s t P0  have s': "ord p (a^r) * t = s"
      by (metis mult.commute mult_cancel1 mult.assoc)
    have "ord p (a^r) * t*r = r * ord p (a^r) * t"
      by (metis mult.assoc mult.commute)
    hence exps: "a^(ord p (a^r) * t*r) = ((a ^ r) ^ ord p (a^r)) ^ t"
      by (simp only: power_mult)
    then have th: "[((a ^ r) ^ ord p (a^r)) ^ t= 1] (mod p)"
      by (metis cong_exp_nat ord power_one)
    have pd0: "p dvd a^(ord p (a^r) * t*r) - 1"
      by (metis cong_to_1_nat exps th)
    from nqr s s' have "(n - 1) div P = ord p (a^r) * t*r" using P0 by simp
    with caP have "coprime (a^(ord p (a^r) * t*r) - 1) n" by simp
    with p01 pn pd0 coprime_common_divisor_nat have False
      by auto}
  hence d1: "d = 1" by blast
  hence o: "ord p (a^r) = q" using d by simp
  from pp phi_prime[of p] have phip: "phi p = p - 1" by simp
  {fix d assume d: "d dvd p" "d dvd a" "d \<noteq> 1"
    from pp[unfolded prime_def] d have dp: "d = p" by blast
    from n have "n \<noteq> 0" by simp
    then have False using d
      by (metis coprime_minus_one_nat dp lucas_coprime_lemma an coprime_nat
           gcd_lcm_complete_lattice_nat.top_greatest pn)}
  hence cpa: "coprime p a" by auto
  have arp: "coprime (a^r) p"
    by (metis coprime_exp_nat cpa gcd_nat.commute)
  from euler_theorem_nat[OF arp, simplified ord_divides] o phip
  have "q dvd (p - 1)" by simp
  then obtain d where d:"p - 1 = q * d"
    unfolding dvd_def by blast
  have p0:"p \<noteq> 0"
    by (metis p01(1))
  from p0 d have "p + q * 0 = 1 + q * d" by simp
  then show ?thesis
    by (metis cong_iff_lin_nat mult.commute)
qed

theorem pocklington:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q\<^sup>2"
  and an: "[a^ (n - 1) = 1] (mod n)"
  and aq: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a^ ((n - 1) div p) - 1) n"
  shows "prime n"
unfolding prime_prime_factor_sqrt[of n]
proof-
  let ?ths = "n \<noteq> 0 \<and> n \<noteq> 1 \<and> \<not> (\<exists>p. prime p \<and> p dvd n \<and> p\<^sup>2 \<le> n)"
  from n have n01: "n\<noteq>0" "n\<noteq>1" by arith+
  {fix p assume p: "prime p" "p dvd n" "p\<^sup>2 \<le> n"
    from p(3) sqr have "p^(Suc 1) \<le> q^(Suc 1)" by (simp add: power2_eq_square)
    hence pq: "p \<le> q"
      by (metis le0 power_le_imp_le_base)
    from pocklington_lemma[OF n nqr an aq p(1,2)]
    have th: "q dvd p - 1"
      by (metis cong_to_1_nat)
    have "p - 1 \<noteq> 0" using prime_ge_2_nat [OF p(1)] by arith
    with pq p have False
      by (metis Suc_diff_1 gcd_le2_nat gcd_semilattice_nat.inf_absorb1 not_less_eq_eq
            prime_gt_0_nat th) }
  with n01 show ?ths by blast
qed

(* Variant for application, to separate the exponentiation.                  *)
lemma pocklington_alt:
  assumes n: "n \<ge> 2" and nqr: "n - 1 = q*r" and sqr: "n \<le> q\<^sup>2"
  and an: "[a^ (n - 1) = 1] (mod n)"
  and aq:"\<forall>p. prime p \<and> p dvd q \<longrightarrow> (\<exists>b. [a^((n - 1) div p) = b] (mod n) \<and> coprime (b - 1) n)"
  shows "prime n"
proof-
  {fix p assume p: "prime p" "p dvd q"
    from aq[rule_format] p obtain b where
      b: "[a^((n - 1) div p) = b] (mod n)" "coprime (b - 1) n" by blast
    {assume a0: "a=0"
      from n an have "[0 = 1] (mod n)" unfolding a0 power_0_left by auto
      hence False using n by (simp add: cong_nat_def dvd_eq_mod_eq_0[symmetric])}
    hence a0: "a\<noteq> 0" ..
    hence a1: "a \<ge> 1" by arith
    from one_le_power[OF a1] have ath: "1 \<le> a ^ ((n - 1) div p)" .
    {assume b0: "b = 0"
      from p(2) nqr have "(n - 1) mod p = 0"
        by (metis mod_0 mod_mod_cancel mod_mult_self1_is_0)
      with mod_div_equality[of "n - 1" p]
      have "(n - 1) div p * p= n - 1" by auto
      hence eq: "(a^((n - 1) div p))^p = a^(n - 1)"
        by (simp only: power_mult[symmetric])
      have "p - 1 \<noteq> 0" using prime_ge_2_nat [OF p(1)] by arith
      then have pS: "Suc (p - 1) = p" by arith
      from b have d: "n dvd a^((n - 1) div p)" unfolding b0
        by (metis b0 diff_0_eq_0 gcd_dvd2_nat gcd_lcm_complete_lattice_nat.inf_bot_left
                   gcd_lcm_complete_lattice_nat.inf_top_left)
      from divides_rexp[OF d, of "p - 1"] pS eq cong_dvd_eq_nat [OF an] n
      have False
        by simp}
    then have b0: "b \<noteq> 0" ..
    hence b1: "b \<ge> 1" by arith
    from cong_imp_coprime_nat[OF Cong.cong_diff_nat[OF cong_sym_nat [OF b(1)] cong_refl_nat[of 1] b1]]
         ath b1 b nqr
    have "coprime (a ^ ((n - 1) div p) - 1) n"
      by simp}
  hence th: "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a ^ ((n - 1) div p) - 1) n "
    by blast
  from pocklington[OF n nqr sqr an th] show ?thesis .
qed

subsection{*Prime factorizations*}

(* FIXME some overlap with material in UniqueFactorization, class unique_factorization *)

definition "primefact ps n = (foldr op * ps  1 = n \<and> (\<forall>p\<in> set ps. prime p))"

lemma primefact: assumes n: "n \<noteq> 0"
  shows "\<exists>ps. primefact ps n"
using n
proof(induct n rule: nat_less_induct)
  fix n assume H: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>ps. primefact ps m)" and n: "n\<noteq>0"
  let ?ths = "\<exists>ps. primefact ps n"
  {assume "n = 1"
    hence "primefact [] n" by (simp add: primefact_def)
    hence ?ths by blast }
  moreover
  {assume n1: "n \<noteq> 1"
    with n have n2: "n \<ge> 2" by arith
    obtain p where p: "prime p" "p dvd n"
      by (metis n1 prime_factor_nat)
    from p(2) obtain m where m: "n = p*m" unfolding dvd_def by blast
    from n m have m0: "m > 0" "m\<noteq>0" by auto
    have "1 < p"
      by (metis p(1) prime_nat_def)
    with m0 m have mn: "m < n" by auto
    from H[rule_format, OF mn m0(2)] obtain ps where ps: "primefact ps m" ..
    from ps m p(1) have "primefact (p#ps) n" by (simp add: primefact_def)
    hence ?ths by blast}
  ultimately show ?ths by blast
qed

lemma primefact_contains:
  assumes pf: "primefact ps n" and p: "prime p" and pn: "p dvd n"
  shows "p \<in> set ps"
  using pf p pn
proof(induct ps arbitrary: p n)
  case Nil thus ?case by (auto simp add: primefact_def)
next
  case (Cons q qs p n)
  from Cons.prems[unfolded primefact_def]
  have q: "prime q" "q * foldr op * qs 1 = n" "\<forall>p \<in>set qs. prime p"  and p: "prime p" "p dvd q * foldr op * qs 1" by simp_all
  {assume "p dvd q"
    with p(1) q(1) have "p = q" unfolding prime_def by auto
    hence ?case by simp}
  moreover
  { assume h: "p dvd foldr op * qs 1"
    from q(3) have pqs: "primefact qs (foldr op * qs 1)"
      by (simp add: primefact_def)
    from Cons.hyps[OF pqs p(1) h] have ?case by simp}
  ultimately show ?case
    by (metis p prime_dvd_mult_eq_nat)
qed

lemma primefact_variant: "primefact ps n \<longleftrightarrow> foldr op * ps 1 = n \<and> list_all prime ps"
  by (auto simp add: primefact_def list_all_iff)

(* Variant of Lucas theorem.                                                 *)

lemma lucas_primefact:
  assumes n: "n \<ge> 2" and an: "[a^(n - 1) = 1] (mod n)"
  and psn: "foldr op * ps 1 = n - 1"
  and psp: "list_all (\<lambda>p. prime p \<and> \<not> [a^((n - 1) div p) = 1] (mod n)) ps"
  shows "prime n"
proof-
  {fix p assume p: "prime p" "p dvd n - 1" "[a ^ ((n - 1) div p) = 1] (mod n)"
    from psn psp have psn1: "primefact ps (n - 1)"
      by (auto simp add: list_all_iff primefact_variant)
    from p(3) primefact_contains[OF psn1 p(1,2)] psp
    have False by (induct ps, auto)}
  with lucas[OF n an] show ?thesis by blast
qed

(* Variant of Pocklington theorem.                                           *)

lemma pocklington_primefact:
  assumes n: "n \<ge> 2" and qrn: "q*r = n - 1" and nq2: "n \<le> q\<^sup>2"
  and arnb: "(a^r) mod n = b" and psq: "foldr op * ps 1 = q"
  and bqn: "(b^q) mod n = 1"
  and psp: "list_all (\<lambda>p. prime p \<and> coprime ((b^(q div p)) mod n - 1) n) ps"
  shows "prime n"
proof-
  from bqn psp qrn
  have bqn: "a ^ (n - 1) mod n = 1"
    and psp: "list_all (\<lambda>p. prime p \<and> coprime (a^(r *(q div p)) mod n - 1) n) ps"
    unfolding arnb[symmetric] power_mod
    by (simp_all add: power_mult[symmetric] algebra_simps)
  from n  have n0: "n > 0" by arith
  from mod_div_equality[of "a^(n - 1)" n]
    mod_less_divisor[OF n0, of "a^(n - 1)"]
  have an1: "[a ^ (n - 1) = 1] (mod n)"
    by (metis bqn cong_nat_def mod_mod_trivial)
  {fix p assume p: "prime p" "p dvd q"
    from psp psq have pfpsq: "primefact ps q"
      by (auto simp add: primefact_variant list_all_iff)
    from psp primefact_contains[OF pfpsq p]
    have p': "coprime (a ^ (r * (q div p)) mod n - 1) n"
      by (simp add: list_all_iff)
    from p prime_def have p01: "p \<noteq> 0" "p \<noteq> 1" "p =Suc(p - 1)"
      by auto
    from div_mult1_eq[of r q p] p(2)
    have eq1: "r* (q div p) = (n - 1) div p"
      unfolding qrn[symmetric] dvd_eq_mod_eq_0 by (simp add: mult.commute)
    have ath: "\<And>a (b::nat). a <= b \<Longrightarrow> a \<noteq> 0 ==> 1 <= a \<and> 1 <= b" by arith
    {assume "a ^ ((n - 1) div p) mod n = 0"
      then obtain s where s: "a ^ ((n - 1) div p) = n*s"
        unfolding mod_eq_0_iff by blast
      hence eq0: "(a^((n - 1) div p))^p = (n*s)^p" by simp
      from qrn[symmetric] have qn1: "q dvd n - 1" unfolding dvd_def by auto
      from dvd_trans[OF p(2) qn1]
      have npp: "(n - 1) div p * p = n - 1" by simp
      with eq0 have "a^ (n - 1) = (n*s)^p"
        by (simp add: power_mult[symmetric])
      hence "1 = (n*s)^(Suc (p - 1)) mod n" using bqn p01 by simp
      also have "\<dots> = 0" by (simp add: mult.assoc)
      finally have False by simp }
      then have th11: "a ^ ((n - 1) div p) mod n \<noteq> 0" by auto
    have th1: "[a ^ ((n - 1) div p) mod n = a ^ ((n - 1) div p)] (mod n)"
      unfolding cong_nat_def by simp
    from  th1   ath[OF mod_less_eq_dividend th11]
    have th: "[a ^ ((n - 1) div p) mod n - 1 = a ^ ((n - 1) div p) - 1] (mod n)"
      by (metis cong_diff_nat cong_refl_nat)
    have "coprime (a ^ ((n - 1) div p) - 1) n"
      by (metis cong_imp_coprime_nat eq1 p' th) }
  with pocklington[OF n qrn[symmetric] nq2 an1]
  show ?thesis by blast
qed

end