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

section \<open>Auxiliary Lemmas about @{term "(^^)"}\<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_compose)
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 \<open>m < n\<close> 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"
    define k' l' where "k' = min k l" and "l' = 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 \<open>f permutes S\<close> 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"

  define m' n' where "m' = min m n" and "n' = 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"

  define m' n' where "m' = min m n" and "n' = 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)
  with False \<open>y \<in> orbit f x\<close> have "funpow_dist1 f x y \<le> funpow_dist1 f x y mod m"
    by auto (metis funpow_dist_least funpow_dist_prop funpow_dist_step funpow_simp_l not_less)
  with \<open>m > 0\<close> show ?thesis
    by (auto intro: order_trans)
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) \<open>inj f\<close> * 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


(*
  Boolean Expression Checkers Based on Binary Decision Trees
  Author: Tobias Nipkow
*)

theory Boolean_Expression_Checkers
  imports Main "HOL-Library.Mapping" "Eval_Base.Eval_Base"
begin

section \<open>Tautology (etc) Checking via Binary Decision Trees\<close>

subsection \<open>Binary Decision Trees\<close>

datatype 'a ifex = Trueif | Falseif | IF 'a "'a ifex" "'a ifex"

fun val_ifex :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "val_ifex Trueif s = True"
| "val_ifex Falseif s = False"
| "val_ifex (IF n t1 t2) s = (if s n then val_ifex t1 s else val_ifex t2 s)"

subsubsection \<open>Environment\<close>

text \<open>Environments are substitutions of values for variables:\<close>

type_synonym 'a env_bool = "('a, bool) mapping"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "agree s env = (\<forall>x b. Mapping.lookup env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil:
  "agree s Mapping.empty"
  by (simp add: agree_def lookup_empty)

lemma lookup_update_unfold:
  "Mapping.lookup (Mapping.update k v m) k' = (if k = k' then Some v else Mapping.lookup m k')"
  using lookup_update lookup_update_neq by metis

lemma agree_Cons:
  "x \<notin> Mapping.keys env \<Longrightarrow> agree s (Mapping.update x b env) = ((if b then s x else \<not> s x) \<and> agree s env)"
  by (simp add: agree_def lookup_update_unfold; unfold keys_is_none_rep lookup_update_unfold Option.is_none_def; blast)

lemma agreeDT:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some True \<Longrightarrow> s x"
  by (simp add: agree_def)

lemma agreeDF:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some False \<Longrightarrow> \<not>s x"
  by (auto simp add: agree_def)

subsection \<open>Recursive Tautology Checker\<close>

text \<open>Provided for completeness. However, it is recommend to use the checkers based on reduced trees.\<close>

fun taut_test_rec :: "'a ifex \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "taut_test_rec Trueif env = True"
| "taut_test_rec Falseif env = False"
| "taut_test_rec (IF x t1 t2) env = (case Mapping.lookup env x of
  Some b \<Rightarrow> taut_test_rec (if b then t1 else t2) env |
  None \<Rightarrow> taut_test_rec t1 (Mapping.update x True env) \<and> taut_test_rec t2 (Mapping.update x False env))"

lemma taut_test_rec:
  "taut_test_rec t env = (\<forall>s. agree s env \<longrightarrow> val_ifex t s)"
proof2 (induction t arbitrary: env)
  case Falseif
    have "agree (\<lambda>x. the (Mapping.lookup env x)) env"
      by (auto simp: agree_def)
    thus ?case
      by auto
next
  case (IF x t1 t2)
    thus ?case
    proof (cases "Mapping.lookup env x")
      case None
        with IF show ?thesis
          by simp (metis is_none_simps(1) agree_Cons keys_is_none_rep)
    qed (simp add: agree_def)
qed simp

definition taut_test_ifex :: "'a ifex \<Rightarrow> bool"
where
  "taut_test_ifex t = taut_test_rec t Mapping.empty"

corollary taut_test_ifex:
  "taut_test_ifex t = (\<forall>s. val_ifex t s)"
  by (auto simp: taut_test_ifex_def taut_test_rec agree_Nil)

subsection \<open>Reduced Binary Decision Trees\<close>

subsubsection \<open>Normalisation\<close>

text \<open>A normalisation avoiding duplicate variables and collapsing @{term "If x t t"} to \<open>t\<close>.\<close>

definition mkIF :: "'a \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "mkIF x t1 t2 = (if t1=t2 then t1 else IF x t1 t2)"

fun reduce :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "reduce env (IF x t1 t2) = (case Mapping.lookup env x of
     None \<Rightarrow> mkIF x (reduce (Mapping.update x True env) t1) (reduce (Mapping.update x False env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))"
| "reduce _ t = t"

primrec normif :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "normif env Trueif t1 t2 = reduce env t1"
| "normif env Falseif t1 t2 = reduce env t2"
| "normif env (IF x t1 t2) t3 t4 =
    (case Mapping.lookup env x of
       None \<Rightarrow> mkIF x (normif (Mapping.update x True env) t1 t3 t4) (normif (Mapping.update x False env) t2 t3 t4) |
       Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

subsubsection \<open>Functional Correctness Proof\<close>

lemma val_mkIF:
  "val_ifex (mkIF x t1 t2) s = val_ifex (IF x t1 t2) s"
  by (auto simp: mkIF_def Let_def)

theorem val_reduce:
  "agree s env \<Longrightarrow> val_ifex (reduce env t) s = val_ifex t s"
  apply2 (induction t arbitrary: s env)
  by(auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

lemma val_normif:
  "agree s env \<Longrightarrow> val_ifex (normif env t t1 t2) s = val_ifex (if val_ifex t s then t1 else t2) s"
  apply2 (induct t arbitrary: t1 t2 s env)
  by(auto simp: val_reduce val_mkIF agree_Cons map_of_eq_None_iff keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

subsubsection \<open>Reduced If-Expressions\<close>

text \<open>An expression reduced iff no variable appears twice on any branch and there is no subexpression @{term "IF x t t"}.\<close>

fun reduced :: "'a ifex \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (IF x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono:
  "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"
  apply2 (induction t arbitrary: X Y)
  by (auto, (metis insert_mono)+)

lemma reduced_mkIF:
  "x \<notin> X \<Longrightarrow> reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
  by (auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "reduced (reduce env t) (Mapping.keys env)"
proof2(induction t arbitrary: env)
  case (IF x t1 t2)
    thus ?case
      using IF.IH(1) IF.IH(2)
      apply (auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
      by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed auto

lemma reduced_normif:
  "reduced (normif env t t1 t2) (Mapping.keys env)"
proof2(induction t arbitrary: t1 t2 env)
  case (IF x s1 s2)
  thus ?case using IF.IH
    apply (auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
    by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed (auto simp: reduced_reduce)

subsubsection \<open>Checkers Based on Reduced Binary Decision Trees\<close>

text \<open>The checkers are parameterized over the translation function to binary decision trees.
  They rely on the fact that @{term ifex_of} produces reduced trees\<close>

definition taut_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "taut_test ifex_of b = (ifex_of b = Trueif)"

definition sat_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "sat_test ifex_of b = (ifex_of b \<noteq> Falseif)"

definition impl_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "impl_test ifex_of b1 b2 = (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif = Trueif)"

definition equiv_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "equiv_test ifex_of b1 b2 = (let t1 = ifex_of b1; t2 = ifex_of b2
    in Trueif = normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

locale reduced_bdt_checkers =
  fixes
    ifex_of :: "'b \<Rightarrow> 'a ifex"
  fixes
    val :: "'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  assumes
    val_ifex: "val_ifex (ifex_of b) s = val b s"
  assumes
    reduced_ifex: "reduced (ifex_of b) {}"
begin

text \<open>Proof that reduced if-expressions are @{const Trueif}, @{const Falseif}
or can evaluate to both @{const True} and @{const False}.\<close>

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow> val_ifex t s1 = val_ifex t s2"
  apply2 (induction t arbitrary: X) by auto

lemma reduced_IF_depends:
  "\<lbrakk> reduced t X; t \<noteq> Trueif; t \<noteq> Falseif \<rbrakk> \<Longrightarrow> \<exists>s1 s2. val_ifex t s1 \<noteq> val_ifex t s2"
proof2(induction t arbitrary: X)
  case (IF x t1 t2)
  let ?t = "IF x t1 t2"
  have 1: "reduced t1 (insert x X)" using IF.prems(1) by simp
  have 2: "reduced t2 (insert x X)" using IF.prems(1) by simp
  show ?case
  proof(cases t1)
    case [simp]: Trueif
    show ?thesis
    proof (cases t2)
      case Trueif thus ?thesis using IF.prems(1) by simp
    next
      case Falseif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case [simp]: Falseif
    show ?thesis
    proof (cases t2)
      case Falseif thus ?thesis using IF.prems(1) by simp
    next
      case Trueif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case IF
    then obtain s1 s2 where "val_ifex t1 s1 \<noteq> val_ifex t1 s2"
      using IF.IH(1)[OF 1] IF.prems(1) by auto
    hence "val_ifex ?t (s1(x:=True)) \<noteq> val_ifex ?t (s2(x:=True))"
      using same_val_if_reduced[OF 1, of "s1(x:=True)" s1]
          same_val_if_reduced[OF 1, of "s2(x:=True)" s2] by simp
    thus ?thesis by blast
  qed
qed auto

corollary taut_test:
  "taut_test ifex_of b = (\<forall>s. val b s)"
  by (metis taut_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary sat_test:
  "sat_test ifex_of b = (\<exists>s. val b s)"
  by (metis sat_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary impl_test:
  "impl_test ifex_of b1 b2 = (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
proof -
  have "impl_test ifex_of b1 b2 = (\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s)"
    using reduced_IF_depends[OF reduced_normif] by (fastforce  simp: impl_test_def)
  also
  have "(\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s) \<longleftrightarrow> (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
    using reduced_IF_depends[OF reduced_ifex] val_ifex unfolding val_normif[OF agree_Nil] by simp
  finally
  show ?thesis .
qed

corollary equiv_test:
  "equiv_test ifex_of b1 b2 = (\<forall>s. val b1 s = val b2 s)"
proof -
  have "equiv_test ifex_of b1 b2 = (\<forall>s. val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s)"
    by (simp add: equiv_test_def Let_def; insert reduced_IF_depends[OF reduced_normif]; force)
  moreover
  {
    fix s
    have "val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s
      = (val b1 s = val b2 s)"
      using val_ifex by (simp add: Let_def val_normif[OF agree_Nil])
  }
  ultimately
  show ?thesis
    by blast
qed

end

subsection \<open>Boolean Expressions\<close>

text \<open>This is the simplified interface to the tautology checker. If you have your own type of Boolean
expressions you can either define your own translation to reduced binary decision trees or you can just
translate into this type.\<close>

datatype 'a bool_expr =
  Const_bool_expr bool |
  Atom_bool_expr 'a |
  Neg_bool_expr "'a bool_expr" |
  And_bool_expr "'a bool_expr" "'a bool_expr" |
  Or_bool_expr "'a bool_expr" "'a bool_expr" |
  Imp_bool_expr "'a bool_expr" "'a bool_expr" |
  Iff_bool_expr "'a bool_expr" "'a bool_expr"

primrec val_bool_expr :: "'a bool_expr \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"val_bool_expr (Const_bool_expr b) s = b" |
"val_bool_expr (Atom_bool_expr x) s = s x" |
"val_bool_expr (Neg_bool_expr b) s = (\<not> val_bool_expr b s)" |
"val_bool_expr (And_bool_expr b1 b2) s = (val_bool_expr b1 s \<and> val_bool_expr b2 s)" |
"val_bool_expr (Or_bool_expr b1 b2) s = (val_bool_expr b1 s \<or> val_bool_expr b2 s)" |
"val_bool_expr (Imp_bool_expr b1 b2) s = (val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" |
"val_bool_expr (Iff_bool_expr b1 b2) s = (val_bool_expr b1 s = val_bool_expr b2 s)"

fun ifex_of :: "'a bool_expr \<Rightarrow> 'a ifex" where
"ifex_of (Const_bool_expr b) = (if b then Trueif else Falseif)" |
"ifex_of (Atom_bool_expr x)   = IF x Trueif Falseif" |
"ifex_of (Neg_bool_expr b)   = normif Mapping.empty (ifex_of b) Falseif Trueif" |
"ifex_of (And_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Falseif" |
"ifex_of (Or_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) Trueif (ifex_of b2)" |
"ifex_of (Imp_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif" |
"ifex_of (Iff_bool_expr b1 b2) = (let t1 = ifex_of b1; t2 = ifex_of b2 in
   normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

theorem val_ifex:
  "val_ifex (ifex_of b) s = val_bool_expr b s"
  apply2(induct_tac b) by(auto simp: val_normif agree_Nil Let_def)

theorem reduced_ifex:
  "reduced (ifex_of b) {}"
  apply2(induction b) by(simp add: Let_def; metis keys_empty reduced_normif)+

definition "bool_taut_test \<equiv> taut_test ifex_of"
definition "bool_sat_test \<equiv> sat_test ifex_of"
definition "bool_impl_test \<equiv> impl_test ifex_of"
definition "bool_equiv_test \<equiv> equiv_test ifex_of"

lemma bool_tests:
  "bool_taut_test b = (\<forall>s. val_bool_expr b s)" (is ?t1)
  "bool_sat_test b = (\<exists>s. val_bool_expr b s)" (is ?t2)
  "bool_impl_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" (is ?t3)
  "bool_equiv_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longleftrightarrow> val_bool_expr b2 s)" (is ?t4)
proof -
  interpret reduced_bdt_checkers ifex_of val_bool_expr
    by (unfold_locales; insert val_ifex reduced_ifex; blast)
  show ?t1 ?t2 ?t3 ?t4
    by (simp_all add: bool_taut_test_def bool_sat_test_def bool_impl_test_def bool_equiv_test_def taut_test sat_test impl_test equiv_test)
qed

end


(*  Title:      HOL/Analysis/L2_Norm.thy
    Author:     Brian Huffman, Portland State University
*)

chapter \<open>Linear Algebra\<close>

theory L2_Norm
imports Complex_Main
begin

section \<open>L2 Norm\<close>

definition\<^marker>\<open>tag important\<close> L2_set :: "('a \<Rightarrow> real) \<Rightarrow> 'a set \<Rightarrow> real" where
"L2_set f A = sqrt (\<Sum>i\<in>A. (f i)\<^sup>2)"

lemma L2_set_cong:
  "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> L2_set f A = L2_set g B"
  unfolding L2_set_def by simp

lemma L2_set_cong_simp:
  "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> L2_set f A = L2_set g B"
  unfolding L2_set_def simp_implies_def by simp

lemma L2_set_infinite [simp]: "\<not> finite A \<Longrightarrow> L2_set f A = 0"
  unfolding L2_set_def by simp

lemma L2_set_empty [simp]: "L2_set f {} = 0"
  unfolding L2_set_def by simp

lemma L2_set_insert [simp]:
  "\<lbrakk>finite F; a \<notin> F\<rbrakk> \<Longrightarrow>
    L2_set f (insert a F) = sqrt ((f a)\<^sup>2 + (L2_set f F)\<^sup>2)"
  unfolding L2_set_def by (simp add: sum_nonneg)

lemma L2_set_nonneg [simp]: "0 \<le> L2_set f A"
  unfolding L2_set_def by (simp add: sum_nonneg)

lemma L2_set_0': "\<forall>a\<in>A. f a = 0 \<Longrightarrow> L2_set f A = 0"
  unfolding L2_set_def by simp

lemma L2_set_constant: "L2_set (\<lambda>x. y) A = sqrt (of_nat (card A)) * \<bar>y\<bar>"
  unfolding L2_set_def by (simp add: real_sqrt_mult)

lemma L2_set_mono:
  assumes "\<And>i. i \<in> K \<Longrightarrow> f i \<le> g i"
  assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
  shows "L2_set f K \<le> L2_set g K"
  unfolding L2_set_def
  by (simp add: sum_nonneg sum_mono power_mono assms)

lemma L2_set_strict_mono:
  assumes "finite K" and "K \<noteq> {}"
  assumes "\<And>i. i \<in> K \<Longrightarrow> f i < g i"
  assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
  shows "L2_set f K < L2_set g K"
  unfolding L2_set_def
  by (simp add: sum_strict_mono power_strict_mono assms)

lemma L2_set_right_distrib:
  "0 \<le> r \<Longrightarrow> r * L2_set f A = L2_set (\<lambda>x. r * f x) A"
  unfolding L2_set_def
  apply (simp add: power_mult_distrib)
  apply (simp add: sum_distrib_left [symmetric])
  apply (simp add: real_sqrt_mult sum_nonneg)
  done

lemma L2_set_left_distrib:
  "0 \<le> r \<Longrightarrow> L2_set f A * r = L2_set (\<lambda>x. f x * r) A"
  unfolding L2_set_def
  apply (simp add: power_mult_distrib)
  apply (simp add: sum_distrib_right [symmetric])
  apply (simp add: real_sqrt_mult sum_nonneg)
  done

lemma L2_set_eq_0_iff: "finite A \<Longrightarrow> L2_set f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  unfolding L2_set_def
  by (simp add: sum_nonneg sum_nonneg_eq_0_iff)

proposition L2_set_triangle_ineq:
  "L2_set (\<lambda>i. f i + g i) A \<le> L2_set f A + L2_set g A"
proof (cases "finite A")
  case False
  thus ?thesis by simp
next
  case True
  thus ?thesis
  proof (induct set: finite)
    case empty
    show ?case by simp
  next
    case (insert x F)
    hence "sqrt ((f x + g x)\<^sup>2 + (L2_set (\<lambda>i. f i + g i) F)\<^sup>2) \<le>
           sqrt ((f x + g x)\<^sup>2 + (L2_set f F + L2_set g F)\<^sup>2)"
      by (intro real_sqrt_le_mono add_left_mono power_mono insert
                L2_set_nonneg add_increasing zero_le_power2)
    also have
      "\<dots> \<le> sqrt ((f x)\<^sup>2 + (L2_set f F)\<^sup>2) + sqrt ((g x)\<^sup>2 + (L2_set g F)\<^sup>2)"
      by (rule real_sqrt_sum_squares_triangle_ineq)
    finally show ?case
      using insert by simp
  qed
qed

lemma L2_set_le_sum [rule_format]:
  "(\<forall>i\<in>A. 0 \<le> f i) \<longrightarrow> L2_set f A \<le> sum f A"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply clarsimp
  apply (erule order_trans [OF sqrt_sum_squares_le_sum])
  apply simp
  apply simp
  apply simp
  done

lemma L2_set_le_sum_abs: "L2_set f A \<le> (\<Sum>i\<in>A. \<bar>f i\<bar>)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply simp
  apply (rule order_trans [OF sqrt_sum_squares_le_sum_abs])
  apply simp
  apply simp
  done

lemma L2_set_mult_ineq: "(\<Sum>i\<in>A. \<bar>f i\<bar> * \<bar>g i\<bar>) \<le> L2_set f A * L2_set g A"
  apply (cases "finite A")
  apply (induct set: finite)
  apply simp
  apply (rule power2_le_imp_le, simp)
  apply (rule order_trans)
  apply (rule power_mono)
  apply (erule add_left_mono)
  apply (simp add: sum_nonneg)
  apply (simp add: power2_sum)
  apply (simp add: power_mult_distrib)
  apply (simp add: distrib_left distrib_right)
  apply (rule ord_le_eq_trans)
  apply (rule L2_set_mult_ineq_lemma)
  apply simp_all
  done

lemma member_le_L2_set: "\<lbrakk>finite A; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le> L2_set f A"
  unfolding L2_set_def
  by (auto intro!: member_le_sum real_le_rsqrt)

end


theory Tree0
imports Main
begin

datatype tree0 = Leaf | Node tree0 tree0

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Leaf = 1" |
"nodes (Node t1 t2) = 1 + nodes t1 + nodes t2"

lemma "nodes (Node t t) = 2 * (nodes t) + 1"
apply(auto)
done

lemma "nodes (explode (Suc n) t) = 2 * nodes (explode n t) + 1"
apply(induction n arbitrary: t)
apply(auto)
done

lemma "nodes (explode n (Node t t)) = 2 * nodes (explode n t) + 1"
apply(induction n arbitrary: t)
apply(auto)
done

lemma "n \<ge> 2 \<Longrightarrow> (n::nat) - 2 + 1 = n - 1"
apply(auto)
done

lemma "nodes (explode n t) = ((nodes t) + 1) * 2 ^ n - 1"
apply(induction n arbitrary: t)
apply(auto simp add:algebra_simps)
done

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor Scalar Multiplication\<close>

theory Tensor_Scalar_Mult
imports Tensor_Plus Tensor_Subtensor
begin

definition vec_smult::"'a::ring \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"vec_smult \<alpha> \<beta> = map ((*) \<alpha>) \<beta>"

lemma vec_smult0: "vec_smult 0 as = vec0 (length as)"
  by (induction as; auto simp add:vec0_def vec_smult_def)

lemma vec_smult_distr_right:
shows "vec_smult (\<alpha> + \<beta>) as = vec_plus (vec_smult \<alpha> as) (vec_smult \<beta> as)"
  unfolding vec_smult_def vec_plus_def
  by (induction as; simp add: distrib_right)

lemma vec_smult_Cons:
shows "vec_smult \<alpha> (a # as) = (\<alpha> * a) # vec_smult \<alpha> as" by (simp add: vec_smult_def)

lemma vec_plus_Cons:
shows "vec_plus (a # as) (b # bs) = (a+b) # vec_plus as bs" by (simp add: vec_plus_def)

lemma vec_smult_distr_left:
assumes "length as = length bs"
shows "vec_smult \<alpha> (vec_plus as bs) = vec_plus (vec_smult \<alpha> as) (vec_smult \<alpha> bs)"
using assms proof (induction as arbitrary:bs)
  case Nil
  then show ?case unfolding vec_smult_def vec_plus_def by simp
next
  case (Cons a as')
  then obtain b bs' where "bs = b # bs'" by (metis Suc_length_conv)
  then have 0:"vec_smult \<alpha> (vec_plus (a # as') bs) = (\<alpha>*(a+b)) # vec_smult \<alpha> (vec_plus as' bs')"
    unfolding vec_smult_def vec_plus_def using Cons.IH[of bs'] by simp
  have "length bs' = length as'" using Cons.prems \<open>bs = b # bs'\<close> by auto
  then show ?case unfolding 0 unfolding  \<open>bs = b # bs'\<close> vec_smult_Cons vec_plus_Cons
    by (simp add: Cons.IH distrib_left)
qed

lemma length_vec_smult: "length (vec_smult \<alpha> v) = length v" unfolding vec_smult_def by simp

definition smult::"'a::ring \<Rightarrow> 'a tensor \<Rightarrow> 'a tensor" (infixl "\<cdot>" 70) where
"smult \<alpha> A = (tensor_from_vec (dims A) (vec_smult \<alpha> (vec A)))"

lemma tensor_smult0: fixes A::"'a::ring tensor"
shows "0 \<cdot> A = tensor0 (dims A)"
  unfolding smult_def tensor0_def vec_smult_def using vec_smult0 length_vec
  by (metis (no_types) vec_smult_def)

lemma dims_smult[simp]:"dims (\<alpha> \<cdot> A) = dims A"
and   vec_smult[simp]: "vec  (\<alpha> \<cdot> A) = map ((*) \<alpha>) (vec A)"
  unfolding smult_def vec_smult_def by (simp add: length_vec)+

lemma tensor_smult_distr_right: "(\<alpha> + \<beta>) \<cdot> A = \<alpha> \<cdot> A  + \<beta> \<cdot> A"
  unfolding plus_def plus_base_def
  by (auto; metis smult_def vec_smult_def vec_smult_distr_right)

lemma tensor_smult_distr_left: "dims A = dims B \<Longrightarrow> \<alpha> \<cdot> (A + B) = \<alpha> \<cdot> A  + \<alpha> \<cdot> B"
proof -
  assume a1: "dims A = dims B"
  then have f2: "length (vec_plus (vec A) (vec B)) = length (vec A)"
    by (simp add: length_vec vec_plus_def)
  have f3: "dims (tensor_from_vec (dims B) (vec_smult \<alpha> (vec A))) = dims B"
    using a1 by (simp add: length_vec vec_smult_def)
  have f4: "vec (\<alpha> \<cdot> A) = vec_smult \<alpha> (vec A)"
    by (simp add: vec_smult_def)
  have "length (vec_smult \<alpha> (vec B)) = length (vec B)"
    by (simp add: vec_smult_def)
  then show ?thesis
    unfolding plus_def plus_base_def using f4 f3 f2 a1
    by (simp add: length_vec smult_def vec_smult_distr_left)
qed

lemma smult_fixed_length_sublist:
assumes "length xs = l * c" "i<c"
shows "fixed_length_sublist (vec_smult \<alpha> xs) l i = vec_smult \<alpha> (fixed_length_sublist xs l i)"
unfolding fixed_length_sublist_def vec_smult_def by (simp add: drop_map take_map)

lemma smult_subtensor:
assumes "dims A \<noteq> []" "i < hd (dims A)"
shows "\<alpha> \<cdot> subtensor A i = subtensor (\<alpha> \<cdot> A) i"
proof (rule tensor_eqI)
  show "dims (\<alpha> \<cdot> subtensor A i) = dims (subtensor (\<alpha> \<cdot> A) i)"
    using dims_smult dims_subtensor assms(1) assms(2) by simp
  show "vec (\<alpha> \<cdot> subtensor A i) = vec (subtensor (\<alpha> \<cdot> A) i)"
    unfolding vec_smult
    unfolding vec_subtensor[OF \<open>dims A \<noteq> []\<close> \<open>i < hd (dims A)\<close>]
    using vec_subtensor[of "\<alpha> \<cdot> A" i]
    by (simp add: assms(1) assms(2) drop_map fixed_length_sublist_def take_map)
qed

lemma lookup_smult:
assumes "is \<lhd> dims A"
shows "lookup (\<alpha> \<cdot> A) is = \<alpha> * lookup A is"
using assms proof (induction A arbitrary:"is" rule:subtensor_induct)
  case (order_0 A "is")
  then have "length (vec A) = 1" by (simp add: length_vec)
  then have "hd (vec_smult \<alpha> (vec A)) = \<alpha> * hd (vec A)" unfolding vec_smult_def by (metis list.map_sel(1) list.size(3) zero_neq_one)
  moreover have "is = []" using order_0 by auto
  ultimately show ?case unfolding smult_def by (auto simp add: \<open>length (Tensor.vec A) = 1\<close> lookup_def length_vec_smult order_0.hyps)
next
  case (order_step A "is")
  then obtain i is' where "is = i # is'" by blast
  then have "lookup (\<alpha> \<cdot> subtensor A i) is' = \<alpha> * lookup (subtensor A i) is'"
    by (metis (no_types, lifting) dims_subtensor list.sel(1) list.sel(3) order_step.IH order_step.hyps order_step.prems valid_index_dimsE)
  then show ?case using smult_subtensor \<open>is = i # is'\<close> dims_smult lookup_subtensor1
    list.sel(1) order_step.hyps order_step.prems valid_index_dimsE
    by metis
qed

lemma tensor_smult_assoc:
fixes A::"'a::ring tensor"
shows "\<alpha> \<cdot> (\<beta> \<cdot> A) = (\<alpha> * \<beta>) \<cdot> A"
by (rule tensor_lookup_eqI, simp, metis lookup_smult dims_smult mult.assoc)

end