(*
  File:     Algebraic_Integer_Divisibility.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Divisibility of algebraic integers\<close>
theory Algebraic_Integer_Divisibility
  imports "Algebraic_Numbers.Algebraic_Numbers"
begin

text \<open>
  In this section, we define a notion of divisibility of algebraic integers: \<open>y\<close> is divisible
  by \<open>x\<close> if \<open>y / x\<close> is an algebraic integer (or if \<open>x\<close> and \<open>y\<close> are both zero).

  Technically, the definition does not require \<open>x\<close> and \<open>y\<close> to be algebraic integers themselves,
  but we will always use it that way (in fact, in our case \<open>x\<close> will always be a rational integer).
\<close>

definition alg_dvd :: "'a :: field \<Rightarrow> 'a \<Rightarrow> bool" (infix "alg'_dvd" 50) where
  "x alg_dvd y \<longleftrightarrow> (x = 0 \<longrightarrow> y = 0) \<and> algebraic_int (y / x)"

lemma alg_dvd_imp_algebraic_int:
  fixes x y :: "'a :: field_char_0"
  shows "x alg_dvd y \<Longrightarrow> algebraic_int x \<Longrightarrow> algebraic_int y"
  using algebraic_int_times[of "y / x" x] by (auto simp: alg_dvd_def)

lemma alg_dvd_0_left_iff [simp]: "0 alg_dvd x \<longleftrightarrow> x = 0"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_0_right [iff]: "x alg_dvd 0"
  by (auto simp: alg_dvd_def)

lemma one_alg_dvd_iff [simp]: "1 alg_dvd x \<longleftrightarrow> algebraic_int x"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_of_int [intro]:
  assumes "x dvd y"
  shows   "of_int x alg_dvd of_int y"
proof (cases "of_int x = (0 :: 'a)")
  case False
  from assms obtain z where z: "y = x * z"
    by (elim dvdE)
  have "algebraic_int (of_int z)"
    by auto
  also have "of_int z = of_int y / (of_int x :: 'a)"
    using False by (simp add: z field_simps)
  finally show ?thesis
    using False by (simp add: alg_dvd_def)
qed (use assms in \<open>auto simp: alg_dvd_def\<close>)

lemma alg_dvd_of_nat [intro]:
  assumes "x dvd y"
  shows   "of_nat x alg_dvd of_nat y"
  using alg_dvd_of_int[of "int x" "int y"] assms by simp

lemma alg_dvd_of_int_iff [simp]:
  "(of_int x :: 'a :: field_char_0) alg_dvd of_int y \<longleftrightarrow> x dvd y"
proof
  assume "(of_int x :: 'a) alg_dvd of_int y"
  hence "of_int y / (of_int x :: 'a) \<in> \<int>" and nz: "of_int x = (0::'a) \<longrightarrow> of_int y = (0::'a)"
    by (auto simp: alg_dvd_def dest!: rational_algebraic_int_is_int)
  then obtain n where "of_int y / of_int x = (of_int n :: 'a)"
    by (elim Ints_cases)
  hence "of_int y = (of_int (x * n) :: 'a)"
    unfolding of_int_mult using nz by (auto simp: field_simps)
  hence "y = x * n"
    by (subst (asm) of_int_eq_iff)
  thus "x dvd y"
    by auto
qed blast

lemma alg_dvd_of_nat_iff [simp]:
  "(of_nat x :: 'a :: field_char_0) alg_dvd of_nat y \<longleftrightarrow> x dvd y"
proof -
  have "(of_int (int x) :: 'a) alg_dvd of_int (int y) \<longleftrightarrow> x dvd y"
    by (subst alg_dvd_of_int_iff) auto
  thus ?thesis unfolding of_int_of_nat_eq .
qed

lemma alg_dvd_add [intro]:
  fixes x y z :: "'a :: field_char_0"
  shows "x alg_dvd y \<Longrightarrow> x alg_dvd z \<Longrightarrow> x alg_dvd (y + z)"
  unfolding alg_dvd_def by (auto simp: add_divide_distrib)

lemma alg_dvd_uminus_right [intro]: "x alg_dvd y \<Longrightarrow> x alg_dvd -y"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_uminus_right_iff [simp]: "x alg_dvd -y \<longleftrightarrow> x alg_dvd y"
  using alg_dvd_uminus_right[of x y] alg_dvd_uminus_right[of x "-y"] by auto

lemma alg_dvd_diff [intro]:
  fixes x y z :: "'a :: field_char_0"
  shows "x alg_dvd y \<Longrightarrow> x alg_dvd z \<Longrightarrow> x alg_dvd (y - z)"
  unfolding alg_dvd_def by (auto simp: diff_divide_distrib)

lemma alg_dvd_triv_left [intro]: "algebraic_int y \<Longrightarrow> x alg_dvd x * y"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_triv_right [intro]: "algebraic_int x \<Longrightarrow> y alg_dvd x * y"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_triv_left_iff: "x alg_dvd x * y \<longleftrightarrow> x = 0 \<or> algebraic_int y"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_triv_right_iff: "y alg_dvd x * y \<longleftrightarrow> y = 0 \<or> algebraic_int x"
  by (auto simp: alg_dvd_def)

lemma alg_dvd_triv_left_iff' [simp]: "x \<noteq> 0 \<Longrightarrow> x alg_dvd x * y \<longleftrightarrow> algebraic_int y"
  by (simp add: alg_dvd_triv_left_iff)

lemma alg_dvd_triv_right_iff' [simp]: "y \<noteq> 0 \<Longrightarrow> y alg_dvd x * y \<longleftrightarrow> algebraic_int x"
  by (simp add: alg_dvd_triv_right_iff)

lemma alg_dvd_trans [trans]:
  fixes x y z :: "'a :: field_char_0"
  shows "x alg_dvd y \<Longrightarrow> y alg_dvd z \<Longrightarrow> x alg_dvd z"
  using algebraic_int_times[of "y / x" "z / y"] by (auto simp: alg_dvd_def)

lemma alg_dvd_mono [simp]:
  fixes a b c d :: "'a :: field_char_0"
  shows "a alg_dvd c \<Longrightarrow> b alg_dvd d \<Longrightarrow> (a * b) alg_dvd (c * d)"
  using algebraic_int_times[of "c / a" "d / b"] by (auto simp: alg_dvd_def)

lemma alg_dvd_mult [simp]:
  fixes a b c :: "'a :: field_char_0"
  shows "a alg_dvd c \<Longrightarrow> algebraic_int b \<Longrightarrow> a alg_dvd (b * c)"
  using alg_dvd_mono[of a c 1 b] by (auto simp: mult.commute)

lemma alg_dvd_mult2 [simp]:
  fixes a b c :: "'a :: field_char_0"
  shows "a alg_dvd b \<Longrightarrow> algebraic_int c \<Longrightarrow> a alg_dvd (b * c)"
  using alg_dvd_mult[of a b c] by (simp add: mult.commute)

text \<open>
  A crucial theorem: if an integer \<open>x\<close> divides a rational number \<open>y\<close>, then \<open>y\<close> is in fact
  also an integer, and that integer is a multiple of \<open>x\<close>.
\<close>
lemma alg_dvd_int_rat:
  fixes y :: "'a :: field_char_0"
  assumes "of_int x alg_dvd y" and "y \<in> \<rat>"
  shows   "\<exists>n. y = of_int n \<and> x dvd n"
proof (cases "x = 0")
  case False
  have "y / of_int x \<in> \<int>"
    by (intro rational_algebraic_int_is_int) (use assms in \<open>auto simp: alg_dvd_def\<close>)
  then obtain n where n: "of_int n = y / (of_int x :: 'a)"
    by (elim Ints_cases) auto
  hence "y = of_int (n * x)"
    using False by (simp add: field_simps)
  thus ?thesis by (intro exI[of _ "x * n"]) auto
qed (use assms in auto)

lemma prod_alg_dvd_prod:
  fixes f :: "'a \<Rightarrow> 'b :: field_char_0"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x alg_dvd g x"
  shows   "prod f A alg_dvd prod g A"
  using assms by (induction A rule: infinite_finite_induct) auto

lemma alg_dvd_sum:
  fixes f :: "'a \<Rightarrow> 'b :: field_char_0"
  assumes "\<And>x. x \<in> A \<Longrightarrow> y alg_dvd f x"
  shows   "y alg_dvd sum f A"
  using assms by (induction A rule: infinite_finite_induct) auto

lemma not_alg_dvd_sum:
  fixes f :: "'a \<Rightarrow> 'b :: field_char_0"
  assumes "\<And>x. x \<in> A-{x'} \<Longrightarrow> y alg_dvd f x"
  assumes "\<not>y alg_dvd f x'"
  assumes "x' \<in> A" "finite A"
  shows   "\<not>y alg_dvd sum f A"
proof
  assume *: "y alg_dvd sum f A"
  have "y alg_dvd sum f A - sum f (A - {x'})"
    using \<open>x' \<in> A\<close> by (intro alg_dvd_diff[OF * alg_dvd_sum] assms) auto
  also have "\<dots> = sum f (A - (A - {x'}))"
    using assms by (subst sum_diff) auto
  also have "A - (A - {x'}) = {x'}"
    using assms by auto
  finally show False using assms by simp
qed

lemma fact_dvd_pochhammer:
  assumes "m \<le> n + 1"
  shows   "fact m dvd pochhammer (int n - int m + 1) m"
proof -
  have "(real n gchoose m) * fact m = of_int (pochhammer (int n - int m + 1) m)"
    by (simp add: gbinomial_pochhammer' pochhammer_of_int [symmetric])
  also have "(real n gchoose m) * fact m = of_int (int (n choose m) * fact m)"
    by (simp add: binomial_gbinomial)
  finally have "int (n choose m) * fact m = pochhammer (int n - int m + 1) m"
    by (subst (asm) of_int_eq_iff)
  from this [symmetric] show ?thesis by simp
qed

lemma coeff_higher_pderiv:
  "coeff ((pderiv ^^ m) f) n = pochhammer (of_nat (Suc n)) m * coeff f (n + m)"
  by (induction m arbitrary: n) (simp_all add: coeff_pderiv pochhammer_rec algebra_simps)

lemma fact_alg_dvd_poly_higher_pderiv:
  fixes p :: "'a :: field_char_0 poly"
  assumes "\<And>i. algebraic_int (poly.coeff p i)" "algebraic_int x" "m \<le> k"
  shows   "fact m alg_dvd poly ((pderiv ^^ k) p) x"
  unfolding poly_altdef
proof (intro alg_dvd_sum, goal_cases)
  case (1 i)
  have "(of_int (fact m) :: 'a) alg_dvd (of_int (fact k))"
    by (intro alg_dvd_of_int fact_dvd assms)
  also have "(of_int (fact k) :: 'a) alg_dvd of_int (pochhammer (int i + 1) k)"
    using fact_dvd_pochhammer[of k "i + k"]
    by (intro alg_dvd_of_int fact_dvd_pochhammer) (auto simp: algebra_simps)
  finally have "fact m alg_dvd (pochhammer (of_nat i + 1) k :: 'a)"
    by (simp flip: pochhammer_of_int)
  also have "\<dots> alg_dvd pochhammer (of_nat i + 1) k * poly.coeff p (i + k)"
    by (rule alg_dvd_triv_left) (rule assms)
  also have "\<dots> = poly.coeff ((pderiv ^^ k) p) i"
    unfolding coeff_higher_pderiv by (simp add: add_ac flip: pochhammer_of_int)
  also have "\<dots> alg_dvd poly.coeff ((pderiv ^^ k) p) i * x ^ i"
    by (intro alg_dvd_triv_left algebraic_int_power assms)
  finally show ?case .
qed

end


(* Section 2.5 *)
theory BDatatypes
imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node t\<^sub>1 x t\<^sub>2) = Node (mirror t\<^sub>2) x (mirror t\<^sub>1)"

lemma mirror_mirror: "mirror (mirror t) = t"
apply (induct_tac t)
apply auto
done

primrec flatten :: "'a tree \<Rightarrow> 'a list" where
"flatten Tip = []" |
"flatten (Node t\<^sub>1 x t\<^sub>2) = flatten t\<^sub>1 @ [x] @ flatten t\<^sub>2"

lemma "flatten (mirror t) = rev (flatten t)"
apply (induct_tac t)
apply auto
done

lemma "(case xs of [] \<Rightarrow> [] | y # ys \<Rightarrow> xs) = xs"
apply (case_tac xs)
apply auto
done

datatype boolex = Const bool | Var nat | Neg boolex | And boolex boolex

primrec "value" :: "boolex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"value (Const b) env = b" |
"value (Var n)   env = env n" |
"value (Neg b)   env = (\<not> value b env)" |
"value (And b c) env = (value b env \<and> value c env)"

datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex

primrec valif :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"valif (CIF b)    env = b" |
"valif (VIF n)    env = env n" |
"valif (IF c t f) env = (if valif c env then valif t env else valif f env)"

primrec bool2if :: "boolex \<Rightarrow> ifex" where
"bool2if (Const b) = CIF b" |
"bool2if (Var n)   = VIF n" |
"bool2if (Neg b)   = IF (bool2if b) (CIF False) (CIF True)" |
"bool2if (And b c) = IF (bool2if b) (bool2if c) (CIF False)"

lemma "valif (bool2if b) env = value b env"
apply (induct_tac b)
apply auto
done

primrec normif :: "ifex \<Rightarrow> ifex \<Rightarrow> ifex \<Rightarrow> ifex" where
"normif (CIF b) t f      = IF (CIF b) t f" |
"normif (VIF n) t f      = IF (VIF n) t f" |
"normif (IF c c\<^sub>1 c\<^sub>2) t f = normif c (normif c\<^sub>1 t f) (normif c\<^sub>2 t f)"

primrec norm :: "ifex \<Rightarrow> ifex" where
"norm (CIF b) = CIF b" |
"norm (VIF n) = VIF n" |
"norm (IF c t f) = normif c (norm t) (norm f)"

theorem "valif (norm b) env = valif b env"
apply (induct_tac b)
apply auto
done

primrec normal :: "ifex \<Rightarrow> bool" where
"normal (CIF b)    = True" |
"normal (VIF n)    = True" |
"normal (IF c t f) = ((case c of CIF b \<Rightarrow> True | VIF n \<Rightarrow> True | IF x y z \<Rightarrow> False)
                   \<and> normal t
                   \<and> normal f)"

lemma [simp]: "\<forall>t f. normal (normif c t f) = (normal t \<and> normal f)"
apply (induct_tac c)
apply auto
done

theorem "normal (norm b)"
apply (induct_tac b)
apply auto
done

(* Strengthened s.t. the first argument to IF must be a variable *)
primrec normif' :: "ifex \<Rightarrow> ifex \<Rightarrow> ifex \<Rightarrow> ifex" where
"normif' (CIF b) t f      = (if b then t else f)" |
"normif' (VIF n) t f      = IF (VIF n) t f" |
"normif' (IF c c\<^sub>1 c\<^sub>2) t f = normif' c (normif' c\<^sub>1 t f) (normif' c\<^sub>2 t f)"

primrec norm' :: "ifex \<Rightarrow> ifex" where
"norm' (CIF b) = CIF b" |
"norm' (VIF n) = VIF n" |
"norm' (IF c t f) = normif' c (norm' t) (norm' f)"

lemma [simp]: "\<forall>t e. valif (normif' b t e) env = valif (IF b t e) env"
apply (induct_tac b)
apply auto
done

theorem "valif (norm' b) env = valif b env"
apply (induct_tac b)
apply auto
done

primrec normal' :: "ifex \<Rightarrow> bool" where
"normal' (CIF b)    = True" |
"normal' (VIF n)    = True" |
"normal' (IF c t f) = ((case c of CIF b \<Rightarrow> False | VIF n \<Rightarrow> True | IF x y z \<Rightarrow> False)
                    \<and> normal' t
                    \<and> normal' f)"

lemma [simp]: "\<forall>t f. (normal' t \<and> normal' f) \<longrightarrow> normal' (normif' c t f)"
apply (induct_tac c)
apply auto
done

theorem "normal' (norm' b)"
apply (induct_tac b)
apply auto
done

end


(*  Title:       Definition of Expectation and Distribution of uniformly distributed bit vectors
    Author:      Max Haslbeck
*)

section "Probability Theory"

theory Prob_Theory
imports "HOL-Probability.Probability"
begin

lemma integral_map_pmf[simp]:
  fixes f::"real \<Rightarrow> real"
  shows "(\<integral>x. f x \<partial>(map_pmf g M)) = (\<integral>x. f (g x) \<partial>M)"
   unfolding map_pmf_rep_eq
 using integral_distr[of g "(measure_pmf M)" "(count_space UNIV)" f] by auto

subsection "function \<open>E\<close>"

definition E :: "real pmf \<Rightarrow> real"  where
  "E M = (\<integral>x. x \<partial> measure_pmf M)"

translations
  "\<integral> x. f \<partial>M" <= "CONST lebesgue_integral M (\<lambda>x. f)"

notation (latex output) E  ("E[_]" [1] 100)

lemma E_const[simp]: "E (return_pmf a) = a"
unfolding E_def
unfolding return_pmf.rep_eq
by (simp add: integral_return)

lemma E_null[simp]: "E (return_pmf 0) = 0"
by auto

lemma E_finite_sum: "finite (set_pmf X) \<Longrightarrow> E X = (\<Sum>x\<in>(set_pmf X). pmf X x * x)"
  unfolding E_def by (subst integral_measure_pmf) simp_all

lemma E_of_const: "E(map_pmf (\<lambda>x. y) (X::real pmf)) = y" by auto

lemma E_nonneg:
  shows "(\<forall>x\<in>set_pmf X. 0\<le> x) \<Longrightarrow> 0 \<le> E X"
unfolding E_def
using integral_nonneg by (simp add: AE_measure_pmf_iff integral_nonneg_AE)

lemma E_nonneg_fun: fixes f::"'a\<Rightarrow>real"
  shows "(\<forall>x\<in>set_pmf X. 0\<le>f x) \<Longrightarrow> 0 \<le> E (map_pmf f X)"
using E_nonneg by auto

lemma E_cong:
  fixes f::"'a \<Rightarrow> real"
  shows "finite (set_pmf X) \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) = (u x)) \<Longrightarrow> E (map_pmf f X) = E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_cong_AE)
apply(simp add: integrable_measure_pmf_finite)+
by (simp add: AE_measure_pmf_iff)

lemma E_mono3:
  fixes f::"'a \<Rightarrow> real"
  shows " integrable (measure_pmf X) f \<Longrightarrow>  integrable (measure_pmf X) u \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) \<le> (u x)) \<Longrightarrow> E (map_pmf f X) \<le> E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
by (auto simp add: AE_measure_pmf_iff)

lemma E_mono2:
  fixes f::"'a \<Rightarrow> real"
  shows "finite (set_pmf X) \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) \<le> (u x)) \<Longrightarrow> E (map_pmf f X) \<le> E (map_pmf u X)"
unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
apply(simp add: integrable_measure_pmf_finite)+
by (simp add: AE_measure_pmf_iff)

lemma E_linear_diff2: "finite (set_pmf A) \<Longrightarrow> E (map_pmf f A) - E (map_pmf g A) = E (map_pmf (\<lambda>x. (f x) - (g x)) A)"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_diff[of "measure_pmf A" f g, symmetric])
 by (simp_all add: integrable_measure_pmf_finite)

lemma E_linear_plus2: "finite (set_pmf A) \<Longrightarrow> E (map_pmf f A) + E (map_pmf g A) = E (map_pmf (\<lambda>x. (f x) + (g x)) A)"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_add[of "measure_pmf A" f g, symmetric])
 by (simp_all add: integrable_measure_pmf_finite)

lemma E_linear_sum2: "finite (set_pmf D) \<Longrightarrow> E(map_pmf (\<lambda>x. (\<Sum>i<up. f i x)) D)
      = (\<Sum>i<(up::nat). E(map_pmf (f i) D))"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

lemma E_linear_sum_allg: "finite (set_pmf D) \<Longrightarrow> E(map_pmf (\<lambda>x. (\<Sum>i\<in> A. f i x)) D)
      = (\<Sum>i\<in> (A::'a set). E(map_pmf (f i) D))"
unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

lemma E_finite_sum_fun: "finite (set_pmf X) \<Longrightarrow>
    E (map_pmf f X) = (\<Sum>x\<in>set_pmf X. pmf X x * f x)"
proof -
  assume finite: "finite (set_pmf X)"
  have "E (map_pmf f X) = (\<integral>x. f x \<partial>measure_pmf X)"
      unfolding E_def by auto
  also have "\<dots> = (\<Sum>x\<in>set_pmf X. pmf X x * f x)"
    by (subst integral_measure_pmf) (auto simp add: finite)
  finally show ?thesis .
qed

lemma E_bernoulli: "0\<le>p \<Longrightarrow> p\<le>1 \<Longrightarrow>
        E (map_pmf f (bernoulli_pmf p)) = p*(f True) + (1-p)*(f False)"
unfolding E_def by (auto)

subsection "function \<open>bv\<close>"

  fun bv:: "nat \<Rightarrow> bool list pmf" where
  "bv 0 = return_pmf []"
| "bv (Suc n) =  do {
                    (xs::bool list) \<leftarrow> bv n;
                    (x::bool) \<leftarrow> (bernoulli_pmf 0.5);
                    return_pmf (x#xs)
                  }"

lemma bv_finite: "finite (bv n)"
by (induct  n) auto

lemma len_bv_n: "\<forall>xs \<in> set_pmf (bv n). length xs = n"
apply(induct n) by auto

lemma bv_set: "set_pmf (bv n) = {x::bool list. length x = n}"
proof (induct n)
  case (Suc n)
  then have "set_pmf (bv (Suc n)) = (\<Union>x\<in>{x. length x = n}. {True # x, False # x})"
    by(simp add: set_pmf_bernoulli UNIV_bool)
  also have "\<dots> = {x#xs| x xs. length xs = n}" by auto
  also have "\<dots> = {x. length x = Suc n} " using Suc_length_conv by fastforce
  finally show ?case .
qed (simp)

lemma len_not_in_bv: "length xs  \<noteq> n \<Longrightarrow> xs \<notin> set_pmf (bv n)"
by(auto simp: len_bv_n)

lemma not_n_bv_0: "length xs \<noteq> n \<Longrightarrow> pmf (bv n) xs = 0"
by (simp add: len_not_in_bv pmf_eq_0_set_pmf)

lemma bv_comp_bernoulli: "n < l
        \<Longrightarrow> map_pmf (\<lambda>y. y!n) (bv l) = bernoulli_pmf (5 / 10)"
proof (induct n arbitrary: l)
  case 0
  then obtain m where "l = Suc m" by (metis Suc_pred)
  then show "map_pmf (\<lambda>y. y!0) (bv l) =  bernoulli_pmf (5 / 10)" by (auto simp: map_pmf_def bind_return_pmf bind_assoc_pmf bind_return_pmf')
next
  case (Suc n)
  then have "0 < l" by auto
  then obtain m where lsm: "l = Suc m" by (metis Suc_pred)
  with Suc(2) have nltm: "n < m" by auto

  from lsm have "map_pmf (\<lambda>y. y ! Suc n) (bv l)
       =  map_pmf (\<lambda>x. x!n) (bind_pmf (bv m) (\<lambda>t. (return_pmf t)))" by (auto simp: map_bind_pmf)
also
  have "\<dots> =  map_pmf (\<lambda>x. x!n) (bv m)" by (auto simp: bind_return_pmf')
also
  have "\<dots> = bernoulli_pmf (5 / 10)" by (auto simp add: Suc(1)[of m, OF nltm])
finally
  show ?case .
qed

lemma pmf_2elemlist: "pmf (bv (Suc 0)) ([x]) = pmf (bv 0) [] * pmf (bernoulli_pmf (5 / 10)) x"
  unfolding bv.simps(2)[where n=0] pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{[]}"])
  apply (auto) by (cases x) auto

lemma pmf_moreelemlist: "pmf (bv (Suc n)) (x#xs) = pmf (bv n) xs * pmf (bernoulli_pmf (5 / 10)) x"
  unfolding bv.simps(2) pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{xs}"])
  apply auto apply (cases x) apply(auto)
  apply (meson indicator_simps(2) list.inject singletonD)
  apply (meson indicator_simps(2) list.inject singletonD)
  apply (cases x) by(auto)

lemma list_pmf: "length xs = n \<Longrightarrow> pmf (bv n) xs = (1 / 2)^n"
proof(induct n arbitrary: xs)
  case 0
  then have "xs = []" by auto
  then show "pmf (bv 0) xs = (1 / 2) ^ 0" by(auto)
next
  case (Suc n xs)
  then obtain a as where split: "xs = a#as" by (metis Suc_length_conv)
  have "length as = n" using Suc(2) split by auto
  with Suc(1) have 1: "pmf (bv n) as = (1 / 2) ^ n" by auto

  from split pmf_moreelemlist[where n=n and x=a and xs=as] have
    "pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
  then have "pmf (bv (Suc n)) xs = (1 / 2) ^ n * 1 / 2" using 1 by auto
  then show "pmf (bv (Suc n)) xs = (1 / 2) ^ Suc n" by auto
qed

lemma bv_0_notlen: "pmf (bv n) xs = 0 \<Longrightarrow> length xs \<noteq> n "
by(auto simp: list_pmf)

lemma "length xs > n \<Longrightarrow> pmf (bv n) xs = 0"
proof (induct n arbitrary: xs)
  case (Suc n xs)
  then obtain a as where split: "xs = a#as" by (metis Suc_length_conv Suc_lessE)
  have "length as > n" using Suc(2) split by auto
  with Suc(1) have 1: "pmf (bv n) as = 0" by auto
  from split pmf_moreelemlist[where n=n and x=a and xs=as] have
    "pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
  then have "pmf (bv (Suc n)) xs = 0 * 1 / 2" using 1 by auto
  then show "pmf (bv (Suc n)) xs = 0" by auto
qed simp

lemma map_hd_list_pmf: "map_pmf hd (bv (Suc n)) = bernoulli_pmf (5 / 10)"
  by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf')

lemma map_tl_list_pmf: "map_pmf tl (bv (Suc n)) = bv n"
  by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf' )

subsection "function \<open>flip\<close>"

fun flip :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "flip _ [] = []"
| "flip 0 (x#xs) = (\<not>x)#xs"
| "flip (Suc n) (x#xs) = x#(flip n xs)"

lemma flip_length[simp]: "length (flip i xs) = length xs"
apply(induct xs arbitrary: i) apply(simp) apply(case_tac i) by(simp_all)

lemma flip_out_of_bounds: "y \<ge> length X \<Longrightarrow> flip y X = X"
apply(induct X arbitrary: y)
proof -
  case (Cons X Xs)
  hence "y > 0" by auto
  with Cons obtain y' where y1: "y = Suc y'" and y2: "y' \<ge> length Xs" by (metis Suc_pred' length_Cons not_less_eq_eq)
  then have "flip y (X # Xs) = X#(flip y' Xs)" by auto
  moreover from Cons y2 have "flip y' Xs = Xs" by auto
  ultimately show ?case by auto
qed simp

lemma flip_other: "y < length X \<Longrightarrow> z < length X \<Longrightarrow> z \<noteq> y \<Longrightarrow> flip z X ! y = X ! y"
apply(induct y arbitrary: X z)
apply(simp) apply (metis flip.elims neq0_conv nth_Cons_0)
proof (case_tac z, goal_cases)
  case (1 y X z)
  then obtain a as where "X=a#as" using length_greater_0_conv by (metis (full_types) flip.elims)
  with 1(5) show ?case by(simp)
next
  case (2 y X z z')
  from 2 have 3: "z' \<noteq> y" by auto
  from 2(2) have "length X > 0" by auto
  then obtain a as where aas: "X = a#as" by (metis (full_types) flip.elims length_greater_0_conv)
  then have a: "flip (Suc z') X ! Suc y = flip z' as ! y"
    and b : "(X ! Suc y) = (as !  y)" by auto
  from 2(2) aas have 1: "y < length as" by auto
  from 2(3,5) aas have f2: "z' < length as" by auto
  note c=2(1)[OF 1 f2 3]

  have "flip z X ! Suc y = flip (Suc z') X ! Suc y" using 2 by auto
  also have "\<dots> = flip z' as ! y" by (rule a)
  also have "\<dots> = as ! y" by (rule c)
  also have "\<dots> = (X ! Suc y)" by (rule b[symmetric])
  finally show "flip z X ! Suc y = (X ! Suc y)" .
qed

lemma flip_itself: "y < length X \<Longrightarrow> flip y X ! y = (\<not> X ! y)"
apply(induct y arbitrary: X)
apply(simp) apply (metis flip.elims nth_Cons_0 old.nat.distinct(2))
proof -
  fix y
  fix X::"bool list"
  assume iH: "(\<And>X. y < length X \<Longrightarrow> flip y X ! y = (\<not> X ! y))"
  assume len: "Suc y < length X"
  from len have "y < length X" by auto
  from len have "length X > 0" by auto
  then obtain z zs where zzs: "X = z#zs" by (metis (full_types) flip.elims length_greater_0_conv)
  then have a: "flip (Suc y) X ! Suc y = flip y zs ! y"
    and b : "(\<not> X ! Suc y) = (\<not> zs !  y)" by auto
  from len zzs have "y < length zs" by auto
  note c=iH[OF this]
  from a b c show "flip (Suc y) X ! Suc y = (\<not> X ! Suc y)" by auto
qed

lemma flip_twice: "flip i (flip i b) = b"
proof (cases "i < length b")
  case True
  then have A: "i < length (flip i b)" by simp
  show ?thesis apply(simp add: list_eq_iff_nth_eq) apply(clarify)
  proof (goal_cases)
    case (1 j)
    then show ?case
      apply(cases "i=j")
        using flip_itself[OF A] flip_itself[OF True] apply(simp)
        using flip_other True 1 by auto
  qed
qed (simp add: flip_out_of_bounds)

lemma flipidiflip: "y < length X \<Longrightarrow> e < length X  \<Longrightarrow> flip e X ! y = (if e=y then ~ (X ! y) else X ! y)"
apply(cases "e=y")
apply(simp add: flip_itself)
by(simp add: flip_other)

lemma bernoulli_Not: "map_pmf Not (bernoulli_pmf (1 / 2)) = (bernoulli_pmf (1 / 2))"
apply(rule pmf_eqI)
proof (case_tac i, goal_cases)
  case (1 i)
  then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
    pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not False)" by auto
  also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) False" apply (rule pmf_map_inj') apply(rule injI) by auto
  also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) i" by auto
  finally show ?case .
next
  case (2 i)
  then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
    pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not True)" by auto
  also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) True" apply (rule pmf_map_inj') apply(rule injI) by auto
  also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) i" by auto
  finally show ?case .
qed

lemma inv_flip_bv: "map_pmf (flip i) (bv n) = (bv n)"
proof(induct n arbitrary: i)
   case (Suc n i)
   note iH=this
   have "bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. map_pmf (flip i) (return_pmf (xa # x))))
    = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa .bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))"
    by(rule bind_commute_pmf)
   also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa . bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
   proof (cases i)
    case 0
    then have "bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))
        = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf ((\<not> xa) # x)))" by auto
    also have "\<dots>  = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf ((\<not> xa) # x)))"
      by(rule bind_commute_pmf)
    also have "\<dots>
        = bind_pmf (bv n) (\<lambda>x. bind_pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (\<lambda>xa. return_pmf (xa # x)))"
              by(auto simp add: bind_map_pmf)
    also have "\<dots> = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf (xa # x)))" by (simp only: bernoulli_Not)
    also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
      by(rule bind_commute_pmf)
    finally show ?thesis .
   next
    case (Suc i')
    have "bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))
        = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # flip i' x)))" unfolding Suc by(simp)
    also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (map_pmf (flip i') (bv n)) (\<lambda>x. return_pmf (xa # x)))"
        by(auto simp add: bind_map_pmf)
    also have "\<dots> =  bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
        using iH[of "i'"] by simp
    finally show ?thesis .
   qed
   also have "\<dots> = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf (xa # x)))"
    by(rule bind_commute_pmf)
   finally show ?case by(simp add: map_pmf_def bind_assoc_pmf)
qed simp

subsection "Example for pmf"

definition "twocoins =
                do {
                    x \<leftarrow> (bernoulli_pmf 0.4);
                    y \<leftarrow> (bernoulli_pmf 0.5);
                    return_pmf (x \<or> y)
                  }"

lemma experiment0_7: "pmf twocoins True = 0.7"
unfolding twocoins_def
  unfolding pmf_bind pmf_return
  apply (subst integral_measure_pmf[where A="{True, False}"])
  by auto

subsection "Sum Distribution"

definition "Sum_pmf p Da Db = (bernoulli_pmf p) \<bind> (%b. if b then map_pmf Inl Da else map_pmf Inr Db )"

lemma b0: "bernoulli_pmf 0 = return_pmf False"
apply(rule pmf_eqI) apply(case_tac i)
  by(simp_all)
lemma b1: "bernoulli_pmf 1 = return_pmf True"
apply(rule pmf_eqI) apply(case_tac i)
  by(simp_all)

lemma Sum_pmf_0: "Sum_pmf 0 Da Db = map_pmf Inr Db"
unfolding Sum_pmf_def
apply(rule pmf_eqI)
  by(simp add: b0 bind_return_pmf)

lemma Sum_pmf_1: "Sum_pmf 1 Da Db = map_pmf Inl Da"
unfolding Sum_pmf_def
apply(rule pmf_eqI)
  by(simp add: b1 bind_return_pmf)

definition "Proj1_pmf D = map_pmf (%a. case a of Inl e \<Rightarrow> e) (cond_pmf D {f. (\<exists>e. Inl e = f)})"

lemma A: "(case_sum (\<lambda>e. e) (\<lambda>a. undefined)) (Inl e) = e"
  by(simp)

lemma B: "inj (case_sum (\<lambda>e. e) (\<lambda>a. undefined))"
  oops

lemma none: "p >0 \<Longrightarrow> p < 1 \<Longrightarrow> (set_pmf (bernoulli_pmf p \<bind>
          (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
          \<inter> {f. (\<exists>e. Inl e = f)}) \<noteq> {}"
    apply(simp add: UNIV_bool)
      using set_pmf_not_empty by fast
lemma none2: "p >0 \<Longrightarrow> p < 1 \<Longrightarrow>  (set_pmf (bernoulli_pmf p \<bind>
          (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
          \<inter> {f. (\<exists>e. Inr e = f)}) \<noteq> {}"
    apply(simp add: UNIV_bool)
      using set_pmf_not_empty by fast

lemma C: "set_pmf (Proj1_pmf (Sum_pmf 0.5 Da Db)) = set_pmf Da"
proof -
  show ?thesis
    unfolding Sum_pmf_def Proj1_pmf_def
    apply(simp add: )
    using none[of "0.5" Da Db] apply(simp add: set_cond_pmf UNIV_bool)
      by force
qed

thm integral_measure_pmf

thm pmf_cond pmf_cond[OF none]

lemma proj1_pmf: assumes "p>0" "p<1" shows "Proj1_pmf (Sum_pmf p Da Db) =  Da"
proof -

  have kl: "\<And>e. pmf (map_pmf Inr Db) (Inl e) = 0"
    apply(simp only: pmf_eq_0_set_pmf)
    apply(simp) by blast

  have ll: "measure_pmf.prob
           (bernoulli_pmf p \<bind>
            (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. \<exists>e. Inl e = f} = p"
       using assms
     apply(simp add: integral_pmf[symmetric] pmf_bind)
     apply(subst Bochner_Integration.integral_add)
      using integrable_pmf apply fast
      using integrable_pmf apply fast
        by(simp add: integral_pmf)

  have E: "(cond_pmf
       (bernoulli_pmf p \<bind>
        (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
       {f. \<exists>e. Inl e = f}) =
    map_pmf Inl Da"
    apply(rule pmf_eqI)
      apply(subst pmf_cond)
      using none[of p Da Db] assms apply (simp)
       using assms apply(auto)
          apply(subst pmf_bind)
          apply(simp add: kl ll )
          apply(simp only: pmf_eq_0_set_pmf) by auto

  have ID: "case_sum (\<lambda>e. e) (\<lambda>a. undefined) \<circ> Inl = id"
    by fastforce
  show ?thesis
    unfolding Sum_pmf_def Proj1_pmf_def
    apply(simp only: E)
    apply(simp add: pmf.map_comp ID)
  done

qed

definition "Proj2_pmf D = map_pmf (%a. case a of Inr e \<Rightarrow> e) (cond_pmf D {f. (\<exists>e. Inr e = f)})"

lemma proj2_pmf: assumes "p>0" "p<1" shows "Proj2_pmf (Sum_pmf p Da Db) =  Db"
proof -

  have kl: "\<And>e. pmf (map_pmf Inl Da) (Inr e) = 0"
    apply(simp only: pmf_eq_0_set_pmf)
    apply(simp) by blast

  have ll: "measure_pmf.prob
           (bernoulli_pmf p \<bind>
            (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
           {f. \<exists>e. Inr e = f} = 1-p"
       using assms
     apply(simp add: integral_pmf[symmetric] pmf_bind)
     apply(subst Bochner_Integration.integral_add)
      using integrable_pmf apply fast
      using integrable_pmf apply fast
        by(simp add: integral_pmf)

  have E: "(cond_pmf
       (bernoulli_pmf p \<bind>
        (\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
       {f. \<exists>e. Inr e = f}) =
    map_pmf Inr Db"
    apply(rule pmf_eqI)
      apply(subst pmf_cond)
      using none2[of p Da Db] assms apply (simp)
       using assms apply(auto)
          apply(subst pmf_bind)
          apply(simp add: kl ll )
          apply(simp only: pmf_eq_0_set_pmf) by auto

  have ID: "case_sum (\<lambda>e. undefined) (\<lambda>a. a) \<circ> Inr = id"
    by fastforce
  show ?thesis
    unfolding Sum_pmf_def Proj2_pmf_def
    apply(simp only: E)
    apply(simp add: pmf.map_comp ID)
  done

qed

definition "invSum invA invB D x i == invA (Proj1_pmf D) x i \<and> invB (Proj2_pmf D) x i"

term "(%a. case a of Inl e \<Rightarrow> Inl (fa e) | Inr e \<Rightarrow> Inr (fb e))"
definition "f_on2 fa fb = (%a. case a of Inl e \<Rightarrow> map_pmf Inl (fa e) | Inr e \<Rightarrow> map_pmf Inr (fb e))"

term "bind_pmf"

lemma Sum_bind_pmf: assumes a: "bind_pmf Da fa = Da'" and b: "bind_pmf Db fb = Db'"
  shows "bind_pmf (Sum_pmf p Da Db) (f_on2 fa fb)
              = Sum_pmf p Da' Db'"
proof -
  { fix x
  have "(if x then map_pmf Inl Da else map_pmf Inr Db) \<bind>
                 case_sum (\<lambda>e. map_pmf Inl (fa e))
                  (\<lambda>e. map_pmf Inr (fb e))
            =
        (if x then map_pmf Inl Da \<bind> case_sum (\<lambda>e. map_pmf Inl (fa e))
                  (\<lambda>e. map_pmf Inr (fb e))
              else map_pmf Inr Db \<bind> case_sum (\<lambda>e. map_pmf Inl (fa e))
                  (\<lambda>e. map_pmf Inr (fb e)))"
                  apply(simp) done
  also
    have "\<dots> = (if x then map_pmf Inl (bind_pmf Da fa) else map_pmf Inr (bind_pmf Db fb))"
      by(auto simp add: map_pmf_def bind_assoc_pmf bind_return_pmf)
  also
    have "\<dots> = (if x then map_pmf Inl Da' else map_pmf Inr Db')"
      using a b by simp
  finally
    have "(if x then map_pmf Inl Da else map_pmf Inr Db) \<bind>
                 case_sum (\<lambda>e. map_pmf Inl (fa e))
                  (\<lambda>e. map_pmf Inr (fb e)) = (if x then map_pmf Inl Da' else map_pmf Inr Db')" .
  } note gr=this

  show ?thesis
    unfolding Sum_pmf_def f_on2_def
    apply(rule pmf_eqI)
    apply(case_tac i)
    by(simp_all add: bind_return_pmf bind_assoc_pmf gr)
qed

definition "sum_map_pmf fa fb = (%a. case a of Inl e \<Rightarrow> Inl (fa e) | Inr e \<Rightarrow> Inr (fb e))"

lemma Sum_map_pmf: assumes a: "map_pmf fa Da = Da'" and b: "map_pmf fb Db = Db'"
  shows "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
              = Sum_pmf p Da' Db'"
proof -
  have "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
        = bind_pmf (Sum_pmf p Da Db) (f_on2 (\<lambda>x. return_pmf (fa x)) (\<lambda>x. return_pmf (fb x)))"
        using a b
  unfolding map_pmf_def sum_map_pmf_def f_on2_def
    by(auto simp add: bind_return_pmf sum.case_distrib)
also
  have "\<dots> = Sum_pmf p Da' Db'"
 using assms[unfolded map_pmf_def]
 by(rule Sum_bind_pmf )
finally
  show ?thesis .
qed

end


theory Submission
  imports Defs
begin

lemma S_ge_2:
  "S n \<ge> 2"
  by (induction n) auto

lemma prime_factors_nonempty:
  "prime_factors n \<noteq> {}" if "n > 1" for n :: nat
  by (metis less_trans neq_iff prime_factorization_1 prod_mset_prime_factorization_nat
        set_mset_eq_empty_iff that zero_less_one)

lemma pf_in_prime_factors[intro]:
  "pf n \<in> prime_factors n" if "n > 1" for n :: nat
  unfolding pf_def using prime_factors_nonempty[OF \<open>n > 1\<close>] by (intro Min_in) auto

lemma pf_S_in_prime_factors[simp, intro]:
  "pf (S n) \<in> prime_factors (S n)"
  using S_ge_2[of n] by auto

theorem prime_pf_Suc_S:
  "prime(pf(S(n)+1))"
  using S_ge_2[of n] by force

lemma prime_factors_subs:
  "prime_factors m \<subseteq> prime_factors (m * k)" if "0 < m" "0 < k" for m k :: nat
  using that by (intro dvd_prime_factors) auto

lemma prime_factors_S_Suc:
  "prime_factors (S m + 1) \<subseteq> prime_factors (S (m + 1))"
  using prime_factors_subs[of "S m + 1" "S m"] S_ge_2[of m] by simp

lemma prime_factors_S_le_subs:
  "prime_factors (S m + 1) \<subseteq> prime_factors (S n)" if "m < n"
  using that
  apply (induction n)
  apply simp
  subgoal for n
    apply (cases "m = n")
    using prime_factors_S_Suc
     apply simp
    apply simp
    apply (erule subset_trans)
    using prime_factors_subs[of "S n" "S n + 1"] S_ge_2[of n]
    apply simp
    done
  done

lemma prime_factors_int_Suc:
  "prime_factors n \<inter> prime_factors (n + 1) = {}" if "n > 0" for n :: nat
  by (metis add_eq_0_iff_both_eq_0 gcd_add2 inf_bot_right not_gr_zero prime_factorization_1
      prime_factors_gcd set_mset_empty that zero_neq_one)

lemma prime_factors_S_neq:
  "prime_factors (S m + 1) \<inter> prime_factors (S n + 1) = {}" if "m < n"
  using prime_factors_int_Suc[of "S n"] S_ge_2[of n] prime_factors_S_le_subs[OF \<open>m < n\<close>] by auto

lemma pf_S_inj_aux:
  assumes "pf(S(n)+1) = pf(S(m)+1)" "m < n"
  shows False
proof -
  have "pf(S(n)+1) \<in> prime_factors (S n + 1)" "pf(S(m)+1) \<in> prime_factors (S m + 1)"
    using S_ge_2[of n] S_ge_2[of m] by auto
  with prime_factors_S_neq[OF \<open>m < n\<close>] assms(1) show ?thesis
    by auto
qed

theorem pf_S_inj:
  assumes "pf(S(n)+1) = pf(S(m)+1)"
  shows "n = m"
  using pf_S_inj_aux assms by (metis less_linear)

theorem infinitely_many_primes:
  "infinite {p :: nat. prime p}"
proof -
  let ?S = "(\<lambda>n. pf(S(n)+1)) ` UNIV" let ?P = "{p :: nat. prime p}"
  have "?S \<subseteq> ?P"
    using prime_pf_Suc_S by auto
  moreover have "infinite ?S"
    by (intro range_inj_infinite inj_onI, rule pf_S_inj)
  ultimately show ?thesis
    by (rule infinite_super)
qed

end


(*
  File:    Eulerian_Polynomials.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Eulerian polynomials\<close>
theory Eulerian_Polynomials
imports
  Complex_Main
  "HOL-Combinatorics.Stirling"
  "HOL-Computational_Algebra.Computational_Algebra"
begin

text \<open>
  The Eulerian polynomials are a sequence of polynomials that is related to
  the closed forms of the power series
  \[\sum_{n=0}^\infty n^k X^n\]
  for a fixed $k$.
\<close>
primrec eulerian_poly :: "nat \<Rightarrow> 'a :: idom poly" where
  "eulerian_poly 0 = 1"
| "eulerian_poly (Suc n) = (let p = eulerian_poly n in
     [:0,1,-1:] * pderiv p + p * [:1, of_nat n:])"

lemmas eulerian_poly_Suc [simp del] = eulerian_poly.simps(2)

lemma eulerian_poly:
  "fps_of_poly (eulerian_poly k :: 'a :: field poly) =
     Abs_fps (\<lambda>n. of_nat (n+1) ^ k) * (1 - fps_X) ^ (k + 1)"
proof (induction k)
  case 0
  have "Abs_fps (\<lambda>_. 1 :: 'a) = inverse (1 - fps_X)"
    by (rule fps_inverse_unique [symmetric])
       (simp add: inverse_mult_eq_1 fps_inverse_gp' [symmetric])
  thus ?case by (simp add: inverse_mult_eq_1)
next
  case (Suc k)
  define p :: "'a fps" where "p = fps_of_poly (eulerian_poly k)"
  define F :: "'a fps" where "F = Abs_fps (\<lambda>n. of_nat (n+1) ^ k)"

  have p: "p = F * (1 - fps_X) ^ (k+1)" by (simp add: p_def Suc F_def)
  have p': "fps_deriv p = fps_deriv F * (1 - fps_X) ^ (k + 1) - F * (1 - fps_X) ^ k * of_nat (k + 1)"
    by (simp add: p fps_deriv_power algebra_simps fps_const_neg [symmetric] fps_of_nat
             del: power_Suc of_nat_Suc fps_const_neg)

  have "fps_of_poly (eulerian_poly (Suc k)) = (fps_X * fps_deriv F + F) * (1 - fps_X) ^ (Suc k + 1)"
    apply (simp add: Let_def p_def [symmetric] fps_of_poly_simps eulerian_poly_Suc del: power_Suc)
    apply (simp add: p p' fps_deriv_power fps_const_neg [symmetric] fps_of_nat
                del: power_Suc of_nat_Suc fps_const_neg)
    apply (simp add: algebra_simps)
    done
  also have "fps_X * fps_deriv F + F = Abs_fps (\<lambda>n. of_nat (n + 1) ^ Suc k)"
    unfolding F_def by (intro fps_ext) (auto simp: algebra_simps)
  finally show ?case .
qed

lemma eulerian_poly':
  "Abs_fps (\<lambda>n. of_nat (n+1) ^ k) =
     fps_of_poly (eulerian_poly k :: 'a :: field poly) / (1 - fps_X) ^ (k + 1)"
  by (subst eulerian_poly) simp

lemma eulerian_poly'':
  assumes k: "k > 0"
  shows "Abs_fps (\<lambda>n. of_nat n ^ k) =
           fps_of_poly (pCons 0 (eulerian_poly k :: 'a :: field poly)) / (1 - fps_X) ^ (k + 1)"
proof -
  from assms have "Abs_fps (\<lambda>n. of_nat n ^ k :: 'a) = fps_X * Abs_fps (\<lambda>n. of_nat (n + 1) ^ k)"
    by (intro fps_ext) (auto simp: of_nat_diff)
  also have "Abs_fps (\<lambda>n. of_nat (n + 1) ^ k :: 'a) =
               fps_of_poly (eulerian_poly k) / (1 - fps_X) ^ (k + 1)" by (rule eulerian_poly')
  also have "fps_X * \<dots> = fps_of_poly (pCons 0 (eulerian_poly k)) / (1 - fps_X) ^ (k + 1)"
    by (simp add: fps_of_poly_pCons fps_divide_unit)
  finally show ?thesis .
qed

definition fps_monom_poly :: "'a :: field \<Rightarrow> nat \<Rightarrow> 'a poly"
  where "fps_monom_poly c k = (if k = 0 then 1 else pcompose (pCons 0 (eulerian_poly k)) [:0,c:])"

primrec fps_monom_poly_aux :: "'a :: field \<Rightarrow> nat \<Rightarrow> 'a poly" where
  "fps_monom_poly_aux c 0 = [:c:]"
| "fps_monom_poly_aux c (Suc k) =
      (let p = fps_monom_poly_aux c k
       in  [:0,1,-c:] * pderiv p + [:1, of_nat k * c:] * p)"

lemma fps_monom_poly_aux:
  "fps_monom_poly_aux c k = smult c (pcompose (eulerian_poly k) [:0,c:])"
  by (induction k)
     (simp_all add: eulerian_poly_Suc Let_def pderiv_pcompose pcompose_pCons
                    pcompose_add pcompose_smult pcompose_uminus smult_add_right pderiv_pCons
                    pderiv_smult algebra_simps one_pCons)

lemma fps_monom_poly_code [code]:
  "fps_monom_poly c k = (if k = 0 then 1 else pCons 0 (fps_monom_poly_aux c k))"
  by (simp add: fps_monom_poly_def fps_monom_poly_aux pcompose_pCons)

lemma fps_monom_aux:
  "Abs_fps (\<lambda>n. of_nat n ^ k) = fps_of_poly (fps_monom_poly 1 k) / (1 - fps_X) ^ (k+1)"
proof (cases "k = 0")
  assume [simp]: "k = 0"
  hence "Abs_fps (\<lambda>n. of_nat n ^ k :: 'a) = Abs_fps (\<lambda>_. 1)" by simp
  also have "\<dots> = 1 / (1 - fps_X)" by (subst gp [symmetric]) simp_all
  finally show ?thesis by (simp add: fps_monom_poly_def)
qed (insert eulerian_poly''[of k, where ?'a = 'a], simp add: fps_monom_poly_def)

lemma fps_monom:
  "Abs_fps (\<lambda>n. of_nat n ^ k * c ^ n) =
      fps_of_poly (fps_monom_poly c k) / (1 - fps_const c * fps_X) ^ (k+1)"
proof -
  have "Abs_fps (\<lambda>n. of_nat n ^ k * c ^ n) =
          fps_compose (Abs_fps (\<lambda>n. of_nat n ^ k)) (fps_const c * fps_X)"
    by (subst fps_compose_linear) (simp add: mult_ac)
  also have "Abs_fps (\<lambda>n. of_nat n ^ k) = fps_of_poly (fps_monom_poly 1 k) / (1 - fps_X) ^ (k+1)"
    by (rule fps_monom_aux)
  also have "fps_compose \<dots> (fps_const c * fps_X) =
                 (fps_of_poly (fps_monom_poly 1 k) oo fps_const c * fps_X) /
                 ((1 - fps_X) ^ (k + 1) oo fps_const c * fps_X)"
    by (intro fps_compose_divide_distrib)
       (simp_all add: fps_compose_power [symmetric] fps_compose_sub_distrib del: power_Suc)
  also have "fps_of_poly (fps_monom_poly 1 k) oo (fps_const c * fps_X) =
                fps_of_poly (fps_monom_poly c k)"
    by (simp add: fps_monom_poly_def fps_of_poly_pcompose fps_of_poly_simps
                  fps_of_poly_pCons mult_ac)
  also have "((1 - fps_X) ^ (k + 1) oo fps_const c * fps_X) = (1 - fps_const c * fps_X) ^ (k + 1)"
    by (simp add: fps_compose_power [symmetric] fps_compose_sub_distrib del: power_Suc)
  finally show ?thesis .
qed

end


(*
  File:     Min_Int_Poly.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>The minimal polynomial of an algebraic number\<close>
theory Min_Int_Poly
imports
  Algebraic_Numbers_Prelim
begin

text \<open>
  Given an algebraic number \<open>x\<close> in a field, the minimal polynomial is the unique irreducible
  integer polynomial with positive leading coefficient that has \<open>x\<close> as a root.

  Note that we assume characteristic 0 since the material upon which all of this builds also
  assumes it.
\<close>

definition min_int_poly :: "'a :: field_char_0 \<Rightarrow> int poly" where
  "min_int_poly x =
     (if algebraic x then THE p. p represents x \<and> irreducible p \<and> lead_coeff p > 0
      else [:0, 1:])"

lemma
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows min_int_poly_represents [intro]: "algebraic x \<Longrightarrow> min_int_poly x represents x"
  and   min_int_poly_irreducible [intro]: "irreducible (min_int_poly x)"
  and   lead_coeff_min_int_poly_pos: "lead_coeff (min_int_poly x) > 0"
proof -
  note * = theI'[OF algebraic_imp_represents_unique, of x]
  show "min_int_poly x represents x" if "algebraic x"
    using *[OF that] by (simp add: that min_int_poly_def)
  have "irreducible [:0, 1::int:]"
    by (rule irreducible_linear_poly) auto
  thus "irreducible (min_int_poly x)"
    using * by (auto simp: min_int_poly_def)
  show "lead_coeff (min_int_poly x) > 0"
    using * by (auto simp: min_int_poly_def)
qed

lemma
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows degree_min_int_poly_pos [intro]: "degree (min_int_poly x) > 0"
    and degree_min_int_poly_nonzero [simp]: "degree (min_int_poly x) \<noteq> 0"
proof -
  show "degree (min_int_poly x) > 0"
  proof (cases "algebraic x")
    case True
    hence "min_int_poly x represents x"
      by auto
    thus ?thesis by blast
  qed (auto simp: min_int_poly_def)
  thus "degree (min_int_poly x) \<noteq> 0"
    by blast
qed

lemma min_int_poly_primitive [intro]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "primitive (min_int_poly x)"
  by (rule irreducible_imp_primitive) auto

lemma min_int_poly_content [simp]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "content (min_int_poly x) = 1"
  using min_int_poly_primitive[of x] by (simp add: primitive_def)

lemma ipoly_min_int_poly [simp]:
  "algebraic x \<Longrightarrow> ipoly (min_int_poly x) (x :: 'a :: {field_gcd, field_char_0}) = 0"
  using min_int_poly_represents[of x] by (auto simp: represents_def)

lemma min_int_poly_nonzero [simp]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "min_int_poly x \<noteq> 0"
  using lead_coeff_min_int_poly_pos[of x] by auto

lemma min_int_poly_normalize [simp]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "normalize (min_int_poly x) = min_int_poly x"
  unfolding normalize_poly_def using lead_coeff_min_int_poly_pos[of x] by simp

lemma min_int_poly_prime_elem [intro]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "prime_elem (min_int_poly x)"
  using min_int_poly_irreducible[of x] by blast

lemma min_int_poly_prime [intro]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  shows "prime (min_int_poly x)"
  using min_int_poly_prime_elem[of x]
  by (simp only: prime_normalize_iff [symmetric] min_int_poly_normalize)

lemma min_int_poly_unique:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  assumes "p represents x" "irreducible p" "lead_coeff p > 0"
  shows "min_int_poly x = p"
proof -
  from assms(1) have x: "algebraic x"
    using algebraic_iff_represents by blast
  thus ?thesis
    using the1_equality[OF algebraic_imp_represents_unique[OF x], of p] assms
    unfolding min_int_poly_def by auto
qed

lemma min_int_poly_of_int [simp]:
  "min_int_poly (of_int n :: 'a :: {field_char_0, field_gcd}) = [:-of_int n, 1:]"
  by (intro min_int_poly_unique irreducible_linear_poly) auto

lemma min_int_poly_of_nat [simp]:
  "min_int_poly (of_nat n :: 'a :: {field_char_0, field_gcd}) = [:-of_nat n, 1:]"
  using min_int_poly_of_int[of "int n"] by (simp del: min_int_poly_of_int)

lemma min_int_poly_0 [simp]: "min_int_poly (0 :: 'a :: {field_char_0, field_gcd}) = [:0, 1:]"
  using min_int_poly_of_int[of 0] unfolding of_int_0 by simp

lemma min_int_poly_1 [simp]: "min_int_poly (1 :: 'a :: {field_char_0, field_gcd}) = [:-1, 1:]"
  using min_int_poly_of_int[of 1] unfolding of_int_1 by simp

lemma poly_min_int_poly_0_eq_0_iff [simp]:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  assumes "algebraic x"
  shows "poly (min_int_poly x) 0 = 0 \<longleftrightarrow> x = 0"
proof
  assume *: "poly (min_int_poly x) 0 = 0"
  show "x = 0"
  proof (rule ccontr)
    assume "x \<noteq> 0"
    hence "poly (min_int_poly x) 0 \<noteq> 0"
      using assms by (intro represents_irr_non_0) auto
    with * show False by contradiction
  qed
qed auto

lemma min_int_poly_eqI:
  fixes x :: "'a :: {field_char_0, field_gcd}"
  assumes "p represents x" "irreducible p" "lead_coeff p \<ge> 0"
  shows   "min_int_poly x = p"
proof -
  from assms have [simp]: "p \<noteq> 0"
    by auto
  have "lead_coeff p \<noteq> 0"
    by auto
  with assms(3) have "lead_coeff p > 0"
    by linarith
  moreover have "algebraic x"
    using \<open>p represents x\<close> by (meson algebraic_iff_represents)
  ultimately show ?thesis
    unfolding min_int_poly_def
    using the1_equality[OF algebraic_imp_represents_unique[OF \<open>algebraic x\<close>], of p] assms by auto
qed

text \<open>Implementation for real and rational numbers\<close>

lemma min_int_poly_of_rat: "min_int_poly (of_rat r :: 'a :: {field_char_0, field_gcd}) = poly_rat r"
  by (intro min_int_poly_unique, auto)

definition min_int_poly_real :: "real \<Rightarrow> int poly" where
  [simp]: "min_int_poly_real = min_int_poly"

lemma min_int_poly_real_code_unfold [code_unfold]: "min_int_poly = min_int_poly_real"
  by simp

lemma min_int_poly_real_basic_impl[code]: "min_int_poly_real (real_of_rat x) = poly_rat x"
  unfolding min_int_poly_real_def by (rule min_int_poly_of_rat)

lemma min_int_poly_rat_code_unfold [code_unfold]: "min_int_poly = poly_rat"
  by (intro ext, insert min_int_poly_of_rat[where ?'a = rat], auto)

end


theory Funpow
imports
  "HOL-Library.FuncSet"
  "HOL-Library.Permutations"
begin

section \<open>Auxiliary Lemmas about @{term "op ^^"}\<close>

lemma funpow_simp_l: "f ((f ^^ n) x) = (f ^^ Suc n) x"
  by (metis comp_apply funpow.simps(2))

lemma funpow_add_app: "(f ^^ n) ((f ^^ m) x) = (f ^^ (n + m)) x"
  by (metis comp_apply funpow_add)

lemma funpow_mod_eq:
  assumes "(f ^^ n) x = x" "0 < n" shows "(f ^^ (m mod n)) x = (f ^^ m) x"
proof (induct m rule: less_induct)
  case (less m)
  { assume "m < n" then have ?case by simp }
  moreover
  { assume "m = n" then have ?case by (simp add: \<open>_ = x\<close>)}
  moreover
  { assume "n < m"
    then have "m - n < m" "0 < m - n"  using \<open>0 < n\<close> by arith+

    have "(f ^^ (m mod n)) x = (f ^^ ((m - n) mod n)) x"
      using \<open>0 < m - n\<close> by (simp add: mod_geq)
    also have "\<dots> = (f ^^ (m - n)) x"
      using \<open>m - n < m\<close> by (rule less)
    also have "\<dots> = (f ^^ (m - n)) ((f ^^ n) x)"
      by (simp add: assms)
    also have "\<dots> = (f ^^ m) x"
      using \<open>0 < m - n\<close> by (simp add: funpow_add_app)
    finally have ?case . }
  ultimately show ?case by (metis linorder_neqE_nat)
qed

lemma id_funpow_id:
  assumes "f x = x" shows "(f ^^ n) x = x"
  using assms by (induct n) auto

lemma inv_id_abs[simp]: "inv (\<lambda>a. a) = id" unfolding id_def[symmetric] by simp

lemma inj_funpow:
  fixes f :: "'a \<Rightarrow> 'a"
  assumes "inj f" shows "inj (f ^^ n)"
proof (induct n)
  case 0 then show ?case by (auto simp: id_def[symmetric])
next
  case (Suc n) with assms show ?case unfolding funpow.simps by (rule inj_comp)
qed

lemma funpow_inj_finite:
  assumes "inj p" "finite {(p ^^ n) x |n. True}"
  shows "\<exists>n>0. (p ^^ n) x = x"
proof -
  have "\<not>finite {0::nat..}" by simp
  moreover
  have "{(p ^^ n) x |n. True} = (\<lambda>n. (p ^^ n) x) ` {0..}" by auto
  with assms have "finite \<dots>" by simp
  ultimately have "\<exists>n\<in>{0..}. \<not> finite {m \<in> {0..}. (p ^^ m) x = (p ^^ n) x}"
    by (rule pigeonhole_infinite)
  then obtain n where "\<not>finite {m. (p ^^ m) x = (p ^^ n) x}" by auto
  then have "\<not>finite ({m. (p ^^ m) x = (p ^^ n) x} - {n})" by auto
  then have "({m. (p ^^ m) x = (p ^^ n) x} - {n}) \<noteq> {}"
    by (metis finite.emptyI)
  then obtain m where m: "(p ^^ m) x = (p ^^ n) x" "m \<noteq> n" by auto

  { fix m n assume "(p ^^ n) x = (p ^^ m) x" "m < n"
    have "(p ^^ (n - m)) x = inv (p ^^ m) ((p ^^ m) ((p ^^ (n - m)) x))"
      using \<open>inj p\<close> by (simp add: inv_f_f inj_funpow)
    also have "((p ^^ m) ((p ^^ (n - m)) x)) = (p ^^ n) x"
      using `m < n` by (simp add: funpow_add_app)
    also have "inv (p ^^ m) \<dots> = x"
      using \<open>inj p\<close>  by (simp add: \<open>(p ^^ n) x = _\<close> inj_funpow)
    finally have "(p ^^ (n - m)) x = x" "0 < n - m"
      using \<open>m < n\<close> by auto }
  note general = this

  show ?thesis
  proof (cases m n rule: linorder_cases)
    case less
    then show ?thesis using general m by metis
  next
    case equal
    then show ?thesis using m by metis
  next
    case greater
    then show ?thesis using general m by metis
  qed
qed

lemma permutes_in_funpow_image:
  assumes "f permutes S" "x \<in> S"
  shows "(f ^^ n) x \<in> S"
  using assms by (induct n) (auto simp: permutes_in_image)

(* XXX move*)
lemma permutation_self:
  assumes "permutation p" shows "\<exists>n>0. (p ^^ n) x = x"
proof cases
  assume "p x = x" then show ?thesis by auto
next
  assume "p x \<noteq> x"
  from assms have "inj p" by (intro permutation_bijective bij_is_inj)
  { fix n
    from \<open>p x \<noteq> x\<close> have "(p ^^ Suc n) x \<noteq> (p ^^ n) x"
    proof (induct n arbitrary: x)
      case 0 then show ?case by simp
    next
      case (Suc n)
      have "p (p x) \<noteq> p x"
      proof (rule notI)
        assume "p (p x) = p x"
        then show False using \<open>p x \<noteq> x\<close> \<open>inj p\<close> by (simp add: inj_eq)
      qed
      have "(p ^^ Suc (Suc n)) x = (p ^^ Suc n) (p x)"
        by (metis funpow_simp_l funpow_swap1)
      also have "\<dots> \<noteq> (p ^^ n) (p x)"
        by (rule Suc) fact
      also have "(p ^^ n) (p x) = (p ^^ Suc n) x"
        by (metis funpow_simp_l funpow_swap1)
      finally show ?case by simp
    qed }
  then have "{(p ^^ n) x | n. True} \<subseteq> {x. p x \<noteq> x}"
    by auto
  then have "finite {(p ^^ n) x | n. True}"
    using permutation_finite_support[OF assms] by (rule finite_subset)
  with \<open>inj p\<close> show ?thesis by (rule funpow_inj_finite)
qed

(* XXX move *)
lemma (in -) funpow_invs:
  assumes "m \<le> n" and inv: "\<And>x. f (g x) = x"
  shows "(f ^^ m) ((g ^^ n) x) = (g ^^ (n - m)) x"
  using \<open>m \<le> n\<close>
proof (induction m)
  case (Suc m)
  moreover then have "n - m = Suc (n - Suc m)" by auto
  ultimately show ?case by (auto simp: inv)
qed simp

section \<open>Function-power distance between values\<close>

(* xxx move *)
definition funpow_dist :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "funpow_dist f x y \<equiv> LEAST n. (f ^^ n) x = y"

abbreviation funpow_dist1 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "funpow_dist1 f x y \<equiv> Suc (funpow_dist f (f x) y)"

lemma funpow_dist_0:
  assumes "x = y" shows "funpow_dist f x y = 0"
  using assms unfolding funpow_dist_def by (intro Least_eq_0) simp

lemma funpow_dist_least:
  assumes "n < funpow_dist f x y" shows "(f ^^ n) x \<noteq> y"
proof (rule notI)
  assume "(f ^^ n) x = y"
  then have "funpow_dist f x y \<le> n" unfolding funpow_dist_def by (rule Least_le)
  with assms show False by linarith
qed

lemma funpow_dist1_least:
  assumes "0 < n" "n < funpow_dist1 f x y" shows "(f ^^ n) x \<noteq> y"
proof (rule notI)
  assume "(f ^^ n) x = y"
  then have "(f ^^ (n - 1)) (f x) = y"
    using \<open>0 < n\<close> by (cases n) (simp_all add: funpow_swap1)
  then have "funpow_dist f (f x) y \<le> n - 1" unfolding funpow_dist_def by (rule Least_le)
  with assms show False by simp
qed

section \<open>Cyclic Permutations\<close>

inductive_set orbit :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a set" for f x where
  base: "f x \<in> orbit f x" |
  step: "y \<in> orbit f x \<Longrightarrow> f y \<in> orbit f x"

definition cyclic_on :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "cyclic_on f S \<longleftrightarrow> (\<exists>s\<in>S. S = orbit f s)"

lemma orbit_altdef: "orbit f x = {(f ^^ n) x | n. 0 < n}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix y assume "y \<in> ?L" then show "y \<in> ?R"
    by (induct rule: orbit.induct) (auto simp: exI[where x=1] exI[where x="Suc n" for n])
next
  fix y assume "y \<in> ?R"
  then obtain n where "y = (f ^^ n) x" "0 < n" by blast
  then show "y \<in> ?L"
  proof (induction n arbitrary: y)
    case (Suc n) then show ?case by (cases "n = 0") (auto intro: orbit.intros)
  qed simp
qed

lemma orbit_trans:
  assumes "s \<in> orbit f t" "t \<in> orbit f u" shows "s \<in> orbit f u"
  using assms by induct (auto intro: orbit.intros)

lemma orbit_subset:
  assumes "s \<in> orbit f (f t)" shows "s \<in> orbit f t"
  using assms by (induct) (auto intro: orbit.intros)

lemma orbit_sim_step:
  assumes "s \<in> orbit f t" shows "f s \<in> orbit f (f t)"
  using assms by induct (auto intro: orbit.intros)

lemma orbit_step:
  assumes "y \<in> orbit f x" "f x \<noteq> y" shows "y \<in> orbit f (f x)"
  using assms
proof induction
  case (step y) then show ?case by (cases "x = y") (auto intro: orbit.intros)
qed simp

lemma self_in_orbit_trans:
  assumes "s \<in> orbit f s" "t \<in> orbit f s" shows "t \<in> orbit f t"
  using assms(2,1) by induct (auto intro: orbit_sim_step)

lemma orbit_swap:
  assumes "s \<in> orbit f s" "t \<in> orbit f s" shows "s \<in> orbit f t"
  using assms(2,1)
proof induction
  case base then show ?case by (cases "f s = s") (auto intro: orbit_step)
next
  case (step x) then show ?case by (cases "f x = s") (auto intro: orbit_step)
qed

lemma permutation_self_in_orbit:
  assumes "permutation f" shows "s \<in> orbit f s"
  unfolding orbit_altdef using permutation_self[OF assms, of s] by simp metis

lemma orbit_altdef_self_in:
  assumes "s \<in> orbit f s" shows "orbit f s = {(f ^^ n) s | n. True}"
proof (intro set_eqI iffI)
  fix x assume "x \<in> {(f ^^ n) s | n. True}"
  then obtain n where "x = (f ^^ n) s" by auto
  then show "x \<in> orbit f s" using assms by (cases "n = 0") (auto simp: orbit_altdef)
qed (auto simp: orbit_altdef)

lemma orbit_altdef_permutation:
  assumes "permutation f" shows "orbit f s = {(f ^^ n) s | n. True}"
  using assms by (intro orbit_altdef_self_in permutation_self_in_orbit)

lemma orbit_altdef_bounded:
  assumes "(f ^^ n) s = s" "0 < n" shows "orbit f s = {(f ^^ m) s| m. m < n}"
proof -
  from assms have "s \<in> orbit f s" unfolding orbit_altdef by auto metis
  then have "orbit f s = {(f ^^ m) s|m. True}" by (rule orbit_altdef_self_in)
  also have "\<dots> = {(f ^^ m) s| m. m < n}"
    using assms by (auto simp: funpow_mod_eq intro: exI[where x="m mod n" for m])
  finally show ?thesis .
qed

lemma funpow_in_orbit:
  assumes "s \<in> orbit f t" shows "(f ^^ n) s \<in> orbit f t"
  using assms by (induct n) (auto intro: orbit.intros)

lemma finite_orbit:
  assumes "s \<in> orbit f s" shows "finite (orbit f s)"
proof -
  from assms obtain n where n: "0 < n" "(f ^^n) s = s" by (auto simp: orbit_altdef)
  then show ?thesis by (auto simp: orbit_altdef_bounded)
qed

lemma self_in_orbit_step:
  assumes "s \<in> orbit f s" shows "orbit f (f s) = orbit f s"
proof (intro set_eqI iffI)
  fix t assume "t \<in> orbit f s" then show "t \<in> orbit f (f s)"
    using assms by (auto intro: orbit_step orbit_sim_step)
qed (auto intro: orbit_subset)

lemma permutation_orbit_step:
  assumes "permutation f" shows "orbit f (f s) = orbit f s"
  using assms by (intro self_in_orbit_step permutation_self_in_orbit)

lemma orbit_nonempty:
  "orbit f s \<noteq> {}"
  using orbit.base by fastforce

lemma orbit_inv_eq:
  assumes "permutation f"
  shows "orbit (inv f) x = orbit f x" (is "?L = ?R")
proof -
  { fix g y assume A: "permutation g" "y \<in> orbit (inv g) x"
    have "y \<in> orbit g x"
    proof -
      have inv_g: "\<And>y. x = g y \<Longrightarrow> inv g x = y" "\<And>y. inv g (g y) = y"
        by (metis A(1) bij_inv_eq_iff permutation_bijective)+

      { fix y assume "y \<in> orbit g x"
        then have "inv g y \<in> orbit g x"
          by (cases) (simp_all add: inv_g A(1) permutation_self_in_orbit)
      } note inv_g_in_orb = this

      from A(2) show ?thesis
        by induct (simp_all add: inv_g_in_orb A permutation_self_in_orbit)
    qed
  } note orb_inv_ss = this

  have "inv (inv f) = f"
    by (simp add: assms inv_inv_eq permutation_bijective)
  then show ?thesis
    using orb_inv_ss[OF assms] orb_inv_ss[OF permutation_inverse[OF assms]] by auto
qed

lemma cyclic_on_alldef:
  "cyclic_on f S \<longleftrightarrow> S \<noteq> {} \<and> (\<forall>s\<in>S. S = orbit f s)"
  unfolding cyclic_on_def by (auto intro: orbit.step orbit_swap orbit_trans)

lemma cyclic_on_funpow_in:
  assumes "cyclic_on f S" "s \<in> S" shows "(f^^n) s \<in> S"
  using assms unfolding cyclic_on_def by (auto intro: funpow_in_orbit)

lemma finite_cyclic_on:
  assumes "cyclic_on f S" shows "finite S"
  using assms by (auto simp: cyclic_on_def finite_orbit)

lemma cyclic_on_singleI:
  assumes "s \<in> S" "S = orbit f s" shows "cyclic_on f S"
  using assms unfolding cyclic_on_def by blast

lemma inj_on_funpow_least:
  assumes "(f ^^ n) s = s" "\<And>m. \<lbrakk>m < n; 0 < m\<rbrakk> \<Longrightarrow> (f ^^ m) s \<noteq> s"
  shows "inj_on (\<lambda>k. (f^^k) s) {0..<n}"
proof -
  { fix k l assume A: "k < n" "l < n" "k \<noteq> l" "(f ^^ k) s = (f ^^ l) s"
    def k' \<equiv> "min k l" and l' \<equiv> "max k l"
    with A have A': "k' < l'" "(f ^^ k') s = (f ^^ l') s" "l' < n"
      by (auto simp: min_def max_def)

    have "s = (f ^^ ((n - l') + l')) s" using assms \<open>l' < n\<close> by simp
    also have "\<dots> = (f ^^ (n - l')) ((f ^^ l') s)" by (simp add: funpow_add)
    also have "(f ^^ l') s = (f ^^ k') s" by (simp add: A')
    also have "(f ^^ (n - l')) \<dots> = (f ^^ (n - l' + k')) s" by (simp add: funpow_add)
    finally have "(f ^^ (n - l' + k')) s = s" by simp
    moreover have "n - l' + k' < n" "0 < n - l' + k'"using A' by linarith+
    ultimately have False using assms(2) by auto
  }
  then show ?thesis by (intro inj_onI) auto
qed

lemma cyclic_on_inI:
  assumes "cyclic_on f S" "s \<in> S" shows "f s \<in> S"
  using assms by (auto simp: cyclic_on_def intro: orbit.intros)

lemma bij_betw_funpow:
  assumes "bij_betw f S S" shows "bij_betw (f ^^ n) S S"
proof (induct n)
  case 0 then show ?case by (auto simp: id_def[symmetric])
next
  case (Suc n)
  then show ?case unfolding funpow.simps using assms by (rule bij_betw_trans)
qed

(*XXX rename move*)
lemma orbit_FOO:
  assumes self:"a \<in> orbit g a"
    and eq: "\<And>x. x \<in> orbit g a \<Longrightarrow>  g' (f x) = f (g x)"
  shows "f ` orbit g a = orbit g' (f a)" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix x assume "x \<in> ?L"
  then obtain x0 where "x0 \<in> orbit g a" "x = f x0" by auto
  then show "x \<in> ?R"
  proof (induct arbitrary: x)
    case base then show ?case by (auto simp: self orbit.base eq[symmetric])
  next
    case step then show ?case by cases (auto simp: eq[symmetric] orbit.intros)
  qed
next
  fix x assume "x \<in> ?R"
  then show "x \<in> ?L"
  proof (induct arbitrary: )
    case base then show ?case by (auto simp: self orbit.base eq)
  next
    case step then show ?case by cases (auto simp: eq orbit.intros)
  qed
qed

lemma cyclic_on_FOO:
  assumes "cyclic_on f S"
  assumes "\<And>x. x \<in> S \<Longrightarrow> g (h x) = h (f x)"
  shows "cyclic_on g (h ` S)"
  using assms by (auto simp: cyclic_on_def) (meson orbit_FOO)

lemma cyclic_on_f_in:
  assumes "f permutes S" "cyclic_on f A" "f x \<in> A"
  shows "x \<in> A"
proof -
  from assms have fx_in_orb: "f x \<in> orbit f (f x)" by (auto simp: cyclic_on_alldef)
  from assms have "A = orbit f (f x)" by (auto simp: cyclic_on_alldef)
  moreover
  then have "\<dots> = orbit f x" using \<open>f x \<in> A\<close> by (auto intro: orbit_step orbit_subset)
  ultimately
    show ?thesis by (metis (no_types) orbit.simps permutes_inverses(2)[OF assms(1)])
qed

lemma permutes_not_in:
  assumes "f permutes S" "x \<notin> S" shows "f x = x"
  using assms by (auto simp: permutes_def)

lemma orbit_cong0:
  assumes "x \<in> A" "f \<in> A \<rightarrow> A" "\<And>y. y \<in> A \<Longrightarrow> f y = g y" shows "orbit f x = orbit g x"
proof -
  { fix n have "(f ^^ n) x = (g ^^ n) x \<and> (f ^^ n) x \<in> A"
      by (induct n rule: nat.induct) (insert assms, auto)
  } then show ?thesis by (auto simp: orbit_altdef)
qed

lemma orbit_cong:
  assumes self_in: "t \<in> orbit f t" and eq: "\<And>s. s \<in> orbit f t \<Longrightarrow> g s = f s"
  shows "orbit g t = orbit f t"
  using assms(1) _ assms(2) by (rule orbit_cong0) (auto simp: orbit.step eq)

lemma cyclic_cong:
  assumes "\<And>s. s \<in> S \<Longrightarrow> f s = g s" shows "cyclic_on f S = cyclic_on g S"
proof -
  have "(\<exists>s\<in>S. orbit f s = orbit g s) \<Longrightarrow> cyclic_on f S = cyclic_on g S"
    by (metis cyclic_on_alldef cyclic_on_def)
  then show ?thesis by (metis assms orbit_cong cyclic_on_def)
qed

lemma permutes_comp_preserves_cyclic1:
  assumes "g permutes B" "cyclic_on f C"
  assumes "A \<inter> B = {}" "C \<subseteq> A"
  shows "cyclic_on (f o g) C"
proof -
  have *: "\<And>c. c \<in> C \<Longrightarrow> f (g c) = f c"
    using assms by (subst permutes_not_in[where f=g]) auto
  with assms(2) show ?thesis by (simp cong: cyclic_cong)
qed

lemma permutes_comp_preserves_cyclic2:
  assumes "f permutes A" "cyclic_on g C"
  assumes "A \<inter> B = {}" "C \<subseteq> B"
  shows "cyclic_on (f o g) C"
proof -
  obtain c where c: "c \<in> C" "C = orbit g c" "c \<in> orbit g c"
    using \<open>cyclic_on g C\<close> by (auto simp: cyclic_on_def)
  then have "\<And>c. c \<in> C \<Longrightarrow> f (g c) = g c"
    using assms c by (subst permutes_not_in[where f=f]) (auto intro: orbit.intros)
  with assms(2) show ?thesis by (simp cong: cyclic_cong)
qed

(*XXX merge with previous section?*)
subsection \<open>Orbits\<close>

lemma permutes_orbit_subset:
  assumes "f permutes S" "x \<in> S" shows "orbit f x \<subseteq> S"
proof
  fix y assume "y \<in> orbit f x"
  then show "y \<in> S" by induct (auto simp: permutes_in_image assms)
qed

lemma cyclic_on_orbit':
  assumes "permutation f" shows "cyclic_on f (orbit f x)"
  unfolding cyclic_on_alldef using orbit_nonempty[of f x]
  by (auto intro: assms orbit_swap orbit_trans permutation_self_in_orbit)

(* XXX remove? *)
lemma cyclic_on_orbit:
  assumes "f permutes S" "finite S" shows "cyclic_on f (orbit f x)"
  using assms by (intro cyclic_on_orbit') (auto simp: permutation_permutes)

lemma orbit_cyclic_eq3:
  assumes "cyclic_on f S" "y \<in> S" shows "orbit f y = S"
  using assms unfolding cyclic_on_alldef by simp

(*XXX move*)
lemma orbit_eq_singleton_iff: "orbit f x = {x} \<longleftrightarrow> f x = x" (is "?L \<longleftrightarrow> ?R")
proof
  assume A: ?R
  { fix y assume "y \<in> orbit f x" then have "y = x"
      by induct (auto simp: A)
  } then show ?L by (metis orbit_nonempty singletonI subsetI subset_singletonD)
next
  assume A: ?L
  then have "\<And>y. y \<in> orbit f x \<Longrightarrow> f x = y"
    by - (erule orbit.cases, simp_all)
  then show ?R using A by blast
qed

(* XXX move *)
lemma eq_on_cyclic_on_iff1:
  assumes "cyclic_on f S" "x \<in> S"
  obtains "f x \<in> S" "f x = x \<longleftrightarrow> card S = 1"
proof
  from assms show "f x \<in> S" by (auto simp: cyclic_on_def intro: orbit.intros)
  from assms have "S = orbit f x" by (auto simp: cyclic_on_alldef)
  then have "f x = x \<longleftrightarrow> S = {x}" by (metis orbit_eq_singleton_iff)
  then show "f x = x \<longleftrightarrow> card S = 1" using \<open>x \<in> S\<close> by (auto simp: card_Suc_eq)
qed

subsection \<open>Decomposition of Arbitrary Permutations\<close>

definition perm_restrict :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "perm_restrict f S x \<equiv> if x \<in> S then f x else x"

lemma perm_restrict_comp:
  assumes "A \<inter> B = {}" "cyclic_on f B"
  shows "perm_restrict f A o perm_restrict f B = perm_restrict f (A \<union> B)"
proof -
  have "\<And>x. x \<in> B \<Longrightarrow> f x \<in> B" using \<open>cyclic_on f B\<close> by (rule cyclic_on_inI)
  with assms show ?thesis by (auto simp: perm_restrict_def fun_eq_iff)
qed

lemma perm_restrict_simps:
  "x \<in> S \<Longrightarrow> perm_restrict f S x = f x"
  "x \<notin> S \<Longrightarrow> perm_restrict f S x = x"
  by (auto simp: perm_restrict_def)

lemma perm_restrict_perm_restrict:
  "perm_restrict (perm_restrict f A) B = perm_restrict f (A \<inter> B)"
  by (auto simp: perm_restrict_def)

lemma perm_restrict_union:
  assumes "perm_restrict f A permutes A" "perm_restrict f B permutes B" "A \<inter> B = {}"
  shows "perm_restrict f A o perm_restrict f B = perm_restrict f (A \<union> B)"
  using assms by (auto simp: fun_eq_iff perm_restrict_def permutes_def) (metis Diff_iff Diff_triv)

lemma perm_restrict_id[simp]:
  assumes "f permutes S" shows "perm_restrict f S = f"
  using assms by (auto simp: permutes_def perm_restrict_def)

lemma cyclic_on_perm_restrict:
  "cyclic_on (perm_restrict f S) S \<longleftrightarrow> cyclic_on f S"
  by (simp add: perm_restrict_def cong: cyclic_cong)

lemma perm_restrict_diff_cyclic:
  assumes "f permutes S" "cyclic_on f A"
  shows "perm_restrict f (S - A) permutes (S - A)"
proof -
  { fix y
    have "\<exists>x. perm_restrict f (S - A) x = y"
    proof cases
      assume A: "y \<in> S - A"
      with \<open>f permutes S\<close> obtain x where "f x = y" "x \<in> S"
        unfolding permutes_def by auto metis
      moreover
      with A have "x \<notin> A" by (metis Diff_iff assms(2) cyclic_on_inI)
      ultimately
      have "perm_restrict f (S - A) x = y"  by (simp add: perm_restrict_simps)
      then show ?thesis ..
    next
      assume "y \<notin> S - A"
      then have "perm_restrict f (S - A) y = y" by (simp add: perm_restrict_simps)
      then show ?thesis ..
    qed
  } note X = this

  { fix x y assume "perm_restrict f (S - A) x = perm_restrict f (S - A) y"
    with assms have "x = y"
      by (auto simp: perm_restrict_def permutes_def split: if_splits intro: cyclic_on_f_in)
  } note Y = this

  show ?thesis by (auto simp: permutes_def perm_restrict_simps X intro: Y)
qed

lemma orbit_eqI:
  "y = f x \<Longrightarrow> y \<in> orbit f x"
  "z = f y \<Longrightarrow>y \<in> orbit f x \<Longrightarrow>z \<in> orbit f x"
  by (metis orbit.base) (metis orbit.step)

lemma permutes_decompose:
  assumes "f permutes S" "finite S"
  shows "\<exists>C. (\<forall>c \<in> C. cyclic_on f c) \<and> \<Union>C = S \<and> (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {})"
  using assms(2,1)
proof (induction arbitrary: f rule: finite_psubset_induct)
  case (psubset S)

  show ?case
  proof (cases "S = {}")
    case True then show ?thesis by (intro exI[where x="{}"]) auto
  next
    case False
    then obtain s where "s \<in> S" by auto
    with `f permutes S` have "orbit f s \<subseteq> S"
      by (rule permutes_orbit_subset)
    have cyclic_orbit: "cyclic_on f (orbit f s)"
      using \<open>f permutes S\<close> \<open>finite S\<close> by (rule cyclic_on_orbit)

    let ?f' = "perm_restrict f (S - orbit f s)"

    have "f s \<in> S" using \<open>f permutes S\<close> \<open>s \<in> S\<close> by (auto simp: permutes_in_image)
    then have "S - orbit f s \<subset> S" using orbit.base[of f s] \<open>s \<in> S\<close> by blast
    moreover
    have "?f' permutes (S - orbit f s)"
      using \<open>f permutes S\<close> cyclic_orbit by (rule perm_restrict_diff_cyclic)
    ultimately
    obtain C where C: "\<And>c. c \<in> C \<Longrightarrow> cyclic_on ?f' c" "\<Union>C = S - orbit f s"
        "\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}"
      using psubset.IH by metis

    { fix c assume "c \<in> C"
      then have *: "\<And>x. x \<in> c \<Longrightarrow> perm_restrict f (S - orbit f s) x = f x"
        using C(2) \<open>f permutes S\<close> by (auto simp add: perm_restrict_def)
      then have "cyclic_on f c" using C(1)[OF \<open>c \<in> C\<close>] by (simp cong: cyclic_cong add: *)
    } note in_C_cyclic = this

    have Un_ins: "\<Union>insert (orbit f s) C = S"
      using \<open>\<Union>C = _\<close>  \<open>orbit f s \<subseteq> S\<close> by blast

    have Disj_ins: "(\<forall>c1 \<in> insert (orbit f s) C. \<forall>c2 \<in> insert (orbit f s) C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {})"
      using C by auto

    show ?thesis
      by (intro conjI Un_ins Disj_ins exI[where x="insert (orbit f s) C"])
        (auto simp: cyclic_orbit in_C_cyclic)
  qed
qed

subsection \<open>Funpow + Orbit\<close>

lemma funpow_dist_prop:
  "y \<in> orbit f x \<Longrightarrow> (f ^^ funpow_dist f x y) x = y"
  unfolding funpow_dist_def by (rule LeastI_ex) (auto simp: orbit_altdef)

lemma funpow_dist_0_eq:
  assumes "y \<in> orbit f x" shows "funpow_dist f x y = 0 \<longleftrightarrow> x = y"
  using assms by (auto simp: funpow_dist_0 dest: funpow_dist_prop)

lemma funpow_dist_step:
  assumes "x \<noteq> y" "y \<in> orbit f x" shows "funpow_dist f x y = Suc (funpow_dist f (f x) y)"
proof -
  from \<open>y \<in> _\<close> obtain n where "(f ^^ n) x = y" by (auto simp: orbit_altdef)
  with \<open>x \<noteq> y\<close> obtain n' where [simp]: "n = Suc n'" by (cases n) auto

  show ?thesis
    unfolding funpow_dist_def
  proof (rule Least_Suc2)
    show "(f ^^ n) x = y" by fact
    then show "(f ^^ n') (f x) = y" by (simp add: funpow_swap1)
    show "(f ^^ 0) x \<noteq> y" using \<open>x \<noteq> y\<close> by simp
    show "\<forall>k. ((f ^^ Suc k) x = y) = ((f ^^ k) (f x) = y)"
      by (simp add: funpow_swap1)
  qed
qed

lemma funpow_dist1_prop:
  assumes "y \<in> orbit f x" shows "(f ^^ funpow_dist1 f x y) x = y"
  by (metis assms funpow.simps(1) funpow_dist_0 funpow_dist_prop funpow_simp_l funpow_swap1 id_apply orbit_step)

(*XXX simplify? *)
lemma funpow_neq_less_funpow_dist:
  assumes "y \<in> orbit f x" "m \<le> funpow_dist f x y" "n \<le> funpow_dist f x y" "m \<noteq> n"
  shows "(f ^^ m) x \<noteq> (f ^^ n) x"
proof (rule notI)
  assume A: "(f ^^ m) x = (f ^^ n) x"

  def m' \<equiv> "min m n" and n' \<equiv> "max m n"
  with A assms have A': "m' < n'" "(f ^^ m') x = (f ^^ n') x" "n' \<le> funpow_dist f x y"
    by (auto simp: min_def max_def)

  have "y = (f ^^ funpow_dist f x y) x"
    using \<open>y \<in> _\<close> by (simp only: funpow_dist_prop)
  also have "\<dots> = (f ^^ ((funpow_dist f x y - n') + n')) x"
    using \<open>n' \<le> _\<close> by simp
  also have "\<dots> = (f ^^ ((funpow_dist f x y - n') + m')) x"
    by (simp add: funpow_add \<open>(f ^^ m') x = _\<close>)
  also have "(f ^^ ((funpow_dist f x y - n') + m')) x \<noteq> y"
    using A' by (intro funpow_dist_least) linarith
  finally show "False" by simp
qed

(* XXX reduce to funpow_neq_less_funpow_dist? *)
lemma funpow_neq_less_funpow_dist1:
  assumes "y \<in> orbit f x" "m < funpow_dist1 f x y" "n < funpow_dist1 f x y" "m \<noteq> n"
  shows "(f ^^ m) x \<noteq> (f ^^ n) x"
proof (rule notI)
  assume A: "(f ^^ m) x = (f ^^ n) x"

  def m' \<equiv> "min m n" and n' \<equiv> "max m n"
  with A assms have A': "m' < n'" "(f ^^ m') x = (f ^^ n') x" "n' < funpow_dist1 f x y"
    by (auto simp: min_def max_def)

  have "y = (f ^^ funpow_dist1 f x y) x"
    using \<open>y \<in> _\<close> by (simp only: funpow_dist1_prop)
  also have "\<dots> = (f ^^ ((funpow_dist1 f x y - n') + n')) x"
    using \<open>n' < _\<close> by simp
  also have "\<dots> = (f ^^ ((funpow_dist1 f x y - n') + m')) x"
    by (simp add: funpow_add \<open>(f ^^ m') x = _\<close>)
  also have "(f ^^ ((funpow_dist1 f x y - n') + m')) x \<noteq> y"
    using A' by (intro funpow_dist1_least) linarith+
  finally show "False" by simp
qed

lemma inj_on_funpow_dist:
  assumes "y \<in> orbit f x" shows "inj_on (\<lambda>n. (f ^^ n) x) {0..funpow_dist f x y}"
  using funpow_neq_less_funpow_dist[OF assms] by (intro inj_onI) auto

lemma orbit_conv_funpow_dist1:
  assumes "x \<in> orbit f x"
  shows "orbit f x = (\<lambda>n. (f ^^ n) x) ` {0..<funpow_dist1 f x x}" (is "?L = ?R")
  using funpow_dist1_prop[OF assms]
  by (auto simp: orbit_altdef_bounded[where n="funpow_dist1 f x x"])

lemma funpow_dist1_prop1:
  assumes "(f ^^ n) x = y" "0 < n" shows "(f ^^ funpow_dist1 f x y) x = y"
proof -
  from assms have "y \<in> orbit f x" by (auto simp: orbit_altdef)
  then show ?thesis by (rule funpow_dist1_prop)
qed

lemma funpow_dist1_dist:
  assumes "funpow_dist1 f x y < funpow_dist1 f x z"
  assumes "{y,z} \<subseteq> orbit f x"
  shows "funpow_dist1 f x z = funpow_dist1 f x y + funpow_dist1 f y z" (is "?L = ?R")
proof -
  have x_z: "(f ^^ funpow_dist1 f x z) x = z" using assms by (blast intro: funpow_dist1_prop)
  have x_y: "(f ^^ funpow_dist1 f x y) x = y" using assms by (blast intro: funpow_dist1_prop)

  have "(f ^^ (funpow_dist1 f x z - funpow_dist1 f x y)) y
      = (f ^^ (funpow_dist1 f x z - funpow_dist1 f x y)) ((f ^^ funpow_dist1 f x y) x)"
    using x_y by simp
  also have "\<dots> = z"
    using assms x_z by (simp del: funpow.simps add: funpow_add_app)
  finally have y_z_diff: "(f ^^ (funpow_dist1 f x z - funpow_dist1 f x y)) y = z" .
  then have "(f ^^ funpow_dist1 f y z) y = z"
    using assms by (intro funpow_dist1_prop1) auto
  then have "(f ^^ funpow_dist1 f y z) ((f ^^ funpow_dist1 f x y) x) = z"
    using x_y by simp
  then have "(f ^^ (funpow_dist1 f y z + funpow_dist1 f x y)) x = z"
    by (simp del: funpow.simps add: funpow_add_app)

  show ?thesis
  proof (rule antisym)
    from y_z_diff have "(f ^^ funpow_dist1 f y z) y = z"
      using assms by (intro funpow_dist1_prop1) auto
    then have "(f ^^ funpow_dist1 f y z) ((f ^^ funpow_dist1 f x y) x) = z"
      using x_y by simp
    then have "(f ^^ (funpow_dist1 f y z + funpow_dist1 f x y)) x = z"
      by (simp del: funpow.simps add: funpow_add_app)
    then have "funpow_dist1 f x z \<le> funpow_dist1 f y z + funpow_dist1 f x y"
      using funpow_dist1_least not_less by fastforce
    then show "?L \<le> ?R" by presburger
  next
    have "funpow_dist1 f y z \<le> funpow_dist1 f x z - funpow_dist1 f x y"
      using y_z_diff assms(1) by (metis not_less zero_less_diff funpow_dist1_least)
    then show "?R \<le> ?L" by linarith
  qed
qed

lemma funpow_dist1_le_self:
  assumes "(f ^^ m) x = x" "0 < m" "y \<in> orbit f x"
  shows "funpow_dist1 f x y \<le> m"
proof (cases "x = y")
  case True with assms show ?thesis by (auto dest!: funpow_dist1_least)
next
  case False
  have "(f ^^ funpow_dist1 f x y) x = (f ^^ (funpow_dist1 f x y mod m)) x"
    using assms by (simp add: funpow_mod_eq)
  then have "\<not>(funpow_dist1 f x y mod m < funpow_dist1 f x y)"
    by (metis False assms(3) funpow_dist_least funpow_dist_prop funpow_dist_step)
  then show ?thesis
    by (metis (poly_guards_query) Divides.mod_less_eq_dividend assms(2) le_less mod_less_divisor)
qed

subsection \<open>Permutation Domains\<close>

definition has_dom :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "has_dom f S \<equiv> \<forall>s. s \<notin> S \<longrightarrow> f s = s"

lemma permutes_conv_has_dom:
  "f permutes S \<longleftrightarrow> bij f \<and> has_dom f S"
  by (auto simp: permutes_def has_dom_def bij_iff)

section \<open>Segments\<close>

inductive_set segment :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a set" for f a b where
  base: "f a \<noteq> b \<Longrightarrow> f a \<in> segment f a b" |
  step: "x \<in> segment f a b \<Longrightarrow> f x \<noteq> b \<Longrightarrow> f x \<in> segment f a b"

lemma segment_step_2D:
  assumes "x \<in> segment f a (f b)" shows "x \<in> segment f a b \<or> x = b"
  using assms by induct (auto intro: segment.intros)

lemma not_in_segment2D:
  assumes "x \<in> segment f a b" shows "x \<noteq> b"
  using assms by induct auto

lemma segment_altdef:
  assumes "b \<in> orbit f a"
  shows "segment f a b = (\<lambda>n. (f ^^ n) a) ` {1..<funpow_dist1 f a b}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix x assume "x \<in> ?L"
  have "f a \<noteq>b \<Longrightarrow> b \<in> orbit f (f a)"
    using assms  by (simp add: orbit_step)
  then have *: "f a \<noteq> b \<Longrightarrow> 0 < funpow_dist f (f a) b"
    using assms using gr0I funpow_dist_0_eq[OF \<open>_ \<Longrightarrow> b \<in> orbit f (f a)\<close>] by (simp add: orbit.intros)
  from \<open>x \<in> ?L\<close> show "x \<in> ?R"
  proof induct
    case base then show ?case by (intro image_eqI[where x=1]) (auto simp: *)
  next
    case step then show ?case using assms funpow_dist1_prop less_antisym
      by (fastforce intro!: image_eqI[where x="Suc n" for n])
  qed
next
  fix x assume "x \<in> ?R"
  then obtain n where "(f ^^ n ) a = x" "0 < n" "n < funpow_dist1 f a b" by auto
  then show "x \<in> ?L"
  proof (induct n arbitrary: x)
    case 0 then show ?case by simp
  next
    case (Suc n)
    have "(f ^^ Suc n) a \<noteq> b" using Suc by (meson funpow_dist1_least)
    with Suc show ?case by (cases "n = 0") (auto intro: segment.intros)
  qed
qed

(*XXX move up*)
lemma segmentD_orbit:
  assumes "x \<in> segment f y z" shows "x \<in> orbit f y"
  using assms by induct (auto intro: orbit.intros)

lemma segment1_empty: "segment f x (f x) = {}"
  by (auto simp: segment_altdef orbit.base funpow_dist_0)

lemma segment_subset:
  assumes "y \<in> segment f x z"
  assumes "w \<in> segment f x y"
  shows "w \<in> segment f x z"
  using assms by (induct arbitrary: w) (auto simp: segment1_empty intro: segment.intros dest: segment_step_2D elim: segment.cases)

(* XXX move up*)
lemma not_in_segment1:
  assumes "y \<in> orbit f x" shows "x \<notin> segment f x y"
proof
  assume "x \<in> segment f x y"
  then obtain n where n: "0 < n" "n < funpow_dist1 f x y" "(f ^^ n) x = x"
    using assms by (auto simp: segment_altdef Suc_le_eq)
  then have neq_y: "(f ^^ (funpow_dist1 f x y - n)) x \<noteq> y" by (simp add: funpow_dist1_least)

  have "(f ^^ (funpow_dist1 f x y - n)) x = (f ^^ (funpow_dist1 f x y - n)) ((f ^^ n) x)"
    using n by (simp add: funpow_add_app)
  also have "\<dots> = (f ^^ funpow_dist1 f x y) x"
    using \<open>n < _\<close> by (simp add: funpow_add_app)
  also have "\<dots> = y" using assms by (rule funpow_dist1_prop)
  finally show False using neq_y by contradiction
qed

lemma not_in_segment2: "y \<notin> segment f x y"
  using not_in_segment2D by metis

(*XXX move*)
lemma in_segmentE:
  assumes "y \<in> segment f x z" "z \<in> orbit f x"
  obtains "(f ^^ funpow_dist1 f x y) x = y" "funpow_dist1 f x y < funpow_dist1 f x z"
proof
  from assms show "(f ^^ funpow_dist1 f x y) x = y"
    by (intro segmentD_orbit funpow_dist1_prop)
  moreover
  obtain n where "(f ^^ n) x = y" "0 < n" "n < funpow_dist1 f x z"
    using assms by (auto simp: segment_altdef)
  moreover then have "funpow_dist1 f x y \<le> n" by (meson funpow_dist1_least not_less)
  ultimately show "funpow_dist1 f x y < funpow_dist1 f x z" by linarith
qed

(*XXX move*)
lemma cyclic_split_segment:
  assumes S: "cyclic_on f S" "a \<in> S" "b \<in> S" and "a \<noteq> b"
  shows "S = {a,b} \<union> segment f a b \<union> segment f b a" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix c assume "c \<in> ?L"
  with S have "c \<in> orbit f a" unfolding cyclic_on_alldef by auto
  then show "c \<in> ?R" by induct (auto intro: segment.intros)
next
  fix c assume "c \<in> ?R"
  moreover have "segment f a b \<subseteq> orbit f a" "segment f b a \<subseteq> orbit f b"
    by (auto dest: segmentD_orbit)
  ultimately show "c \<in> ?L" using S by (auto simp: cyclic_on_alldef)
qed

(*XXX move*)
lemma segment_split:
  assumes y_in_seg: "y \<in> segment f x z"
  shows "segment f x z = segment f x y \<union> {y} \<union> segment f y z" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix w assume "w \<in> ?L" then show "w \<in> ?R" by induct (auto intro: segment.intros)
next
  fix w assume "w \<in> ?R"
  moreover
  { assume "w \<in> segment f x y" then have "w \<in> segment f x z"
    using segment_subset[OF y_in_seg] by auto }
  moreover
  { assume "w \<in> segment f y z" then have "w \<in> segment f x z"
      using y_in_seg by induct (auto intro: segment.intros) }
  ultimately
  show "w \<in> ?L" using y_in_seg by (auto intro: segment.intros)
qed

lemma in_segmentD_inv:
  assumes "x \<in> segment f a b" "x \<noteq> f a"
  assumes "inj f"
  shows "inv f x \<in> segment f a b"
  using assms by (auto elim: segment.cases)

lemma in_orbit_invI:
  assumes "b \<in> orbit f a"
  assumes "inj f"
  shows "a \<in> orbit (inv f) b"
  using assms(1)
  apply induct
   apply (simp add: assms(2) orbit_eqI(1))
  by (metis assms(2) inv_f_f orbit.base orbit_trans)

lemma segment_step_2:
  assumes A: "x \<in> segment f a b" "b \<noteq> a" and "inj f"
  shows "x \<in> segment f a (f b)"
  using A by induct (auto intro: segment.intros dest: not_in_segment2D injD[OF \<open>inj f\<close>])

lemma inv_end_in_segment:
  assumes "b \<in> orbit f a" "f a \<noteq> b" "bij f"
  shows "inv f b \<in> segment f a b"
  using assms(1,2)
proof induct
  case base then show ?case by simp
next
  case (step x)
  moreover
  from \<open>bij f\<close> have "inj f" by (rule bij_is_inj)
  moreover
  then have "x \<noteq> f x \<Longrightarrow> f a = x \<Longrightarrow> x \<in> segment f a (f x)" by (meson segment.simps)
  moreover
  have "x \<noteq> f x"
    using step \<open>inj f\<close> by (metis in_orbit_invI inv_f_eq not_in_segment1 segment.base)
  then have "inv f x \<in> segment f a (f x) \<Longrightarrow> x \<in> segment f a (f x)"
    using \<open>bij f\<close> \<open>inj f\<close> by (auto dest: segment.step simp: surj_f_inv_f bij_is_surj)
  then have "inv f x \<in> segment f a x \<Longrightarrow> x \<in> segment f a (f x)"
    using \<open>f a \<noteq> f x\<close> \<open>inj f\<close> by (auto dest: segment_step_2 injD)
  ultimately show ?case by (cases "f a = x") simp_all
qed

lemma segment_overlapping:
  assumes "x \<in> orbit f a" "x \<in> orbit f b" "bij f"
  shows "segment f a x \<subseteq> segment f b x \<or> segment f b x \<subseteq> segment f a x"
  using assms(1,2)
proof induction
  case base then show ?case by (simp add: segment1_empty)
next
  case (step x)
  from \<open>bij f\<close> have "inj f" by (simp add: bij_is_inj)
  have *: "\<And>f x y. y \<in> segment f x (f x) \<Longrightarrow> False" by (simp add: segment1_empty)
  { fix y z
    assume A: "y \<in> segment f b (f x)" "y \<notin> segment f a (f x)" "z \<in> segment f a (f x)"
    from \<open>x \<in> orbit f a\<close> \<open>f x \<in> orbit f b\<close> \<open>y \<in> segment f b (f x)\<close>
    have "x \<in> orbit f b"
      by (metis * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq[OF \<open>inj f\<close>] segmentD_orbit)
    moreover
    with \<open>x \<in> orbit f a\<close> step.IH
    have "segment f a (f x) \<subseteq> segment f b (f x) \<or> segment f b (f x) \<subseteq> segment f a (f x)"
      apply auto
       apply (metis * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq[OF \<open>inj f\<close>] segment_step_2D segment_subset step.prems subsetCE)
      by (metis (no_types, lifting) `inj f` * inv_end_in_segment[OF _ _ \<open>bij f\<close>] inv_f_eq orbit_eqI(2) segment_step_2D segment_subset subsetCE)
    ultimately
    have "segment f a (f x) \<subseteq> segment f b (f x)" using A by auto
  } note C = this
  then show ?case by auto
qed

lemma segment_disj:
  assumes "a \<noteq> b" "bij f"
  shows "segment f a b \<inter> segment f b a = {}"
proof (rule ccontr)
  assume "\<not>?thesis"
  then obtain x where x: "x \<in> segment f a b" "x \<in> segment f b a" by blast
  then have "segment f a b = segment f a x \<union> {x} \<union> segment f x b"
      "segment f b a = segment f b x \<union> {x} \<union> segment f x a"
    by (auto dest: segment_split)
  then have o: "x \<in> orbit f a" "x \<in> orbit f b" by (auto dest: segmentD_orbit)

  note * = segment_overlapping[OF o \<open>bij f\<close>]
  have "inj f" using \<open>bij f\<close> by (simp add: bij_is_inj)

  have "segment f a x = segment f b x"
  proof (intro set_eqI iffI)
    fix y assume A: "y \<in> segment f b x"
    then have "y \<in> segment f a x \<or> f a \<in> segment f b a"
      using * x(2) by (auto intro: segment.base segment_subset)
    then show "y \<in> segment f a x"
      using \<open>inj f\<close> A by (metis (no_types) not_in_segment2 segment_step_2)
  next
    fix y assume A: "y \<in> segment f a x "
    then have "y \<in> segment f b x \<or> f b \<in> segment f a b"
      using * x(1) by (auto intro: segment.base segment_subset)
    then show "y \<in> segment f b x"
      using \<open>inj f\<close> A by (metis (no_types) not_in_segment2 segment_step_2)
  qed
  moreover
  have "segment f a x \<noteq> segment f b x"
    by (metis assms bij_is_inj not_in_segment2 segment.base segment_step_2 segment_subset x(1))
  ultimately show False by contradiction
qed

lemma segment_x_x_eq:
  assumes "permutation f"
  shows "segment f x x = orbit f x - {x}" (is "?L = ?R")
proof (intro set_eqI iffI)
  fix y assume "y \<in> ?L" then show "y \<in> ?R" by (auto dest: segmentD_orbit simp: not_in_segment2)
next
  fix y assume "y \<in> ?R"
  then have "y \<in> orbit f x" "y \<noteq> x" by auto
  then show "y \<in> ?L" by induct (auto intro: segment.intros)
qed

section \<open>Lists of Powers\<close>

definition iterate :: "nat \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a ) \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "iterate m n f x = map (\<lambda>n. (f^^n) x) [m..<n]"

lemma set_iterate:
  "set (iterate m n f x) = (\<lambda>k. (f ^^ k) x) ` {m..<n} "
  by (auto simp: iterate_def)

lemma iterate_empty[simp]: "iterate n m f x = [] \<longleftrightarrow> m \<le> n"
  by (auto simp: iterate_def)

lemma iterate_nth[simp]:
  assumes "k < n - m" shows "iterate m n f x ! k = (f^^(m+k)) x"
  using assms
  by (induct k arbitrary: m) (auto simp: iterate_def)

lemma iterate_applied:
  "iterate n m f (f x) = iterate (Suc n) (Suc m) f x"
  by (induct m arbitrary: n) (auto simp: iterate_def funpow_swap1)

end