(*
  File:     List_Inversions.thy
  Author:   Manuel Eberl, TU München

  A formalisation of inversions of a list and the O(n log n) divide-and-conquer algorithm
  to count them.
*)
section \<open>The Inversions of a List\<close>
theory List_Inversions
  imports Main "HOL-Library.Permutations"
begin

subsection \<open>Definition of inversions\<close>

context preorder
begin

text \<open>
  We define inversions as pair of indices w.\,r.\,t.\ a preorder.
\<close>
inductive_set inversions :: "'a list \<Rightarrow> (nat \<times> nat) set" for xs :: "'a list" where
  "i < j \<Longrightarrow> j < length xs \<Longrightarrow> less (xs ! j) (xs ! i) \<Longrightarrow> (i, j) \<in> inversions xs"

lemma inversions_subset: "inversions xs \<subseteq> Sigma {..<length xs} (\<lambda>i. {i<..<length xs})"
  by (auto simp: inversions.simps)

lemma finite_inversions [intro]: "finite (inversions xs)"
  by (rule finite_subset[OF inversions_subset]) auto

lemma inversions_altdef: "inversions xs = {(i, j). i < j \<and> j < length xs \<and> less (xs ! j) (xs ! i)}"
  by (auto simp: inversions.simps)

lemma inversions_code:
  "inversions xs =
     Sigma {..<length xs} (\<lambda>i. Set.filter (\<lambda>j. less (xs ! j) (xs ! i)) {i<..<length xs})"
  by (auto simp: inversions_altdef)

lemmas (in -) [code] = inversions_code

lemma inversions_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversions xs = {}"
  by (auto simp: inversions_altdef)

lemma inversions_imp_less:
  "z \<in> inversions xs \<Longrightarrow> fst z < snd z"
  "z \<in> inversions xs \<Longrightarrow> snd z < length xs"
  by (auto simp: inversions_altdef)

lemma inversions_Nil [simp]: "inversions [] = {}"
  by (auto simp: inversions_altdef)

lemma inversions_Cons:
  "inversions (x # xs) =
     (\<lambda>j. (0, j + 1)) ` {j\<in>{..<length xs}. less (xs ! j) x} \<union>
     map_prod Suc Suc ` inversions xs" (is "_ = ?rhs")
proof -
  have "z \<in> inversions (x # xs) \<longleftrightarrow> z \<in> ?rhs" for z
    by (cases z) (auto simp: inversions_altdef map_prod_def nth_Cons split: nat.splits)
  thus ?thesis by blast
qed

text \<open>
  The following function returns the inversions between two lists, i.\,e.\ all pairs of
  an element in the first list with an element in the second list such that the former
  is greater than the latter.
\<close>
definition inversions_between :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat \<times> nat) set" where
  "inversions_between xs ys =
     {(i, j) \<in> {..<length xs}\<times>{..<length ys}. less (ys ! j) (xs ! i)}"

lemma finite_inversions_between [intro]: "finite (inversions_between xs ys)"
    by (rule finite_subset[of _ "{..<length xs} \<times> {..<length xs + length ys}"])
       (auto simp: inversions_between_def)

lemma inversions_between_Nil [simp]:
  "inversions_between [] ys = {}"
  "inversions_between xs [] = {}"
  by (simp_all add: inversions_between_def)

text \<open>
  We can now show the following equality for the inversions of the concatenation of two lists:
\<close>
proposition inversions_append:
  fixes xs ys
  defines "m \<equiv> length xs" and "n \<equiv> length ys"
  shows "inversions (xs @ ys) =
           inversions xs \<union> map_prod ((+) m) ((+) m) ` inversions ys \<union>
           map_prod id ((+) m) ` inversions_between xs ys"
        (is "_ = ?rhs")
proof -
  note defs = inversions_altdef inversions_between_def m_def n_def map_prod_def
  have "z \<in> inversions (xs @ ys) \<longleftrightarrow> z \<in> ?rhs" for z
  proof
    assume "z \<in> inversions (xs @ ys)"
    then obtain i j where [simp]: "z = (i, j)"
                      and ij: "i < j" "j < m + n" "less ((xs @ ys) ! j) ((xs @ ys) ! i)"
      by (cases z) (auto simp: inversions_altdef m_def n_def)
    from ij consider "j < m" | "i \<ge> m" | "i < m" "j \<ge> m" by linarith
    thus "z \<in> ?rhs"
    proof cases
      assume "i < m" "j \<ge> m"
      define j' where "j' = j - m"
      have [simp]: "j = m + j'"
        using \<open>j \<ge> m\<close> by (simp add: j'_def)
      from ij and \<open>i < m\<close> show ?thesis
        by (auto simp: inversions_altdef map_prod_def inversions_between_def nth_append m_def n_def)
    next
      assume "i \<ge> m"
      define i' j' where "i' = i - m" and "j' = j - m"
      have [simp]: "i = m + i'" "j = m + j'"
        using \<open>i < j\<close> and \<open>i \<ge> m\<close> by (simp_all add: i'_def j'_def)
      from ij show ?thesis
        by (auto simp: inversions_altdef map_prod_def nth_append m_def n_def)
    qed (use ij in \<open>auto simp: nth_append defs\<close>)
  qed (auto simp: nth_append defs)
  thus ?thesis by blast
qed

subsection \<open>Counting inversions\<close>

text \<open>
  We now define versions of @{const inversions} and @{const inversions_between} that
  only return the \<^emph>\<open>number\<close> of inversions.
\<close>
definition inversion_number :: "'a list \<Rightarrow> nat" where
  "inversion_number xs = card (inversions xs)"

definition inversion_number_between where
  "inversion_number_between xs ys = card (inversions_between xs ys)"

lemma inversions_between_code:
  "inversions_between xs ys =
     Set.filter (\<lambda>(i,j). less (ys ! j) (xs ! i)) ({..<length xs}\<times>{..<length ys})"
  by (auto simp: inversions_between_def)

lemmas (in -) [code] = inversions_between_code

lemma inversion_number_Nil [simp]: "inversion_number [] = 0"
  by (simp add: inversion_number_def)

lemma inversion_number_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversion_number xs = 0"
  by (auto simp: inversion_number_def)

lemma inversion_number_between_Nil [simp]:
  "inversion_number_between [] ys = 0"
  "inversion_number_between xs [] = 0"
  by (simp_all add: inversion_number_between_def)

text \<open>
  We again get the following nice equation for the number of inversions of a concatenation:
\<close>
proposition inversion_number_append:
  "inversion_number (xs @ ys) =
     inversion_number xs + inversion_number ys + inversion_number_between xs ys"
proof -
  define m n where "m = length xs" and "n = length ys"
  let ?A = "inversions xs"
  let ?B = "map_prod ((+) m) ((+) m) ` inversions ys"
  let ?C = "map_prod id ((+) m) ` inversions_between xs ys"

  have "inversion_number (xs @ ys) = card (?A \<union> ?B \<union> ?C)"
    by (simp add: inversion_number_def inversions_append m_def)
  also have "\<dots> = card (?A \<union> ?B) + card ?C"
    by (intro card_Un_disjoint finite_inversions finite_inversions_between finite_UnI finite_imageI)
       (auto simp: inversions_altdef inversions_between_def m_def n_def)
  also have "card (?A \<union> ?B) = inversion_number xs + card ?B" unfolding inversion_number_def
    by (intro card_Un_disjoint finite_inversions finite_UnI finite_imageI)
       (auto simp: inversions_altdef m_def n_def)
  also have "card ?B = inversion_number ys" unfolding inversion_number_def
    by (intro card_image) (auto simp: map_prod_def inj_on_def)
  also have "card ?C = inversion_number_between xs ys"
    unfolding inversion_number_between_def by (intro card_image inj_onI) (auto simp: map_prod_def)
  finally show ?thesis .
qed

subsection \<open>Stability of inversions between lists under permutations\<close>

text \<open>
  A crucial fact for counting list inversions with merge sort is that the number
  of inversions \<^emph>\<open>between\<close> two lists does not change when the lists are permuted. This is
  true because the set of inversions commutes with the act of permuting the list:
\<close>
lemma inversions_between_permute1:
  assumes "\<pi> permutes {..<length xs}"
  shows   "inversions_between (permute_list \<pi> xs) ys =
             map_prod (inv \<pi>) id ` inversions_between xs ys"
proof -
  from assms have [simp]: "\<pi> i < length xs" if "i < length xs" "\<pi> permutes {..<length xs}" for i \<pi>
    using permutes_in_image[OF that(2)] that by auto
  have *: "inv \<pi> permutes {..<length xs}"
    using assms by (rule permutes_inv)
  from assms * show ?thesis unfolding inversions_between_def map_prod_def
    by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
qed

lemma inversions_between_permute2:
  assumes "\<pi> permutes {..<length ys}"
  shows   "inversions_between xs (permute_list \<pi> ys) =
             map_prod id (inv \<pi>) ` inversions_between xs ys"
proof -
  from assms have [simp]: "\<pi> i < length ys" if "i < length ys" "\<pi> permutes {..<length ys}" for i \<pi>
    using permutes_in_image[OF that(2)] that by auto
  have *: "inv \<pi> permutes {..<length ys}"
    using assms by (rule permutes_inv)
  from assms * show ?thesis unfolding inversions_between_def map_prod_def
    by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
qed

proposition inversions_between_permute:
  assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
  shows   "inversions_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
             map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys"
  by (simp add: inversions_between_permute1 inversions_between_permute2 assms
                map_prod_def image_image case_prod_unfold)

corollary inversion_number_between_permute:
  assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
  shows   "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
             inversion_number_between xs ys"
proof -
  have "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
          card (map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys)"
    by (simp add: inversion_number_between_def inversions_between_permute assms)
  also have "\<dots> = inversion_number_between xs ys"
    unfolding inversion_number_between_def using assms[THEN permutes_inj_on[OF permutes_inv]]
    by (intro card_image inj_onI) (auto simp: map_prod_def)
  finally show ?thesis .
qed

text \<open>
  The following form of the above theorem is nicer to apply since it has the form of a
  congruence rule.
\<close>
corollary inversion_number_between_cong_mset:
  assumes "mset xs = mset xs'" and "mset ys = mset ys'"
  shows   "inversion_number_between xs ys = inversion_number_between xs' ys'"
proof -
  obtain \<pi>1 \<pi>2 where \<pi>12: "\<pi>1 permutes {..<length xs'}" "xs = permute_list \<pi>1 xs'"
                          "\<pi>2 permutes {..<length ys'}" "ys = permute_list \<pi>2 ys'"
    using assms[THEN mset_eq_permutation] by metis
  thus ?thesis by (simp add: inversion_number_between_permute)
qed

subsection \<open>Inversions between sorted lists\<close>

text \<open>
  Another fact that is crucial to the efficient computation of the inversion number is this:
  If we have two sorted lists, we can reduce computing the inversions by inspecting the
  first elements and deleting one of them.
\<close>
lemma inversions_between_Cons_Cons:
  assumes "sorted_wrt less_eq (x # xs)" and "sorted_wrt less_eq (y # ys)"
  shows   "inversions_between (x # xs) (y # ys) =
             (if \<not>less y x then
                map_prod Suc id ` inversions_between xs (y # ys)
              else
                {..<length (x#xs)} \<times> {0} \<union>
                map_prod id Suc ` inversions_between (x # xs) ys)"
  using assms  unfolding inversions_between_def map_prod_def
  by (auto, (auto simp: set_conv_nth nth_Cons less_le_not_le image_iff
                  intro: order_trans split: nat.splits)?)
  (* A bit fragile, but doing this manually is annoying *)

text \<open>
  This leads to the following analogous equation for counting the inversions between two
  sorted lists. Note that a single step of this only takes constant time (assuming we
  pre-computed the lengths of the lists) so that the entire function runs in linear time.
\<close>

text \<open>
  We now define a function to compute the inversion number between two lists that are
  assumed to be sorted using the equalities we just derived.
\<close>
fun inversion_number_between_sorted :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
  "inversion_number_between_sorted [] ys = 0"
| "inversion_number_between_sorted xs [] = 0"
| "inversion_number_between_sorted (x # xs) (y # ys) =
             (if \<not>less y x then
                inversion_number_between_sorted xs (y # ys)
              else
                inversion_number_between_sorted (x # xs) ys + length (x # xs))"

theorem inversion_number_between_sorted_correct:
  "sorted_wrt less_eq xs \<Longrightarrow> sorted_wrt less_eq ys \<Longrightarrow>
     inversion_number_between_sorted xs ys = inversion_number_between xs ys"
  by (induction xs ys rule: inversion_number_between_sorted.induct)
     (simp_all add: inversion_number_between_Cons_Cons)

end

subsection \<open>Merge sort\<close>

(* TODO: Could be replaced by mergesort from HOL-Library in Isabelle 2019. *)
text \<open>
  For convenience, we first define a simple merge sort that does not compute the inversions.
  At this point, we need to start assuming a linear ordering since the merging function
  does not work otherwise.
\<close>

context linorder
begin

definition split_list
  where "split_list xs = (let n = length xs div 2 in (take n xs, drop n xs))"

fun merge_lists :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "merge_lists [] ys = ys"
| "merge_lists xs [] = xs"
| "merge_lists (x # xs) (y # ys) =
    (if less_eq x y then x # merge_lists xs (y # ys) else y # merge_lists (x # xs) ys)"

lemma set_merge_lists [simp]: "set (merge_lists xs ys) = set xs \<union> set ys"
  by (induction xs ys rule: merge_lists.induct) auto

lemma mset_merge_lists [simp]: "mset (merge_lists xs ys) = mset xs + mset ys"
  by (induction xs ys rule: merge_lists.induct) auto

lemma sorted_merge_lists [simp, intro]:
  "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (merge_lists xs ys)"
  by (induction xs ys rule: merge_lists.induct) auto

fun merge_sort :: "'a list \<Rightarrow> 'a list" where
  "merge_sort xs =
    (if length xs \<le> 1 then
       xs
     else
       merge_lists (merge_sort (take (length xs div 2) xs))
                   (merge_sort (drop (length xs div 2) xs)))"

lemmas [simp del] = merge_sort.simps

lemma merge_sort_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> merge_sort xs = xs"
  by (subst merge_sort.simps) auto

theorem mset_merge_sort [simp]: "mset (merge_sort xs) = mset xs"
  by (induction xs rule: merge_sort.induct)
     (subst merge_sort.simps, auto simp flip: mset_append)

corollary set_merge_sort [simp]: "set (merge_sort xs) = set xs"
  by (rule mset_eq_setD) simp_all

theorem sorted_merge_sort [simp, intro]: "sorted (merge_sort xs)"
  by (induction xs rule: merge_sort.induct)
     (subst merge_sort.simps, use sorted01 in auto)

lemma inversion_number_between_code:
  "inversion_number_between xs ys = inversion_number_between_sorted (sort xs) (sort ys)"
  by (subst inversion_number_between_sorted_correct)
     (simp_all add: sorted_sorted_wrt [symmetric] cong: inversion_number_between_cong_mset)

lemmas (in -) [code_unfold] = inversion_number_between_code

subsection \<open>Merge sort with inversion counting\<close>

text \<open>
  Finally, we can put together all the components and define a variant of merge sort that
  counts the number of inversions in the original list:
\<close>
function sort_and_count_inversions :: "'a list \<Rightarrow> 'a list \<times> nat" where
  "sort_and_count_inversions xs =
     (if length xs \<le> 1 then
        (xs, 0)
      else
        let (xs1, xs2) = split_list xs;
            (xs1', m) = sort_and_count_inversions xs1;
            (xs2', n) = sort_and_count_inversions xs2
        in
            (merge_lists xs1' xs2', m + n + inversion_number_between_sorted xs1' xs2'))"
  by auto
termination by (relation "measure length") (auto simp: split_list_def Let_def)

lemmas [simp del] = sort_and_count_inversions.simps

text \<open>
  The projection of this function to the first component is simply the standard merge sort
  algorithm that we defined and proved correct before.
\<close>
theorem fst_sort_and_count_inversions [simp]:
  "fst (sort_and_count_inversions xs) = merge_sort xs"
  by (induction xs rule: length_induct)
     (subst sort_and_count_inversions.simps, subst merge_sort.simps,
      simp_all add: split_list_def case_prod_unfold Let_def)

text \<open>
  The projection to the second component is the inversion number.
\<close>
theorem snd_sort_and_count_inversions [simp]:
  "snd (sort_and_count_inversions xs) = inversion_number xs"
proof (induction xs rule: length_induct)
  case (1 xs)
  show ?case
  proof (cases "length xs \<le> 1")
    case False
    have "xs = take (length xs div 2) xs @ drop (length xs div 2) xs" by simp
    also have "inversion_number \<dots> = snd (sort_and_count_inversions xs)"
      by (subst inversion_number_append, subst sort_and_count_inversions.simps)
         (use False 1 in \<open>auto simp: Let_def split_list_def case_prod_unfold
                                     inversion_number_between_sorted_correct
                                     sorted_sorted_wrt [symmetric]
                               cong: inversion_number_between_cong_mset\<close>)
    finally show ?thesis ..
  qed (auto simp: sort_and_count_inversions.simps)
qed

lemmas (in -) [code_unfold] = snd_sort_and_count_inversions [symmetric]

end

end


theory ListSet imports Main
begin

primrec member where
  \<open>member _ [] = False\<close> |
  \<open>member m (n # A) = (m = n \<or> member m A)\<close>

lemma member_iff [iff]: \<open>member m A \<longleftrightarrow> m \<in> set A\<close>
  by (induct A) simp_all

primrec common where
  \<open>common _ [] = False\<close> |
  \<open>common X (y # Y) = (member y X \<or> common X Y)\<close>

lemma common_iff [iff]: \<open>common A B \<longleftrightarrow> set A \<inter> set B \<noteq> {}\<close>
  by (induct B) simp_all

definition add where "
  add a X \<equiv>
    if member a X
    then X
    else a # X"

lemma add_simp [simp]: \<open>add a X = Y \<longrightarrow> (insert a (set X)) = set Y\<close>
  by (metis add_def insert_absorb list.simps(15) member_iff)

(*UNION*)
primrec union (infixr \<open>U\<close> 100) where
  \<open>union A [] = A\<close> |
  \<open>union A (b # B) = union (add b A) B\<close>

lemma union_simp [simp]: \<open>union A B = C \<longrightarrow> set A \<union> set B = set C\<close>
  apply (induct B arbitrary: A C)
   apply simp
  by (metis Un_insert_left Un_insert_right add_simp list.simps(15) union.simps(2))

lemma union_member: \<open>member a (A U B) \<longleftrightarrow> member a A \<or> member a B\<close>
  by (metis Un_iff member_iff union_simp)
(*\UNION*)

(*REMOVE*)
primrec remove where
  \<open>remove [] B = []\<close> |
  \<open>remove (a # A) B = (
    if member a B
    then remove A B
    else a # remove A B)\<close>

lemma remove_simp [simp]: \<open>remove A B = C \<longrightarrow> set A - set B = set C\<close>
  apply (induct A arbitrary: B C)
   apply simp
  by (metis insert_Diff_if list.simps(15) member_iff remove.simps(2))

lemma remove_iff : \<open>set (remove A B) = set A - set B\<close>
  by simp

lemma removent: \<open>\<not>common A B \<Longrightarrow> remove A B = A\<close>
proof (induct A)
case Nil
  then show ?case by simp
next
  case (Cons a A)
  then have a: "\<not> common (a # A) B \<and> (\<not> common A B \<longrightarrow> remove A B = A)" by simp
  then have 1:"\<not> member a B"
    by (metis common_iff insert_disjoint(1) list.simps(15) member_iff)
  from a have "\<not> common A B"
    by (metis "1" Int_insert_left_if0 common_iff list.simps(15) member_iff)
  then show ?case using 1
    using Cons.hyps by fastforce
qed

lemma removent2: \<open>\<not> member b B \<Longrightarrow> member b A \<Longrightarrow> member b (remove A B)\<close>
  by (metis DiffI member_iff remove_simp)

lemma remove_size: \<open>common A B \<Longrightarrow> size (remove A B) < size A\<close>
proof (induct A)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  then have a: "(common A B \<longrightarrow> length (remove A B) < length A) \<and> common (a # A) B" by simp
  then show ?case
  proof cases
    assume "member a B"
    then show ?thesis using a
      by (metis dual_order.strict_trans impossible_Cons not_le_imp_less remove.simps(2) removent)
  next
    assume "\<not> member a B"
    then have "common A B"
      using Cons.prems set_ConsD by fastforce
    then show ?thesis using a by simp
  qed
qed

lemma member_remove: \<open>member a B \<Longrightarrow> \<not> member a (remove A B)\<close>
  by (metis DiffD2 member_iff remove_simp)
(*\REMOVE*)

(*SETEQUAL*)
definition set_equal where \<open>set_equal A B \<equiv> remove A B = [] \<and> remove B A = []\<close>

lemma set_equal_iff[iff]: "set_equal A B \<longleftrightarrow> set A = set B"
  apply (induct A arbitrary: B)
   apply (smt (z3) Diff_empty remove_simp set_empty set_equal_def)
  by (smt (verit) Diff_cancel Un_Diff_cancel Un_left_commute
      remove_simp set_empty2 set_equal_def sup_bot.right_neutral)

lemma set_equal_reflexive: \<open>set_equal A A\<close>
  by simp

lemma set_equal_commutative: \<open>set_equal A B \<longleftrightarrow> set_equal B A\<close>
  by auto

lemma set_equal_associative: \<open>set_equal A B \<Longrightarrow> set_equal B C \<Longrightarrow> set_equal A C\<close>
  by simp

lemma union_commutative: \<open>set_equal (A U B) (B U A)\<close>
  apply simp
  by (metis Un_commute union_simp)

lemma union_associative: \<open>set_equal (A U (B U C)) ((A U B) U C)\<close>
  by (metis boolean_algebra_cancel.sup1 set_equal_iff union_simp)

lemma union_reflexive:\<open>set_equal A (A U A)\<close>
  by (metis set_equal_iff sup.idem union_simp)

lemma equal_add: \<open>set_equal A B \<Longrightarrow> set_equal (add a A) (add a B)\<close>
  by (metis add_simp set_equal_iff)

lemma unionadd1: \<open>set_equal (add a (A U B)) ((add a A) U B)\<close>
  by (metis Un_insert_left add_simp set_equal_iff union_simp)

lemma unionadd11: \<open>set_equal (add a (add b (A U B))) ((add a (add b A)) U B)\<close>
  by (metis add_simp set_equal_iff unionadd1)

lemma unionadd2: \<open>set_equal (add a (A U B)) (A U (add a B))\<close>
  by (metis add_simp set_equal_iff union_commutative unionadd1)

lemma unionaddnt: \<open>set_equal ([] U B) B\<close>
proof (induct B)
  case Nil
  then show ?case by simp
next
  case (Cons a B)
  then show ?case using set_equal_def
    by (smt (verit, del_insts) add_def add_simp
        list.simps(15) set_equal_iff union.simps(2) unionadd1)
qed

lemma union_with_equal: \<open>set_equal A B \<Longrightarrow> set_equal (C U A) (C U B)\<close>
  apply (induct C)
   apply (metis set_equal_iff unionaddnt)
  apply simp
  by (metis union_simp)

lemma union_with_equal2: \<open>set_equal A B \<Longrightarrow> set_equal (A U C) (B U C)\<close>
  by (metis set_equal_iff union_simp)

lemma set_equal_append_add: \<open>set_equal (a # A) (add a A)\<close>
  by simp

lemma remove_equal: \<open>set_equal A B \<Longrightarrow> set_equal (remove A C) (remove B C)\<close>
  by (metis remove_simp set_equal_iff)

lemma remove_commute: \<open>set_equal (remove (remove A B) C) (remove A (C @ B))\<close>
proof (induct A)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  consider \<open>member a B \<or> member a C\<close> | \<open>\<not>member a B \<and> \<not>member a C\<close>
    by auto
  then show ?case
  proof cases
    case 1
    have \<open>member a (C @ B)\<close>
      by (metis 1 UnI1 UnI2 member_iff set_append)
    then have \<open>set_equal (remove (a # A) (C @ B)) (remove A (C @ B))\<close>
      by simp
    moreover have \<open>set_equal (remove (remove (a # A) B) C) (remove (remove A B) C)\<close>
      using "1" by auto
    ultimately show ?thesis
      using Cons.hyps by force
  next
    case 2
    then have \<open>\<not>member a (C @ B)\<close>
      by (metis Un_iff member_iff set_append)
    then have \<open>set_equal (remove (a # A) (C @ B)) (a # (remove A (C @ B)))\<close>
      by simp
    moreover have \<open>set_equal (remove (remove (a # A) B) C) (a # (remove (remove A B) C))\<close>
      using "2" by auto
    ultimately show ?thesis
      using Cons.hyps by force
  qed
qed

lemma set_equal_remove_commont: \<open>
  \<not> common A B \<Longrightarrow> set_equal (remove (B @ A) B) A\<close>
proof (induct B)
  case Nil
  then show ?case
    by (simp add: removent)
next
  case (Cons a B)
  have 0:\<open>\<not>member a A\<close>
    by (meson Cons.prems common.simps(2))
  have 1:\<open>set_equal A (remove (B @ A) B)\<close>
    by (meson Cons.hyps Cons.prems common.simps(2) set_equal_commutative)
  then have 2:\<open>\<not> member a (remove (B @ A) B)\<close>
    by (metis Cons.prems ListSet.member.simps(1) common.simps(2) removent2 set_equal_def)
  have \<open>set_equal A (remove (B @ A) B)\<close>
    using "1" by auto
  moreover have \<open>set_equal ... (remove (remove (B @ A) B) [a])\<close>
    by (metis "2" append_Nil2 common.simps(1) common.simps(2) remove_commute removent)
  moreover have \<open>set_equal ... (remove (B @ A) (a # B))\<close>
    by (metis append_Cons append_Nil remove_commute)
  moreover have \<open>set_equal ... (remove (a # B @ A) (a # B))\<close>
    by (metis ListSet.member.simps(2) remove.simps(2) union_with_equal union.simps(1) unionaddnt)
  ultimately show ?case
    by simp
qed

lemma set_equal_commont_remove: \<open>
  \<not> common A C \<Longrightarrow> set_equal (C @ A) B \<Longrightarrow> set_equal A (remove B C)\<close>
proof -
  assume a1:\<open>\<not> common A C\<close>
  assume a2:\<open>set_equal (C @ A) B\<close>
  then have \<open>set_equal (remove (C @ A) C) (remove B C)\<close>
    by (meson remove_equal)
  moreover have \<open>set_equal (remove (C @ A) C) A\<close> using a1
    by (meson set_equal_remove_commont)
  ultimately show ?thesis
    by simp
qed

lemma double_union_equal: \<open>
  set_equal A C \<Longrightarrow> set_equal B D \<Longrightarrow> set_equal (A U B) (C U D)\<close> (is \<open>?A1 \<Longrightarrow> ?A2 \<Longrightarrow> ?C\<close>)
proof -
  assume a1:"?A1"
  assume a2:\<open>?A2\<close>
  have \<open>set_equal (A U B) (A U D)\<close>
    by (meson a2 union_with_equal)
  then show ?C
    by (metis a1 set_equal_iff union_simp)
qed

lemma set_equal_add_con: \<open>set_equal (add a (b # A)) (b # (add a A))\<close>
proof-
  have \<open>set_equal (add a (b # A)) (add a (add b A))\<close>
    by (meson equal_add set_equal_append_add)
  moreover have \<open>set_equal ... (add b (add a A))\<close>
    by (metis calculation set_equal_associative set_equal_commutative union.simps(1)
        union.simps(2) union_commutative unionadd2)
  ultimately show ?thesis
    by simp
qed
(*\SETEQUAL*)

(*SUBSET*)
definition sub_set where "sub_set A B \<equiv> remove A B = []"

lemma sub_set_iff[iff]: "sub_set A B \<longleftrightarrow> set A \<subseteq> set B"
  apply (induct A)
   apply (simp add: sub_set_def)
  by (metis Diff_eq_empty_iff remove_simp set_empty sub_set_def)

lemma sub_set_union1: \<open>sub_set A (A U B)\<close>
  by (metis sub_set_iff sup.cobounded1 union_simp)

lemma sub_set_union2: \<open>sub_set A (B U A)\<close>
  by (metis UnI2 sub_set_iff subsetI union_simp)

lemma sub_set_remove: \<open>\<not> member a' A \<Longrightarrow> sub_set A B \<Longrightarrow> sub_set A (remove B [a'])\<close>
proof (induct A arbitrary: a' B)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  have 1:"a' \<noteq> a"
    by (metis Cons.prems(1) member.simps(2))
  have 2:"sub_set A (remove B [a'])"
    by (metis Cons.hyps Cons.prems(1) Cons.prems(2) member.simps(2)
        list.distinct(1) remove.simps(2) sub_set_def)
  show ?case
  proof cases
    assume "member a B"
    then have "member a (remove B [a'])"
      by (metis "1" member.simps(1)
          member.simps(2) removent2)
    then show ?thesis
      by (metis 2 remove.simps(2) sub_set_def)
  next
    assume "\<not>member a B"
    then show ?thesis
      by (metis Cons.prems(2) list.distinct(1) remove.simps(2) sub_set_def)
  qed
qed

lemma sub_set_remove2: \<open>\<not> member a' A \<Longrightarrow> sub_set A (a' # B) \<Longrightarrow> sub_set A B\<close>
  using set_ConsD by fastforce

lemma add_sub_set: \<open>sub_set A B \<Longrightarrow> sub_set A (add b B)\<close>
  by (metis add_simp sub_set_iff subset_insertI2)

lemma sub_set_union: \<open>sub_set A C \<Longrightarrow> sub_set B C \<Longrightarrow> sub_set (A U B) C\<close>
  by (metis Un_subset_iff sub_set_iff union_simp)

lemma member_sub_set: \<open>(\<forall> a. member a A \<longrightarrow> member a B) \<longleftrightarrow> sub_set A B\<close>
  by auto

lemma sub_remove_set: \<open>sub_set A B \<Longrightarrow> sub_set (remove A C) B\<close>
  using remove_iff by fast

lemma sub_remove_middle: \<open>A = A1 @ A2 @ A3 \<Longrightarrow> A' = A1 @ A3 \<Longrightarrow> sub_set A' A\<close>
  apply (induct A1 arbitrary: A A')
   apply simp
   apply (meson sub_set_iff sub_set_union2)
  by (metis (full_types) Cons_eq_appendI ListSet.member.simps(2) member_sub_set)
(*\SUBSET*)

(*ISSET*)
primrec is_set where
  \<open>is_set [] = True\<close> |
  \<open>is_set (a # A) = (\<not> member a A \<and> is_set A)\<close>

lemma is_set_size: \<open>is_set A \<longleftrightarrow> (\<forall> a. member a A \<longrightarrow> Suc (size (remove A [a])) = size A)\<close>
proof (induct A)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  assume a1: "is_set A = (\<forall>a. member a A \<longrightarrow> Suc (length (remove A [a])) = length A)"
  show "is_set (a # A) \<longleftrightarrow> (\<forall>aa. member aa (a # A) \<longrightarrow> Suc (length (remove (a # A) [aa])) = length (a # A))"
  proof
    assume a2: "is_set (a # A)"
    then have 1:"(\<forall>a. member a A \<longrightarrow> Suc (length (remove A [a])) = length A)" using a1  by simp

    show "(\<forall>aa. member aa (a # A) \<longrightarrow> Suc (length (remove (a # A) [aa])) = length (a # A))"
    proof
      fix aa
      show "member aa (a # A) \<longrightarrow> Suc (length (remove (a # A) [aa])) = length (a # A)"
      proof
        assume a3: "member aa (a # A)"
        show "Suc (length (remove (a # A) [aa])) = length (a # A)"
        proof cases
          assume "member aa A"
          then show ?thesis
            using 1 a2 by auto
        next
          assume a4: "\<not> member aa A"
          then have 1: \<open>remove (a # A) [aa] = remove A [aa]\<close>
            by (metis member.simps(2) a3 remove.simps(2))
          then have "remove A [aa] = A" using a4 removent
            by force
          then show ?thesis
            using 1 by auto
        qed
      qed
    qed
  next
    assume a2:"\<forall>aa. member aa (a # A) \<longrightarrow> Suc (length (remove (a # A) [aa])) = length (a # A)"
    have "\<forall>a. member a A \<longrightarrow> Suc (length (remove A [a])) = length A"
    proof
      fix a'
      show "member a' A \<longrightarrow> Suc (length (remove A [a'])) = length A"
      proof
        assume a3:"member a' A"
        then have 1: "Suc (length (remove (a # A) [a'])) = length (a # A)" using a2
          by (meson member.simps(2))
        have "a \<noteq> a'"
        proof (rule ccontr)
          assume "\<not>a \<noteq> a'"
          then have 2:"remove (a # A) [a'] = remove A [a']" by simp
          have "length (remove A [a']) < length A" using a3
            by (metis common.simps(2) remove_size)
          then show "False"
            using 1 2 by fastforce
        qed
        then show "Suc (length (remove A [a'])) = length A"
          using 1 by auto
      qed
    qed
    then show "is_set (a # A)"
      using member.simps(2) a1 a2 by fastforce
  qed
qed

lemma union_is_set: \<open>is_set A \<Longrightarrow> is_set (A U B)\<close>
  apply (induct B arbitrary: A)
  apply simp
 by (metis add_def is_set.simps(2) union.simps(2))

lemma add_is_set: \<open>is_set A \<Longrightarrow> is_set (add a A)\<close>
  by (simp add: add_def)

lemma remove_is_set: \<open>is_set A \<Longrightarrow> is_set (remove A B)\<close>
proof (induct A)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  then show ?case
  proof cases
    assume "member a B"
    then show ?thesis
      using Cons.hyps Cons.prems by auto
  next
    assume "\<not>member a B"
    have "\<not> member a A"
      using Cons.prems by auto
    then have "\<not> member a (remove A B)"
      by (metis DiffE member_iff remove_simp)
    then show ?thesis
      using Cons.hyps Cons.prems by auto
  qed
qed

lemma set_size_equal: \<open>is_set A \<Longrightarrow> is_set B \<Longrightarrow> set_equal A B \<Longrightarrow> length A = length B\<close>
  apply (induct A arbitrary: B)
   apply simp
  by (smt (verit, ccfv_threshold) member.simps(2) is_set.simps(2) is_set_size
      length_Cons less_irrefl_nat list.distinct(1) nat.inject remove.simps(2) remove_equal
      remove_is_set remove_size removent set_equal_def)

lemma sub_set_size: \<open>is_set A \<Longrightarrow> is_set B \<Longrightarrow> sub_set A B \<Longrightarrow> length A \<le> length B\<close>
proof (induct A arbitrary: B)
  case Nil
  then show ?case by simp
next
  case (Cons a A)
  then show ?case
  proof cases
    assume "member a A"
    then show ?thesis
      by (meson Cons.prems(1) is_set.simps(2))
  next
    assume a:"\<not> member a A"
    then have "member a B"
      by (metis Cons.prems(3) in_mono list.set_intros(1) member_iff sub_set_iff)
    moreover have "is_set A"
      using Cons.prems(1) by auto
    moreover have "is_set (remove B [a])"
      by (simp add: Cons.prems(2) remove_is_set)
    then have "length A \<le> length (remove B [a])"
      by (metis Cons.hyps Cons.prems(3) a calculation(1)
          calculation(2) remove.simps(2) sub_set_def sub_set_remove)
    then show ?thesis
      using Cons.prems(2) calculation(1) is_set_size by fastforce
  qed
qed

lemma add_size: \<open>length (add a A) \<le> length A + 1\<close>
proof cases
  assume "member a A"
  then show ?thesis
    by (simp add: add_def)
next
  assume "\<not> member a A"
  then show ?thesis
    by (metis One_nat_def add_def eq_imp_le list.size(4))
qed
(*\ISSET*)
end


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

subsection\<open>Mutually Inductive Definitions\<close>

text\<open>
Just as there are datatypes defined by mutual recursion, there are sets defined
by mutual induction. As a trivial example we consider the even and odd
natural numbers:
\<close>

inductive_set
  Even :: "nat set" and
  Odd  :: "nat set"
where
  zero:  "0 \<in> Even"
| EvenI: "n \<in> Odd \<Longrightarrow> Suc n \<in> Even"
| OddI:  "n \<in> Even \<Longrightarrow> Suc n \<in> Odd"

text\<open>\noindent
The mutually inductive definition of multiple sets is no different from
that of a single set, except for induction: just as for mutually recursive
datatypes, induction needs to involve all the simultaneously defined sets. In
the above case, the induction rule is called @{thm[source]Even_Odd.induct}
(simply concatenate the names of the sets involved) and has the conclusion
@{text[display]"(?x \<in> Even \<longrightarrow> ?P ?x) \<and> (?y \<in> Odd \<longrightarrow> ?Q ?y)"}

If we want to prove that all even numbers are divisible by two, we have to
generalize the statement as follows:
\<close>

lemma "(m \<in> Even \<longrightarrow> 2 dvd m) \<and> (n \<in> Odd \<longrightarrow> 2 dvd (Suc n))"

txt\<open>\noindent
The proof is by rule induction. Because of the form of the induction theorem,
it is applied by \<open>rule\<close> rather than \<open>erule\<close> as for ordinary
inductive definitions:
\<close>

apply(rule Even_Odd.induct)

txt\<open>
@{subgoals[display,indent=0]}
The first two subgoals are proved by simplification and the final one can be
proved in the same manner as in \S\ref{sec:rule-induction}
where the same subgoal was encountered before.
We do not show the proof script.
\<close>
(*<*)
  apply simp
 apply simp
apply(simp add: dvd_def)
apply(clarify)
apply(rule_tac x = "Suc k" in exI)
apply simp
done
(*>*)

subsection\<open>Inductively Defined Predicates\label{sec:ind-predicates}\<close>

text\<open>\index{inductive predicates|(}
Instead of a set of even numbers one can also define a predicate on \<^typ>\<open>nat\<close>:
\<close>

inductive evn :: "nat \<Rightarrow> bool" where
zero: "evn 0" |
step: "evn n \<Longrightarrow> evn(Suc(Suc n))"

text\<open>\noindent Everything works as before, except that
you write \commdx{inductive} instead of \isacommand{inductive\_set} and
\<^prop>\<open>evn n\<close> instead of \<^prop>\<open>n \<in> Even\<close>.
When defining an n-ary relation as a predicate, it is recommended to curry
the predicate: its type should be \mbox{\<open>\<tau>\<^sub>1 \<Rightarrow> \<dots> \<Rightarrow> \<tau>\<^sub>n \<Rightarrow> bool\<close>}
rather than
\<open>\<tau>\<^sub>1 \<times> \<dots> \<times> \<tau>\<^sub>n \<Rightarrow> bool\<close>. The curried version facilitates inductions.

When should you choose sets and when predicates? If you intend to combine your notion with set theoretic notation, define it as an inductive set. If not, define it as an inductive predicate, thus avoiding the \<open>\<in>\<close> notation. But note that predicates of more than one argument cannot be combined with the usual set theoretic operators: \<^term>\<open>P \<union> Q\<close> is not well-typed if \<open>P, Q :: \<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2 \<Rightarrow> bool\<close>, you have to write \<^term>\<open>%x y. P x y & Q x y\<close> instead.
\index{inductive predicates|)}
\<close>

(*<*)end(*>*)


(*
  File:      HOL/Computational_Algebra/Nth_Powers.thy
  Author:    Manuel Eberl <manuel@pruvisto.org>

  n-th powers in general and n-th roots of natural numbers
*)
section \<open>$n$-th powers and roots of naturals\<close>
theory Nth_Powers
  imports Primes
begin

subsection \<open>The set of $n$-th powers\<close>

definition is_nth_power :: "nat \<Rightarrow> 'a :: monoid_mult \<Rightarrow> bool" where
  "is_nth_power n x \<longleftrightarrow> (\<exists>y. x = y ^ n)"

lemma is_nth_power_nth_power [simp, intro]: "is_nth_power n (x ^ n)"
  by (auto simp add: is_nth_power_def)

lemma is_nth_powerI [intro?]: "x = y ^ n \<Longrightarrow> is_nth_power n x"
  by (auto simp: is_nth_power_def)

lemma is_nth_powerE: "is_nth_power n x \<Longrightarrow> (\<And>y. x = y ^ n \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp: is_nth_power_def)

abbreviation is_square where "is_square \<equiv> is_nth_power 2"

lemma is_zeroth_power [simp]: "is_nth_power 0 x \<longleftrightarrow> x = 1"
  by (simp add: is_nth_power_def)

lemma is_first_power [simp]: "is_nth_power 1 x"
  by (simp add: is_nth_power_def)

lemma is_first_power' [simp]: "is_nth_power (Suc 0) x"
  by (simp add: is_nth_power_def)

lemma is_nth_power_0 [simp]: "n > 0 \<Longrightarrow> is_nth_power n (0 :: 'a :: semiring_1)"
  by (auto simp: is_nth_power_def power_0_left intro!: exI[of _ 0])

lemma is_nth_power_0_iff [simp]: "is_nth_power n (0 :: 'a :: semiring_1) \<longleftrightarrow> n > 0"
  by (cases n) auto

lemma is_nth_power_1 [simp]: "is_nth_power n 1"
  by (auto simp: is_nth_power_def intro!: exI[of _ 1])

lemma is_nth_power_Suc_0 [simp]: "is_nth_power n (Suc 0)"
  by (simp add: One_nat_def [symmetric] del: One_nat_def)

lemma is_nth_power_conv_multiplicity:
  fixes x :: "'a :: {factorial_semiring, normalization_semidom_multiplicative}"
  assumes "n > 0"
  shows   "is_nth_power n (normalize x) \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x)"
proof (cases "x = 0")
  case False
  show ?thesis
  proof (safe intro!: is_nth_powerI elim!: is_nth_powerE)
    fix y p :: 'a assume *: "normalize x = y ^ n" "prime p"
    with assms and False have [simp]: "y \<noteq> 0" by (auto simp: power_0_left)
    have "multiplicity p x = multiplicity p (y ^ n)"
      by (subst *(1) [symmetric]) simp
    with False and * and assms show "n dvd multiplicity p x"
      by (auto simp: prime_elem_multiplicity_power_distrib)
  next
    assume *: "\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x"
    have "multiplicity p ((\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n) =
            multiplicity p x" if "prime p" for p
    proof -
      from that and * have "n dvd multiplicity p x" by blast
      have "multiplicity p x = 0" if "p \<notin> prime_factors x"
        using that and \<open>prime p\<close> by (simp add: prime_factors_multiplicity)
      with that and * and assms show ?thesis unfolding prod_power_distrib power_mult [symmetric]
        by (subst multiplicity_prod_prime_powers) (auto simp: in_prime_factors_imp_prime elim: dvdE)
    qed
    with assms False
      have "normalize x = normalize ((\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n)"
      by (intro multiplicity_eq_imp_eq) (auto simp: multiplicity_prod_prime_powers)
    thus "normalize x = normalize (\<Prod>p\<in>prime_factors x. p ^ (multiplicity p x div n)) ^ n"
      by (simp add: normalize_power)
  qed
qed (insert assms, auto)

lemma is_nth_power_conv_multiplicity_nat:
  assumes "n > 0"
  shows   "is_nth_power n (x :: nat) \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> n dvd multiplicity p x)"
  using is_nth_power_conv_multiplicity[OF assms, of x] by simp

lemma is_nth_power_mult:
  assumes "is_nth_power n a" "is_nth_power n b"
  shows   "is_nth_power n (a * b :: 'a :: comm_monoid_mult)"
proof -
  from assms obtain a' b' where "a = a' ^ n" "b = b' ^ n" by (auto elim!: is_nth_powerE)
  hence "a * b = (a' * b') ^ n" by (simp add: power_mult_distrib)
  thus ?thesis by (rule is_nth_powerI)
qed

lemma is_nth_power_mult_coprime_natD:
  fixes a b :: nat
  assumes "coprime a b" "is_nth_power n (a * b)" "a > 0" "b > 0"
  shows   "is_nth_power n a" "is_nth_power n b"
proof -
  have A: "is_nth_power n a" if "coprime a b" "is_nth_power n (a * b)" "a \<noteq> 0" "b \<noteq> 0" "n > 0"
    for a b :: nat unfolding is_nth_power_conv_multiplicity_nat[OF \<open>n > 0\<close>]
  proof safe
    fix p :: nat assume p: "prime p"
    from \<open>coprime a b\<close> have "\<not>(p dvd a \<and> p dvd b)"
      using coprime_common_divisor_nat[of a b p] p by auto
    moreover from that and p
      have "n dvd multiplicity p a + multiplicity p b"
      by (auto simp: is_nth_power_conv_multiplicity_nat prime_elem_multiplicity_mult_distrib)
    ultimately show "n dvd multiplicity p a"
      by (auto simp: not_dvd_imp_multiplicity_0)
  qed
  from A [of a b] assms show "is_nth_power n a"
    by (cases "n = 0") simp_all
  from A [of b a] assms show "is_nth_power n b"
    by (cases "n = 0") (simp_all add: ac_simps)
qed

lemma is_nth_power_mult_coprime_nat_iff:
  fixes a b :: nat
  assumes "coprime a b"
  shows   "is_nth_power n (a * b) \<longleftrightarrow> is_nth_power n a \<and>is_nth_power n b"
  using assms
  by (cases "a = 0"; cases "b = 0")
     (auto intro: is_nth_power_mult dest: is_nth_power_mult_coprime_natD[of a b n]
           simp del: One_nat_def)

lemma is_nth_power_prime_power_nat_iff:
  fixes p :: nat assumes "prime p"
  shows "is_nth_power n (p ^ k) \<longleftrightarrow> n dvd k"
  using assms
  by (cases "n > 0")
     (auto simp: is_nth_power_conv_multiplicity_nat prime_elem_multiplicity_power_distrib)

lemma is_nth_power_nth_power':
  assumes "n dvd n'"
  shows   "is_nth_power n (m ^ n')"
proof -
  from assms have "n' = n' div n * n" by simp
  also have "m ^ \<dots> = (m ^ (n' div n)) ^ n" by (simp add: power_mult)
  also have "is_nth_power n \<dots>" by simp
  finally show ?thesis .
qed

definition is_nth_power_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  where [code_abbrev]: "is_nth_power_nat = is_nth_power"

lemma is_nth_power_nat_code [code]:
  "is_nth_power_nat n m =
     (if n = 0 then m = 1
      else if m = 0 then n > 0
      else if n = 1 then True
      else (\<exists>k\<in>{1..m}. k ^ n = m))"
  by (auto simp: is_nth_power_nat_def is_nth_power_def power_eq_iff_eq_base self_le_power)

(* TODO: Harmonise with Discrete.sqrt *)

subsection \<open>The $n$-root of a natural number\<close>

definition nth_root_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_root_nat k n = (if k = 0 then 0 else Max {m. m ^ k \<le> n})"

lemma zeroth_root_nat [simp]: "nth_root_nat 0 n = 0"
  by (simp add: nth_root_nat_def)

lemma nth_root_nat_aux1:
  assumes "k > 0"
  shows   "{m::nat. m ^ k \<le> n} \<subseteq> {..n}"
proof safe
  fix m assume "m ^ k \<le> n"
  show "m \<le> n"
  proof (cases "m = 0")
    case False
    with assms have "m ^ 1 \<le> m ^ k" by (intro power_increasing) simp_all
    also note \<open>m ^ k \<le> n\<close>
    finally show ?thesis by simp
  qed simp_all
qed

lemma nth_root_nat_aux2:
  assumes "k > 0"
  shows   "finite {m::nat. m ^ k \<le> n}" "{m::nat. m ^ k \<le> n} \<noteq> {}"
proof -
  from assms have "{m. m ^ k \<le> n} \<subseteq> {..n}" by (rule nth_root_nat_aux1)
  moreover have "finite {..n}" by simp
  ultimately show "finite {m::nat. m ^ k \<le> n}" by (rule finite_subset)
next
  from assms show "{m::nat. m ^ k \<le> n} \<noteq> {}" by (auto intro!: exI[of _ 0] simp: power_0_left)
qed

lemma
  assumes "k > 0"
  shows   nth_root_nat_power_le: "nth_root_nat k n ^ k \<le> n"
    and   nth_root_nat_ge: "x ^ k \<le> n \<Longrightarrow> x \<le> nth_root_nat k n"
  using Max_in[OF nth_root_nat_aux2[OF assms], of n]
        Max_ge[OF nth_root_nat_aux2(1)[OF assms], of x n] assms
  by (auto simp: nth_root_nat_def)

lemma nth_root_nat_less:
  assumes "k > 0" "x ^ k > n"
  shows   "nth_root_nat k n < x"
proof -
  from \<open>k > 0\<close> have "nth_root_nat k n ^ k \<le> n" by (rule nth_root_nat_power_le)
  also have "n < x ^ k" by fact
  finally show ?thesis by (rule power_less_imp_less_base) simp_all
qed

lemma nth_root_nat_unique:
  assumes "m ^ k \<le> n" "(m + 1) ^ k > n"
  shows   "nth_root_nat k n = m"
proof (cases "k > 0")
  case True
  from nth_root_nat_less[OF \<open>k > 0\<close> assms(2)]
    have "nth_root_nat k n \<le> m" by simp
  moreover from \<open>k > 0\<close> and assms(1) have "nth_root_nat k n \<ge> m"
    by (intro nth_root_nat_ge)
  ultimately show ?thesis by (rule antisym)
qed (insert assms, auto)

lemma nth_root_nat_0 [simp]: "nth_root_nat k 0 = 0" by (simp add: nth_root_nat_def)
lemma nth_root_nat_1 [simp]: "k > 0 \<Longrightarrow> nth_root_nat k 1 = 1"
  by (rule nth_root_nat_unique) (auto simp del: One_nat_def)
lemma nth_root_nat_Suc_0 [simp]: "k > 0 \<Longrightarrow> nth_root_nat k (Suc 0) = Suc 0"
  using nth_root_nat_1 by (simp del: nth_root_nat_1)

lemma first_root_nat [simp]: "nth_root_nat 1 n = n"
  by (intro nth_root_nat_unique) auto

lemma first_root_nat' [simp]: "nth_root_nat (Suc 0) n = n"
  by (intro nth_root_nat_unique) auto

lemma nth_root_nat_code_naive':
  "nth_root_nat k n = (if k = 0 then 0 else Max (Set.filter (\<lambda>m. m ^ k \<le> n) {..n}))"
proof (cases "k > 0")
  case True
  hence "{m. m ^ k \<le> n} \<subseteq> {..n}" by (rule nth_root_nat_aux1)
  hence "Set.filter (\<lambda>m. m ^ k \<le> n) {..n} = {m. m ^ k \<le> n}"
    by (auto simp: Set.filter_def)
  with True show ?thesis by (simp add: nth_root_nat_def Set.filter_def)
qed simp

function nth_root_nat_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_root_nat_aux m k acc n =
     (let acc' = (k + 1) ^ m
      in  if k \<ge> n \<or> acc' > n then k else nth_root_nat_aux m (k+1) acc' n)"
  by auto
termination by (relation "measure (\<lambda>(_,k,_,n). n - k)", goal_cases) auto

lemma nth_root_nat_aux_le:
  assumes "k ^ m \<le> n" "m > 0"
  shows   "nth_root_nat_aux m k (k ^ m) n ^ m \<le> n"
  using assms
  by (induction m k "k ^ m" n rule:  nth_root_nat_aux.induct) (auto simp: Let_def)

lemma nth_root_nat_aux_gt:
  assumes "m > 0"
  shows   "(nth_root_nat_aux m k (k ^ m) n + 1) ^ m > n"
  using assms
proof (induction m k "k ^ m" n rule:  nth_root_nat_aux.induct)
  case (1 m k n)
  have "n < Suc k ^ m" if "n \<le> k"
  proof -
    note that
    also have "k < Suc k ^ 1" by simp
    also from \<open>m > 0\<close> have "\<dots> \<le> Suc k ^ m" by (intro power_increasing) simp_all
    finally show ?thesis .
  qed
  with 1 show ?case by (auto simp: Let_def)
qed

lemma nth_root_nat_aux_correct:
  assumes "k ^ m \<le> n" "m > 0"
  shows   "nth_root_nat_aux m k (k ^ m) n = nth_root_nat m n"
  by (rule sym, intro nth_root_nat_unique nth_root_nat_aux_le nth_root_nat_aux_gt assms)

lemma nth_root_nat_naive_code [code]:
  "nth_root_nat m n = (if m = 0 \<or> n = 0 then 0 else if m = 1 \<or> n = 1 then n else
                        nth_root_nat_aux m 1 1 n)"
  using nth_root_nat_aux_correct[of 1 m n] by auto

lemma nth_root_nat_nth_power [simp]: "k > 0 \<Longrightarrow> nth_root_nat k (n ^ k) = n"
  by (intro nth_root_nat_unique order.refl power_strict_mono) simp_all

lemma nth_root_nat_nth_power':
  assumes "k > 0" "k dvd m"
  shows   "nth_root_nat k (n ^ m) = n ^ (m div k)"
proof -
  from assms have "m = (m div k) * k" by simp
  also have "n ^ \<dots> = (n ^ (m div k)) ^ k" by (simp add: power_mult)
  also from assms have "nth_root_nat k \<dots> = n ^ (m div k)" by simp
  finally show ?thesis .
qed

lemma nth_root_nat_mono:
  assumes "m \<le> n"
  shows   "nth_root_nat k m \<le> nth_root_nat k n"
proof (cases "k = 0")
  case False
  with assms show ?thesis unfolding nth_root_nat_def
    using nth_root_nat_aux2[of k m] nth_root_nat_aux2[of k n]
    by (auto intro!: Max_mono)
qed auto

end


(*
  File:    Primorial.thy
  Author:  Manuel Eberl, TU München

  The primorial function x#, i.\,e. the product of all primes no greater than x.
*)
section \<open>The Primorial function\<close>
theory Primorial
  imports Prime_Distribution_Elementary_Library Primes_Omega
begin

subsection \<open>Definition and basic properties\<close>

definition primorial :: "real \<Rightarrow> nat" where
  "primorial x = \<Prod>{p. prime p \<and> real p \<le> x}"

lemma primorial_mono: "x \<le> y \<Longrightarrow> primorial x \<le> primorial y"
  unfolding primorial_def
  by (intro dvd_imp_le prod_dvd_prod_subset)
     (auto intro!: prod_pos finite_primes_le dest: prime_gt_0_nat)

lemma prime_factorization_primorial:
  "prime_factorization (primorial x) = mset_set {p. prime p \<and> real p \<le> x}"
proof (intro multiset_eqI)
  fix p :: nat
  note fin = finite_primes_le[of x]
  show "count (prime_factorization (primorial x)) p =
          count (mset_set {p. prime p \<and> real p \<le> x}) p"
  proof (cases "prime p")
    case True
    hence "count (prime_factorization (primorial x)) p =
             sum (multiplicity p) {p. prime p \<and> real p \<le> x}"
      unfolding primorial_def count_prime_factorization using fin
      by (subst prime_elem_multiplicity_prod_distrib) auto
    also from True have "\<dots> = sum (\<lambda>_. 1) (if p \<le> x then {p} else {})" using fin
      by (intro sum.mono_neutral_cong_right) (auto simp: prime_multiplicity_other split: if_splits)
    also have "\<dots> = count (mset_set {p. prime p \<and> real p \<le> x}) p"
      using True fin by auto
    finally show ?thesis .
  qed auto
qed

lemma prime_factors_primorial [simp]:
  "prime_factors (primorial x) = {p. prime p \<and> real p \<le> x}"
  unfolding prime_factorization_primorial using finite_primes_le[of x] by simp

lemma primorial_pos [simp, intro]: "primorial x > 0"
  unfolding primorial_def by (intro prod_pos) (auto dest: prime_gt_0_nat)

lemma primorial_neq_zero [simp]: "primorial x \<noteq> 0"
  by auto

lemma of_nat_primes_omega_primorial [simp]: "real (primes_omega (primorial x)) = primes_pi x"
  by (simp add: primes_omega_def primes_pi_def prime_sum_upto_def)

lemma primes_omega_primorial: "primes_omega (primorial x) = nat \<lfloor>primes_pi x\<rfloor>"
  by (simp add: primes_omega_def primes_pi_def prime_sum_upto_def)

lemma prime_dvd_primorial_iff: "prime p \<Longrightarrow> p dvd primorial x \<longleftrightarrow> p \<le> x"
  using finite_primes_le[of x]
  by (auto simp: primorial_def prime_dvd_prod_iff dest: primes_dvd_imp_eq)

lemma squarefree_primorial [intro]: "squarefree (primorial x)"
  unfolding primorial_def
  by (intro squarefree_prod_coprime) (auto simp: squarefree_prime intro: primes_coprime)

lemma primorial_ge: "primorial x \<ge> 2 powr primes_pi x"
proof -
  have "2 powr primes_pi x = real (\<Prod>p | prime p \<and> real p \<le> x. 2)"
    by (simp add: primes_pi_def prime_sum_upto_def powr_realpow)
  also have "(\<Prod>p | prime p \<and> real p \<le> x. 2) \<le> (\<Prod>p | prime p \<and> real p \<le> x. p)"
    by (intro prod_mono) (auto dest: prime_gt_1_nat)
  also have "\<dots> = primorial x" by (simp add: primorial_def)
  finally show ?thesis by simp
qed

lemma primorial_at_top: "filterlim primorial at_top at_top"
proof -
  have "filterlim (\<lambda>x. real (primorial x)) at_top at_top"
  proof (rule filterlim_at_top_mono)
    show "eventually (\<lambda>x. primorial x \<ge> 2 powr primes_pi x) at_top"
      by (intro always_eventually primorial_ge allI)
    have "filterlim (\<lambda>x. exp (ln 2 * primes_pi x)) at_top at_top"
      by (intro filterlim_compose[OF exp_at_top]
                filterlim_tendsto_pos_mult_at_top[OF tendsto_const] \<pi>_at_top) auto
    thus "filterlim (\<lambda>x. 2 powr primes_pi x) at_top at_top"
      by (simp add: powr_def mult_ac)
  qed
  thus ?thesis unfolding filterlim_sequentially_iff_filterlim_real [symmetric] .
qed

lemma totient_primorial:
  "real (totient (primorial x)) =
     real (primorial x) * (\<Prod>p | prime p \<and> real p \<le> x. 1 - 1 / real p)" for x
proof -
  have "real (totient (primorial x)) =
          primorial x * (\<Prod>p\<in>prime_factors (primorial x). 1 - 1 / p)"
    by (rule totient_formula2)
  thus ?thesis by simp
qed

lemma ln_primorial: "ln (primorial x) = primes_theta x"
proof -
  have "finite {p. prime p \<and> real p \<le> x}"
    by (rule finite_subset[of _ "{..nat \<lfloor>x\<rfloor>}"]) (auto simp: le_nat_iff le_floor_iff)
  thus ?thesis unfolding of_nat_prod primorial_def
    by (subst ln_prod) (auto dest: prime_gt_0_nat simp: \<theta>_def prime_sum_upto_def)
qed

lemma divisor_count_primorial: "divisor_count (primorial x) = 2 powr primes_pi x"
proof -
  have "divisor_count (primorial x) = (\<Prod>p | prime p \<and> real p \<le> x. divisor_count p)"
    unfolding primorial_def
    by (subst divisor_count.prod_coprime) (auto simp: primes_coprime)
  also have "\<dots> = (\<Prod>p | prime p \<and> real p \<le> x. 2)"
    by (intro prod.cong divisor_count.prime) auto
  also have "\<dots> = 2 powr primes_pi x"
    by (simp add: primes_pi_def prime_sum_upto_def powr_realpow)
  finally show ?thesis .
qed

subsection \<open>An alternative view on primorials\<close>

text \<open>
  The following function is an alternative representation of primorials; instead of taking
  the product of all primes up to a given real bound \<open>x\<close>, it takes the product of the first
  \<open>k\<close> primes. This is sometimes more convenient.
\<close>
definition primorial' :: "nat \<Rightarrow> nat" where
  "primorial' n = (\<Prod>k<n. nth_prime k)"

lemma primorial'_Suc: "primorial' (Suc n) = nth_prime n * primorial' n"
  by (simp add: primorial'_def)

lemma primorial'_pos [intro]: "primorial' n > 0"
  unfolding primorial'_def by (auto intro: prime_gt_0_nat)

lemma primorial'_neq_0 [simp]: "primorial' n \<noteq> 0"
  by auto

lemma strict_mono_primorial': "strict_mono primorial'"
  unfolding strict_mono_Suc_iff
proof
  fix n :: nat
  have "primorial' n * 1 < primorial' n * nth_prime n"
    using prime_gt_1_nat[OF prime_nth_prime[of n]]
    by (intro mult_strict_left_mono) auto
  thus "primorial' n < primorial' (Suc n)"
    by (simp add: primorial'_Suc)
qed

lemma prime_factorization_primorial':
  "prime_factorization (primorial' k) = mset_set (nth_prime ` {..<k})"
proof -
  have "prime_factorization (primorial' k) = (\<Sum>i<k. prime_factorization (nth_prime i))"
    unfolding primorial'_def by (subst prime_factorization_prod) (auto intro: prime_gt_0_nat)
  also have "\<dots> = (\<Sum>i<k. {#nth_prime i#})"
    by (intro sum.cong prime_factorization_prime) auto
  also have "\<dots> = (\<Sum>p\<in>nth_prime ` {..<k}. {#p#})"
    by (subst sum.reindex) (auto intro: inj_onI)
  also have "\<dots> = mset_set (nth_prime ` {..<k})"
    by simp
  finally show ?thesis .
qed

lemma prime_factors_primorial': "prime_factors (primorial' k) = nth_prime ` {..<k}"
  by (simp add: prime_factorization_primorial')

lemma primes_omega_primorial' [simp]: "primes_omega (primorial' k) = k"
  unfolding primes_omega_def prime_factors_primorial' by (subst card_image) (auto intro: inj_onI)

lemma squarefree_primorial' [intro]: "squarefree (primorial' x)"
  unfolding primorial'_def
  by (intro squarefree_prod_coprime) (auto intro: squarefree_prime intro: primes_coprime)

lemma divisor_count_primorial' [simp]: "divisor_count (primorial' k) = 2 ^ k"
  by (subst divisor_count_squarefree) auto

lemma totient_primorial':
  "totient (primorial' k) = primorial' k * (\<Prod>i<k. 1 - 1 / nth_prime i)"
  unfolding totient_formula2 prime_factors_primorial'
  by (subst prod.reindex) (auto intro: inj_onI)

lemma primorial_conv_primorial': "primorial x = primorial' (nat \<lfloor>primes_pi x\<rfloor>)"
  unfolding primorial_def primorial'_def
proof (rule prod.reindex_bij_witness[of _ nth_prime "\<lambda>p. nat \<lfloor>primes_pi (real p)\<rfloor> - 1"])
  fix p assume p: "p \<in> {p. prime p \<and> real p \<le> x}"
  have [simp]: "primes_pi 2 = 1" by (auto simp: eval_\<pi>)
  have "primes_pi p \<ge> 1"
    using p \<pi>_mono[of 2 "real p"] by (auto dest!: prime_gt_1_nat)
  with p show "nth_prime (nat \<lfloor>primes_pi p\<rfloor> - 1) = p"
    using \<pi>_pos[of "real p"]
    by (intro nth_prime_eqI'')
       (auto simp: le_nat_iff le_floor_iff primes_pi_def prime_sum_upto_def of_nat_diff)
  from p have "nat \<lfloor>primes_pi (real p)\<rfloor> \<le> nat \<lfloor>primes_pi x\<rfloor>"
    by (intro nat_mono floor_mono \<pi>_mono) auto
  hence "nat \<lfloor>primes_pi (real p)\<rfloor> - 1 < nat \<lfloor>primes_pi x\<rfloor>"
    using \<open>primes_pi p \<ge> 1\<close> by linarith
  thus  "nat \<lfloor>primes_pi (real p)\<rfloor> - 1 \<in> {..<nat \<lfloor>primes_pi x\<rfloor>}" by simp
  show "nth_prime (nat \<lfloor>primes_pi (real p)\<rfloor> - 1) = p"
    using p \<open>primes_pi p \<ge> 1\<close>
    by (intro nth_prime_eqI'') (auto simp: le_nat_iff primes_pi_def prime_sum_upto_def)
next
  fix k assume k: "k \<in> {..<nat \<lfloor>primes_pi x\<rfloor>}"
  thus *: "nat \<lfloor>primes_pi (real (nth_prime k))\<rfloor> - 1 = k" by auto
  from k have "\<not>(x < 2)" by (intro notI) auto
  hence "x \<ge> 2" by simp
  have "real (nth_prime k) \<le> real (nth_prime (nat \<lfloor>primes_pi x\<rfloor> - 1))"
    using k by simp
  also have "\<dots> \<le> x"
    using nth_prime_partition''[of x] \<open>x \<ge> 2\<close> by auto
  finally show "nth_prime k \<in> {p. prime p \<and> real p \<le> x}"
    by auto
qed

lemma primorial'_conv_primorial:
  assumes "n > 0"
  shows   "primorial' n = primorial (nth_prime (n - 1))"
proof -
  have "primorial (nth_prime (n - 1)) = (\<Prod>k<nat (int (n - 1) + 1). nth_prime k)"
    by (simp add: primorial_conv_primorial' primorial'_def)
  also have "nat (int (n - 1) + 1) = n"
    using assms by auto
  finally show ?thesis by (simp add: primorial'_def)
qed

subsection \<open>Maximal compositeness of primorials\<close>

text \<open>
  Primorials are maximally composite, i.\,e.\ any number with \<open>k\<close> distinct prime factors
  is as least as big as the primorial with \<open>k\<close> distinct prime factors, and and number less
  than a primorial has strictly less prime factors.
\<close>

lemma nth_prime_le_prime_sequence:
  fixes p :: "nat \<Rightarrow> nat"
  assumes "strict_mono_on p {..<n}" and "\<And>k. k < n \<Longrightarrow> prime (p k)" and "k < n"
  shows   "nth_prime k \<le> p k"
  using assms(3)
proof (induction k)
  case 0
  hence "prime (p 0)" by (intro assms)
  hence "p 0 \<ge> 2" by (auto dest: prime_gt_1_nat)
  thus ?case by simp
next
  case (Suc k)
  have IH: "Suc (nth_prime k) \<le> Suc (p k)" using Suc by simp
  have "nth_prime (Suc k) = smallest_prime_beyond (Suc (nth_prime k))"
    by (simp add: nth_prime_Suc)
  also {
    have "Suc (nth_prime k) \<le> Suc (p k)" using Suc by simp
    also have "\<dots> \<le> smallest_prime_beyond (Suc (p k))"
      by (rule smallest_prime_beyond_le)
    finally have "smallest_prime_beyond (Suc (nth_prime k)) \<le> smallest_prime_beyond (Suc (p k))"
      by (rule smallest_prime_beyond_smallest[OF prime_smallest_prime_beyond])
  }
  also have "p k < p (Suc k)"
    using Suc by (intro strict_mono_onD[OF assms(1)]) auto
  hence "smallest_prime_beyond (Suc (p k)) \<le> p (Suc k)"
    using Suc.prems by (intro smallest_prime_beyond_smallest assms) auto
  finally show ?case .
qed

theorem primorial'_primes_omega_le:
  fixes n :: nat
  assumes n: "n > 0"
  shows "primorial' (primes_omega n) \<le> n"
proof (cases "n = 1")
  case True
  thus ?thesis by simp
next
  case False
  with assms have "n > 1" by simp
  define m where "m = primes_omega n"
  define P where "P = {p. prime p \<and> real p \<le> primes_pi n}"
  define ps where "ps = sorted_list_of_set (prime_factors n)"
  have set_ps: "set ps = prime_factors n" by (simp add: ps_def)
  have [simp]: "length ps = m" by (simp add: ps_def m_def primes_omega_def)
  have "sorted ps" "distinct ps" by (simp_all add: ps_def)
  hence mono: "strict_mono_on (\<lambda>k. ps ! k) {..<m}"
    by (intro strict_mono_onI le_neq_trans) (auto simp: sorted_nth_mono distinct_conv_nth)
  from \<open>n > 1\<close> have "m > 0"
    by (auto simp: m_def prime_factorization_empty_iff intro!: Nat.gr0I)

  have "primorial' m = (\<Prod>k<m. nth_prime k)"
    using \<open>m > 0\<close> by (simp add: of_nat_diff primorial'_def m_def)
  also have "(\<Prod>k<m. nth_prime k) \<le> (\<Prod>k<m. ps ! k ^ multiplicity (ps ! k) n)"
  proof (intro prod_mono conjI)
    fix i assume i: "i \<in> {..<m}"
    hence p: "ps ! i \<in> prime_factors n"
      using set_ps by (auto simp: set_conv_nth)
    with i set_ps have "nth_prime i \<le> ps ! i"
      by (intro nth_prime_le_prime_sequence[where n = m] mono) (auto simp: set_conv_nth)
    also have "\<dots> \<le> ps ! i ^ multiplicity (ps ! i) n"
      using p by (intro self_le_power) (auto simp: prime_factors_multiplicity dest: prime_gt_1_nat)
    finally show "nth_prime i \<le> \<dots>" .
  qed auto
  also have "\<dots> = (\<Prod>p\<in>(\<lambda>i. ps ! i) ` {..<m}. p ^ multiplicity p n)"
    using \<open>distinct ps\<close> by (subst prod.reindex) (auto intro!: inj_onI simp: distinct_conv_nth)
  also have "(\<lambda>i. ps ! i) ` {..<m} = set ps"
    by (auto simp: set_conv_nth)
  also have "set ps = prime_factors n"
    by (simp add: set_ps)
  also have "(\<Prod>p\<in>prime_factors n. p ^ multiplicity p n) = n"
    using \<open>n > 1\<close> by (intro prime_factorization_nat [symmetric]) auto
  finally show "primorial' m \<le> n" .
qed

lemma primes_omega_less_primes_omega_primorial:
  fixes n :: nat
  assumes n: "n > 0" and "n < primorial x"
  shows "primes_omega n < primes_omega (primorial x)"
proof (cases "n > 1")
  case False
  have [simp]: "primes_pi 2 = 1" by (simp add: eval_\<pi>)
  from False assms have [simp]: "n = 1" by auto
  from assms have "\<not>(x < 2)"
    by (intro notI) (auto simp: primorial_conv_primorial')
  thus ?thesis using assms \<pi>_mono[of 2 x] by auto
next
  case True
  define m where "m = primes_omega n"
  have le: "primorial' m \<le> n"
    using primorial'_primes_omega_le[of n] \<open>n > 1\<close> by (simp add: m_def primes_omega_def)
  also have "\<dots> < primorial x" by fact
  also have "\<dots> = primorial' (nat \<lfloor>primes_pi x\<rfloor>)"
    by (simp add: primorial_conv_primorial')
  finally have "m < nat \<lfloor>primes_pi x\<rfloor>"
    using strict_mono_less[OF strict_mono_primorial'] by simp
  hence "m < primes_pi x" by linarith
  also have "\<dots> = primes_omega (primorial x)" by simp
  finally show ?thesis unfolding m_def of_nat_less_iff .
qed

lemma primes_omega_le_primes_omega_primorial:
  fixes n :: nat
  assumes "n \<le> primorial x"
  shows   "primes_omega n \<le> primes_omega (primorial x)"
proof -
  consider "n = 0" | "n > 0" "n = primorial x" | "n > 0" "n \<noteq> primorial x" by force
  thus ?thesis
    by cases (use primes_omega_less_primes_omega_primorial[of n x] assms in auto)
qed

end


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

  The unique decomposition of a natural number into a squarefree part and a square.
*)

section \<open>Squarefree decomposition of natural numbers\<close>
theory Squarefree_Nat
imports
  Main
  "HOL-Number_Theory.Number_Theory"
  Prime_Harmonic_Misc
begin

text \<open>
  The squarefree part of a natural number is the set of all prime factors that appear
  with odd multiplicity. The square part, correspondingly, is what remains after dividing
  by the squarefree part.
\<close>
definition squarefree_part :: "nat \<Rightarrow> nat set" where
  "squarefree_part n = {p\<in>prime_factors n. odd (multiplicity p n)}"

definition square_part :: "nat \<Rightarrow> nat" where
  "square_part n = (if n = 0 then 0 else (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n div 2)))"

lemma squarefree_part_0 [simp]: "squarefree_part 0 = {}"
  by (simp add: squarefree_part_def)

lemma square_part_0 [simp]: "square_part 0 = 0"
  by (simp add: square_part_def)

lemma squarefree_decompose: "\<Prod>(squarefree_part n) * square_part n ^ 2 = n"
proof (cases "n = 0")
  case False
  define A s where "A = squarefree_part n" and "s = square_part n"
  have "(\<Prod>A) = (\<Prod>p\<in>A. p ^ (multiplicity p n mod 2))"
    by (intro prod.cong) (auto simp: A_def squarefree_part_def elim!: oddE)
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n mod 2))"
    by (intro prod.mono_neutral_left) (auto simp: A_def  squarefree_part_def)
  also from False have "\<dots> * s^2 = n"
    by (simp add: s_def square_part_def prod.distrib [symmetric] power_add [symmetric]
                  power_mult [symmetric] prime_factorization_nat [symmetric] algebra_simps
                  prod_power_distrib)
  finally show "\<Prod>A * s^2 = n" .
qed simp

lemma squarefree_part_pos [simp]: "\<Prod>(squarefree_part n) > 0"
  using prime_gt_0_nat unfolding squarefree_part_def by auto

lemma squarefree_part_ge_Suc_0 [simp]: "\<Prod>(squarefree_part n) \<ge> Suc 0"
  using squarefree_part_pos[of n] by presburger

lemma squarefree_part_subset [intro]: "squarefree_part n \<subseteq> prime_factors n"
  unfolding squarefree_part_def by auto

lemma squarefree_part_finite [simp]: "finite (squarefree_part n)"
  by (rule finite_subset[OF squarefree_part_subset]) simp

lemma squarefree_part_dvd [simp]: "\<Prod>(squarefree_part n) dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma squarefree_part_dvd' [simp]: "p \<in> squarefree_part n \<Longrightarrow> p dvd n"
  by (rule dvd_prodD[OF _ squarefree_part_dvd]) simp_all

lemma square_part_dvd [simp]: "square_part n ^ 2 dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma square_part_dvd' [simp]: "square_part n dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma squarefree_part_le: "p \<in> squarefree_part n \<Longrightarrow> p \<le> n"
  by (cases "n = 0") (simp_all add: dvd_imp_le)

lemma square_part_le: "square_part n \<le> n"
  by (cases "n = 0") (simp_all add: dvd_imp_le)

lemma square_part_le_sqrt: "square_part n \<le> nat \<lfloor>sqrt (real n)\<rfloor>"
proof -
  have "1 * square_part n ^ 2 \<le> \<Prod>(squarefree_part n) * square_part n ^ 2"
    by (intro mult_right_mono) simp_all
  also have "\<dots> = n" by (rule squarefree_decompose)
  finally have "real (square_part n ^ 2) \<le> real n" by (subst of_nat_le_iff) simp
  hence "sqrt (real (square_part n ^ 2)) \<le> sqrt (real n)"
    by (subst real_sqrt_le_iff) simp_all
  also have "sqrt (real (square_part n ^ 2)) = real (square_part n)" by simp
  finally show ?thesis by linarith
qed

lemma square_part_pos [simp]: "n > 0 \<Longrightarrow> square_part n > 0"
  unfolding square_part_def using prime_gt_0_nat by auto

lemma square_part_ge_Suc_0 [simp]: "n > 0 \<Longrightarrow> square_part n \<ge> Suc 0"
  using square_part_pos[of n] by presburger

lemma zero_not_in_squarefree_part [simp]: "0 \<notin> squarefree_part n"
  unfolding squarefree_part_def by auto

lemma multiplicity_squarefree_part:
  "prime p \<Longrightarrow> multiplicity p (\<Prod>(squarefree_part n)) = (if p \<in> squarefree_part n then 1 else 0)"
  using squarefree_part_subset[of n]
  by (intro multiplicity_prod_prime_powers_nat') auto

text \<open>
  The squarefree part really is square, its only square divisor is 1.
\<close>
lemma square_dvd_squarefree_part_iff:
  "x^2 dvd \<Prod>(squarefree_part n) \<longleftrightarrow> x = 1"
proof (rule iffI, rule multiplicity_eq_nat)
  assume dvd: "x^2 dvd \<Prod>(squarefree_part n)"
  hence "x \<noteq> 0" using squarefree_part_subset[of n] prime_gt_0_nat by (intro notI) auto
  thus x: "x > 0" by simp

  fix p :: nat assume p: "prime p"
  from p x have "2 * multiplicity p x = multiplicity p (x^2)"
    by (simp add: multiplicity_power_nat)
  also from dvd have "\<dots> \<le> multiplicity p (\<Prod>(squarefree_part n))"
    by (intro dvd_imp_multiplicity_le) simp_all
  also have "\<dots> \<le> 1" using multiplicity_squarefree_part[of p n] p by simp
  finally show "multiplicity p x = multiplicity p 1" by simp
qed simp_all

lemma squarefree_decomposition_unique1:
  assumes "squarefree_part m = squarefree_part n"
  assumes "square_part m = square_part n"
  shows   "m = n"
  by (subst (1 2) squarefree_decompose [symmetric]) (simp add: assms)

lemma squarefree_decomposition_unique2:
  assumes n: "n > 0"
  assumes decomp: "n = (\<Prod>A2 * s2^2)"
  assumes prime: "\<And>x. x \<in> A2 \<Longrightarrow> prime x"
  assumes fin: "finite A2"
  assumes s2_nonneg: "s2 \<ge> 0"
  shows "A2 = squarefree_part n" and "s2 = square_part n"
proof -
  define A1 s1 where "A1 = squarefree_part n" and "s1 = square_part n"
  have "finite A1" unfolding A1_def by simp
  note fin = \<open>finite A1\<close> \<open>finite A2\<close>

  have "A1 \<subseteq> prime_factors n" unfolding A1_def using squarefree_part_subset .
  note subset = this prime

  have "\<Prod>A1 > 0" "\<Prod>A2 > 0" using subset(1)  prime_gt_0_nat
    by (auto intro!: prod_pos dest: prime)
  from n have "s1 > 0" unfolding s1_def by simp
  from assms have "s2 \<noteq> 0" by (intro notI) simp
  hence "s2 > 0" by simp
  note pos = \<open>\<Prod>A1 > 0\<close> \<open>\<Prod>A2 > 0\<close> \<open>s1 > 0\<close> \<open>s2 > 0\<close>

  have eq': "multiplicity p s1 = multiplicity p s2"
            "multiplicity p (\<Prod>A1) = multiplicity p (\<Prod>A2)"
    if   p: "prime p" for p
  proof -
    define m where "m = multiplicity p"
    from decomp have "m (\<Prod>A1 * s1^2) = m (\<Prod>A2 * s2^2)" unfolding A1_def s1_def
      by (simp add: A1_def s1_def squarefree_decompose)
    with p pos have eq: "m (\<Prod>A1) + 2 * m s1 = m (\<Prod>A2) + 2 * m s2"
      by (simp add: m_def prime_elem_multiplicity_mult_distrib multiplicity_power_nat)
    moreover from fin subset p have "m (\<Prod>A1) \<le> 1" "m (\<Prod>A2) \<le> 1" unfolding m_def
      by ((subst multiplicity_prod_prime_powers_nat', auto)[])+
    ultimately show "m s1 = m s2" by linarith
    with eq show "m (\<Prod>A1) = m (\<Prod>A2)" by simp
  qed

  show "s2 = square_part n"
    by (rule multiplicity_eq_nat) (insert pos eq'(1), auto simp: s1_def)
  have "\<Prod>A2 = \<Prod>(squarefree_part n)"
    by (rule multiplicity_eq_nat) (insert pos eq'(2), auto simp: A1_def)
  with fin subset show "A2 = squarefree_part n" unfolding A1_def
    by (intro prod_prime_eq) auto
qed

lemma squarefree_decomposition_unique2':
  assumes decomp: "(\<Prod>A1 * s1^2) = (\<Prod>A2 * s2^2 :: nat)"
  assumes fin: "finite A1" "finite A2"
  assumes subset: "\<And>x. x \<in> A1 \<Longrightarrow> prime x" "\<And>x. x \<in> A2 \<Longrightarrow> prime x"
  assumes pos: "s1 > 0" "s2 > 0"
  defines "n \<equiv> \<Prod>A1 * s1^2"
  shows "A1 = A2" "s1 = s2"
proof -
  from pos have n: "n > 0" using prime_gt_0_nat
    by (auto simp: n_def intro!: prod_pos dest: subset)
  have "A1 = squarefree_part n" "s1 = square_part n"
    by ((rule squarefree_decomposition_unique2[of n A1 s1], insert assms n, simp_all)[])+
  moreover have "A2 = squarefree_part n" "s2 = square_part n"
    by ((rule squarefree_decomposition_unique2[of n A2 s2], insert assms n, simp_all)[])+
  ultimately show "A1 = A2" "s1 = s2" by simp_all
qed

text \<open>
  The following is a nice and simple lower bound on the number of prime numbers less than
  a given number due to Erd\H{o}s. In particular, it implies that there are infinitely many primes.
\<close>
lemma primes_lower_bound:
  fixes n :: nat
  assumes "n > 0"
  defines "\<pi> \<equiv> \<lambda>n. card {p. prime p \<and> p \<le> n}"
  shows   "real (\<pi> n) \<ge> ln (real n) / ln 4"
proof -
  have "real n = real (card {1..n})" by simp
  also have "{1..n} = (\<lambda>(A, b). \<Prod>A * b^2) ` (\<lambda>n. (squarefree_part n, square_part n)) ` {1..n}"
    unfolding image_comp o_def squarefree_decompose case_prod_unfold fst_conv snd_conv by simp
  also have "card \<dots> \<le> card ((\<lambda>n. (squarefree_part n, square_part n)) ` {1..n})"
    by (rule card_image_le) simp_all
  also have "\<dots> \<le> card (squarefree_part ` {1..n} \<times> square_part ` {1..n})"
    by (rule card_mono) auto
  also have "real \<dots> = real (card (squarefree_part ` {1..n})) * real (card (square_part ` {1..n}))"
    by simp
  also have "\<dots> \<le> 2 ^ \<pi> n * sqrt (real n)"
  proof (rule mult_mono)
    have "card (squarefree_part ` {1..n}) \<le> card (Pow {p. prime p \<and> p \<le> n})"
      using squarefree_part_subset squarefree_part_le by (intro card_mono) force+
    also have "real \<dots> = 2 ^ \<pi> n" by (simp add: \<pi>_def card_Pow)
    finally show "real (card (squarefree_part ` {1..n})) \<le> 2 ^ \<pi> n" by - simp_all
  next
    have "square_part k \<le> nat \<lfloor>sqrt n\<rfloor>" if "k \<le> n" for k
      by (rule order.trans[OF square_part_le_sqrt])
         (insert that, auto intro!: nat_mono floor_mono)
    hence "card (square_part ` {1..n}) \<le> card {1..nat \<lfloor>sqrt n\<rfloor>}"
      by (intro card_mono) (auto intro: order.trans[OF square_part_le_sqrt])
    also have "\<dots> = nat \<lfloor>sqrt n\<rfloor>" by simp
    also have "real \<dots> \<le> sqrt n" by simp
    finally show "real (card (square_part ` {1..n})) \<le> sqrt (real n)" by - simp_all
  qed simp_all
  finally have "real n \<le> 2 ^ \<pi> n * sqrt (real n)" by - simp_all
  with \<open>n > 0\<close> have "ln (real n) \<le> ln (2 ^ \<pi> n * sqrt (real n))"
    by (subst ln_le_cancel_iff) simp_all
  moreover have "ln (4 :: real) = real 2 * ln 2" by (subst ln_realpow [symmetric]) simp_all
  ultimately show ?thesis using \<open>n > 0\<close>
    by (simp add: ln_mult ln_realpow[of _ "\<pi> n"] ln_sqrt field_simps)
qed

end


theory HSV_tasks_2019_solutions imports Complex_Main begin

section \<open>Task 1: proving that 2 * sqrt 2 is irrational.\<close>

(* The following theorem is copied from Chapter 3 of the worksheet *)
theorem sqrt2_irrational: "sqrt 2 \<notin> \<rat>"
proof auto
  assume "sqrt 2 \<in> \<rat>"
  then obtain m n where
    "n \<noteq> 0" and "\<bar>sqrt 2\<bar> = real m / real n" and "coprime m n"
    by (rule Rats_abs_nat_div_natE)
  hence "\<bar>sqrt 2\<bar>^2 = (real m / real n)^2" by auto
  hence "2 = (real m / real n)^2" by simp
  hence "2 = (real m)^2 / (real n)^2" unfolding power_divide by auto
  hence "2 * (real n)^2 = (real m)^2"
    by (simp add: nonzero_eq_divide_eq `n \<noteq> 0`)
  hence "real (2 * n^2) = (real m)^2" by auto
  hence *: "2 * n^2 = m^2"
    using of_nat_power_eq_of_nat_cancel_iff by blast
  hence "even (m^2)" by presburger
  hence "even m" by simp
  then obtain m' where "m = 2 * m'" by auto
  with * have "2 * n^2 = (2 * m')^2" by auto
  hence "2 * n^2 = 4 * m'^2" by simp
  hence "n^2 = 2 * m'^2" by simp
  hence "even (n^2)" by presburger
  hence "even n" by simp
  with `even m` and `coprime m n` show False by auto
qed

theorem "2 * sqrt 2 \<notin> \<rat>"
proof auto
  assume *: "2 * sqrt 2 \<in> \<rat>"
  have "2 \<in> \<rat>" by simp
  with * have "2 * sqrt 2 / 2 \<in> \<rat>" using Rats_divide by blast
  hence "sqrt 2 \<in> \<rat>" by simp
  with sqrt2_irrational show False by simp
qed

section \<open>Task 2: L-numbers.\<close>

fun L :: "nat \<Rightarrow> nat" where
  "L n = (if n < 2 then n else 2 + L (n - 1))"

value "L 0" (* should be 0 *)
value "L 1" (* should be 1 *)
value "L 2" (* should be 3 *)
value "L 3" (* should be 5 *)

lemma L_helper: "L (Suc n) = 2 * (Suc n) - 1"
  apply (induct n)
   apply simp+
  done

theorem "L n = (if n = 0 then 0 else 2 * n - 1)"
  apply (cases n)
   apply simp
  using L_helper apply auto
  done

section \<open>Task 3: Pyramidal numbers.\<close>

fun py :: "nat \<Rightarrow> nat" where
  "py n = (if n = 0 then 0 else n^2 + py (n-1))"

value "py 0" (* 0 *)
value "py 1" (* 1 *)
value "py 2" (* 5 *)
value "py 3" (* 14 *)
value "py 4" (* 30 *)
value "py 5" (* 55 *)
value "py 6" (* 91 *)

theorem "py n = ((2 * n + 1) * (n + 1) * n) div 6"
proof (induct n)
  case 0
  thus ?case by simp
next
  case (Suc n)
  assume IH: "py n = ((2 * n + 1) * (n + 1) * n) div 6" (* induction hypothesis *)

  have "py (Suc n) = (Suc n)^2 + py n" by simp
  also have "... = (Suc n)^2 + ((2 * n + 1) * (n + 1) * n) div 6" using IH by simp
  also have "... = (6 * (n + 1)^2 + (2 * n + 1) * (n + 1) * n) div 6" by simp
  also have "... = (6 * (n^2 + 2*n + 1) + (2 * n + 1) * (n + 1) * n) div 6"
    by (metis Suc_eq_plus1 add_Suc mult_2 one_add_one plus_1_eq_Suc power2_sum power_one)
  also have "... = (2 * n * n + 4 * n + 3 * n + 6) * (n + 1) div 6"
    by (simp add: add_mult_distrib power2_eq_square distrib_right)
  also have "... = (2 * n * (n + 2) + 3 * (n + 2)) * (n + 1) div 6"
    by (smt add.assoc distrib_right mult.commute mult_2_right numeral_Bit0)
  also have "... = (2 * n + 3) * (n + 2) * (n + 1) div 6"
    by (simp add: distrib_right)
  also have "... = (2 * Suc n + 1) * (Suc n + 1) * Suc n div 6"
    by (metis One_nat_def Suc_1 Suc_eq_plus1 add_Suc_shift distrib_left mult_2 numeral_3_eq_3)
  finally show "py (Suc n) = (2 * Suc n + 1) * (Suc n + 1) * Suc n div 6" by assumption
qed

section \<open>Task 4: the opt_NOT optimisation leaves no consecutive NOTs in the circuit.\<close>

datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

text \<open>Simulates a circuit given a valuation for each input wire\<close>

fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

text \<open>A function that optimises a circuit by removing pairs of consecutive NOT gates\<close>

fun opt_NOT where
  "opt_NOT (NOT (NOT c)) = opt_NOT c"
| "opt_NOT (NOT c) = NOT (opt_NOT c)"
| "opt_NOT (AND c1 c2) = AND (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT (OR c1 c2) = OR (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT TRUE = TRUE"
| "opt_NOT FALSE = FALSE"
| "opt_NOT (INPUT i) = INPUT i"

text \<open>We can prove that the optimiser does its job: that the optimised
circuit has no consecutive NOT gates.\<close>

fun has_double_NOT where
  "has_double_NOT (NOT (NOT c)) = True"
| "has_double_NOT (NOT c) = has_double_NOT c"
| "has_double_NOT (AND c1 c2) = (has_double_NOT c1 \<or> has_double_NOT c2)"
| "has_double_NOT (OR c1 c2) = (has_double_NOT c1 \<or> has_double_NOT c2)"
| "has_double_NOT _ = False"

theorem opt_NOT_is_complete: "\<not> has_double_NOT (opt_NOT c)"
  by (induct c rule: opt_NOT.induct, auto)

section \<open>Task 5: Removing NOT-NOT is idempotent.\<close>

text \<open>We can prove that the optimiser is 'idempotent': applying it twice is the
same as applying it just once.\<close>

theorem opt_NOT_is_idempotent: "opt_NOT (opt_NOT c) = opt_NOT c"
  by (induct c rule: opt_NOT.induct, auto)

section \<open>Task 6: Applying De Morgan's laws is sound.\<close>

text \<open>Optimising based on De Morgan's laws\<close>

fun opt_DM where
  "opt_DM (NOT c) = NOT (opt_DM c)"
| "opt_DM (AND (NOT c1) (NOT c2)) = NOT (OR (opt_DM c1) (opt_DM c2))"
| "opt_DM (AND c1 c2) = AND (opt_DM c1) (opt_DM c2)"
| "opt_DM (OR (NOT c1) (NOT c2)) = NOT (AND (opt_DM c1) (opt_DM c2))"
| "opt_DM (OR c1 c2) = OR (opt_DM c1) (opt_DM c2)"
| "opt_DM TRUE = TRUE"
| "opt_DM FALSE = FALSE"
| "opt_DM (INPUT i) = INPUT i"

theorem opt_DM_is_sound: "simulate (opt_DM c) \<rho> = simulate c \<rho>"
  by (induct rule: opt_DM.induct, auto)

text \<open>The following non-theorem is easily contradicted, e.g.
  using c = AND (NOT (NOT TRUE)) (NOT (NOT TRUE)). Therefore,
  opt_DM isn't idempotent.\<close>

theorem opt_DM_is_idempotent: "opt_DM (opt_DM c) = opt_DM c"
  oops

section \<open>Task 7: Applying both optimisations successively is sound.\<close>

(* The following theorem was provided in the worksheet *)
theorem opt_NOT_is_sound: "simulate (opt_NOT c) \<rho> = simulate c \<rho>"
  by (induct rule: opt_NOT.induct, auto)

theorem both_sound: "simulate (opt_DM (opt_NOT c)) \<rho> = simulate c \<rho>"
  apply (subst opt_DM_is_sound)
  apply (subst opt_NOT_is_sound)
  apply auto
  done

section \<open>Task 8: Neither optimisation increases the circuit's area.\<close>

text \<open>The following function calculates the area of a circuit (i.e. number of gates).\<close>

fun area :: "circuit \<Rightarrow> nat" where
  "area (NOT c) = 1 + area c"
| "area (AND c1 c2) = 1 + area c1 + area c2"
| "area (OR c1 c2) = 1 + area c1 + area c2"
| "area _ = 0"

theorem opt_NOT_doesnt_increase_area: "area (opt_NOT c) \<le> area c"
  by (induct rule: opt_NOT.induct, auto)

theorem opt_DM_doesnt_increase_area: "area (opt_DM c) \<le> area c"
  by (induct rule: opt_DM.induct, auto)

section \<open>Task 9: Neither optimisation increases the circuit's delay.\<close>

text \<open>Delay (assuming all gates have a delay of 1, and constants and inputs are instantaneous)\<close>

fun delay :: "circuit \<Rightarrow> nat" where
  "delay (NOT c) = 1 + delay c"
| "delay (AND c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay (OR c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay _ = 0"

text \<open>We can prove that our optimisations never increase the maximum delay of a circuit.\<close>

theorem opt_NOT_doesnt_increase_delay: "delay (opt_NOT c) \<le> delay c"
  by (induct rule: opt_NOT.induct, auto)

theorem opt_DM_doesnt_increase_delay: "delay (opt_DM c) \<le> delay c"
  by (induct rule: opt_DM.induct, auto)

section \<open>Task 10: Constant folding.\<close>

text \<open>Here is an optimiser that performs 'constant folding': wherever it sees a gate with
constants (TRUE and FALSE) as inputs, it tries to replace the gate with TRUE, FALSE, or the other
input depending on the logical behaviour of the gate.

For instance, it replaces NOT FALSE with TRUE, AND FALSE c with FALSE for all inputs c, and
OR c FALSE with c.

This optimiser is somewhat more complicated than the other optimisers: it has a lot of rules, and
needs to do analysis on the results of recursively applying itself.

First, we define how it translates NOT gates, AND gates, and OR gates:\<close>

fun opt_CF_NOT where
  "opt_CF_NOT TRUE  = FALSE"
| "opt_CF_NOT FALSE = TRUE"
| "opt_CF_NOT c     = NOT c"

fun opt_CF_AND where
  "opt_CF_AND TRUE  c2     = c2"
| "opt_CF_AND c1     TRUE  = c1"
| "opt_CF_AND FALSE _     = FALSE"
| "opt_CF_AND _     FALSE = FALSE"
| "opt_CF_AND c1     c2     = AND c1 c2"

fun opt_CF_OR where
  "opt_CF_OR FALSE c2     = c2"
| "opt_CF_OR c1     FALSE = c1"
| "opt_CF_OR TRUE  _     = TRUE"
| "opt_CF_OR _     TRUE  = TRUE"
| "opt_CF_OR c1     c2     = OR c1 c2"

text \<open>The actual optimiser just runs the above rewrites on each NOT, AND, and OR gate.\<close>

fun opt_CF where
  "opt_CF (NOT c) = opt_CF_NOT (opt_CF c)"
| "opt_CF (AND c1 c2) = opt_CF_AND (opt_CF c1) (opt_CF c2)"
| "opt_CF (OR c1 c2) = opt_CF_OR  (opt_CF c1) (opt_CF c2)"
| "opt_CF x = x"

text \<open>To prove the constant folder sound, first consider the soundness of the sub-cases.\<close>

lemma opt_CF_NOT_is_sound: "simulate (opt_CF_NOT c) \<rho> = simulate (NOT c) \<rho>"
  by (cases c, auto)

lemma opt_CF_AND_is_sound: "simulate (opt_CF_AND c1 c2) \<rho> = simulate (AND c1 c2) \<rho>"
  by (induct c1 c2 rule: opt_CF_AND.induct, auto)

lemma opt_CF_OR_is_sound: "simulate (opt_CF_OR c1 c2) \<rho> = simulate (OR c1 c2) \<rho>"
  by (induct c1 c2 rule: opt_CF_OR.induct, auto)

theorem opt_CF_is_sound: "simulate (opt_CF c) \<rho> = simulate c \<rho>"
  by (induct c rule: opt_CF.induct,
      auto simp add: opt_CF_NOT_is_sound opt_CF_AND_is_sound opt_CF_OR_is_sound)

text \<open>To get an idea of whether the constant folder is complete, we can see whether it reduces a
circuit with only constant inputs into a single TRUE or FALSE constant.  First, define what it
means for a circuit to have no inputs, and to be only a constant.\<close>

fun no_inputs where
  "no_inputs (NOT c) = no_inputs c"
| "no_inputs (AND c1 c2) = (no_inputs c1 \<and> no_inputs c2)"
| "no_inputs (OR c1 c2) = (no_inputs c1 \<and> no_inputs c2)"
| "no_inputs (INPUT _) = False"
| "no_inputs _ = True"

fun is_constant where
  "is_constant c = (c = TRUE \<or> c = FALSE)"

lemma opt_CF_NOT_reduce:
  assumes "is_constant c"
  shows "is_constant (opt_CF_NOT c)"
  using assms
  by (cases c, auto)

lemma opt_CF_AND_reduce:
  assumes "is_constant c1" and "is_constant c2"
  shows "is_constant (opt_CF_AND c1 c2)"
  using assms
  by (induct c1 c2 rule: opt_CF_AND.induct, auto)

lemma opt_CF_OR_reduce:
  assumes "is_constant c1" and "is_constant c2"
  shows "is_constant (opt_CF_OR c1 c2)"
  using assms
  by (induct c1 c2 rule: opt_CF_OR.induct, auto)

theorem opt_CF_reduce:
  assumes "no_inputs c"
  shows "is_constant (opt_CF c)"
  using assms
  by (induct c rule: opt_CF.induct,
      auto simp add: opt_CF_NOT_reduce opt_CF_AND_reduce opt_CF_OR_reduce)

lemma opt_CF_NOT_doesnt_increase_area: "area (opt_CF_NOT c) \<le> area (NOT c)"
  by (cases c, auto)

lemma opt_CF_AND_doesnt_increase_area: "area (opt_CF_AND c1 c2) \<le> area (AND c1 c2)"
  by (induct c1 c2 rule: opt_CF_AND.induct, auto)

lemma opt_CF_OR_doesnt_increase_area: "area (opt_CF_OR c1 c2) \<le> area (OR c1 c2)"
  by (induct c1 c2 rule: opt_CF_OR.induct, auto)

theorem opt_CF_doesnt_increase_area: "area (opt_CF c) \<le> area c"
proof (induct rule: opt_CF.induct)
  case (1 c)
  have "area (opt_CF (NOT c))
                 = area (opt_CF_NOT (opt_CF c))" by simp
  also have "... \<le> area (NOT (opt_CF c))"
    using opt_CF_NOT_doesnt_increase_area by assumption
  also have "... \<le> area (NOT c)" using 1 by simp
  finally show ?case by assumption
next
  case (2 c1 c2)
  have "area (opt_CF (AND c1 c2))
                 = area (opt_CF_AND (opt_CF c1) (opt_CF c2))" by simp
  also have "... \<le> area (AND (opt_CF c1) (opt_CF c2))"
    using opt_CF_AND_doesnt_increase_area by assumption
  also have "... \<le> area (AND c1 c2)" using 2 by simp
  finally show ?case by assumption
next
  case (3 c1 c2)
  have "area (opt_CF (OR c1 c2))
                 = area (opt_CF_OR (opt_CF c1) (opt_CF c2))" by simp
  also have "... \<le> area (OR (opt_CF c1) (opt_CF c2))"
    using opt_CF_OR_doesnt_increase_area by assumption
  also have "... \<le> area (OR c1 c2)" using 3 by simp
  finally show ?case by assumption
qed simp+

lemma opt_CF_NOT_doesnt_increase_delay: "delay (opt_CF_NOT c) \<le> delay (NOT c)"
  by (cases c, auto)

lemma opt_CF_AND_doesnt_increase_delay: "delay (opt_CF_AND c1 c2) \<le> delay (AND c1 c2)"
  by (induct c1 c2 rule: opt_CF_AND.induct, auto)

lemma opt_CF_OR_doesnt_increase_delay: "delay (opt_CF_OR c1 c2) \<le> delay (OR c1 c2)"
  by (induct c1 c2 rule: opt_CF_OR.induct, auto)

theorem opt_CF_doesnt_increase_delay: "delay (opt_CF c) \<le> delay c"
proof (induct rule: opt_CF.induct)
  case (1 c)
  have "delay (opt_CF (NOT c))
                 = delay (opt_CF_NOT (opt_CF c))" by simp
  also have "... \<le> delay (NOT (opt_CF c))"
    using opt_CF_NOT_doesnt_increase_delay by assumption
  also have "... \<le> delay (NOT c)" using 1 by simp
  finally show ?case by assumption
next
  case (2 c1 c2)
  have "delay (opt_CF (AND c1 c2))
                 = delay (opt_CF_AND (opt_CF c1) (opt_CF c2))" by simp
  also have "... \<le> delay (AND (opt_CF c1) (opt_CF c2))"
    using opt_CF_AND_doesnt_increase_delay by assumption
  also have "... \<le> delay (AND c1 c2)" using 2 by auto
  finally show ?case by assumption
next
  case (3 c1 c2)
  have "delay (opt_CF (OR c1 c2))
                 = delay (opt_CF_OR (opt_CF c1) (opt_CF c2))" by simp
  also have "... \<le> delay (OR (opt_CF c1) (opt_CF c2))"
    using opt_CF_OR_doesnt_increase_delay by assumption
  also have "... \<le> delay (OR c1 c2)" using 3 by auto
  finally show ?case by assumption
qed simp+

section \<open>Task 11: Adding fan-out.\<close>

text \<open>Please see separate file.\<close>

end


(*  Title:      HOL/Imperative_HOL/ex/Sorted_List.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Sorted lists as representation of finite sets\<close>

theory Sorted_List
imports Main
begin

text \<open>Merge function for two distinct sorted lists to get compound distinct sorted list\<close>

fun merge :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge (x#xs) (y#ys) =
  (if x < y then x # merge xs (y#ys) else (if x > y then y # merge (x#xs) ys else x # merge xs ys))"
| "merge xs [] = xs"
| "merge [] ys = ys"

text \<open>The function package does not derive automatically the more general rewrite rule as follows:\<close>
lemma merge_Nil[simp]: "merge [] ys = ys"
by (cases ys) auto

lemma set_merge[simp]: "set (merge xs ys) = set xs \<union> set ys"
by (induct xs ys rule: merge.induct, auto)

lemma sorted_merge[simp]:
     "List.sorted (merge xs ys) = (List.sorted xs \<and> List.sorted ys)"
by (induct xs ys rule: merge.induct, auto simp add: sorted_Cons)

lemma distinct_merge[simp]: "\<lbrakk> distinct xs; distinct ys; List.sorted xs; List.sorted ys \<rbrakk> \<Longrightarrow> distinct (merge xs ys)"
by (induct xs ys rule: merge.induct, auto simp add: sorted_Cons)

text \<open>The remove function removes an element from a sorted list\<close>

primrec remove :: "('a :: linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "remove a [] = []"
  |  "remove a (x#xs) = (if a > x then (x # remove a xs) else (if a = x then xs else x#xs))"

lemma remove': "sorted xs \<and> distinct xs \<Longrightarrow> sorted (remove a xs) \<and> distinct (remove a xs) \<and> set (remove a xs) = set xs - {a}"
apply (induct xs)
apply (auto simp add: sorted_Cons)
done

lemma set_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> set (remove a xs) = set xs - {a}"
using remove' by auto

lemma sorted_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> sorted (remove a xs)"
using remove' by auto

lemma distinct_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> distinct (remove a xs)"
using remove' by auto

lemma remove_insort_cancel: "remove a (insort a xs) = xs"
apply (induct xs)
apply simp
apply auto
done

lemma remove_insort_commute: "\<lbrakk> a \<noteq> b; sorted xs \<rbrakk> \<Longrightarrow> remove b (insort a xs) = insort a (remove b xs)"
apply (induct xs)
apply auto
apply (auto simp add: sorted_Cons)
apply (case_tac xs)
apply auto
done

lemma notinset_remove: "x \<notin> set xs \<Longrightarrow> remove x xs = xs"
apply (induct xs)
apply auto
done

lemma remove1_eq_remove:
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow> remove1 x xs = remove x xs"
apply (induct xs)
apply (auto simp add: sorted_Cons)
apply (subgoal_tac "x \<notin> set xs")
apply (simp add: notinset_remove)
apply fastforce
done

lemma sorted_remove1:
  "sorted xs \<Longrightarrow> sorted (remove1 x xs)"
apply (induct xs)
apply (auto simp add: sorted_Cons)
done

subsection \<open>Efficient member function for sorted lists\<close>

primrec smember :: "'a list \<Rightarrow> 'a::linorder \<Rightarrow> bool" where
  "smember [] x \<longleftrightarrow> False"
| "smember (y#ys) x \<longleftrightarrow> x = y \<or> (x > y \<and> smember ys x)"

lemma "sorted xs \<Longrightarrow> smember xs x \<longleftrightarrow> (x \<in> set xs)"
  by (induct xs) (auto simp add: sorted_Cons)

end