header {* Affine Form *}
theory Affine_Form
imports
  "~~/src/HOL/Multivariate_Analysis/Multivariate_Analysis"
begin

text {*\label{sec:affineform}*}

subsection {* Partial Deviations *}

typedef 'a pdevs = "{x::nat \<Rightarrow> 'a::zero. finite {i. x i \<noteq> 0}}"
  morphisms pdevs_apply Abs_pdev
  by (auto intro!: exI[where x="\<lambda>x. 0"])

setup_lifting type_definition_pdevs

lemma pdevs_eqI: "(\<And>i. pdevs_apply x i = pdevs_apply y i) \<Longrightarrow> x = y"
  by transfer auto

definition pdevs_val :: "(nat \<Rightarrow> real) \<Rightarrow> 'a::real_normed_vector pdevs \<Rightarrow> 'a"
  where "pdevs_val e x = (\<Sum>i. e i *\<^sub>R pdevs_apply x i)"

definition valuate:: "((nat \<Rightarrow> real) \<Rightarrow> 'a) \<Rightarrow> 'a set"
  where "valuate x = x ` (UNIV \<rightarrow> {-1 .. 1})"

lemma valuate_ex: "x \<in> valuate f \<longleftrightarrow> (\<exists>e. (\<forall>i. e i \<in> {-1 .. 1}) \<and> x = f e)"
  unfolding valuate_def
  by (auto simp add: valuate_def Pi_iff) blast

instantiation pdevs :: (equal) equal
begin

definition equal_pdevs::"'a pdevs \<Rightarrow> 'a pdevs \<Rightarrow> bool"
  where "equal_pdevs a b \<longleftrightarrow> a = b"

instance proof qed (simp add: equal_pdevs_def)
end

subsection {* Affine Forms *}

text {* The data structure of affine forms represents particular sets, zonotopes *}

type_synonym 'a aform = "'a \<times> 'a pdevs"

subsection {* Evaluation, Range, Joint Range *}

definition aform_val :: "(nat \<Rightarrow> real) \<Rightarrow> 'a::real_normed_vector aform \<Rightarrow> 'a"
  where "aform_val e X = fst X + pdevs_val e (snd X)"

definition Affine ::
    "'a::real_normed_vector aform \<Rightarrow> 'a set"
  where "Affine X = valuate (\<lambda>e. aform_val e X)"

definition Joints ::
    "'a::real_normed_vector aform list \<Rightarrow> 'a list set"
  where "Joints XS = valuate (\<lambda>e. map (aform_val e) XS)"

lemma Joints_nthE:
  assumes "zs \<in> Joints ZS"
  obtains e where
    "\<And>i. i < length zs \<Longrightarrow> zs ! i = aform_val e (ZS ! i)"
    "\<And>i. e i \<in> {-1..1}"
  using assms
  by atomize_elim (auto simp: Joints_def Pi_iff valuate_ex)

lemma Joints_mapE:
  assumes "ys \<in> Joints YS"
  obtains e where
    "ys = map (\<lambda>x. aform_val e x) YS"
    "\<And>i. e i \<in> {-1 .. 1}"
  using assms
  by (force simp: Joints_def valuate_def)

lemma zipped_equals_mapped_Elem:
  assumes "ys = map (aform_val e) YS"
  assumes e: "\<And>i. e i \<in> {-1 .. 1}"
  assumes [simp]: "length xs = length XS"
  assumes [simp]: "length ys = length XS"
  assumes "set (zip xs XS) = set (zip ys YS)"
  shows "xs = map (aform_val e) XS"
proof -
  from assms have ys: "\<And>i. i < length ys \<Longrightarrow> ys ! i = aform_val e (YS ! i)"
    by auto
  from assms have set_eq: "{(xs ! i, XS ! i) |i. i < length xs \<and> i < length XS} \<subseteq>
    {(ys ! i, YS ! i) |i. i < length ys \<and> i < length YS}"
    using assms(2)
    by (auto simp: set_zip)
  hence "\<forall>i<length XS. \<exists>j<length XS. xs ! i = ys ! j \<and> XS ! i = YS ! j"
    by auto
  then obtain j where j: "\<And>i. i < length XS \<Longrightarrow> xs ! i = ys ! (j i)"
    "\<And>i. i < length XS \<Longrightarrow> XS ! i = YS ! (j i)"
    "\<And>i. i < length XS \<Longrightarrow> j i < length XS"
    by metis
  show ?thesis
    using assms
    by (auto simp: Joints_def j ys intro!: exI[where x=e] nth_equalityI)
qed

lemma Joints_set_zip:
  assumes "ys \<in> Joints YS"
  assumes [simp]: "length xs = length XS"
  assumes [simp]: "length YS = length XS"
  assumes sets_eq: "set (zip xs XS) = set (zip ys YS)"
  shows "xs \<in> Joints XS"
proof -
  from assms have ls[simp]: "length ys = length XS"
    by (auto simp: Joints_def valuate_def)
  from Joints_mapE assms obtain e where
    ys: "ys = map (\<lambda>x. aform_val e x) YS"
    and e: "\<And>i. e i \<in> {-1 .. 1}"
    by blast
  show "xs \<in> Joints XS"
    using e zipped_equals_mapped_Elem[OF ys e assms(2) ls sets_eq]
    by (auto simp: Joints_def valuate_def intro!: exI[where x=e])
qed

definition Joints2 ::
    "'a::real_normed_vector aform list \<Rightarrow>'b::real_normed_vector aform \<Rightarrow> ('a list \<times> 'b) set"
  where "Joints2 XS Y = valuate (\<lambda>e. (map (aform_val e) XS, aform_val e Y))"

lemma Joints2E:
  assumes "zs_y \<in> Joints2 ZS Y"
  obtains e where
    "\<And>i. i < length (fst zs_y) \<Longrightarrow> (fst zs_y) ! i = aform_val e (ZS ! i)"
    "snd (zs_y) = aform_val e Y"
    "\<And>i. e i \<in> {-1..1}"
  using assms
  by atomize_elim (auto simp: Joints2_def Pi_iff valuate_ex)

subsection {* Domain *}

definition "pdevs_domain x = {i. pdevs_apply x i \<noteq> 0}"

lemma finite_pdevs_domain[intro, simp]: "finite (pdevs_domain x)"
  unfolding pdevs_domain_def by transfer

lemma in_pdevs_domain[simp]: "i \<in> pdevs_domain x \<longleftrightarrow> pdevs_apply x i \<noteq> 0"
  by (auto simp: pdevs_domain_def)

subsection {* Least Fresh Index *}

definition degree::"'a::real_vector pdevs \<Rightarrow> nat"
  where "degree x = (LEAST i. \<forall>j\<ge>i. pdevs_apply x j = 0)"

lemma degree[rule_format, intro, simp]:
  shows "\<forall>j\<ge>degree x. pdevs_apply x j = 0"
  unfolding degree_def
proof (rule LeastI_ex)
  from assms have "\<And>j. j > Max (pdevs_domain x) \<Longrightarrow> j \<notin> (pdevs_domain x)"
    by (metis Max_less_iff all_not_in_conv less_irrefl_nat finite_pdevs_domain)
  then show "\<exists>xa. \<forall>j\<ge>xa. pdevs_apply x j = 0"
    by (auto intro!: exI[where x="Max (pdevs_domain x) + 1"])
qed

lemma degree_le:
  assumes d: "\<forall>j \<ge> d. pdevs_apply x j = 0"
  shows "degree x \<le> d"
  unfolding degree_def
  by (rule Least_le) (rule d)

lemma degree_gt: "pdevs_apply x j \<noteq> 0 \<Longrightarrow> degree x > j"
  by auto

lemma pdevs_val_pdevs_domain: "pdevs_val e X = (\<Sum>i\<in>pdevs_domain X. e i *\<^sub>R pdevs_apply X i)"
  by (auto simp: pdevs_val_def intro!: suminf_finite)

lemma pdevs_val_setsum: "pdevs_val e X = (\<Sum>i < degree X. e i *\<^sub>R pdevs_apply X i)"
  by (auto intro!: degree_gt setsum.mono_neutral_cong_left simp: pdevs_val_pdevs_domain)

lemma degree_eqI:
  assumes "pdevs_apply x d \<noteq> 0"
  assumes "\<And>j. j > d \<Longrightarrow> pdevs_apply x j = 0"
  shows "degree x = Suc d"
  unfolding eq_iff
  by (auto intro!: degree_gt degree_le assms simp: Suc_le_eq)

lemma finite_degree_nonzero[intro, simp]: "finite {i. pdevs_apply x i \<noteq> 0}"
  by transfer (auto simp: vimage_def Collect_neg_eq)

lemma degree_eq_Suc_max:
  "degree x = (if (\<forall>i. pdevs_apply x i = 0) then 0 else Suc (Max {i. pdevs_apply x i \<noteq> 0}))"
proof -
  {
    assume "\<And>i. pdevs_apply x i = 0"
    hence ?thesis
      by auto (metis degree_le le_0_eq)
  } moreover {
    fix i assume "pdevs_apply x i \<noteq> 0"
    hence ?thesis
      using Max_in[OF finite_degree_nonzero, of x]
      by (auto intro!: degree_eqI) (metis Max.coboundedI[OF finite_degree_nonzero] in_pdevs_domain
        le_eq_less_or_eq less_asym pdevs_domain_def)
  } ultimately show ?thesis
    by blast
qed

lemma pdevs_val_degree_cong:
  assumes "b = d"
  assumes "\<And>i. i < degree b \<Longrightarrow> a i = c i"
  shows "pdevs_val a b = pdevs_val c d"
  using assms
  by (auto simp: pdevs_val_setsum)

abbreviation degree_aform::"'a::real_vector aform \<Rightarrow> nat"
  where "degree_aform X \<equiv> degree (snd X)"

lemma degree_cong: "(\<And>i. (pdevs_apply x i = 0) = (pdevs_apply y i = 0)) \<Longrightarrow> degree x = degree y"
  unfolding degree_def
  by auto

lemma Least_True_nat[intro, simp]: "(LEAST i::nat. True) = 0"
  by (metis (lifting) One_nat_def less_one not_less_Least not_less_eq)

subsection {* Total Deviation *}

definition tdev::"'a::ordered_euclidean_space pdevs \<Rightarrow> 'a" where
  "tdev x = (\<Sum>i<degree x. \<bar>pdevs_apply x i\<bar>)"

lemma abs_pdevs_val_le_tdev: "e \<in> UNIV \<rightarrow> {-1 .. 1} \<Longrightarrow> \<bar>pdevs_val e x\<bar> \<le> tdev x"
  by (force simp: pdevs_val_setsum tdev_def abs_scaleR Pi_iff
    intro!: order_trans[OF setsum_abs] setsum_mono scaleR_left_le_one_le
    intro: abs_leI)

subsection {* Binary Pointwise Operations *}

definition binop_pdevs_raw::
    "('a::real_vector \<Rightarrow> 'b::real_vector \<Rightarrow> 'c::real_vector) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'c"
  where "binop_pdevs_raw f x y i = (if x i = 0 \<and> y i = 0 then 0 else f (x i) (y i))"

lemma nonzeros_binop_pdevs_subset: "{i. binop_pdevs_raw f x y i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0} \<union> {i. y i \<noteq> 0}"
  by (auto simp: binop_pdevs_raw_def)

lift_definition binop_pdevs::
    "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a::real_vector pdevs \<Rightarrow> 'b::real_vector pdevs \<Rightarrow> 'c::real_vector pdevs"
  is binop_pdevs_raw
  using nonzeros_binop_pdevs_subset
  by (rule finite_subset) auto

lemma pdevs_apply_binop_pdevs[simp]: "pdevs_apply (binop_pdevs f x y) i =
  (if pdevs_apply x i = 0 \<and> pdevs_apply y i = 0 then 0 else f (pdevs_apply x i) (pdevs_apply y i))"
  by transfer (auto simp: binop_pdevs_raw_def)

subsection {* Addition *}

definition add_pdevs::"'a::real_vector pdevs \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs"
  where "add_pdevs = binop_pdevs op +"

lemma pdevs_apply_add_pdevs[simp]:
  "pdevs_apply (add_pdevs X Y) n = pdevs_apply X n + pdevs_apply Y n"
  by (auto simp: add_pdevs_def)

lemma pdevs_val_add_pdevs[simp]:
  fixes x y::"'a::euclidean_space"
  shows "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y"
proof -
  let ?sum = "\<lambda>m X. \<Sum>i < m. e i *\<^sub>R pdevs_apply X i"
  let ?m = "max (degree X) (degree Y)"
  have "pdevs_val e X + pdevs_val e Y = ?sum (degree X) X + ?sum (degree Y) Y"
    by (simp add: pdevs_val_setsum)
  also have "?sum (degree X) X = ?sum ?m X"
    by (rule setsum.mono_neutral_cong_left) auto
  also have "?sum (degree Y) Y = ?sum ?m Y"
    by (rule setsum.mono_neutral_cong_left) auto
  also have "?sum ?m X + ?sum ?m Y = (\<Sum>i < ?m. e i *\<^sub>R (pdevs_apply X i + pdevs_apply Y i))"
    by (simp add: scaleR_right_distrib setsum.distrib)
  also have "\<dots> = (\<Sum>i. e i *\<^sub>R (pdevs_apply X i + pdevs_apply Y i))"
    by (rule suminf_finite[symmetric]) auto
  also have "\<dots> = pdevs_val e (add_pdevs X Y)"
    by (simp add: pdevs_val_def)
  finally show "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y" by simp
qed

subsection {* Total Deviation *}

lemma tdev_eq_zero_iff: fixes X::"real pdevs" shows "tdev X = 0 \<longleftrightarrow> (\<forall>e. pdevs_val e X = 0)"
  by (force simp add: pdevs_val_setsum tdev_def setsum_nonneg_eq_0_iff
    dest!: spec[where x="\<lambda>i. if pdevs_apply X i \<ge> 0 then 1 else -1"] split: split_if_asm)

lemma tdev_nonneg[intro, simp]: "tdev X \<ge> 0"
  by (auto simp: tdev_def)

lemma tdev_nonpos_iff[simp]: "tdev X \<le> 0 \<longleftrightarrow> tdev X = 0"
  by (auto simp: order.antisym)

subsection {* Unary Operations *}

definition unop_pdevs_raw::
    "('a::zero \<Rightarrow> 'b::zero) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'b"
  where "unop_pdevs_raw f x i = (if x i = 0 then 0 else f (x i))"

lemma nonzeros_unop_pdevs_subset: "{i. unop_pdevs_raw f x i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0}"
  by (auto simp: unop_pdevs_raw_def)

lift_definition unop_pdevs::
    "('a \<Rightarrow> 'b) \<Rightarrow> 'a::zero pdevs \<Rightarrow> 'b::zero pdevs"
  is unop_pdevs_raw
  using nonzeros_unop_pdevs_subset
  by (rule finite_subset) auto

lemma pdevs_apply_unop_pdevs[simp]: "pdevs_apply (unop_pdevs f x) i =
  (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i))"
  by transfer (auto simp: unop_pdevs_raw_def)

subsection {* Pointwise Scaling of Partial Deviations *}

definition scaleR_pdevs::"real \<Rightarrow> 'a::real_vector pdevs \<Rightarrow> 'a pdevs"
  where "scaleR_pdevs r x = unop_pdevs (op *\<^sub>R r) x"

lemma pdevs_apply_scaleR_pdevs[simp]:
  "pdevs_apply (scaleR_pdevs x Y) n = x *\<^sub>R pdevs_apply Y n"
  by (auto simp: scaleR_pdevs_def)

lemma degree_scaleR_pdevs[simp]: "degree (scaleR_pdevs r x) = (if r = 0 then 0 else degree x)"
  unfolding degree_def
  by auto

lemma pdevs_val_scaleR_pdevs[simp]:
  fixes x::real and Y::"'a::real_normed_vector pdevs"
  shows "pdevs_val e (scaleR_pdevs x Y) = x *\<^sub>R pdevs_val e Y"
  by (auto simp: pdevs_val_setsum scaleR_setsum_right ac_simps)

subsection {* Partial Deviations Scale Pointwise *}

definition pdevs_scaleR::"real pdevs \<Rightarrow> 'a::real_vector \<Rightarrow> 'a pdevs"
  where "pdevs_scaleR r x = unop_pdevs (\<lambda>r. r *\<^sub>R x) r"

lemma pdevs_apply_pdevs_scaleR[simp]:
  "pdevs_apply (pdevs_scaleR X y) n = pdevs_apply X n *\<^sub>R y"
  by (auto simp: pdevs_scaleR_def)

lemma degree_pdevs_scaleR[simp]: "degree (pdevs_scaleR r x) = (if x = 0 then 0 else degree r)"
  unfolding degree_def
  by auto

lemma pdevs_val_pdevs_scaleR[simp]:
  fixes X::"real pdevs" and y::"'a::real_normed_vector"
  shows "pdevs_val e (pdevs_scaleR X y) = pdevs_val e X *\<^sub>R y"
  by (auto simp: pdevs_val_setsum scaleR_setsum_left)

subsection {* Pointwise Unary Minus *}

definition uminus_pdevs::"'a::real_vector pdevs \<Rightarrow> 'a pdevs"
  where "uminus_pdevs = unop_pdevs uminus"

lemma pdevs_apply_uminus_pdevs[simp]: "pdevs_apply (uminus_pdevs x) = - pdevs_apply x"
  by (auto simp: uminus_pdevs_def)

lemma degree_uminus_pdevs[simp]: "degree (uminus_pdevs x) = degree x"
  by (rule degree_cong) simp

lemma pdevs_val_uminus_pdevs[simp]: "pdevs_val e (uminus_pdevs x) = - pdevs_val e x"
  unfolding pdevs_val_setsum
  by (auto simp: setsum_negf)

definition "uminus_aform X = (- fst X, uminus_pdevs (snd X))"

lemma fst_uminus_aform[simp]: "fst (uminus_aform Y) = - fst Y"
  by (simp add: uminus_aform_def)

lemma aform_val_uminus_aform[simp]: "aform_val e (uminus_aform X) = - aform_val e X"
  by (auto simp: uminus_aform_def aform_val_def)

subsection {* Constant *}

lift_definition zero_pdevs::"'a::zero pdevs" is "\<lambda>_. 0" by simp

lemma pdevs_apply_zero_pdevs[simp]: "pdevs_apply zero_pdevs i = 0"
  by transfer simp

lemma pdevs_val_zero_pdevs[simp]: "pdevs_val e zero_pdevs = 0"
  by (auto simp: pdevs_val_def)

definition "num_aform f = (f, zero_pdevs)"

subsection {* Inner Product *}

definition pdevs_inner::"'a::euclidean_space pdevs \<Rightarrow> 'a \<Rightarrow> real pdevs"
  where "pdevs_inner x b = unop_pdevs (\<lambda>x. x \<bullet> b) x"

lemma pdevs_apply_pdevs_inner[simp]: "pdevs_apply (pdevs_inner p a) i = pdevs_apply p i \<bullet> a"
  by (simp add: pdevs_inner_def)

lemma pdevs_val_pdevs_inner[simp]: "pdevs_val e (pdevs_inner p a) = pdevs_val e p \<bullet> a"
  by (auto simp add: inner_setsum_left pdevs_val_pdevs_domain intro!: setsum.mono_neutral_cong_left)

definition inner_aform::"'a::euclidean_space aform \<Rightarrow> 'a \<Rightarrow> real aform"
  where "inner_aform X b = (fst X \<bullet> b, pdevs_inner (snd X) b)"

subsection {* Update *}

lemma pdevs_val_upd[simp]:
  "pdevs_val (e(n := e')) X = pdevs_val e X - e n * pdevs_apply X n + e' * pdevs_apply X n"
  unfolding pdevs_val_def
  by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
    auto simp: pdevs_val_def setsum.insert_remove)+

lemma nonzeros_fun_upd:
  "{i. (f(n := a)) i \<noteq> 0} \<subseteq> {i. f i \<noteq> 0} \<union> {n}"
  by (auto split: split_if_asm)

lift_definition pdev_upd::"'a::real_vector pdevs \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a pdevs"
  is "\<lambda>x n a. x(n:=a)"
  by (rule finite_subset[OF nonzeros_fun_upd]) simp

lemma pdevs_apply_pdev_upd[simp]:
  "pdevs_apply (pdev_upd X n x) = (pdevs_apply X)(n:=x)"
  by transfer simp

lemma pdevs_val_pdev_upd[simp]:
  "pdevs_val e (pdev_upd X n x) = pdevs_val e X + e n *\<^sub>R x - e n *\<^sub>R pdevs_apply X n"
  unfolding pdevs_val_def
  by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X],
    auto simp: pdevs_val_def setsum.insert_remove)+

lemma degree_pdev_upd:
  assumes "x = 0 \<longleftrightarrow> pdevs_apply X n = 0"
  shows "degree (pdev_upd X n x) = degree X"
  using assms
  by (auto intro!: degree_cong split: split_if_asm)

subsection {* Inf/Sup *}

definition "Inf_aform X = fst X - tdev (snd X)"

definition "Sup_aform X = fst X + tdev (snd X)"

lemma Inf_aform:
  assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
  shows "Inf_aform X \<le> aform_val e X"
  using order_trans[OF abs_ge_minus_self abs_pdevs_val_le_tdev[OF assms]]
  by (auto simp: Inf_aform_def aform_val_def minus_le_iff)

lemma Sup_aform:
  assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
  shows "aform_val e X \<le> Sup_aform X"
  using order_trans[OF abs_ge_self abs_pdevs_val_le_tdev[OF assms]]
  by (auto simp: Sup_aform_def aform_val_def)

subsection {* Minkowski Sum *}

definition msum_pdevs_raw::"nat\<Rightarrow>(nat \<Rightarrow> 'a::real_vector)\<Rightarrow>(nat \<Rightarrow> 'a)\<Rightarrow>(nat\<Rightarrow>'a)" where
  "msum_pdevs_raw n x y i = (if i < n then x i else y (i - n))"

lemma nonzeros_msum_pdevs_raw:
  "{i. msum_pdevs_raw n f g i \<noteq> 0} = ({0..<n} \<inter> {i. f i \<noteq> 0}) \<union> op + n ` ({i. g i \<noteq> 0})"
  by (force simp: msum_pdevs_raw_def not_less split: split_if_asm)

lift_definition msum_pdevs::"nat\<Rightarrow>'a::real_vector pdevs\<Rightarrow>'a pdevs\<Rightarrow>'a pdevs" is msum_pdevs_raw
  unfolding nonzeros_msum_pdevs_raw by simp

lemma pdevs_apply_msum_pdevs: "pdevs_apply (msum_pdevs n f g) i =
  (if i < n then pdevs_apply f i else pdevs_apply g (i - n))"
  by transfer (auto simp: msum_pdevs_raw_def)

lemma degree_least_nonzero:
  assumes "degree f \<noteq> 0"
  shows "pdevs_apply f (degree f - 1) \<noteq> 0"
proof
  assume H: "pdevs_apply f (degree f - 1) = 0"
  {
    fix j
    assume "j\<ge>degree f - 1"
    with H have "pdevs_apply f j = 0"
      by (cases "degree f - 1 = j") auto
  }
  from degree_le[rule_format, OF this]
  have "degree f \<le> degree f - 1"
    by blast
  with assms show False by simp
qed

lemma degree_leI:
  assumes "(\<And>i. pdevs_apply y i = 0 \<Longrightarrow> pdevs_apply x i = 0)"
  shows "degree x \<le> degree y"
proof cases
  assume "degree x \<noteq> 0"
  from degree_least_nonzero[OF this]
  have "pdevs_apply y (degree x - 1) \<noteq> 0"
    by (auto simp: assms split: split_if_asm)
  from degree_gt[OF this] show ?thesis
    by simp
qed simp

lemma degree_msum_pdevs_ge1:
  shows "degree f \<le> n \<Longrightarrow> degree f \<le> degree (msum_pdevs n f g)"
  by (rule degree_leI) (auto simp: pdevs_apply_msum_pdevs split: split_if_asm)

lemma degree_msum_pdevs_ge2:
  assumes "degree f \<le> n"
  shows "degree g \<le> degree (msum_pdevs n f g) - n"
proof cases
  assume "degree g \<noteq> 0"
  hence "pdevs_apply g (degree g - 1) \<noteq> 0" by (rule degree_least_nonzero)
  hence "pdevs_apply (msum_pdevs n f g) (n + degree g - 1) \<noteq> 0"
    using assms
    by (auto simp: pdevs_apply_msum_pdevs)
  from degree_gt[OF this]
  show ?thesis
    by simp
qed simp

lemma
  setsum_msum_pdevs_cases:
  assumes "degree f \<le> n"
  assumes [simp]: "\<And>i. e i 0 = 0"
  shows "(\<Sum>i <degree (msum_pdevs n f g). e i (if i < n then pdevs_apply f i else pdevs_apply g (i - n))) =
    (\<Sum>i <degree f. e i (pdevs_apply f i)) + (\<Sum>i <degree g. e (i + n) (pdevs_apply g i))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<Sum>i\<in>{..<degree (msum_pdevs n f g)} \<inter> {i. i < n}. e i (pdevs_apply f i)) +
    (\<Sum>i\<in>{..<degree (msum_pdevs n f g)} \<inter> - {i. i < n}. e i (pdevs_apply g (i - n)))"
    (is "_ = ?sum_f + ?sum_g")
     by (simp add: setsum.If_cases if_distrib)
  also have "?sum_f = (\<Sum>i = 0..<degree f. e i (pdevs_apply f i))"
    using assms degree_msum_pdevs_ge1[of f n g]
    by (intro setsum.mono_neutral_cong_right) auto
  also have "?sum_g = (\<Sum>i\<in>{0 + n..<degree (msum_pdevs n f g) - n + n}. e i (pdevs_apply g (i - n)))"
    by (rule setsum.cong) auto
  also have "\<dots> = (\<Sum>i = 0..<degree (msum_pdevs n f g) - n. e (i + n) (pdevs_apply g (i + n - n)))"
    by (rule setsum_shift_bounds_nat_ivl)
  also have "\<dots> = (\<Sum>i = 0..<degree g. e (i + n) (pdevs_apply g i))"
    using assms degree_msum_pdevs_ge2[of f n]
    by (intro setsum.mono_neutral_cong_right) (auto intro!: setsum.mono_neutral_cong_right)
  finally show ?thesis
    by (simp add: atLeast0LessThan)
qed

lemma tdev_msum_pdevs: "degree f \<le> n \<Longrightarrow> tdev (msum_pdevs n f g) = tdev f + tdev g"
  by (auto simp: tdev_def pdevs_apply_msum_pdevs intro!: setsum_msum_pdevs_cases)

lemma pdevs_val_msum_pdevs:
  "degree f \<le> n \<Longrightarrow> pdevs_val e (msum_pdevs n f g) = pdevs_val e f + pdevs_val (\<lambda>i. e (i + n)) g"
  by (auto simp: pdevs_val_setsum pdevs_apply_msum_pdevs intro!: setsum_msum_pdevs_cases)

definition msum_aform::"nat \<Rightarrow> 'a::real_vector aform \<Rightarrow> 'a aform \<Rightarrow> 'a aform"
  where "msum_aform n f g = (fst f + fst g, msum_pdevs n (snd f) (snd g))"

text {* TODO: msum-aform could also round the Center... *}

lemma fst_msum_aform[simp]: "fst (msum_aform n f g) = fst f + fst g"
  by (simp add: msum_aform_def)

lemma snd_msum_aform[simp]: "snd (msum_aform n f g) = msum_pdevs n (snd f) (snd g)"
  by (simp add: msum_aform_def)

lemma finite_nonzero_summable: "finite {i. f i \<noteq> 0} \<Longrightarrow> summable f"
  by (auto intro!: sums_summable sums_finite)

lemma aform_val_msum_aform:
  assumes "degree_aform f \<le> n"
  shows "aform_val e (msum_aform n f g) = aform_val e f + aform_val (\<lambda>i. e (i + n)) g"
  using assms
  by (auto simp: pdevs_val_msum_pdevs aform_val_def)

lemma Inf_aform_msum_aform:
  "degree_aform X \<le> n \<Longrightarrow> Inf_aform (msum_aform n X Y) = Inf_aform X + Inf_aform Y"
  by (simp add: Inf_aform_def tdev_msum_pdevs)

lemma Sup_aform_msum_aform:
  "degree_aform X \<le> n \<Longrightarrow> Sup_aform (msum_aform n X Y) = Sup_aform X + Sup_aform Y"
  by (simp add: Sup_aform_def tdev_msum_pdevs)

lemma Affine_msum_aform:
    "Affine (msum_aform (degree_aform X) X Y) = {x + y |x y. x \<in> Affine X \<and> y \<in> Affine Y}"
  unfolding Affine_def valuate_def
proof safe
  case goal1
  thus ?case
    by (intro exI[where x = "aform_val e X"] exI[where x = "aform_val ((\<lambda>i. e (i + degree_aform X))) Y"])
      (auto simp add: aform_val_def pdevs_val_msum_pdevs)
next
  case goal2
  thus ?case
    by (intro image_eqI[where x="\<lambda>i. if i < degree_aform X then e i else ea (i - degree_aform X)"])
      (force simp: aform_val_def pdevs_val_msum_pdevs intro!: pdevs_val_degree_cong)+
qed

lemma
  abs_diff_eq1:
  fixes l u::"'a::ordered_euclidean_space"
  shows "l \<le> u \<Longrightarrow> \<bar>u - l\<bar> = u - l"
  by (metis abs_of_nonneg diff_add_cancel le_add_same_cancel2)

lemma compact_setsum:
  fixes f :: "'a \<Rightarrow> 'b::topological_space \<Rightarrow> 'c::real_normed_vector"
  assumes "finite I"
  assumes "\<And>i. i \<in> I \<Longrightarrow> compact (S i)"
  assumes "\<And>i. i \<in> I \<Longrightarrow> continuous_on (S i) (f i)"
  assumes "I \<subseteq> J"
  shows "compact {\<Sum>i\<in>I. f i (x i) | x. x \<in> Pi J S}"
  using assms
proof (induct I)
  case empty
  thus ?case
  proof (cases "\<exists>x. x \<in> Pi J S")
    case False
    hence *: "{\<Sum>i\<in>{}. f i (x i) |x. x \<in> Pi J S} = {}"
      by (auto simp: Pi_iff)
    show ?thesis unfolding * by simp
  qed auto
next
  case (insert a I)
  hence "{\<Sum>i\<in>insert a I. f i (xa i) |xa. xa \<in> Pi J S}
    = {x + y |x y. x \<in> f a ` S a \<and> y \<in> {\<Sum>i\<in>I. f i (x i) |x. x \<in> Pi J S}}"
  proof safe
    fix s x
    assume "s \<in> S a" "x \<in> Pi J S"
    thus "\<exists>xa. f a s + (\<Sum>i\<in>I. f i (x i)) = (\<Sum>i\<in>insert a I. f i (xa i)) \<and> xa \<in> Pi J S"
      using insert
      by (auto intro!: exI[where x="x(a:=s)"] setsum.cong)
  qed force
  also have "compact \<dots>"
    using insert
    by (intro compact_sums) (auto intro!: compact_continuous_image)
  finally show ?case .
qed

lemma compact_Affine:
  fixes X::"'a::ordered_euclidean_space aform"
  shows "compact (Affine X)"
proof -
  have "Affine X = {x + y|x y. x \<in> {fst X} \<and>
      y \<in> {(\<Sum>i \<in> {0..<degree_aform X}. e i *\<^sub>R pdevs_apply (snd X) i) | e. e \<in> UNIV \<rightarrow> {-1 .. 1}}}"
    by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_setsum atLeast0LessThan)
  also have "compact \<dots>"
    by (rule compact_sums) (auto intro!: compact_setsum continuous_intros)
  finally show ?thesis .
qed

lemma Joints2_JointsI:
  "(xs, x) \<in> Joints2 XS X \<Longrightarrow> x#xs \<in> Joints (X#XS)"
  by (auto simp: Joints_def Joints2_def valuate_def)

subsection {* Splitting *}

definition "split_aform X i =
  (let xi = pdevs_apply (snd X) i /\<^sub>R 2
  in ((fst X - xi, pdev_upd (snd X) i xi), (fst X + xi, pdev_upd (snd X) i xi)))"

lemma split_aformE:
  assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
  assumes "x = aform_val e X"
  obtains err where "x = aform_val (e(i:=err)) (fst (split_aform X i))" "err \<in> {-1 .. 1}"
    | err where "x = aform_val (e(i:=err)) (snd (split_aform X i))" "err \<in> {-1 .. 1}"
proof (atomize_elim)
  let ?thesis = "(\<exists>err. x = aform_val (e(i := err)) (fst (split_aform X i)) \<and> err \<in> {- 1..1}) \<or>
    (\<exists>err. x = aform_val (e(i := err)) (snd (split_aform X i)) \<and> err \<in> {- 1..1})"
  {
    assume "pdevs_apply (snd X) i = 0"
    hence "X = fst (split_aform X i)"
      by (auto simp: split_aform_def intro!: prod_eqI pdevs_eqI)
    with assms have ?thesis by (auto intro!: exI[where x="e i"])
  } moreover {
    assume "pdevs_apply (snd X) i \<noteq> 0"
    hence [simp]: "degree_aform X > i"
      by (rule degree_gt)
    note assms(2)
    also
    have "aform_val e X = fst X + (\<Sum>i<degree_aform X. e i *\<^sub>R pdevs_apply (snd X) i)"
      by (simp add: aform_val_def pdevs_val_setsum)
    also
    have rewr: "{..<degree_aform X} = {0..<degree_aform X} - {i} \<union> {i}"
      by auto
    have "(\<Sum>i<degree_aform X. e i *\<^sub>R pdevs_apply (snd X) i) =
        (\<Sum>i \<in> {0..<degree_aform X} - {i}. e i *\<^sub>R pdevs_apply (snd X) i) + e i *\<^sub>R pdevs_apply (snd X) i"
      by (subst rewr, subst setsum.union_disjoint) auto
    finally have "x = fst X + \<dots>" .
    hence "x = aform_val (e(i:=2 * e i - 1)) (snd (split_aform X i))"
        "x = aform_val (e(i:=2 * e i + 1)) (fst (split_aform X i))"
      by (auto simp: aform_val_def split_aform_def Let_def pdevs_val_setsum atLeast0LessThan
        Diff_eq degree_pdev_upd if_distrib setsum.If_cases field_simps scaleR_left_distrib[symmetric])
    moreover
    have "2 * e i - 1 \<in> {-1 .. 1} \<or> 2 * e i + 1 \<in> {-1 .. 1}"
      using assms by (auto simp: not_le Pi_iff dest!: spec[where x=i])
    ultimately have ?thesis by blast
  } ultimately show ?thesis by blast
qed

lemma pdevs_val_add: "pdevs_val (\<lambda>i. e i + f i) xs = pdevs_val e xs + pdevs_val f xs"
  by (auto simp: pdevs_val_pdevs_domain algebra_simps setsum.distrib)

lemma pdevs_val_cmul: "pdevs_val (\<lambda>i. u * e i) xs = u *\<^sub>R pdevs_val e xs"
  by (auto simp: pdevs_val_pdevs_domain scaleR_setsum_right)

lemma atLeastAtMost_absI: "- a \<le> a \<Longrightarrow> \<bar>x::real\<bar> \<le> \<bar>a\<bar> \<Longrightarrow> x \<in> atLeastAtMost (- a) a"
  by auto

lemma divide_atLeastAtMost_1_absI: "\<bar>x::real\<bar> \<le> \<bar>a\<bar> \<Longrightarrow> x/a \<in> {-1 .. 1}"
  by (intro atLeastAtMost_absI) (auto simp: divide_le_eq_1)

lemma convex_scaleR_aux: "u + v = 1 \<Longrightarrow> u *\<^sub>R x + v *\<^sub>R x = (x::'a::real_vector)"
  by (metis scaleR_add_left scaleR_one)

lemma convex_mult_aux: "u + v = 1 \<Longrightarrow> u * x + v * x = (x::real)"
  using convex_scaleR_aux[of u v x] by simp

lemma convex_Affine: "convex (Affine X)"
proof (rule convexI)
  fix x y::'a and u v::real
  assume "x \<in> Affine X" "y \<in> Affine X" and convex: "0 \<le> u" "0 \<le> v" "u + v = 1"
  then obtain e f where x: "x = aform_val e X" "e \<in> UNIV \<rightarrow> {-1 .. 1}"
    and y: "y = aform_val f X" "f \<in> UNIV \<rightarrow> {-1 .. 1}"
    by (auto simp: Affine_def valuate_def)
  let ?conv = "\<lambda>i. u * e i + v * f i"
  {
    fix i
    have "\<bar>?conv i\<bar> \<le> u * \<bar>e i\<bar> + v * \<bar>f i\<bar>"
      using convex by (intro order_trans[OF abs_triangle_ineq]) (simp add: abs_mult)
    also have "\<dots> \<le> 1"
      using convex x y
      by (intro convex_bound_le) (auto simp: Pi_iff abs_real_def)
    finally have "?conv i \<le> 1" "-1 \<le> ?conv i"
      by (auto simp: abs_real_def split: split_if_asm)
  }
  thus "u *\<^sub>R x + v *\<^sub>R y \<in> Affine X"
    using convex x y
    by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_add pdevs_val_cmul algebra_simps
      convex_scaleR_aux intro!: image_eqI[where x="?conv"])
qed

end


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

section \<open>Pocklington's Theorem for Primes\<close>

theory Pocklington
imports Residues
begin

subsection \<open>Lemmas about previously defined terms\<close>

lemma prime_nat_iff'': "prime (p::nat) \<longleftrightarrow> p \<noteq> 0 \<and> p \<noteq> 1 \<and> (\<forall>m. 0 < m \<and> m < p \<longrightarrow> coprime p m)"
  apply (auto simp add: prime_nat_iff)
   apply (rule coprimeI)
   apply (auto dest: nat_dvd_not_less simp add: ac_simps)
  apply (metis One_nat_def dvd_1_iff_1 dvd_pos_nat gcd_nat.order_iff is_unit_gcd linorder_neqE_nat nat_dvd_not_less)
  done

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
  then show ?thesis by simp
qed

subsection \<open>Some basic theorems about solving congruences\<close>

lemma cong_solve:
  fixes n :: nat
  assumes an: "coprime a n"
  shows "\<exists>x. [a * x = b] (mod n)"
proof (cases "a = 0")
  case True
  with an show ?thesis
    by (simp add: cong_def)
next
  case False
  from bezout_add_strong_nat [OF this]
  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"
    using assms coprime_common_divisor [of a n d] by simp
  with dxy(3) have "a * x * b = (n * y + 1) * b"
    by simp
  then have "a * (x * b) = n * (y * b) + b"
    by (auto simp: algebra_simps)
  then have "a * (x * b) mod n = (n * (y * b) + b) mod n"
    by simp
  then have "a * (x * b) mod n = b mod n"
    by (simp add: mod_add_left_eq)
  then have "[a * (x * b) = b] (mod n)"
    by (simp only: cong_def)
  then 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 -
  from cong_solve[OF an] obtain x where x: "[a * x = b] (mod n)"
    by blast
  let ?P = "\<lambda>x. x < n \<and> [a * x = b] (mod n)"
  let ?x = "x mod n"
  from x have *: "[a * ?x = b] (mod n)"
    by (simp add: cong_def mod_mult_right_eq[of a x n])
  from mod_less_divisor[ of n x] nz * have Px: "?P ?x" by simp
  have "y = ?x" if Py: "y < n" "[a * y = b] (mod n)" for y
  proof -
    from Py(2) * have "[a * y = a * ?x] (mod n)"
      by (simp add: cong_def)
    then have "[y = ?x] (mod n)"
      by (metis an cong_mult_lcancel_nat)
    with mod_less[OF Py(1)] mod_less_divisor[ of n x] nz
    show ?thesis
      by (simp add: cong_def)
  qed
  with Px show ?thesis by blast
qed

lemma cong_solve_unique_nontrivial:
  fixes p :: nat
  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 (simp add: ac_simps)
  from x0 xp p have px: "coprime x p"
    by (auto simp add: prime_nat_iff'' ac_simps)
  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)
  have "y \<noteq> 0"
  proof
    assume "y = 0"
    with y(2) have "p dvd a"
      using cong_dvd_iff by auto
    with not_prime_1 p pa show False
      by (auto simp add: gcd_nat.order_iff)
  qed
  with y show ?thesis
    by blast
qed

lemma cong_unique_inverse_prime:
  fixes p :: nat
  assumes "prime p" and "0 < x" and "x < p"
  shows "\<exists>!y. 0 < y \<and> y < p \<and> [x * y = 1] (mod p)"
  by (rule cong_solve_unique_nontrivial) (use assms in simp_all)

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"
    using cong_imp_coprime cong_sym by blast+
  then have "coprime x (a*b)"
    by simp
  with x show ?thesis
    by blast
qed

subsection \<open>Lucas's theorem\<close>

lemma lucas_coprime_lemma:
  fixes n :: nat
  assumes m: "m \<noteq> 0" and am: "[a^m = 1] (mod n)"
  shows "coprime a n"
proof -
  consider "n = 1" | "n = 0" | "n > 1" by arith
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by simp
  next
    case 2
    with am m show ?thesis
      by simp
  next
    case 3
    from m obtain m' where m': "m = Suc m'" by (cases m) blast+
    have "d = 1" if d: "d dvd a" "d dvd n" for d
    proof -
      from am mod_less[OF \<open>n > 1\<close>] have am1: "a^m mod n = 1"
        by (simp add: cong_def)
      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 show ?thesis
        by simp
    qed
    then show ?thesis
      by (auto intro: coprimeI)
  qed
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 (rule totient_imp_prime)
  show "totient n = n - 1"
  proof (rule ccontr)
    have "[a ^ totient n = 1] (mod n)"
      by (rule euler_theorem, rule lucas_coprime_lemma [of "n - 1"]) (use n an in auto)
    moreover assume "totient n \<noteq> n - 1"
    then have "totient n > 0" "totient n < n - 1"
      using \<open>n \<ge> 2\<close> and totient_less[of n] by simp_all
    ultimately show False
      using nm by auto
  qed
qed (use n in auto)

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
  show ?lhs if ?rhs
    using that by blast
  show ?rhs if ?lhs
  proof -
    from \<open>?lhs\<close> obtain n where n: "P n" by blast
    let ?x = "Least P"
    have "\<not> P m" if "m < ?x" for m
      by (rule not_less_Least[OF that])
    with LeastI_ex[OF \<open>?lhs\<close>] show ?thesis
      by blast
  qed
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 an1
  have an: "coprime a n" "coprime (a ^ (n - 1)) n"
    using \<open>n \<ge> 2\<close> by simp_all
  have False if H0: "\<exists>m. 0 < m \<and> m < n - 1 \<and> [a ^ m = 1] (mod n)" (is "\<exists>m. ?P m")
  proof -
    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
    have False if nm1: "(n - 1) mod m > 0"
    proof -
      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 = div_mult_mod_eq[of "(n - 1)" m]
      have yn: "coprime ?y n"
        using an(1) by (cases "(n - Suc 0) div m * m = 0") auto
      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_def onen] onen
        by (metis power_one)
      finally have *: "?y mod n = 1"  .
      have **: "[?y * a ^ ((n - 1) mod m) = ?y* 1] (mod n)"
        using an1[unfolded cong_def onen] onen
          div_mult_mod_eq[of "(n - 1)" m, symmetric]
        by (simp add:power_add[symmetric] cong_def * del: One_nat_def)
      have "[a ^ ((n - 1) mod m) = 1] (mod n)"
        by (metis cong_mult_rcancel_nat mult.commute ** yn)
      with m(4)[rule_format, OF th0] nm1
        less_trans[OF mod_less_divisor[OF m(1), of "n - 1"] m(2)] show ?thesis
        by blast
    qed
    then have "(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 auto
    obtain p where p: "prime p" "p dvd r"
      by (metis prime_factor_nat r01(2))
    then have th: "prime p \<and> p dvd n - 1"
      unfolding r by (auto intro: dvd_mult)
    from r have "(a ^ ((n - 1) div p)) mod n = (a^(m*r div p)) mod n"
      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 from m(3) onen have "\<dots> = 1"
      by (simp add: cong_def)
    finally have "[(a ^ ((n - 1) div p))= 1] (mod n)"
      using onen by (simp add: cong_def)
    with pn th show ?thesis by blast
  qed
  then have "\<forall>m. 0 < m \<and> m < n - 1 \<longrightarrow> \<not> [a ^ m = 1] (mod n)"
    by blast
  then show ?thesis by (rule lucas_weak[OF n2 an1])
qed

subsection \<open>Definition of the order of a number mod \<open>n\<close>\<close>

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

text \<open>This has the expected properties.\<close>

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)
  have ex: "\<exists>m>0. ?P m"
  proof (cases "n \<ge> 2")
    case True
    moreover from assms have "coprime a n"
      by (simp add: ac_simps)
    then have "[a ^ totient n = 1] (mod n)"
      by (rule euler_theorem)
    ultimately show ?thesis
      by (auto intro: exI [where x = "totient n"])
  next
    case False
    then have "n = 0 \<or> n = 1"
      by auto
    with assms show ?thesis
      by auto
  qed
  from nat_exists_least_iff'[of ?P] ex assms show ?thesis
    unfolding o[symmetric] by auto
qed

text \<open>With the special value \<open>0\<close> for non-coprime case, it's more convenient.\<close>
lemma ord_works: "[a ^ (ord n a) = 1] (mod n) \<and> (\<forall>m. 0 < m \<and> m < ord n a \<longrightarrow> \<not> [a^ m = 1] (mod n))"
  for n :: nat
  by (cases "coprime n a") (use coprime_ord[of n a] in \<open>auto simp add: ord_def cong_def\<close>)

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

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

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

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

lemma ord_divides:"[a ^ d = 1] (mod n) \<longleftrightarrow> ord n a dvd d"
  (is "?lhs \<longleftrightarrow> ?rhs")
  for n :: nat
proof
  assume ?rhs
  then obtain k where "d = ord n a * k"
    unfolding dvd_def by blast
  then have "[a ^ d = (a ^ (ord n a) mod n)^k] (mod n)"
    by (simp add : cong_def power_mult power_mod)
  also have "[(a ^ (ord n a) mod n)^k = 1] (mod n)"
    using ord[of a n, unfolded cong_def]
    by (simp add: cong_def power_mod)
  finally show ?lhs .
next
  assume ?lhs
  show ?rhs
  proof (cases "coprime n a")
    case prem: False
    then have o: "ord n a = 0" by (simp add: ord_def)
    show ?thesis
    proof (cases d)
      case 0
      with o prem show ?thesis by (simp add: cong_def)
    next
      case (Suc d')
      then have d0: "d \<noteq> 0" by simp
      from prem obtain p where p: "p dvd n" "p dvd a" "p \<noteq> 1"
        by (auto elim: not_coprimeE)
      from \<open>?lhs\<close> obtain q1 q2 where q12: "a ^ d + n * q1 = 1 + n * q2"
        using prem d0 lucas_coprime_lemma
        by (auto elim: not_coprimeE simp add: ac_simps)
      then have "a ^ d + n * q1 - n * q2 = 1" by simp
      with dvd_diff_nat [OF dvd_add [OF divides_rexp]]  dvd_mult2 Suc p have "p dvd 1"
        by metis
      with p(3) have False by simp
      then show ?thesis ..
    qed
  next
    case H: True
    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)"
      using cong_pow ord_works by fastforce
    from H have onz: "?o \<noteq> 0" by (simp add: ord_eq_0)
    then have opos: "?o > 0" by simp
    from div_mult_mod_eq[of d "ord n a"] \<open>?lhs\<close>
    have "[a^(?o*?q + ?r) = 1] (mod n)"
      by (simp add: cong_def mult.commute)
    then have "[(a^?o)^?q * (a^?r) = 1] (mod n)"
      by (simp add: cong_def power_mult[symmetric] power_add[symmetric])
    then have th: "[a^?r = 1] (mod n)"
      using eqo mod_mult_left_eq[of "(a^?o)^?q" "a^?r" n]
      by (simp add: cong_def del: One_nat_def) (metis mod_mult_left_eq nat_mult_1)
    show ?thesis
    proof (cases "?r = 0")
      case True
      then show ?thesis by (simp add: dvd_eq_mod_eq_0)
    next
      case False
      with mod_less_divisor[OF opos, of d] have r0o:"?r >0 \<and> ?r < ?o" by simp
      from conjunct2[OF ord_works[of a n], rule_format, OF r0o] th
      show ?thesis by blast
    qed
  qed
qed

lemma order_divides_totient:
  "ord n a dvd totient n" if "coprime n a"
  using that euler_theorem [of a n]
  by (simp add: ord_divides [symmetric] ac_simps)

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 -
  have th: "[a^d = a^e] (mod n) \<longleftrightarrow> [d = e] (mod (ord n a))"
    if na: "coprime n a" and ed: "(e::nat) \<le> d"
    for n a d e :: nat
  proof -
    from na ed have "\<exists>c. d = e + c" by presburger
    then obtain c where c: "d = e + c" ..
    from na have an: "coprime a n"
      by (simp add: ac_simps)
    then have aen: "coprime (a ^ e) n"
      by (cases "e > 0") simp_all
    from an have acn: "coprime (a ^ c) n"
      by (cases "c > 0") simp_all
    from c have "[a^d = a^e] (mod n) \<longleftrightarrow> [a^(e + c) = a^(e + 0)] (mod n)"
      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)"
      by (auto simp add: cong_altdef_nat)
    finally show ?thesis
      using c by simp
  qed
  consider "e \<le> d" | "d \<le> e" by arith
  then show ?thesis
  proof cases
    case 1
    with na show ?thesis by (rule th)
  next
    case 2
    from th[OF na this] show ?thesis
      by (metis cong_sym)
  qed
qed

lemma ord_not_coprime [simp]: "\<not>coprime n a \<Longrightarrow> ord n a = 0"
  by (simp add: ord_def)

lemma ord_1 [simp]: "ord 1 n = 1"
proof -
  have "(LEAST k. k > 0) = (1 :: nat)"
    by (rule Least_equality) auto
  thus ?thesis by (simp add: ord_def)
qed

lemma ord_1_right [simp]: "ord (n::nat) 1 = 1"
  using ord_divides[of 1 1 n] by simp

lemma ord_Suc_0_right [simp]: "ord (n::nat) (Suc 0) = 1"
  using ord_divides[of 1 1 n] by simp

lemma ord_0_nat [simp]: "ord 0 (n :: nat) = (if n = 1 then 1 else 0)"
proof -
  have "(LEAST k. k > 0) = (1 :: nat)"
    by (rule Least_equality) auto
  thus ?thesis by (auto simp: ord_def)
qed

lemma ord_0_right_nat [simp]: "ord (n :: nat) 0 = (if n = 1 then 1 else 0)"
proof -
  have "(LEAST k. k > 0) = (1 :: nat)"
    by (rule Least_equality) auto
  thus ?thesis by (auto simp: ord_def)
qed

lemma ord_divides': "[a ^ d = Suc 0] (mod n) = (ord n a dvd d)"
  using ord_divides[of a d n] by simp

lemma ord_Suc_0 [simp]: "ord (Suc 0) n = 1"
  using ord_1[where 'a = nat] by (simp del: ord_1)

lemma ord_mod [simp]: "ord n (k mod n) = ord n k"
  by (cases "n = 0") (auto simp add: ord_def cong_def power_mod)

lemma ord_gt_0_iff [simp]: "ord (n::nat) x > 0 \<longleftrightarrow> coprime n x"
  using ord_eq_0[of n x] by auto

lemma ord_eq_Suc_0_iff: "ord n (x::nat) = Suc 0 \<longleftrightarrow> [x = 1] (mod n)"
  using ord_divides[of x 1 n] by (auto simp: ord_divides')

lemma ord_cong:
  assumes "[k1 = k2] (mod n)"
  shows   "ord n k1 = ord n k2"
proof -
  have "ord n (k1 mod n) = ord n (k2 mod n)"
    by (simp only: assms[unfolded cong_def])
  thus ?thesis by simp
qed

lemma ord_nat_code [code_unfold]:
  "ord n a =
     (if n = 0 then if a = 1 then 1 else 0 else
        if coprime n a then Min (Set.filter (\<lambda>k. [a ^ k = 1] (mod n)) {0<..n}) else 0)"
proof (cases "coprime n a \<and> n > 0")
  case True
  define A where "A = {k\<in>{0<..n}. [a ^ k = 1] (mod n)}"
  define k where "k = (LEAST k. k > 0 \<and> [a ^ k = 1] (mod n))"
  have totient: "totient n \<in> A"
    using euler_theorem[of a n] True
    by (auto simp: A_def coprime_commute intro!: Nat.gr0I totient_le)
  moreover have "finite A" by (auto simp: A_def)
  ultimately have *: "Min A \<in> A" and "\<forall>y. y \<in> A \<longrightarrow> Min A \<le> y"
    by (auto intro: Min_in)

  have "k > 0 \<and> [a ^ k = 1] (mod n)"
    unfolding k_def by (rule LeastI[of _ "totient n"]) (use totient in \<open>auto simp: A_def\<close>)
  moreover have "k \<le> totient n"
    unfolding k_def by (intro Least_le) (use totient in \<open>auto simp: A_def\<close>)
  ultimately have "k \<in> A" using totient_le[of n] by (auto simp: A_def)
  hence "Min A \<le> k" by (intro Min_le) (auto simp: \<open>finite A\<close>)
  moreover from * have "k \<le> Min A"
    unfolding k_def by (intro Least_le) (auto simp: A_def)
  ultimately show ?thesis using True by (simp add: ord_def k_def A_def Set.filter_def)
qed auto

theorem ord_modulus_mult_coprime:
  fixes x :: nat
  assumes "coprime m n"
  shows   "ord (m * n) x = lcm (ord m x) (ord n x)"
proof (intro dvd_antisym)
  have "[x ^ lcm (ord m x) (ord n x) = 1] (mod (m * n))"
    using assms by (intro coprime_cong_mult_nat assms) (auto simp: ord_divides')
  thus "ord (m * n) x dvd lcm (ord m x) (ord n x)"
    by (simp add: ord_divides')
next
  show "lcm (ord m x) (ord n x) dvd ord (m * n) x"
  proof (intro lcm_least)
    show "ord m x dvd ord (m * n) x"
      using cong_modulus_mult_nat[of "x ^ ord (m * n) x" 1 m n] assms
      by (simp add: ord_divides')
    show "ord n x dvd ord (m * n) x"
      using cong_modulus_mult_nat[of "x ^ ord (m * n) x" 1 n m] assms
      by (simp add: ord_divides' mult.commute)
  qed
qed

corollary ord_modulus_prod_coprime:
  assumes "finite A" "\<And>i j. i \<in> A \<Longrightarrow> j \<in> A \<Longrightarrow> i \<noteq> j \<Longrightarrow> coprime (f i) (f j)"
  shows   "ord (\<Prod>i\<in>A. f i :: nat) x = (LCM i\<in>A. ord (f i) x)"
  using assms by (induction A rule: finite_induct)
                 (simp, simp, subst ord_modulus_mult_coprime, auto intro!: prod_coprime_right)

lemma ord_power_aux:
  fixes m x k a :: nat
  defines "l \<equiv> ord m a"
  shows   "ord m (a ^ k) * gcd k l = l"
proof (rule dvd_antisym)
  have "[a ^ lcm k l = 1] (mod m)"
    unfolding ord_divides by (simp add: l_def)
  also have "lcm k l = k * (l div gcd k l)"
    by (simp add: lcm_nat_def div_mult_swap)
  finally have "ord m (a ^ k) dvd l div gcd k l"
    unfolding ord_divides [symmetric] by (simp add: power_mult [symmetric])
  thus "ord m (a ^ k) * gcd k l dvd l"
    by (cases "l = 0") (auto simp: dvd_div_iff_mult)

  have "[(a ^ k) ^ ord m (a ^ k) = 1] (mod m)"
    by (rule ord)
  also have "(a ^ k) ^ ord m (a ^ k) = a ^ (k * ord m (a ^ k))"
    by (simp add: power_mult)
  finally have "ord m a dvd k * ord m (a ^ k)"
    by (simp add: ord_divides')
  hence "l dvd gcd (k * ord m (a ^ k)) (l * ord m (a ^ k))"
    by (intro gcd_greatest dvd_triv_left) (auto simp: l_def ord_divides')
  also have "gcd (k * ord m (a ^ k)) (l * ord m (a ^ k)) = ord m (a ^ k) * gcd k l"
    by (subst gcd_mult_distrib_nat) (auto simp: mult_ac)
  finally show "l dvd ord m (a ^ k) * gcd k l" .
qed

theorem ord_power: "coprime m a \<Longrightarrow> ord m (a ^ k :: nat) = ord m a div gcd k (ord m a)"
  using ord_power_aux[of m a k] by (metis div_mult_self_is_m gcd_pos_nat ord_eq_0)

lemma inj_power_mod:
  assumes "coprime n (a :: nat)"
  shows   "inj_on (\<lambda>k. a ^ k mod n) {..<ord n a}"
proof
  fix k l assume *: "k \<in> {..<ord n a}" "l \<in> {..<ord n a}" "a ^ k mod n = a ^ l mod n"
  have "k = l" if "k < l" "l < ord n a" "[a ^ k = a ^ l] (mod n)" for k l
  proof -
    have "l = k + (l - k)" using that by simp
    also have "a ^ \<dots> = a ^ k * a ^ (l - k)"
      by (simp add: power_add)
    also have "[\<dots> = a ^ l * a ^ (l - k)] (mod n)"
      using that by (intro cong_mult) auto
    finally have "[a ^ l * a ^ (l - k) = a ^ l * 1] (mod n)"
      by (simp add: cong_sym_eq)
    with assms have "[a ^ (l - k) = 1] (mod n)"
      by (subst (asm) cong_mult_lcancel_nat) (auto simp: coprime_commute)
    hence "ord n a dvd l - k"
      by (simp add: ord_divides')
    from dvd_imp_le[OF this] and \<open>l < ord n a\<close> have "l - k = 0"
      by (cases "l - k = 0") auto
    with \<open>k < l\<close> show "k = l" by simp
  qed
  from this[of k l] and this[of l k] and * show "k = l"
    by (cases k l rule: linorder_cases) (auto simp: cong_def)
qed

lemma ord_eq_2_iff: "ord n (x :: nat) = 2 \<longleftrightarrow> [x \<noteq> 1] (mod n) \<and> [x\<^sup>2 = 1] (mod n)"
proof
  assume x: "[x \<noteq> 1] (mod n) \<and> [x\<^sup>2 = 1] (mod n)"
  hence "coprime n x"
    by (metis coprime_commute lucas_coprime_lemma zero_neq_numeral)
  with x have "ord n x dvd 2" "ord n x \<noteq> 1" "ord n x > 0"
    by (auto simp: ord_divides' ord_eq_Suc_0_iff)
  thus "ord n x = 2" by (auto dest!: dvd_imp_le simp del: ord_gt_0_iff)
qed (use ord_divides[of _ 2] ord_divides[of _ 1] in auto)

lemma square_mod_8_eq_1_iff: "[x\<^sup>2 = 1] (mod 8) \<longleftrightarrow> odd (x :: nat)"
proof -
  have "[x\<^sup>2 = 1] (mod 8) \<longleftrightarrow> ((x mod 8)\<^sup>2 mod 8 = 1)"
    by (simp add: power_mod cong_def)
  also have "\<dots> \<longleftrightarrow> x mod 8 \<in> {1, 3, 5, 7}"
  proof
    assume x: "(x mod 8)\<^sup>2 mod 8 = 1"
    have "x mod 8 \<in> {..<8}" by simp
    also have "{..<8} = {0, 1, 2, 3, 4, 5, 6, 7::nat}"
      by (simp add: lessThan_nat_numeral lessThan_Suc insert_commute)
    finally have x_cases: "x mod 8 \<in> {0, 1, 2, 3, 4, 5, 6, 7}" .
    from x have "x mod 8 \<notin> {0, 2, 4, 6}"
      using x by (auto intro: Nat.gr0I)
    with x_cases show "x mod 8 \<in> {1, 3, 5, 7}" by simp
  qed auto
  also have "\<dots> \<longleftrightarrow> odd (x mod 8)"
    by (auto elim!: oddE)
  also have "\<dots> \<longleftrightarrow> odd x"
    by presburger
  finally show ?thesis .
qed

lemma ord_twopow_aux:
  assumes "k \<ge> 3" and "odd (x :: nat)"
  shows   "[x ^ (2 ^ (k - 2)) = 1] (mod (2 ^ k))"
  using assms(1)
proof (induction k rule: dec_induct)
  case base
  from assms have "[x\<^sup>2 = 1] (mod 8)"
    by (subst square_mod_8_eq_1_iff) auto
  thus ?case by simp
next
  case (step k)
  define k' where "k' = k - 2"
  have k: "k = Suc (Suc k')"
    using \<open>k \<ge> 3\<close> by (simp add: k'_def)
  from \<open>k \<ge> 3\<close> have "2 * k \<ge> Suc k" by presburger

  from \<open>odd x\<close> have "x > 0" by (intro Nat.gr0I) auto
  from step.IH have "2 ^ k dvd (x ^ (2 ^ (k - 2)) - 1)"
    by (rule cong_to_1_nat)
  then obtain t where "x ^ (2 ^ (k - 2)) - 1 = t * 2 ^ k"
    by auto
  hence "x ^ (2 ^ (k - 2)) = t * 2 ^ k + 1"
    by (metis \<open>0 < x\<close> add.commute add_diff_inverse_nat less_one neq0_conv power_eq_0_iff)
  hence "(x ^ (2 ^ (k - 2))) ^ 2 = (t * 2 ^ k + 1) ^ 2"
    by (rule arg_cong)
  hence "[(x ^ (2 ^ (k - 2))) ^ 2 = (t * 2 ^ k + 1) ^ 2] (mod (2 ^ Suc k))"
    by simp
  also have "(x ^ (2 ^ (k - 2))) ^ 2 = x ^ (2 ^ (k - 1))"
    by (simp_all add: power_even_eq[symmetric] power_mult k )
  also have "(t * 2 ^ k + 1) ^ 2 = t\<^sup>2 * 2 ^ (2 * k) + t * 2 ^ Suc k + 1"
    by (subst power2_eq_square)
       (auto simp: algebra_simps k power2_eq_square[of t]
                   power_even_eq[symmetric] power_add [symmetric])
  also have "[\<dots> = 0 + 0 + 1] (mod 2 ^ Suc k)"
    using \<open>2 * k \<ge> Suc k\<close>
    by (intro cong_add)
       (auto simp: cong_0_iff intro: dvd_mult[OF le_imp_power_dvd] simp del: power_Suc)
  finally show ?case by simp
qed

lemma ord_twopow_3_5:
  assumes "k \<ge> 3" "x mod 8 \<in> {3, 5 :: nat}"
  shows   "ord (2 ^ k) x = 2 ^ (k - 2)"
  using assms(1)
proof (induction k rule: less_induct)
  have "x mod 8 = 3 \<or> x mod 8 = 5" using assms by auto
  hence "odd x" by presburger
  case (less k)
  from \<open>k \<ge> 3\<close> consider "k = 3" | "k = 4" | "k \<ge> 5" by force
  thus ?case
  proof cases
    case 1
    thus ?thesis using assms
      by (auto simp: ord_eq_2_iff cong_def simp flip: power_mod[of x])
  next
    case 2
    from assms have "x mod 8 = 3 \<or> x mod 8 = 5" by auto
    then have x': "x mod 16 = 3 \<or> x mod 16 = 5 \<or> x mod 16 = 11 \<or> x mod 16 = 13"
      using mod_double_modulus [of 8 x] by auto
    hence "[x ^ 4 = 1] (mod 16)" using assms
      by (auto simp: cong_def simp flip: power_mod[of x])
    hence "ord 16 x dvd 2\<^sup>2" by (simp add: ord_divides')
    then obtain l where l: "ord 16 x = 2 ^ l" "l \<le> 2"
      by (subst (asm) divides_primepow_nat) auto

    have "[x ^ 2 \<noteq> 1] (mod 16)"
      using x' by (auto simp: cong_def simp flip: power_mod[of x])
    hence "\<not>ord 16 x dvd 2" by (simp add: ord_divides')
    with l have "l = 2"
      using le_imp_power_dvd[of l 1 2] by (cases "l \<le> 1") auto
    with l show ?thesis by (simp add: \<open>k = 4\<close>)
  next
    case 3
    define k' where "k' = k - 2"
    have k': "k' \<ge> 2" and [simp]: "k = Suc (Suc k')"
      using 3 by (simp_all add: k'_def)
    have IH: "ord (2 ^ k') x = 2 ^ (k' - 2)" "ord (2 ^ Suc k') x = 2 ^ (k' - 1)"
      using less.IH[of k'] less.IH[of "Suc k'"] 3 by simp_all
    from IH have cong: "[x ^ (2 ^ (k' - 2)) = 1] (mod (2 ^ k'))"
      by (simp_all add: ord_divides')
    have notcong: "[x ^ (2 ^ (k' - 2)) \<noteq> 1] (mod (2 ^ Suc k'))"
    proof
      assume "[x ^ (2 ^ (k' - 2)) = 1] (mod (2 ^ Suc k'))"
      hence "ord (2 ^ Suc k') x dvd 2 ^ (k' - 2)"
        by (simp add: ord_divides')
      also have "ord (2 ^ Suc k') x = 2 ^ (k' - 1)"
        using IH by simp
      finally have "k' - 1 \<le> k' - 2"
        by (rule power_dvd_imp_le) auto
      with \<open>k' \<ge> 2\<close> show False by simp
    qed

    have "2 ^ k' + 1 < 2 ^ k' + (2 ^ k' :: nat)"
      using one_less_power[of "2::nat" k'] k' by (intro add_strict_left_mono) auto
    with cong notcong have cong': "x ^ (2 ^ (k' - 2)) mod 2 ^ Suc k' = 1 + 2 ^ k'"
      using mod_double_modulus [of "2 ^ k'" "x ^ 2 ^ (k' - 2)"] k' by (auto simp: cong_def)

    hence "x ^ (2 ^ (k' - 2)) mod 2 ^ k = 1 + 2 ^ k' \<or>
           x ^ (2 ^ (k' - 2)) mod 2 ^ k = 1 + 2 ^ k' + 2 ^ Suc k'"
      using mod_double_modulus [of "2 ^ Suc k'" "x ^ 2 ^ (k' - 2)"] by auto
    hence eq: "[x ^ 2 ^ (k' - 1) = 1 + 2 ^ (k - 1)] (mod 2 ^ k)"
    proof
      assume *: "x ^ (2 ^ (k' - 2)) mod (2 ^ k) = 1 + 2 ^ k'"
      have "[x ^ (2 ^ (k' - 2)) = x ^ (2 ^ (k' - 2)) mod 2 ^ k] (mod 2 ^ k)"
        by simp
      also have "[x ^ (2 ^ (k' - 2)) mod (2 ^ k) = 1 + 2 ^ k'] (mod 2 ^ k)"
        by (subst *) auto
      finally have "[(x ^ 2 ^ (k' - 2)) ^ 2 = (1 + 2 ^ k') ^ 2] (mod 2 ^ k)"
        by (rule cong_pow)
      hence "[x ^ 2 ^ Suc (k' - 2) = (1 + 2 ^ k') ^ 2] (mod 2 ^ k)"
        by (simp add: power_mult [symmetric] power_Suc2 [symmetric] del: power_Suc)
      also have "Suc (k' - 2) = k' - 1"
        using k' by simp
      also have "(1 + 2 ^ k' :: nat)\<^sup>2 = 1 + 2 ^ (k - 1) + 2 ^ (2 * k')"
        by (subst power2_eq_square) (simp add: algebra_simps flip: power_add)
      also have "(2 ^ k :: nat) dvd 2 ^ (2 * k')"
        using k' by (intro le_imp_power_dvd) auto
      hence "[1 + 2 ^ (k - 1) + 2 ^ (2 * k') = 1 + 2 ^ (k - 1) + (0 :: nat)] (mod 2 ^ k)"
        by (intro cong_add) (auto simp: cong_0_iff)
      finally show "[x ^ 2 ^ (k' - 1) = 1 + 2 ^ (k - 1)] (mod 2 ^ k)"
        by simp
    next
      assume *: "x ^ (2 ^ (k' - 2)) mod 2 ^ k = 1 + 2 ^ k' + 2 ^ Suc k'"
      have "[x ^ (2 ^ (k' - 2)) = x ^ (2 ^ (k' - 2)) mod 2 ^ k] (mod 2 ^ k)"
        by simp
      also have "[x ^ (2 ^ (k' - 2)) mod (2 ^ k) = 1 + 3 * 2 ^ k'] (mod 2 ^ k)"
        by (subst *) auto
      finally have "[(x ^ 2 ^ (k' - 2)) ^ 2 = (1 + 3 * 2 ^ k') ^ 2] (mod 2 ^ k)"
        by (rule cong_pow)
      hence "[x ^ 2 ^ Suc (k' - 2) = (1 + 3 * 2 ^ k') ^ 2] (mod 2 ^ k)"
        by (simp add: power_mult [symmetric] power_Suc2 [symmetric] del: power_Suc)
      also have "Suc (k' - 2) = k' - 1"
        using k' by simp
      also have "(1 + 3 * 2 ^ k' :: nat)\<^sup>2 = 1 + 2 ^ (k - 1) + 2 ^ k + 9 * 2 ^ (2 * k')"
        by (subst power2_eq_square) (simp add: algebra_simps flip: power_add)
      also have "(2 ^ k :: nat) dvd 9 * 2 ^ (2 * k')"
        using k' by (intro dvd_mult le_imp_power_dvd) auto
      hence "[1 + 2 ^ (k - 1) + 2 ^ k + 9 * 2 ^ (2 * k') = 1 + 2 ^ (k - 1) + 0 + (0 :: nat)]
               (mod 2 ^ k)"
        by (intro cong_add) (auto simp: cong_0_iff)
      finally show "[x ^ 2 ^ (k' - 1) = 1 + 2 ^ (k - 1)] (mod 2 ^ k)"
        by simp
    qed

    have notcong': "[x ^ 2 ^ (k - 3) \<noteq> 1] (mod 2 ^ k)"
    proof
      assume "[x ^ 2 ^ (k - 3) = 1] (mod 2 ^ k)"
      hence "[x ^ 2 ^ (k' - 1) - x ^ 2 ^ (k' - 1) = 1 + 2 ^ (k - 1) - 1] (mod 2 ^ k)"
        by (intro cong_diff_nat eq) auto
      hence "[2 ^ (k - 1) = (0 :: nat)] (mod 2 ^ k)"
        by (simp add: cong_sym_eq)
      hence "2 ^ k dvd 2 ^ (k - 1)"
        by (simp add: cong_0_iff)
      hence "k \<le> k - 1"
        by (rule power_dvd_imp_le) auto
      thus False by simp
    qed

    have "[x ^ 2 ^ (k - 2) = 1] (mod 2 ^ k)"
      using ord_twopow_aux[of k x] \<open>odd x\<close> \<open>k \<ge> 3\<close> by simp
    hence "ord (2 ^ k) x dvd 2 ^ (k - 2)"
      by (simp add: ord_divides')
    then obtain l where l: "l \<le> k - 2" "ord (2 ^ k) x = 2 ^ l"
      using divides_primepow_nat[of 2 "ord (2 ^ k) x" "k - 2"] by auto

    from notcong' have "\<not>ord (2 ^ k) x dvd 2 ^ (k - 3)"
      by (simp add: ord_divides')
    with l have "l = k - 2"
      using le_imp_power_dvd[of l "k - 3" 2] by (cases "l \<le> k - 3") auto
    with l show ?thesis by simp
  qed
qed

lemma ord_4_3 [simp]: "ord 4 (3::nat) = 2"
proof -
  have "[3 ^ 2 = (1 :: nat)] (mod 4)"
    by (simp add: cong_def)
  hence "ord 4 (3::nat) dvd 2"
    by (subst (asm) ord_divides) auto
  hence "ord 4 (3::nat) \<le> 2"
    by (intro dvd_imp_le) auto
  moreover have "ord 4 (3::nat) \<noteq> 1"
    by (auto simp: ord_eq_Suc_0_iff cong_def)
  moreover have "ord 4 (3::nat) \<noteq> 0"
    by (auto simp: gcd_non_0_nat coprime_iff_gcd_eq_1)
  ultimately show "ord 4 (3 :: nat) = 2"
    by linarith
qed

lemma elements_with_ord_1: "n > 0 \<Longrightarrow> {x\<in>totatives n. ord n x = Suc 0} = {1}"
  by (auto simp: ord_eq_Suc_0_iff cong_def totatives_less)

lemma residue_prime_has_primroot:
  fixes p :: nat
  assumes "prime p"
  shows "\<exists>a\<in>totatives p. ord p a = p - 1"
proof -
  from residue_prime_mult_group_has_gen[OF assms]
    obtain a where a: "a \<in> {1..p-1}" "{1..p-1} = {a ^ i mod p |i. i \<in> UNIV}" by blast
  from a have "coprime p a"
    using a assms by (intro prime_imp_coprime) (auto dest: dvd_imp_le)
  with a(1) have "a \<in> totatives p" by (auto simp: totatives_def coprime_commute)

  have "p - 1 = card {1..p-1}" by simp
  also have "{1..p-1} = {a ^ i mod p |i. i \<in> UNIV}" by fact
  also have "{a ^ i mod p |i. i \<in> UNIV} = (\<lambda>i. a ^ i mod p) ` {..<ord p a}"
  proof (intro equalityI subsetI)
    fix x assume "x \<in> {a ^ i mod p |i. i \<in> UNIV}"
    then obtain i where [simp]: "x = a ^ i mod p" by auto

    have "[a ^ i = a ^ (i mod ord p a)] (mod p)"
      using \<open>coprime p a\<close> by (subst order_divides_expdiff) auto
    hence "\<exists>j. a ^ i mod p = a ^ j mod p \<and> j < ord p a"
      using \<open>coprime p a\<close> by (intro exI[of _ "i mod ord p a"]) (auto simp: cong_def)
    thus "x \<in> (\<lambda>i. a ^ i mod p) ` {..<ord p a}"
      by auto
  qed auto
  also have "card \<dots> = ord p a"
    using inj_power_mod[OF \<open>coprime p a\<close>] by (subst card_image) auto
  finally show ?thesis using \<open>a \<in> totatives p\<close>
    by auto
qed

subsection \<open>Another trivial primality characterization\<close>

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")
  for n :: nat
proof (cases "n = 0 \<or> n = 1")
  case True
  then show ?thesis
     by (metis bigger_prime dvd_0_right not_prime_1 not_prime_0)
next
  case False
  show ?thesis
  proof
    assume "prime n"
    then show ?rhs
      by (metis not_prime_1 prime_nat_iff)
  next
    assume ?rhs
    with False show "prime n"
      by (auto simp: prime_nat_iff) (metis One_nat_def prime_factor_nat prime_nat_iff)
  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)"
  for n :: nat
proof -
  consider "n = 0" | "n = 1" | "n \<noteq> 0" "n \<noteq> 1" by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by simp
  next
    case 2
    then show ?thesis by simp
  next
    case n: 3
    then have 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
      then have "d = 1"
      proof
        assume dn: "d = n"
        from n have "n\<^sup>2 > n * 1"
          by (simp add: power2_eq_square)
        with dn d(2) show ?thesis by simp
      qed
    }
    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)
      then have 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
      from dp ep have "d\<^sup>2 \<le> n \<or> e\<^sup>2 \<le> n"
        by (auto simp add: e power2_eq_square mult_le_cancel_left)
      then have "d = 1 \<or> d = n"
      proof
        assume "d\<^sup>2 \<le> n"
        with H[rule_format, of d] d have "d = 1" by blast
        then show ?thesis ..
      next
        assume h: "e\<^sup>2 \<le> n"
        from e have "e dvd n" by (simp add: dvd_def mult.commute)
        with H[rule_format, of e] h have "e = 1" by simp
        with e have "d = n" by simp
        then show ?thesis ..
      qed
    }
    ultimately show ?thesis
      unfolding prime_nat_iff using np n(2) by blast
  qed
qed

lemma prime_prime_factor_sqrt:
  "prime (n::nat) \<longleftrightarrow> n \<noteq> 0 \<and> n \<noteq> 1 \<and> (\<nexists>p. prime p \<and> p dvd n \<and> p\<^sup>2 \<le> n)"
  (is "?lhs \<longleftrightarrow>?rhs")
proof -
  consider "n = 0" | "n = 1" | "n \<noteq> 0" "n \<noteq> 1"
    by blast
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by (metis not_prime_0)
  next
    case 2
    then show ?thesis by (metis not_prime_1)
  next
    case n: 3
    show ?thesis
    proof
      assume ?lhs
      from this[unfolded prime_divisor_sqrt] n show ?rhs
        by (metis prime_prime_factor)
    next
      assume ?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 \<open>?rhs\<close> n p(1) dvd_trans[OF p(2) d(1)] have False
          by blast
      }
      with n prime_divisor_sqrt show ?lhs by auto
    qed
  qed
qed

subsection \<open>Pocklington theorem\<close>

lemma pocklington_lemma:
  fixes p :: nat
  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 by (auto intro: prime_gt_0_nat)
  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
  have a0: "a \<noteq> 0"
  proof
    assume "a = 0"
    with n have "a^ (n - 1) = 0"
      by (simp add: power_0_left)
    with n an mod_less[of 1 n] show False
      by (simp add: power_0_left cong_def)
  qed
  with n nqr have aqr0: "a ^ (q * r) \<noteq> 0"
    by simp
  then have "(a ^ (q * r) - 1) + 1  = a ^ (q * r)"
    by simp
  with k l have "a ^ (q * r) = p * l * k + 1"
    by simp
  then have "a ^ (r * q) + p * 0 = 1 + p * (l * k)"
    by (simp add: ac_simps)
  then have 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
  have d1: "d = 1"
  proof (rule ccontr)
    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
    from P(1) have P0: "P \<noteq> 0"
      by (metis not_prime_0)
    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)
    then have exps: "a^(ord p (a^r) * t*r) = ((a ^ r) ^ ord p (a^r)) ^ t"
      by (simp only: power_mult)
    then have "[((a ^ r) ^ ord p (a^r)) ^ t= 1] (mod p)"
      by (metis cong_pow ord power_one)
    then have pd0: "p dvd a^(ord p (a^r) * t*r) - 1"
      by (metis cong_to_1_nat exps)
    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 [of _ n p] show False
      by auto
  qed
  with d have o: "ord p (a^r) = q" by simp
  from pp totient_prime [of p] have totient_eq: "totient p = p - 1"
    by simp
  {
    fix d
    assume d: "d dvd p" "d dvd a" "d \<noteq> 1"
    from pp[unfolded prime_nat_iff] d have dp: "d = p" by blast
    from n have "n \<noteq> 0" by simp
    then have False using d dp pn an
      by auto (metis One_nat_def Suc_lessI
        \<open>1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> m = 1 \<or> m = p)\<close> \<open>a ^ (q * r) = p * l * k + 1\<close> add_diff_cancel_left' dvd_diff_nat dvd_power dvd_triv_left gcd_nat.trans nat_dvd_not_less nqr zero_less_diff zero_less_one)
  }
  then have cpa: "coprime p a"
    by (auto intro: coprimeI)
  then have arp: "coprime (a ^ r) p"
    by (cases "r > 0") (simp_all add: ac_simps)
  from euler_theorem [OF arp, simplified ord_divides] o totient_eq have "q dvd (p - 1)"
    by simp
  then obtain d where d:"p - 1 = q * d"
    unfolding dvd_def by blast
  have "p \<noteq> 0"
    by (metis p01(1))
  with 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> (\<nexists>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)
    then have pq: "p \<le> q"
      by (metis le0 power_le_imp_le_base)
    from pocklington_lemma[OF n nqr an aq p(1,2)] have *: "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 * have False
      by (simp add: nat_dvd_not_less)
  }
  with n01 show ?ths by blast
qed

text \<open>Variant for application, to separate the exponentiation.\<close>
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
    have a0: "a \<noteq> 0"
    proof
      assume a0: "a = 0"
      from n an have "[0 = 1] (mod n)"
        unfolding a0 power_0_left by auto
      then show False
        using n by (simp add: cong_def dvd_eq_mod_eq_0[symmetric])
    qed
    then have a1: "a \<ge> 1" by arith
    from one_le_power[OF a1] have ath: "1 \<le> a ^ ((n - 1) div p)" .
    have b0: "b \<noteq> 0"
    proof
      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 div_mult_mod_eq[of "n - 1" p]
      have "(n - 1) div p * p= n - 1" by auto
      then have 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 auto
      from divides_rexp[OF d, of "p - 1"] pS eq cong_dvd_iff [OF an] n show False
        by simp
    qed
    then have b1: "b \<ge> 1" by arith
    from cong_imp_coprime[OF Cong.cong_diff_nat[OF cong_sym [OF b(1)] cong_refl [of 1] b1]]
      ath b1 b nqr
    have "coprime (a ^ ((n - 1) div p) - 1) n"
      by simp
  }
  then have "\<forall>p. prime p \<and> p dvd q \<longrightarrow> coprime (a ^ ((n - 1) div p) - 1) n "
    by blast
  then show ?thesis by (rule pocklington[OF n nqr sqr an])
qed

subsection \<open>Prime factorizations\<close>

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

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

lemma primefact:
  fixes n :: nat
  assumes n: "n \<noteq> 0"
  shows "\<exists>ps. primefact ps n"
proof -
  obtain xs where xs: "mset xs = prime_factorization n"
    using ex_mset [of "prime_factorization n"] by blast
  from assms have "n = prod_mset (prime_factorization n)"
    by (simp add: prod_mset_prime_factorization)
  also have "\<dots> = prod_mset (mset xs)" by (simp add: xs)
  also have "\<dots> = foldr (*) xs 1" by (induct xs) simp_all
  finally have "foldr (*) xs 1 = n" ..
  moreover from xs have "\<forall>p\<in>#mset xs. prime p" by auto
  ultimately have "primefact xs n" by (auto simp: primefact_def)
  then show ?thesis ..
qed

lemma primefact_contains:
  fixes p :: nat
  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
  then show ?case by (auto simp: primefact_def)
next
  case (Cons q qs)
  from Cons.prems[unfolded primefact_def]
  have q: "prime q" "q * foldr (*) qs 1 = n" "\<forall>p \<in>set qs. prime p"
    and p: "prime p" "p dvd q * foldr (*) qs 1"
    by simp_all
  consider "p dvd q" | "p dvd foldr (*) qs 1"
    by (metis p prime_dvd_mult_eq_nat)
  then show ?case
  proof cases
    case 1
    with p(1) q(1) have "p = q"
      unfolding prime_nat_iff by auto
    then show ?thesis by simp
  next
    case prem: 2
    from q(3) have pqs: "primefact qs (foldr (*) qs 1)"
      by (simp add: primefact_def)
    from Cons.hyps[OF pqs p(1) prem] show ?thesis by simp
  qed
qed

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

text \<open>Variant of Lucas theorem.\<close>
lemma lucas_primefact:
  assumes n: "n \<ge> 2" and an: "[a^(n - 1) = 1] (mod n)"
    and psn: "foldr (*) 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

text \<open>Variant of Pocklington theorem.\<close>
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 (*) 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 div_mult_mod_eq[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_def mod_mod_trivial)
  have "coprime (a ^ ((n - 1) div p) - 1) n" if p: "prime p" "p dvd q" for p
  proof -
    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_nat_iff 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: "a \<le> b \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> 1 \<le> a \<and> 1 \<le> b" for a b :: nat
      by arith
    {
      assume "a ^ ((n - 1) div p) mod n = 0"
      then obtain s where s: "a ^ ((n - 1) div p) = n * s"
        by blast
      then have eq0: "(a^((n - 1) div p))^p = (n*s)^p" by simp
      from qrn[symmetric] have qn1: "q dvd n - 1"
        by (auto simp: dvd_def)
      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])
      with bqn p01 have "1 = (n * s)^(Suc (p - 1)) mod n"
        by simp
      also have "\<dots> = 0" by (simp add: mult.assoc)
      finally have False by simp
    }
    then have *: "a ^ ((n - 1) div p) mod n \<noteq> 0" by auto
    have "[a ^ ((n - 1) div p) mod n = a ^ ((n - 1) div p)] (mod n)"
      by (simp add: cong_def)
    with ath[OF mod_less_eq_dividend *]
    have "[a ^ ((n - 1) div p) mod n - 1 = a ^ ((n - 1) div p) - 1] (mod n)"
      by (simp add: cong_diff_nat)
    then show ?thesis
      by (metis cong_imp_coprime eq1 p')
  qed
  with pocklington[OF n qrn[symmetric] nq2 an1] show ?thesis
    by blast
qed

end


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

section \<open>Zorn's Lemma\<close>

theory Zorn_Lemma
imports MainRLT
begin

text \<open>
  Zorn's Lemmas states: if every linear ordered subset of an ordered set \<open>S\<close>
  has an upper bound in \<open>S\<close>, then there exists a maximal element in \<open>S\<close>. In
  our application, \<open>S\<close> is a set of sets ordered by set inclusion. Since the
  union of a chain of sets is an upper bound for all elements of the chain,
  the conditions of Zorn's lemma can be modified: if \<open>S\<close> is non-empty, it
  suffices to show that for every non-empty chain \<open>c\<close> in \<open>S\<close> the union of \<open>c\<close>
  also lies in \<open>S\<close>.
\<close>

theorem Zorn's_Lemma:
  assumes r: "\<And>c. c \<in> chains S \<Longrightarrow> \<exists>x. x \<in> c \<Longrightarrow> \<Union>c \<in> S"
    and aS: "a \<in> S"
  shows "\<exists>y \<in> S. \<forall>z \<in> S. y \<subseteq> z \<longrightarrow> z = y"
proof (rule Zorn_Lemma2)
  show "\<forall>c \<in> chains S. \<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
  proof
    fix c assume "c \<in> chains S"
    show "\<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
    proof cases
      txt \<open>If \<open>c\<close> is an empty chain, then every element in \<open>S\<close> is an upper
        bound of \<open>c\<close>.\<close>

      assume "c = {}"
      with aS show ?thesis by fast

      txt \<open>If \<open>c\<close> is non-empty, then \<open>\<Union>c\<close> is an upper bound of \<open>c\<close>, lying in
        \<open>S\<close>.\<close>
    next
      assume "c \<noteq> {}"
      show ?thesis
      proof
        show "\<forall>z \<in> c. z \<subseteq> \<Union>c" by fast
        show "\<Union>c \<in> S"
        proof (rule r)
          from \<open>c \<noteq> {}\<close> show "\<exists>x. x \<in> c" by fast
          show "c \<in> chains S" by fact
        qed
      qed
    qed
  qed
qed

end


header {* Euclidean Space: Explicit Representation *}
theory Euclidean_Space_Explicit
imports
  "~~/src/HOL/Multivariate_Analysis/Multivariate_Analysis"
begin

subsection {* Explicit Sum for Composition of Components *}

definition (in plus) plusE :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "+\<^sub>E" 65) where "plusE = plus"

definition (in comm_monoid_add) setsumE where "setsumE = setsum"

lemmas setsumE_insert = setsum.insert[simplified plusE_def[symmetric] setsumE_def[symmetric]]
lemma setsumE_singleton: "setsumE f {a} = f a" by (simp add: setsumE_def setsum.insert)

lemmas euclidean_representationE =
  euclidean_representation[simplified setsumE_def[symmetric], symmetric]

subsection {* Conversion for Explicit Representation *}

lemma scaleR_real_1: "scaleR x 1 = x" by simp

named_theorems euclidean_Basis
  "simplification rules for Basis of Euclidean Space"
named_theorems euclidean_Outer
  "simplification rules for rewriting of Euclidean Space as return value"
named_theorems euclidean_Inner
  "simplification rules for rewriting of Euclidean Space as argument"

declare simp_thms[euclidean_Basis, euclidean_Inner, euclidean_Outer]
lemmas [euclidean_Basis] =
  image_insert image_empty Un_insert_left Un_empty_left Un_insert_right Un_empty_right
  Basis_prod_def
  zero_prod_def
  Basis_real_def
  setsumE_insert setsumE_singleton
  setsum.insert setsum.empty
  finite_insert finite.emptyI
  Pair_eq
  empty_iff insert_iff
  refl
  one_neq_zero

lemmas [euclidean_Outer] =
  inner_prod_def
  inner_real_def

lemmas [euclidean_Inner] = plus_prod_def scaleR_prod_def fst_conv snd_conv
  add_0_left
  add_0_right
  scaleR_zero_left
  scaleR_zero_right
  scaleR_real_1
  add_0_left
  add_0_right
  mult_zero_right
  mult_1_right

ML {*

fun Basis_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Basis})
fun Outer_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Outer})
fun Inner_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Inner})

fun rewrite_outer_eucl ctxt =
  Conv.top_sweep_conv
    (fn ctxt => Conv.rewr_conv (@{thm euclidean_representationE[THEN eq_reflection]})
      then_conv Simplifier.rewrite (Basis_simps ctxt)
      then_conv Simplifier.rewrite (Outer_simps ctxt)
    ) ctxt;

fun rewrite_split_beta ctxt =
  Simplifier.rewrite (clear_simpset ctxt addsimps (@{thms split_beta' split_beta}));

fun represent_euclidean ct1 ct2 =
  if (term_of ct1 = term_of ct2)
  then Conv.rewr_conv @{thm euclidean_representation[symmetric, THEN eq_reflection]} ct2
  else Conv.no_conv ct2

fun rewrite_inner_eucl vs cv ctxt =
  Conv.abs_conv (fn (v, ctxt) => rewrite_inner_eucl (v::vs) cv ctxt else_conv cv (v::vs) ctxt) ctxt

fun component_conv conv ct =
  (case Thm.term_of ct of
    Const (@{const_name scaleR}, _) $ _ $ _ => Conv.arg1_conv conv ct
  | _ => raise CTERM ("scaleR_conv", [ct]));

fun euclidify ctxt = rewrite_outer_eucl ctxt
  then_conv rewrite_split_beta ctxt
  then_conv rewrite_inner_eucl []
    (fn vs => fn ctxt => Conv.every_conv (map (fn v => Conv.top_sweep_conv (fn _ => represent_euclidean v) ctxt) vs)) ctxt
  then_conv Conv.top_sweep_conv (fn ctxt => component_conv (
    Simplifier.rewrite (Basis_simps ctxt)
    then_conv Simplifier.rewrite (Inner_simps ctxt))) ctxt
  ;

*}

lemma "(\<lambda>(x1, x2) (y1, y2) (z1, z2, z3). (x1 + x2, x2 * x1 + 1, y1, y2 + z1 * z2 * z3)::real*real*real*real) =
  (\<lambda>x xa xb.
       (xa \<bullet> (0, 1) + xb \<bullet> (1, 0, 0) * (xb \<bullet> (0, 1, 0)) * (xb \<bullet> (0, 0, 1))) *\<^sub>R (0, 0, 0, 1) +\<^sub>E
       (xa \<bullet> (1, 0)) *\<^sub>R (0, 0, 1, 0) +\<^sub>E
       (x \<bullet> (0, 1) * (x \<bullet> (1, 0)) + 1) *\<^sub>R (0, 1, 0, 0) +\<^sub>E
       (x \<bullet> (1, 0) + x \<bullet> (0, 1)) *\<^sub>R (1, 0, 0, 0))"
  by (tactic {*
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
    THEN (rtac refl) 1
  *})

lemma "(\<lambda>(x1, x2) (y1, y2). (x1 + x2, x2 * x1 + 1, y1, y2)::real*real*real*real) =
    (\<lambda>x xa.
       (xa \<bullet> (0, 1)) *\<^sub>R (0, 0, 0, 1) +\<^sub>E
       (xa \<bullet> (1, 0)) *\<^sub>R (0, 0, 1, 0) +\<^sub>E
       (x \<bullet> (0, 1) * (x \<bullet> (1, 0)) + 1) *\<^sub>R (0, 1, 0, 0) +\<^sub>E
       (x \<bullet> (1, 0) + x \<bullet> (0, 1)) *\<^sub>R (1, 0, 0, 0))"
  by (tactic {*
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
    THEN (rtac refl) 1
  *})

lemma "(\<lambda>x y. x + y::real) = (\<lambda>x y. (x \<bullet> 1 + y \<bullet> 1) *\<^sub>R 1)"
  by (tactic {*
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
    THEN (rtac refl) 1
  *})

lemma "(\<lambda>x y. (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1)) *\<^sub>R (1, 0) + (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1)) *\<^sub>R (1, 0)) =
  (\<lambda>(x::real*real*real) (y::real*real*real). 0 *\<^sub>R (0, 1) +\<^sub>E
    (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1) + (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1))) *\<^sub>R (1, 0)::real*real)"
  by (tactic {*
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
    THEN (rtac refl) 1
  *})

end