(*  Title:      HOL/Wellfounded.thy
    Author:     Tobias Nipkow
    Author:     Lawrence C Paulson
    Author:     Konrad Slind
    Author:     Alexander Krauss
    Author:     Andrei Popescu, TU Muenchen
*)

section \<open>Well-founded Recursion\<close>

theory Wellfounded
  imports Transitive_Closure
begin

subsection \<open>Basic Definitions\<close>

definition wf :: "('a \<times> 'a) set \<Rightarrow> bool"
  where "wf r \<longleftrightarrow> (\<forall>P. (\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (\<forall>x. P x))"

definition wfP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "wfP r \<longleftrightarrow> wf {(x, y). r x y}"

lemma wfP_wf_eq [pred_set_conv]: "wfP (\<lambda>x y. (x, y) \<in> r) = wf r"
  by (simp add: wfP_def)

lemma wfUNIVI: "(\<And>P x. (\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x) \<Longrightarrow> P x) \<Longrightarrow> wf r"
  unfolding wf_def by blast

lemmas wfPUNIVI = wfUNIVI [to_pred]

text \<open>Restriction to domain \<open>A\<close> and range \<open>B\<close>.
  If \<open>r\<close> is well-founded over their intersection, then \<open>wf r\<close>.\<close>
lemma wfI:
  assumes "r \<subseteq> A \<times> B"
    and "\<And>x P. \<lbrakk>\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x;  x \<in> A; x \<in> B\<rbrakk> \<Longrightarrow> P x"
  shows "wf r"
  using assms unfolding wf_def by blast

lemma wf_induct:
  assumes "wf r"
    and "\<And>x. \<forall>y. (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
  shows "P a"
  using assms unfolding wf_def by blast

lemmas wfP_induct = wf_induct [to_pred]

lemmas wf_induct_rule = wf_induct [rule_format, consumes 1, case_names less, induct set: wf]

lemmas wfP_induct_rule = wf_induct_rule [to_pred, induct set: wfP]

lemma wf_not_sym: "wf r \<Longrightarrow> (a, x) \<in> r \<Longrightarrow> (x, a) \<notin> r"
  by (induct a arbitrary: x set: wf) blast

lemma wf_asym:
  assumes "wf r" "(a, x) \<in> r"
  obtains "(x, a) \<notin> r"
  by (drule wf_not_sym[OF assms])

lemma wf_imp_asym: "wf r \<Longrightarrow> asym r"
  by (auto intro: asymI elim: wf_asym)

lemma wfP_imp_asymp: "wfP r \<Longrightarrow> asymp r"
  by (rule wf_imp_asym[to_pred])

lemma wf_not_refl [simp]: "wf r \<Longrightarrow> (a, a) \<notin> r"
  by (blast elim: wf_asym)

lemma wf_irrefl:
  assumes "wf r"
  obtains "(a, a) \<notin> r"
  by (drule wf_not_refl[OF assms])

lemma wf_imp_irrefl:
  assumes "wf r" shows "irrefl r"
  using wf_irrefl [OF assms] by (auto simp add: irrefl_def)

lemma wfP_imp_irreflp: "wfP r \<Longrightarrow> irreflp r"
  by (rule wf_imp_irrefl[to_pred])

lemma wf_wellorderI:
  assumes wf: "wf {(x::'a::ord, y). x < y}"
    and lin: "OFCLASS('a::ord, linorder_class)"
  shows "OFCLASS('a::ord, wellorder_class)"
  apply (rule wellorder_class.intro [OF lin])
  apply (simp add: wellorder_class.intro class.wellorder_axioms.intro wf_induct_rule [OF wf])
  done

lemma (in wellorder) wf: "wf {(x, y). x < y}"
  unfolding wf_def by (blast intro: less_induct)

lemma (in wellorder) wfP_less[simp]: "wfP (<)"
  by (simp add: wf wfP_def)

subsection \<open>Basic Results\<close>

text \<open>Point-free characterization of well-foundedness\<close>

lemma wfE_pf:
  assumes wf: "wf R"
    and a: "A \<subseteq> R `` A"
  shows "A = {}"
proof -
  from wf have "x \<notin> A" for x
  proof induct
    fix x assume "\<And>y. (y, x) \<in> R \<Longrightarrow> y \<notin> A"
    then have "x \<notin> R `` A" by blast
    with a show "x \<notin> A" by blast
  qed
  then show ?thesis by auto
qed

lemma wfI_pf:
  assumes a: "\<And>A. A \<subseteq> R `` A \<Longrightarrow> A = {}"
  shows "wf R"
proof (rule wfUNIVI)
  fix P :: "'a \<Rightarrow> bool" and x
  let ?A = "{x. \<not> P x}"
  assume "\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x"
  then have "?A \<subseteq> R `` ?A" by blast
  with a show "P x" by blast
qed

subsubsection \<open>Minimal-element characterization of well-foundedness\<close>

lemma wfE_min:
  assumes wf: "wf R" and Q: "x \<in> Q"
  obtains z where "z \<in> Q" "\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q"
  using Q wfE_pf[OF wf, of Q] by blast

lemma wfE_min':
  "wf R \<Longrightarrow> Q \<noteq> {} \<Longrightarrow> (\<And>z. z \<in> Q \<Longrightarrow> (\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  using wfE_min[of R _ Q] by blast

lemma wfI_min:
  assumes a: "\<And>x Q. x \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q"
  shows "wf R"
proof (rule wfI_pf)
  fix A
  assume b: "A \<subseteq> R `` A"
  have False if "x \<in> A" for x
    using a[OF that] b by blast
  then show "A = {}" by blast
qed

lemma wf_eq_minimal: "wf r \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q))"
  apply (rule iffI)
   apply (blast intro:  elim!: wfE_min)
  by (rule wfI_min) auto

lemmas wfP_eq_minimal = wf_eq_minimal [to_pred]

subsubsection \<open>Well-foundedness of transitive closure\<close>

lemma wf_trancl:
  assumes "wf r"
  shows "wf (r\<^sup>+)"
proof -
  have "P x" if induct_step: "\<And>x. (\<And>y. (y, x) \<in> r\<^sup>+ \<Longrightarrow> P y) \<Longrightarrow> P x" for P x
  proof (rule induct_step)
    show "P y" if "(y, x) \<in> r\<^sup>+" for y
      using \<open>wf r\<close> and that
    proof (induct x arbitrary: y)
      case (less x)
      note hyp = \<open>\<And>x' y'. (x', x) \<in> r \<Longrightarrow> (y', x') \<in> r\<^sup>+ \<Longrightarrow> P y'\<close>
      from \<open>(y, x) \<in> r\<^sup>+\<close> show "P y"
      proof cases
        case base
        show "P y"
        proof (rule induct_step)
          fix y'
          assume "(y', y) \<in> r\<^sup>+"
          with \<open>(y, x) \<in> r\<close> show "P y'"
            by (rule hyp [of y y'])
        qed
      next
        case step
        then obtain x' where "(x', x) \<in> r" and "(y, x') \<in> r\<^sup>+"
          by simp
        then show "P y" by (rule hyp [of x' y])
      qed
    qed
  qed
  then show ?thesis unfolding wf_def by blast
qed

lemmas wfP_trancl = wf_trancl [to_pred]

lemma wf_converse_trancl: "wf (r\<inverse>) \<Longrightarrow> wf ((r\<^sup>+)\<inverse>)"
  apply (subst trancl_converse [symmetric])
  apply (erule wf_trancl)
  done

text \<open>Well-foundedness of subsets\<close>

lemma wf_subset: "wf r \<Longrightarrow> p \<subseteq> r \<Longrightarrow> wf p"
  by (simp add: wf_eq_minimal) fast

lemmas wfP_subset = wf_subset [to_pred]

text \<open>Well-foundedness of the empty relation\<close>

lemma wf_empty [iff]: "wf {}"
  by (simp add: wf_def)

lemma wfP_empty [iff]: "wfP (\<lambda>x y. False)"
proof -
  have "wfP bot"
    by (fact wf_empty[to_pred bot_empty_eq2])
  then show ?thesis
    by (simp add: bot_fun_def)
qed

lemma wf_Int1: "wf r \<Longrightarrow> wf (r \<inter> r')"
  by (erule wf_subset) (rule Int_lower1)

lemma wf_Int2: "wf r \<Longrightarrow> wf (r' \<inter> r)"
  by (erule wf_subset) (rule Int_lower2)

text \<open>Exponentiation.\<close>
lemma wf_exp:
  assumes "wf (R ^^ n)"
  shows "wf R"
proof (rule wfI_pf)
  fix A assume "A \<subseteq> R `` A"
  then have "A \<subseteq> (R ^^ n) `` A"
    by (induct n) force+
  with \<open>wf (R ^^ n)\<close> show "A = {}"
    by (rule wfE_pf)
qed

text \<open>Well-foundedness of \<open>insert\<close>.\<close>
lemma wf_insert [iff]: "wf (insert (y,x) r) \<longleftrightarrow> wf r \<and> (x,y) \<notin> r\<^sup>*" (is "?lhs = ?rhs")
proof
  assume ?lhs then show ?rhs
    by (blast elim: wf_trancl [THEN wf_irrefl]
        intro: rtrancl_into_trancl1 wf_subset rtrancl_mono [THEN subsetD])
next
  assume R: ?rhs
  then have R': "Q \<noteq> {} \<Longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q)" for Q
    by (auto simp: wf_eq_minimal)
  show ?lhs
    unfolding wf_eq_minimal
  proof clarify
    fix Q :: "'a set" and q
    assume "q \<in> Q"
    then obtain a where "a \<in> Q" and a: "\<And>y. (y, a) \<in> r \<Longrightarrow> y \<notin> Q"
      using R by (auto simp: wf_eq_minimal)
    show "\<exists>z\<in>Q. \<forall>y'. (y', z) \<in> insert (y, x) r \<longrightarrow> y' \<notin> Q"
    proof (cases "a=x")
      case True
      show ?thesis
      proof (cases "y \<in> Q")
        case True
        then obtain z where "z \<in> Q" "(z, y) \<in> r\<^sup>*"
                            "\<And>z'. (z', z) \<in> r \<longrightarrow> z' \<in> Q \<longrightarrow> (z', y) \<notin> r\<^sup>*"
          using R' [of "{z \<in> Q. (z,y) \<in> r\<^sup>*}"] by auto
        then have "\<forall>y'. (y', z) \<in> insert (y, x) r \<longrightarrow> y' \<notin> Q"
          using R by(blast intro: rtrancl_trans)+
        then show ?thesis
          by (rule bexI) fact
      next
        case False
        then show ?thesis
          using a \<open>a \<in> Q\<close> by blast
      qed
    next
      case False
      with a \<open>a \<in> Q\<close> show ?thesis
        by blast
    qed
  qed
qed

subsubsection \<open>Well-foundedness of image\<close>

lemma wf_map_prod_image_Dom_Ran:
  fixes r:: "('a \<times> 'a) set"
    and f:: "'a \<Rightarrow> 'b"
  assumes wf_r: "wf r"
    and inj: "\<And> a a'. a \<in> Domain r \<Longrightarrow> a' \<in> Range r \<Longrightarrow> f a = f a' \<Longrightarrow> a = a'"
  shows "wf (map_prod f f ` r)"
proof (unfold wf_eq_minimal, clarify)
  fix B :: "'b set" and b::"'b"
  assume "b \<in> B"
  define A where "A = f -` B \<inter> Domain r"
  show "\<exists>z\<in>B. \<forall>y. (y, z) \<in> map_prod f f ` r \<longrightarrow> y \<notin> B"
  proof (cases "A = {}")
    case False
    then obtain a0 where "a0 \<in> A" and "\<forall>a. (a, a0) \<in> r \<longrightarrow> a \<notin> A"
      using wfE_min[OF wf_r] by auto
    thus ?thesis
      using inj unfolding A_def
      by (intro bexI[of _ "f a0"]) auto
  qed (use \<open>b \<in> B\<close> in  \<open>unfold A_def, auto\<close>)
qed

lemma wf_map_prod_image: "wf r \<Longrightarrow> inj f \<Longrightarrow> wf (map_prod f f ` r)"
by(rule wf_map_prod_image_Dom_Ran) (auto dest: inj_onD)

subsection \<open>Well-Foundedness Results for Unions\<close>

lemma wf_union_compatible:
  assumes "wf R" "wf S"
  assumes "R O S \<subseteq> R"
  shows "wf (R \<union> S)"
proof (rule wfI_min)
  fix x :: 'a and Q
  let ?Q' = "{x \<in> Q. \<forall>y. (y, x) \<in> R \<longrightarrow> y \<notin> Q}"
  assume "x \<in> Q"
  obtain a where "a \<in> ?Q'"
    by (rule wfE_min [OF \<open>wf R\<close> \<open>x \<in> Q\<close>]) blast
  with \<open>wf S\<close> obtain z where "z \<in> ?Q'" and zmin: "\<And>y. (y, z) \<in> S \<Longrightarrow> y \<notin> ?Q'"
    by (erule wfE_min)
  have "y \<notin> Q" if "(y, z) \<in> S" for y
  proof
    from that have "y \<notin> ?Q'" by (rule zmin)
    assume "y \<in> Q"
    with \<open>y \<notin> ?Q'\<close> obtain w where "(w, y) \<in> R" and "w \<in> Q" by auto
    from \<open>(w, y) \<in> R\<close> \<open>(y, z) \<in> S\<close> have "(w, z) \<in> R O S" by (rule relcompI)
    with \<open>R O S \<subseteq> R\<close> have "(w, z) \<in> R" ..
    with \<open>z \<in> ?Q'\<close> have "w \<notin> Q" by blast
    with \<open>w \<in> Q\<close> show False by contradiction
  qed
  with \<open>z \<in> ?Q'\<close> show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<union> S \<longrightarrow> y \<notin> Q" by blast
qed

text \<open>Well-foundedness of indexed union with disjoint domains and ranges.\<close>

lemma wf_UN:
  assumes r: "\<And>i. i \<in> I \<Longrightarrow> wf (r i)"
    and disj: "\<And>i j. \<lbrakk>i \<in> I; j \<in> I; r i \<noteq> r j\<rbrakk> \<Longrightarrow> Domain (r i) \<inter> Range (r j) = {}"
  shows "wf (\<Union>i\<in>I. r i)"
  unfolding wf_eq_minimal
proof clarify
  fix A and a :: "'b"
  assume "a \<in> A"
  show "\<exists>z\<in>A. \<forall>y. (y, z) \<in> \<Union>(r ` I) \<longrightarrow> y \<notin> A"
  proof (cases "\<exists>i\<in>I. \<exists>a\<in>A. \<exists>b\<in>A. (b, a) \<in> r i")
    case True
    then obtain i b c where ibc: "i \<in> I" "b \<in> A" "c \<in> A" "(c,b) \<in> r i"
      by blast
    have ri: "\<And>Q. Q \<noteq> {} \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> r i \<longrightarrow> y \<notin> Q"
      using r [OF \<open>i \<in> I\<close>] unfolding wf_eq_minimal by auto
    show ?thesis
      using ri [of "{a. a \<in> A \<and> (\<exists>b\<in>A. (b, a) \<in> r i) }"] ibc disj
      by blast
  next
    case False
    with \<open>a \<in> A\<close> show ?thesis
      by blast
  qed
qed

lemma wfP_SUP:
  "\<forall>i. wfP (r i) \<Longrightarrow> \<forall>i j. r i \<noteq> r j \<longrightarrow> inf (Domainp (r i)) (Rangep (r j)) = bot \<Longrightarrow>
    wfP (\<Squnion>(range r))"
  by (rule wf_UN[to_pred]) simp_all

lemma wf_Union:
  assumes "\<forall>r\<in>R. wf r"
    and "\<forall>r\<in>R. \<forall>s\<in>R. r \<noteq> s \<longrightarrow> Domain r \<inter> Range s = {}"
  shows "wf (\<Union>R)"
  using assms wf_UN[of R "\<lambda>i. i"] by simp

text \<open>
  Intuition: We find an \<open>R \<union> S\<close>-min element of a nonempty subset \<open>A\<close> by case distinction.
  \<^enum> There is a step \<open>a \<midarrow>R\<rightarrow> b\<close> with \<open>a, b \<in> A\<close>.
    Pick an \<open>R\<close>-min element \<open>z\<close> of the (nonempty) set \<open>{a\<in>A | \<exists>b\<in>A. a \<midarrow>R\<rightarrow> b}\<close>.
    By definition, there is \<open>z' \<in> A\<close> s.t. \<open>z \<midarrow>R\<rightarrow> z'\<close>. Because \<open>z\<close> is \<open>R\<close>-min in the
    subset, \<open>z'\<close> must be \<open>R\<close>-min in \<open>A\<close>. Because \<open>z'\<close> has an \<open>R\<close>-predecessor, it cannot
    have an \<open>S\<close>-successor and is thus \<open>S\<close>-min in \<open>A\<close> as well.
  \<^enum> There is no such step.
    Pick an \<open>S\<close>-min element of \<open>A\<close>. In this case it must be an \<open>R\<close>-min
    element of \<open>A\<close> as well.
\<close>
lemma wf_Un: "wf r \<Longrightarrow> wf s \<Longrightarrow> Domain r \<inter> Range s = {} \<Longrightarrow> wf (r \<union> s)"
  using wf_union_compatible[of s r]
  by (auto simp: Un_ac)

lemma wf_union_merge: "wf (R \<union> S) = wf (R O R \<union> S O R \<union> S)"
  (is "wf ?A = wf ?B")
proof
  assume "wf ?A"
  with wf_trancl have wfT: "wf (?A\<^sup>+)" .
  moreover have "?B \<subseteq> ?A\<^sup>+"
    by (subst trancl_unfold, subst trancl_unfold) blast
  ultimately show "wf ?B" by (rule wf_subset)
next
  assume "wf ?B"
  show "wf ?A"
  proof (rule wfI_min)
    fix Q :: "'a set" and x
    assume "x \<in> Q"
    with \<open>wf ?B\<close> obtain z where "z \<in> Q" and "\<And>y. (y, z) \<in> ?B \<Longrightarrow> y \<notin> Q"
      by (erule wfE_min)
    then have 1: "\<And>y. (y, z) \<in> R O R \<Longrightarrow> y \<notin> Q"
      and 2: "\<And>y. (y, z) \<in> S O R \<Longrightarrow> y \<notin> Q"
      and 3: "\<And>y. (y, z) \<in> S \<Longrightarrow> y \<notin> Q"
      by auto
    show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> ?A \<longrightarrow> y \<notin> Q"
    proof (cases "\<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q")
      case True
      with \<open>z \<in> Q\<close> 3 show ?thesis by blast
    next
      case False
      then obtain z' where "z'\<in>Q" "(z', z) \<in> R" by blast
      have "\<forall>y. (y, z') \<in> ?A \<longrightarrow> y \<notin> Q"
      proof (intro allI impI)
        fix y assume "(y, z') \<in> ?A"
        then show "y \<notin> Q"
        proof
          assume "(y, z') \<in> R"
          then have "(y, z) \<in> R O R" using \<open>(z', z) \<in> R\<close> ..
          with 1 show "y \<notin> Q" .
        next
          assume "(y, z') \<in> S"
          then have "(y, z) \<in> S O R" using  \<open>(z', z) \<in> R\<close> ..
          with 2 show "y \<notin> Q" .
        qed
      qed
      with \<open>z' \<in> Q\<close> show ?thesis ..
    qed
  qed
qed

lemma wf_comp_self: "wf R \<longleftrightarrow> wf (R O R)"  \<comment> \<open>special case\<close>
  by (rule wf_union_merge [where S = "{}", simplified])

subsection \<open>Well-Foundedness of Composition\<close>

text \<open>Bachmair and Dershowitz 1986, Lemma 2. [Provided by Tjark Weber]\<close>

lemma qc_wf_relto_iff:
  assumes "R O S \<subseteq> (R \<union> S)\<^sup>* O R" \<comment> \<open>R quasi-commutes over S\<close>
  shows "wf (S\<^sup>* O R O S\<^sup>*) \<longleftrightarrow> wf R"
    (is "wf ?S \<longleftrightarrow> _")
proof
  show "wf R" if "wf ?S"
  proof -
    have "R \<subseteq> ?S" by auto
    with wf_subset [of ?S] that show "wf R"
      by auto
  qed
next
  show "wf ?S" if "wf R"
  proof (rule wfI_pf)
    fix A
    assume A: "A \<subseteq> ?S `` A"
    let ?X = "(R \<union> S)\<^sup>* `` A"
    have *: "R O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
    proof -
      have "(x, z) \<in> (R \<union> S)\<^sup>* O R" if "(y, z) \<in> (R \<union> S)\<^sup>*" and "(x, y) \<in> R" for x y z
        using that
      proof (induct y z)
        case rtrancl_refl
        then show ?case by auto
      next
        case (rtrancl_into_rtrancl a b c)
        then have "(x, c) \<in> ((R \<union> S)\<^sup>* O (R \<union> S)\<^sup>*) O R"
          using assms by blast
        then show ?case by simp
      qed
      then show ?thesis by auto
    qed
    then have "R O S\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
      using rtrancl_Un_subset by blast
    then have "?S \<subseteq> (R \<union> S)\<^sup>* O (R \<union> S)\<^sup>* O R"
      by (simp add: relcomp_mono rtrancl_mono)
    also have "\<dots> = (R \<union> S)\<^sup>* O R"
      by (simp add: O_assoc[symmetric])
    finally have "?S O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R O (R \<union> S)\<^sup>*"
      by (simp add: O_assoc[symmetric] relcomp_mono)
    also have "\<dots> \<subseteq> (R \<union> S)\<^sup>* O (R \<union> S)\<^sup>* O R"
      using * by (simp add: relcomp_mono)
    finally have "?S O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
      by (simp add: O_assoc[symmetric])
    then have "(?S O (R \<union> S)\<^sup>*) `` A \<subseteq> ((R \<union> S)\<^sup>* O R) `` A"
      by (simp add: Image_mono)
    moreover have "?X \<subseteq> (?S O (R \<union> S)\<^sup>*) `` A"
      using A by (auto simp: relcomp_Image)
    ultimately have "?X \<subseteq> R `` ?X"
      by (auto simp: relcomp_Image)
    then have "?X = {}"
      using \<open>wf R\<close> by (simp add: wfE_pf)
    moreover have "A \<subseteq> ?X" by auto
    ultimately show "A = {}" by simp
  qed
qed

corollary wf_relcomp_compatible:
  assumes "wf R" and "R O S \<subseteq> S O R"
  shows "wf (S O R)"
proof -
  have "R O S \<subseteq> (R \<union> S)\<^sup>* O R"
    using assms by blast
  then have "wf (S\<^sup>* O R O S\<^sup>*)"
    by (simp add: assms qc_wf_relto_iff)
  then show ?thesis
    by (rule Wellfounded.wf_subset) blast
qed

subsection \<open>Acyclic relations\<close>

lemma wf_acyclic: "wf r \<Longrightarrow> acyclic r"
  by (simp add: acyclic_def) (blast elim: wf_trancl [THEN wf_irrefl])

lemmas wfP_acyclicP = wf_acyclic [to_pred]

subsubsection \<open>Wellfoundedness of finite acyclic relations\<close>

lemma finite_acyclic_wf:
  assumes "finite r" "acyclic r" shows "wf r"
  using assms
proof (induction r rule: finite_induct)
  case (insert x r)
  then show ?case
    by (cases x) simp
qed simp

lemma finite_acyclic_wf_converse: "finite r \<Longrightarrow> acyclic r \<Longrightarrow> wf (r\<inverse>)"
  apply (erule finite_converse [THEN iffD2, THEN finite_acyclic_wf])
  apply (erule acyclic_converse [THEN iffD2])
  done

text \<open>
  Observe that the converse of an irreflexive, transitive,
  and finite relation is again well-founded. Thus, we may
  employ it for well-founded induction.
\<close>
lemma wf_converse:
  assumes "irrefl r" and "trans r" and "finite r"
  shows "wf (r\<inverse>)"
proof -
  have "acyclic r"
    using \<open>irrefl r\<close> and \<open>trans r\<close>
    by (simp add: irrefl_def acyclic_irrefl)
  with \<open>finite r\<close> show ?thesis
    by (rule finite_acyclic_wf_converse)
qed

lemma wf_iff_acyclic_if_finite: "finite r \<Longrightarrow> wf r = acyclic r"
  by (blast intro: finite_acyclic_wf wf_acyclic)

subsection \<open>\<^typ>\<open>nat\<close> is well-founded\<close>

lemma less_nat_rel: "(<) = (\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+"
proof (rule ext, rule ext, rule iffI)
  fix n m :: nat
  show "(\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+ m n" if "m < n"
    using that
  proof (induct n)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then show ?case
      by (auto simp add: less_Suc_eq_le le_less intro: tranclp.trancl_into_trancl)
  qed
  show "m < n" if "(\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+ m n"
    using that by (induct n) (simp_all add: less_Suc_eq_le reflexive le_less)
qed

definition pred_nat :: "(nat \<times> nat) set"
  where "pred_nat = {(m, n). n = Suc m}"

definition less_than :: "(nat \<times> nat) set"
  where "less_than = pred_nat\<^sup>+"

lemma less_eq: "(m, n) \<in> pred_nat\<^sup>+ \<longleftrightarrow> m < n"
  unfolding less_nat_rel pred_nat_def trancl_def by simp

lemma pred_nat_trancl_eq_le: "(m, n) \<in> pred_nat\<^sup>* \<longleftrightarrow> m \<le> n"
  unfolding less_eq rtrancl_eq_or_trancl by auto

lemma wf_pred_nat: "wf pred_nat"
  unfolding wf_def
proof clarify
  fix P x
  assume "\<forall>x'. (\<forall>y. (y, x') \<in> pred_nat \<longrightarrow> P y) \<longrightarrow> P x'"
  then show "P x"
    unfolding pred_nat_def by (induction x) blast+
qed

lemma wf_less_than [iff]: "wf less_than"
  by (simp add: less_than_def wf_pred_nat [THEN wf_trancl])

lemma trans_less_than [iff]: "trans less_than"
  by (simp add: less_than_def)

lemma less_than_iff [iff]: "((x,y) \<in> less_than) = (x<y)"
  by (simp add: less_than_def less_eq)

lemma irrefl_less_than: "irrefl less_than"
  using irrefl_def by blast

lemma asym_less_than: "asym less_than"
  by (rule asymI) simp

lemma total_less_than: "total less_than" and total_on_less_than [simp]: "total_on A less_than"
  using total_on_def by force+

lemma wf_less: "wf {(x, y::nat). x < y}"
  by (rule Wellfounded.wellorder_class.wf)

subsection \<open>Accessible Part\<close>

text \<open>
  Inductive definition of the accessible part \<open>acc r\<close> of a
  relation; see also \<^cite>\<open>"paulin-tlca"\<close>.
\<close>

inductive_set acc :: "('a \<times> 'a) set \<Rightarrow> 'a set" for r :: "('a \<times> 'a) set"
  where accI: "(\<And>y. (y, x) \<in> r \<Longrightarrow> y \<in> acc r) \<Longrightarrow> x \<in> acc r"

abbreviation termip :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool"
  where "termip r \<equiv> accp (r\<inverse>\<inverse>)"

abbreviation termi :: "('a \<times> 'a) set \<Rightarrow> 'a set"
  where "termi r \<equiv> acc (r\<inverse>)"

lemmas accpI = accp.accI

lemma accp_eq_acc [code]: "accp r = (\<lambda>x. x \<in> Wellfounded.acc {(x, y). r x y})"
  by (simp add: acc_def)

text \<open>Induction rules\<close>

theorem accp_induct:
  assumes major: "accp r a"
  assumes hyp: "\<And>x. accp r x \<Longrightarrow> \<forall>y. r y x \<longrightarrow> P y \<Longrightarrow> P x"
  shows "P a"
  apply (rule major [THEN accp.induct])
  apply (rule hyp)
   apply (rule accp.accI)
   apply auto
  done

lemmas accp_induct_rule = accp_induct [rule_format, induct set: accp]

theorem accp_downward: "accp r b \<Longrightarrow> r a b \<Longrightarrow> accp r a"
  by (cases rule: accp.cases)

lemma not_accp_down:
  assumes na: "\<not> accp R x"
  obtains z where "R z x" and "\<not> accp R z"
proof -
  assume a: "\<And>z. R z x \<Longrightarrow> \<not> accp R z \<Longrightarrow> thesis"
  show thesis
  proof (cases "\<forall>z. R z x \<longrightarrow> accp R z")
    case True
    then have "\<And>z. R z x \<Longrightarrow> accp R z" by auto
    then have "accp R x" by (rule accp.accI)
    with na show thesis ..
  next
    case False then obtain z where "R z x" and "\<not> accp R z"
      by auto
    with a show thesis .
  qed
qed

lemma accp_downwards_aux: "r\<^sup>*\<^sup>* b a \<Longrightarrow> accp r a \<longrightarrow> accp r b"
  by (erule rtranclp_induct) (blast dest: accp_downward)+

theorem accp_downwards: "accp r a \<Longrightarrow> r\<^sup>*\<^sup>* b a \<Longrightarrow> accp r b"
  by (blast dest: accp_downwards_aux)

theorem accp_wfPI: "\<forall>x. accp r x \<Longrightarrow> wfP r"
proof (rule wfPUNIVI)
  fix P x
  assume "\<forall>x. accp r x" "\<forall>x. (\<forall>y. r y x \<longrightarrow> P y) \<longrightarrow> P x"
  then show "P x"
    using accp_induct[where P = P] by blast
qed

theorem accp_wfPD: "wfP r \<Longrightarrow> accp r x"
  apply (erule wfP_induct_rule)
  apply (rule accp.accI)
  apply blast
  done

theorem wfP_accp_iff: "wfP r = (\<forall>x. accp r x)"
  by (blast intro: accp_wfPI dest: accp_wfPD)

text \<open>Smaller relations have bigger accessible parts:\<close>

lemma accp_subset:
  assumes "R1 \<le> R2"
  shows "accp R2 \<le> accp R1"
proof (rule predicate1I)
  fix x
  assume "accp R2 x"
  then show "accp R1 x"
  proof (induct x)
    fix x
    assume "\<And>y. R2 y x \<Longrightarrow> accp R1 y"
    with assms show "accp R1 x"
      by (blast intro: accp.accI)
  qed
qed

text \<open>This is a generalized induction theorem that works on
  subsets of the accessible part.\<close>

lemma accp_subset_induct:
  assumes subset: "D \<le> accp R"
    and dcl: "\<And>x z. D x \<Longrightarrow> R z x \<Longrightarrow> D z"
    and "D x"
    and istep: "\<And>x. D x \<Longrightarrow> (\<And>z. R z x \<Longrightarrow> P z) \<Longrightarrow> P x"
  shows "P x"
proof -
  from subset and \<open>D x\<close>
  have "accp R x" ..
  then show "P x" using \<open>D x\<close>
  proof (induct x)
    fix x
    assume "D x" and "\<And>y. R y x \<Longrightarrow> D y \<Longrightarrow> P y"
    with dcl and istep show "P x" by blast
  qed
qed

text \<open>Set versions of the above theorems\<close>

lemmas acc_induct = accp_induct [to_set]
lemmas acc_induct_rule = acc_induct [rule_format, induct set: acc]
lemmas acc_downward = accp_downward [to_set]
lemmas not_acc_down = not_accp_down [to_set]
lemmas acc_downwards_aux = accp_downwards_aux [to_set]
lemmas acc_downwards = accp_downwards [to_set]
lemmas acc_wfI = accp_wfPI [to_set]
lemmas acc_wfD = accp_wfPD [to_set]
lemmas wf_acc_iff = wfP_accp_iff [to_set]
lemmas acc_subset = accp_subset [to_set]
lemmas acc_subset_induct = accp_subset_induct [to_set]

subsection \<open>Tools for building wellfounded relations\<close>

text \<open>Inverse Image\<close>

lemma wf_inv_image [simp,intro!]:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes "wf r"
  shows "wf (inv_image r f)"
proof -
  have "\<And>x P. x \<in> P \<Longrightarrow> \<exists>z\<in>P. \<forall>y. (f y, f z) \<in> r \<longrightarrow> y \<notin> P"
  proof -
    fix P and x::'a
    assume "x \<in> P"
    then obtain w where w: "w \<in> {w. \<exists>x::'a. x \<in> P \<and> f x = w}"
      by auto
    have *: "\<And>Q u. u \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q"
      using assms by (auto simp add: wf_eq_minimal)
    show "\<exists>z\<in>P. \<forall>y. (f y, f z) \<in> r \<longrightarrow> y \<notin> P"
      using * [OF w] by auto
  qed
  then show ?thesis
    by (clarsimp simp: inv_image_def wf_eq_minimal)
qed

subsubsection \<open>Conversion to a known well-founded relation\<close>

lemma wf_if_convertible_to_wf:
  fixes r :: "'a rel" and s :: "'b rel" and f :: "'a \<Rightarrow> 'b"
  assumes "wf s" and convertible: "\<And>x y. (x, y) \<in> r \<Longrightarrow> (f x, f y) \<in> s"
  shows "wf r"
proof (rule wfI_min[of r])
  fix x :: 'a and Q :: "'a set"
  assume "x \<in> Q"
  then obtain y where "y \<in> Q" and "\<And>z. (f z, f y) \<in> s \<Longrightarrow> z \<notin> Q"
    by (auto elim: wfE_min[OF wf_inv_image[of s f, OF \<open>wf s\<close>], unfolded in_inv_image])
  thus "\<exists>z \<in> Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q"
    by (auto intro: convertible)
qed

lemma wfP_if_convertible_to_wfP: "wfP S \<Longrightarrow> (\<And>x y. R x y \<Longrightarrow> S (f x) (f y)) \<Longrightarrow> wfP R"
  using wf_if_convertible_to_wf[to_pred, of S R f] by simp

text \<open>Converting to @{typ nat} is a very common special case that might be found more easily by
  Sledgehammer.\<close>

lemma wfP_if_convertible_to_nat:
  fixes f :: "_ \<Rightarrow> nat"
  shows "(\<And>x y. R x y \<Longrightarrow> f x < f y) \<Longrightarrow> wfP R"
  by (rule wfP_if_convertible_to_wfP[of "(<) :: nat \<Rightarrow> nat \<Rightarrow> bool", simplified])

subsubsection \<open>Measure functions into \<^typ>\<open>nat\<close>\<close>

definition measure :: "('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set"
  where "measure = inv_image less_than"

lemma in_measure[simp, code_unfold]: "(x, y) \<in> measure f \<longleftrightarrow> f x < f y"
  by (simp add:measure_def)

lemma wf_measure [iff]: "wf (measure f)"
  unfolding measure_def by (rule wf_less_than [THEN wf_inv_image])

lemma wf_if_measure: "(\<And>x. P x \<Longrightarrow> f(g x) < f x) \<Longrightarrow> wf {(y,x). P x \<and> y = g x}"
  for f :: "'a \<Rightarrow> nat"
  using wf_measure[of f] unfolding measure_def inv_image_def less_than_def less_eq
  by (rule wf_subset) auto

subsubsection \<open>Lexicographic combinations\<close>

definition lex_prod :: "('a \<times>'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> (('a \<times> 'b) \<times> ('a \<times> 'b)) set"
    (infixr "<*lex*>" 80)
    where "ra <*lex*> rb = {((a, b), (a', b')). (a, a') \<in> ra \<or> a = a' \<and> (b, b') \<in> rb}"

lemma in_lex_prod[simp]: "((a, b), (a', b')) \<in> r <*lex*> s \<longleftrightarrow> (a, a') \<in> r \<or> a = a' \<and> (b, b') \<in> s"
  by (auto simp:lex_prod_def)

lemma wf_lex_prod [intro!]:
  assumes "wf ra" "wf rb"
  shows "wf (ra <*lex*> rb)"
proof (rule wfI)
  fix z :: "'a \<times> 'b" and P
  assume * [rule_format]: "\<forall>u. (\<forall>v. (v, u) \<in> ra <*lex*> rb \<longrightarrow> P v) \<longrightarrow> P u"
  obtain x y where zeq: "z = (x,y)"
    by fastforce
  have "P(x,y)" using \<open>wf ra\<close>
  proof (induction x arbitrary: y rule: wf_induct_rule)
    case (less x)
    note lessx = less
    show ?case using \<open>wf rb\<close> less
    proof (induction y rule: wf_induct_rule)
      case (less y)
      show ?case
        by (force intro: * less.IH lessx)
    qed
  qed
  then show "P z"
    by (simp add: zeq)
qed auto

lemma refl_lex_prod[simp]: "refl r\<^sub>B \<Longrightarrow> refl (r\<^sub>A <*lex*> r\<^sub>B)"
  by (auto intro!: reflI dest: refl_onD)

lemma irrefl_on_lex_prod[simp]:
  "irrefl_on A r\<^sub>A \<Longrightarrow> irrefl_on B r\<^sub>B \<Longrightarrow> irrefl_on (A \<times> B) (r\<^sub>A <*lex*> r\<^sub>B)"
  by (auto intro!: irrefl_onI dest: irrefl_onD)

lemma irrefl_lex_prod[simp]: "irrefl r\<^sub>A \<Longrightarrow> irrefl r\<^sub>B \<Longrightarrow> irrefl (r\<^sub>A <*lex*> r\<^sub>B)"
  by (rule irrefl_on_lex_prod[of UNIV _ UNIV, unfolded UNIV_Times_UNIV])

lemma sym_on_lex_prod[simp]:
  "sym_on A r\<^sub>A \<Longrightarrow> sym_on B r\<^sub>B \<Longrightarrow> sym_on (A \<times> B) (r\<^sub>A <*lex*> r\<^sub>B)"
  by (auto intro!: sym_onI dest: sym_onD)

lemma sym_lex_prod[simp]:
  "sym r\<^sub>A \<Longrightarrow> sym r\<^sub>B \<Longrightarrow> sym (r\<^sub>A <*lex*> r\<^sub>B)"
  by (rule sym_on_lex_prod[of UNIV _ UNIV, unfolded UNIV_Times_UNIV])

lemma asym_on_lex_prod[simp]:
  "asym_on A r\<^sub>A \<Longrightarrow> asym_on B r\<^sub>B \<Longrightarrow> asym_on (A \<times> B) (r\<^sub>A <*lex*> r\<^sub>B)"
  by (auto intro!: asym_onI dest: asym_onD)

lemma asym_lex_prod[simp]:
  "asym r\<^sub>A \<Longrightarrow> asym r\<^sub>B \<Longrightarrow> asym (r\<^sub>A <*lex*> r\<^sub>B)"
  by (rule asym_on_lex_prod[of UNIV _ UNIV, unfolded UNIV_Times_UNIV])

lemma trans_on_lex_prod[simp]:
  assumes "trans_on A r\<^sub>A" and "trans_on B r\<^sub>B"
  shows "trans_on (A \<times> B) (r\<^sub>A <*lex*> r\<^sub>B)"
proof (rule trans_onI)
  fix x y z
  show "x \<in> A \<times> B \<Longrightarrow> y \<in> A \<times> B \<Longrightarrow> z \<in> A \<times> B \<Longrightarrow>
       (x, y) \<in> r\<^sub>A <*lex*> r\<^sub>B \<Longrightarrow> (y, z) \<in> r\<^sub>A <*lex*> r\<^sub>B \<Longrightarrow> (x, z) \<in> r\<^sub>A <*lex*> r\<^sub>B"
  using trans_onD[OF \<open>trans_on A r\<^sub>A\<close>, of "fst x" "fst y" "fst z"]
  using trans_onD[OF \<open>trans_on B r\<^sub>B\<close>, of "snd x" "snd y" "snd z"]
  by auto
qed

lemma trans_lex_prod [simp,intro!]: "trans r\<^sub>A \<Longrightarrow> trans r\<^sub>B \<Longrightarrow> trans (r\<^sub>A <*lex*> r\<^sub>B)"
  by (rule trans_on_lex_prod[of UNIV _ UNIV, unfolded UNIV_Times_UNIV])

lemma total_on_lex_prod[simp]:
  "total_on A r\<^sub>A \<Longrightarrow> total_on B r\<^sub>B \<Longrightarrow> total_on (A \<times> B) (r\<^sub>A <*lex*> r\<^sub>B)"
  by (auto simp: total_on_def)

lemma total_lex_prod[simp]: "total r\<^sub>A \<Longrightarrow> total r\<^sub>B \<Longrightarrow> total (r\<^sub>A <*lex*> r\<^sub>B)"
  by (rule total_on_lex_prod[of UNIV _ UNIV, unfolded UNIV_Times_UNIV])

text \<open>lexicographic combinations with measure functions\<close>

definition mlex_prod :: "('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" (infixr "<*mlex*>" 80)
  where "f <*mlex*> R = inv_image (less_than <*lex*> R) (\<lambda>x. (f x, x))"

lemma
  wf_mlex: "wf R \<Longrightarrow> wf (f <*mlex*> R)" and
  mlex_less: "f x < f y \<Longrightarrow> (x, y) \<in> f <*mlex*> R" and
  mlex_leq: "f x \<le> f y \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (x, y) \<in> f <*mlex*> R" and
  mlex_iff: "(x, y) \<in> f <*mlex*> R \<longleftrightarrow> f x < f y \<or> f x = f y \<and> (x, y) \<in> R"
  by (auto simp: mlex_prod_def)

text \<open>Proper subset relation on finite sets.\<close>
definition finite_psubset :: "('a set \<times> 'a set) set"
  where "finite_psubset = {(A, B). A \<subset> B \<and> finite B}"

lemma wf_finite_psubset[simp]: "wf finite_psubset"
  apply (unfold finite_psubset_def)
  apply (rule wf_measure [THEN wf_subset])
  apply (simp add: measure_def inv_image_def less_than_def less_eq)
  apply (fast elim!: psubset_card_mono)
  done

lemma trans_finite_psubset: "trans finite_psubset"
  by (auto simp: finite_psubset_def less_le trans_def)

lemma in_finite_psubset[simp]: "(A, B) \<in> finite_psubset \<longleftrightarrow> A \<subset> B \<and> finite B"
  unfolding finite_psubset_def by auto

text \<open>max- and min-extension of order to finite sets\<close>

inductive_set max_ext :: "('a \<times> 'a) set \<Rightarrow> ('a set \<times> 'a set) set"
  for R :: "('a \<times> 'a) set"
  where max_extI[intro]:
    "finite X \<Longrightarrow> finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> \<exists>y\<in>Y. (x, y) \<in> R) \<Longrightarrow> (X, Y) \<in> max_ext R"

lemma max_ext_wf:
  assumes wf: "wf r"
  shows "wf (max_ext r)"
proof (rule acc_wfI, intro allI)
  show "M \<in> acc (max_ext r)" (is "_ \<in> ?W") for M
  proof (induct M rule: infinite_finite_induct)
    case empty
    show ?case
      by (rule accI) (auto elim: max_ext.cases)
  next
    case (insert a M)
    from wf \<open>M \<in> ?W\<close> \<open>finite M\<close> show "insert a M \<in> ?W"
    proof (induct arbitrary: M)
      fix M a
      assume "M \<in> ?W"
      assume [intro]: "finite M"
      assume hyp: "\<And>b M. (b, a) \<in> r \<Longrightarrow> M \<in> ?W \<Longrightarrow> finite M \<Longrightarrow> insert b M \<in> ?W"
      have add_less: "M \<in> ?W \<Longrightarrow> (\<And>y. y \<in> N \<Longrightarrow> (y, a) \<in> r) \<Longrightarrow> N \<union> M \<in> ?W"
        if "finite N" "finite M" for N M :: "'a set"
        using that by (induct N arbitrary: M) (auto simp: hyp)
      show "insert a M \<in> ?W"
      proof (rule accI)
        fix N
        assume Nless: "(N, insert a M) \<in> max_ext r"
        then have *: "\<And>x. x \<in> N \<Longrightarrow> (x, a) \<in> r \<or> (\<exists>y \<in> M. (x, y) \<in> r)"
          by (auto elim!: max_ext.cases)

        let ?N1 = "{n \<in> N. (n, a) \<in> r}"
        let ?N2 = "{n \<in> N. (n, a) \<notin> r}"
        have N: "?N1 \<union> ?N2 = N" by (rule set_eqI) auto
        from Nless have "finite N" by (auto elim: max_ext.cases)
        then have finites: "finite ?N1" "finite ?N2" by auto

        have "?N2 \<in> ?W"
        proof (cases "M = {}")
          case [simp]: True
          have Mw: "{} \<in> ?W" by (rule accI) (auto elim: max_ext.cases)
          from * have "?N2 = {}" by auto
          with Mw show "?N2 \<in> ?W" by (simp only:)
        next
          case False
          from * finites have N2: "(?N2, M) \<in> max_ext r"
            using max_extI[OF _ _ \<open>M \<noteq> {}\<close>, where ?X = ?N2] by auto
          with \<open>M \<in> ?W\<close> show "?N2 \<in> ?W" by (rule acc_downward)
        qed
        with finites have "?N1 \<union> ?N2 \<in> ?W"
          by (rule add_less) simp
        then show "N \<in> ?W" by (simp only: N)
      qed
    qed
  next
    case infinite
    show ?case
      by (rule accI) (auto elim: max_ext.cases simp: infinite)
  qed
qed

lemma max_ext_additive: "(A, B) \<in> max_ext R \<Longrightarrow> (C, D) \<in> max_ext R \<Longrightarrow> (A \<union> C, B \<union> D) \<in> max_ext R"
  by (force elim!: max_ext.cases)

definition min_ext :: "('a \<times> 'a) set \<Rightarrow> ('a set \<times> 'a set) set"
  where "min_ext r = {(X, Y) | X Y. X \<noteq> {} \<and> (\<forall>y \<in> Y. (\<exists>x \<in> X. (x, y) \<in> r))}"

lemma min_ext_wf:
  assumes "wf r"
  shows "wf (min_ext r)"
proof (rule wfI_min)
  show "\<exists>m \<in> Q. (\<forall>n. (n, m) \<in> min_ext r \<longrightarrow> n \<notin> Q)" if nonempty: "x \<in> Q"
    for Q :: "'a set set" and x
  proof (cases "Q = {{}}")
    case True
    then show ?thesis by (simp add: min_ext_def)
  next
    case False
    with nonempty obtain e x where "x \<in> Q" "e \<in> x" by force
    then have eU: "e \<in> \<Union>Q" by auto
    with \<open>wf r\<close>
    obtain z where z: "z \<in> \<Union>Q" "\<And>y. (y, z) \<in> r \<Longrightarrow> y \<notin> \<Union>Q"
      by (erule wfE_min)
    from z obtain m where "m \<in> Q" "z \<in> m" by auto
    from \<open>m \<in> Q\<close> show ?thesis
    proof (intro rev_bexI allI impI)
      fix n
      assume smaller: "(n, m) \<in> min_ext r"
      with \<open>z \<in> m\<close> obtain y where "y \<in> n" "(y, z) \<in> r"
        by (auto simp: min_ext_def)
      with z(2) show "n \<notin> Q" by auto
    qed
  qed
qed

subsubsection \<open>Bounded increase must terminate\<close>

lemma wf_bounded_measure:
  fixes ub :: "'a \<Rightarrow> nat"
    and f :: "'a \<Rightarrow> nat"
  assumes "\<And>a b. (b, a) \<in> r \<Longrightarrow> ub b \<le> ub a \<and> ub a \<ge> f b \<and> f b > f a"
  shows "wf r"
  by (rule wf_subset[OF wf_measure[of "\<lambda>a. ub a - f a"]]) (auto dest: assms)

lemma wf_bounded_set:
  fixes ub :: "'a \<Rightarrow> 'b set"
    and f :: "'a \<Rightarrow> 'b set"
  assumes "\<And>a b. (b,a) \<in> r \<Longrightarrow> finite (ub a) \<and> ub b \<subseteq> ub a \<and> ub a \<supseteq> f b \<and> f b \<supset> f a"
  shows "wf r"
  apply (rule wf_bounded_measure[of r "\<lambda>a. card (ub a)" "\<lambda>a. card (f a)"])
  apply (drule assms)
  apply (blast intro: card_mono finite_subset psubset_card_mono dest: psubset_eq[THEN iffD2])
  done

lemma finite_subset_wf:
  assumes "finite A"
  shows "wf {(X, Y). X \<subset> Y \<and> Y \<subseteq> A}"
  by (rule wf_subset[OF wf_finite_psubset[unfolded finite_psubset_def]])
    (auto intro: finite_subset[OF _ assms])

hide_const (open) acc accp

end


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

  The primes \<omega> function (i.e. the number of distinct prime factors)
*)
section \<open>The Prime \<open>\<omega>\<close> function\<close>
theory Primes_Omega
  imports Dirichlet_Series.Dirichlet_Series Dirichlet_Series.Divisor_Count
begin

text \<open>
  The prime \<open>\<omega>\<close> function $\omega(n)$ counts the number of distinct prime factors of \<open>n\<close>.
\<close>

definition primes_omega :: "nat \<Rightarrow> nat" where
  "primes_omega n = card (prime_factors n)"

lemma primes_omega_prime [simp]: "prime p \<Longrightarrow> primes_omega p = 1"
  by (simp add: primes_omega_def prime_factorization_prime)

lemma primes_omega_0 [simp]: "primes_omega 0 = 0"
  by (simp add: primes_omega_def)

lemma primes_omega_1 [simp]: "primes_omega 1 = 0"
  by (simp add: primes_omega_def)

lemma primes_omega_Suc_0 [simp]: "primes_omega (Suc 0) = 0"
  by (simp add: primes_omega_def)

lemma primes_omega_power [simp]: "n > 0 \<Longrightarrow> primes_omega (x ^ n) = primes_omega x"
  by (simp add: primes_omega_def prime_factors_power)

lemma primes_omega_primepow [simp]: "primepow n \<Longrightarrow> primes_omega n = 1"
  by (auto simp: primepow_def)

lemma primes_omega_eq_0_iff: "primes_omega n = 0 \<longleftrightarrow> n = 0 \<or> n = 1"
  by (auto simp: primes_omega_def prime_factorization_empty_iff)

lemma primes_omega_pos [simp, intro]: "n > 1 \<Longrightarrow> primes_omega n > 0"
  by (cases "primes_omega n > 0") (auto simp: primes_omega_eq_0_iff)

lemma primes_omega_mult_coprime:
  assumes "coprime x y" "x > 0 \<or> y > 0"
  shows   "primes_omega (x * y) = primes_omega x + primes_omega y"
proof (cases "x = 0 \<or> y = 0")
  case False
  hence "prime_factors (x * y) = prime_factors x \<union> prime_factors y"
    by (subst prime_factorization_mult) auto
  also {
    have "prime_factors x \<inter> prime_factors y = set_mset (prime_factorization (gcd x y))"
      using False by (subst prime_factorization_gcd) auto
    also have "gcd x y = 1" using \<open>coprime x y\<close> by auto
    finally have "card (prime_factors x \<union> prime_factors y) = primes_omega x + primes_omega y"
      unfolding primes_omega_def by (intro card_Un_disjoint) (use False in auto)
  }
  finally show ?thesis by (simp add: primes_omega_def)
qed (use assms in auto)

lemma divisor_count_squarefree:
  assumes "squarefree n" "n > 0"
  shows   "divisor_count n = 2 ^ primes_omega n"
proof -
  have "divisor_count n = (\<Prod>p\<in>prime_factors n. Suc (multiplicity p n))"
    using assms by (subst divisor_count.prod_prime_factors') auto
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. 2)"
    using assms assms by (intro prod.cong) (auto simp: squarefree_factorial_semiring')
  finally show ?thesis by (simp add: primes_omega_def)
qed

end


(*  Title:      HOL/Isar_Examples/First_Order_Logic.thy
    Author:     Makarius
*)

section \<open>A simple formulation of First-Order Logic\<close>

text \<open>
  The subsequent theory development illustrates single-sorted intuitionistic
  first-order logic with equality, formulated within the Pure framework.
\<close>

theory First_Order_Logic
  imports Pure
begin

subsection \<open>Abstract syntax\<close>

typedecl i
typedecl o

judgment Trueprop :: "o \<Rightarrow> prop"  ("_" 5)

subsection \<open>Propositional logic\<close>

axiomatization false :: o  ("\<bottom>")
  where falseE [elim]: "\<bottom> \<Longrightarrow> A"

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and mp [dest]: "A \<longrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"

axiomatization conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
    and conjD1: "A \<and> B \<Longrightarrow> A"
    and conjD2: "A \<and> B \<Longrightarrow> B"

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> show A
    by (rule conjD1)
  from \<open>A \<and> B\<close> show B
    by (rule conjD2)
qed

axiomatization disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C"
    and disjI1 [intro]: "A \<Longrightarrow> A \<or> B"
    and disjI2 [intro]: "B \<Longrightarrow> A \<or> B"

definition true :: o  ("\<top>")
  where "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

theorem trueI [intro]: \<top>
  unfolding true_def ..

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

theorem notI [intro]: "(A \<Longrightarrow> \<bottom>) \<Longrightarrow> \<not> A"
  unfolding not_def ..

theorem notE [elim]: "\<not> A \<Longrightarrow> A \<Longrightarrow> B"
  unfolding not_def
proof -
  assume "A \<longrightarrow> \<bottom>" and A
  then have \<bottom> ..
  then show B ..
qed

definition iff :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longleftrightarrow>" 25)
  where "A \<longleftrightarrow> B \<equiv> (A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"

theorem iffI [intro]:
  assumes "A \<Longrightarrow> B"
    and "B \<Longrightarrow> A"
  shows "A \<longleftrightarrow> B"
  unfolding iff_def
proof
  from \<open>A \<Longrightarrow> B\<close> show "A \<longrightarrow> B" ..
  from \<open>B \<Longrightarrow> A\<close> show "B \<longrightarrow> A" ..
qed

theorem iff1 [elim]:
  assumes "A \<longleftrightarrow> B" and A
  shows B
proof -
  from \<open>A \<longleftrightarrow> B\<close> have "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
    unfolding iff_def .
  then have "A \<longrightarrow> B" ..
  from this and \<open>A\<close> show B ..
qed

theorem iff2 [elim]:
  assumes "A \<longleftrightarrow> B" and B
  shows A
proof -
  from \<open>A \<longleftrightarrow> B\<close> have "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
    unfolding iff_def .
  then have "B \<longrightarrow> A" ..
  from this and \<open>B\<close> show A ..
qed

subsection \<open>Equality\<close>

axiomatization equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infixl "=" 50)
  where refl [intro]: "x = x"
    and subst: "x = y \<Longrightarrow> P x \<Longrightarrow> P y"

theorem trans [trans]: "x = y \<Longrightarrow> y = z \<Longrightarrow> x = z"
  by (rule subst)

theorem sym [sym]: "x = y \<Longrightarrow> y = x"
proof -
  assume "x = y"
  from this and refl show "y = x"
    by (rule subst)
qed

subsection \<open>Quantifiers\<close>

axiomatization All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. P x) \<Longrightarrow> \<forall>x. P x"
    and allD [dest]: "\<forall>x. P x \<Longrightarrow> P a"

axiomatization Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where exI [intro]: "P a \<Longrightarrow> \<exists>x. P x"
    and exE [elim]: "\<exists>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> C) \<Longrightarrow> C"

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain x where "P (f x)" ..
  then show "\<exists>y. P y" ..
qed

lemma "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
proof
  assume "\<exists>x. \<forall>y. R x y"
  then obtain x where "\<forall>y. R x y" ..
  show "\<forall>y. \<exists>x. R x y"
  proof
    fix y
    from \<open>\<forall>y. R x y\<close> have "R x y" ..
    then show "\<exists>x. R x y" ..
  qed
qed

end


(*
  File:    Efficient_Discrete_Sqrt.thy
  Author:  Markus Großer, Manuel Eberl

  A reasonably efficient algorithm to compute the square root of a natural number (rounded down)
  and to test if a natural number is a perfect square.
*)
theory Efficient_Discrete_Sqrt
imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Library.Discrete"
  "HOL-Library.Tree"
  "HOL-Library.IArray"
begin
section \<open>Efficient Algorithms for the Square Root on \<open>\<nat>\<close>\<close>

(*
  TODO: This could perhaps be moved somewhere else. Thre is also probably some overlap
  with Sqrt_Babylonian
*)

subsection \<open>A Discrete Variant of Heron's Algorithm\<close>

text \<open>
  An algorithm for calculating the discrete square root, taken from
  Cohen~\<^cite>\<open>"cohen2010algebraic"\<close>. This algorithm is essentially a discretised variant of
  Heron's method or Newton's method specialised to the square root function.
\<close>

lemma sqrt_eq_floor_sqrt: "Discrete.sqrt n = nat \<lfloor>sqrt n\<rfloor>"
proof -
  have "real ((nat \<lfloor>sqrt n\<rfloor>)\<^sup>2) = (real (nat \<lfloor>sqrt n\<rfloor>))\<^sup>2"
    by simp
  also have "\<dots> \<le> sqrt (real n) ^ 2"
    by (intro power_mono) auto
  also have "\<dots> = real n" by simp
  finally have "(nat \<lfloor>sqrt n\<rfloor>)\<^sup>2 \<le> n"
    by (simp only: of_nat_le_iff)
  moreover have "n < (Suc (nat \<lfloor>sqrt n\<rfloor>))\<^sup>2" proof -
    have "(1 + \<lfloor>sqrt n\<rfloor>)\<^sup>2 > n"
      using floor_correct[of "sqrt n"] real_le_rsqrt[of "1 + \<lfloor>sqrt n\<rfloor>" n]
        of_int_less_iff[of n "(1 + \<lfloor>sqrt n\<rfloor>)\<^sup>2"] not_le
      by fastforce
    then show ?thesis
      using le_nat_floor[of "Suc (nat \<lfloor>sqrt n\<rfloor>)" "sqrt n"]
        of_nat_le_iff[of "(Suc (nat \<lfloor>sqrt n\<rfloor>))\<^sup>2" n] real_le_rsqrt[of _ n] not_le
      by fastforce
  qed
  ultimately show ?thesis using sqrt_unique by fast
qed

fun newton_sqrt_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "newton_sqrt_aux x n =
     (let y = (x + n div x) div 2
      in if y < x then newton_sqrt_aux y n else x)"

declare newton_sqrt_aux.simps [simp del]

lemma newton_sqrt_aux_simps:
  "(x + n div x) div 2 < x \<Longrightarrow> newton_sqrt_aux x n = newton_sqrt_aux ((x + n div x) div 2) n"
  "(x + n div x) div 2 \<ge> x \<Longrightarrow> newton_sqrt_aux x n = x"
  by (subst newton_sqrt_aux.simps; simp add: Let_def)+

lemma heron_step_real: "\<lbrakk>t > 0; n \<ge> 0\<rbrakk> \<Longrightarrow> (t + n/t) / 2 \<ge> sqrt n"
  using arith_geo_mean_sqrt[of t "n/t"] by simp

lemma heron_step_div_eq_floored:
  "(t::nat) > 0 \<Longrightarrow> (t + (n::nat) div t) div 2 = nat \<lfloor>(t + n/t) / 2\<rfloor>"
proof -
  assume "t > 0"
  then have "\<lfloor>(t + n/t) / 2\<rfloor> = \<lfloor>(t*t + n) / (2*t)\<rfloor>"
    by (simp add: mult_divide_mult_cancel_right[of t "t + n/t" 2, symmetric]
        algebra_simps)
  also have "\<dots> = (t*t + n) div (2*t)"
    using floor_divide_of_nat_eq by blast
  also have "\<dots> = (t*t + n) div t div 2"
    by (simp add: Divides.div_mult2_eq mult.commute)
  also have "\<dots> = (t + n div t) div 2"
    by (simp add: \<open>0 < t\<close> power2_eq_square)
  finally show ?thesis by simp
qed

lemma heron_step: "t > 0 \<Longrightarrow> (t + n div t) div 2 \<ge> Discrete.sqrt n"
proof -
  assume "t > 0"
  have "Discrete.sqrt n = nat \<lfloor>sqrt n\<rfloor>" by (rule sqrt_eq_floor_sqrt)
  also have "\<dots> \<le> nat \<lfloor>(t + n/t) / 2\<rfloor>"
    using heron_step_real[of t n] \<open>t > 0\<close> by linarith
  also have "\<dots> = (t + n div t) div 2"
    using heron_step_div_eq_floored[OF \<open>t > 0\<close>] by simp
  finally show ?thesis .
qed

lemma newton_sqrt_aux_correct:
  assumes "x \<ge> Discrete.sqrt n"
  shows   "newton_sqrt_aux x n = Discrete.sqrt n"
  using assms
proof (induction x n rule: newton_sqrt_aux.induct)
  case (1 x n)
  show ?case
  proof (cases "x = Discrete.sqrt n")
    case True
    then have "(x ^ 2) div x \<le> n div x" by (intro div_le_mono) simp_all
    also have "(x ^ 2) div x = x" by (simp add: power2_eq_square)
    finally have "(x + n div x) div 2 \<ge> x" by linarith
    with True show ?thesis by (auto simp: newton_sqrt_aux_simps)
  next
    case False
    with "1.prems" have x_gt_sqrt: "x > Discrete.sqrt n" by auto
    with Discrete.le_sqrt_iff[of x n] have "n < x ^ 2" by simp
    have "x * (n div x) \<le> n" using mult_div_mod_eq[of x n] by linarith
    also have "\<dots> < x ^ 2" using Discrete.le_sqrt_iff[of x n] and x_gt_sqrt by simp
    also have "\<dots> = x * x" by (simp add: power2_eq_square)
    finally have "n div x < x" by (subst (asm) mult_less_cancel1) auto
    then have step_decreasing: "(x + n div x) div 2 < x" by linarith
    with x_gt_sqrt have step_ge_sqrt: "(x + n div x) div 2 \<ge> Discrete.sqrt n"
      by (simp add: heron_step)
    from step_decreasing have "newton_sqrt_aux x n = newton_sqrt_aux ((x + n div x) div 2) n"
      by (simp add: newton_sqrt_aux_simps)
    also have "\<dots> = Discrete.sqrt n"
      by (intro "1.IH" step_decreasing step_ge_sqrt) simp_all
    finally show ?thesis .
  qed
qed

definition newton_sqrt :: "nat \<Rightarrow> nat" where
  "newton_sqrt n = newton_sqrt_aux n n"

declare Discrete.sqrt_code [code del]

theorem Discrete_sqrt_eq_newton_sqrt [code]: "Discrete.sqrt n = newton_sqrt n"
  unfolding newton_sqrt_def by (simp add: newton_sqrt_aux_correct Discrete.sqrt_le)

subsection \<open>Square Testing\<close>

text \<open>
  Next, we implement an algorithm to determine whether a given natural number is a perfect square,
  as described by Cohen~\<^cite>\<open>"cohen2010algebraic"\<close>. Essentially, the number first determines whether
  the number is a square. Essentially
\<close>

definition q11 :: "nat set"
  where "q11 = {0, 1, 3, 4, 5, 9}"
definition q63 :: "nat set"
  where "q63 = {0, 1, 4, 7, 9, 16, 28, 18, 22, 25, 36, 58, 46, 49, 37, 43}"
definition q64 :: "nat set"
  where "q64 = {0, 1, 4, 9, 16, 17, 25, 36, 33, 49, 41, 57}"
definition q65 :: "nat set"
  where "q65 = {0, 1, 4, 10, 14, 9, 16, 26, 30, 25, 29, 40, 56, 36, 49, 61, 35, 51, 39, 55, 64}"

definition q11_array where
  "q11_array = IArray [True,True,False,True,True,True,False,False,False,True,False]"

definition q63_array where
  "q63_array = IArray [True,True,False,False,True,False,False,True,False,True,False,False,
     False,False,False,False,True,False,True,False,False,False,True,False,False,True,False,
     False,True,False,False,False,False,False,False,False,True,True,False,False,False,False,
     False,True,False,False,True,False,False,True,False,False,False,False,False,False,False,
     False,True,False,False,False,False,False]"

definition q64_array where
  "q64_array = IArray [True,True,False,False,True,False,False,False,False,True,False,False,
     False,False,False,False,True,True,False,False,False,False,False,False,False,True,False,
     False,False,False,False,False,False,True,False,False,True,False,False,False,False,True,
     False,False,False,False,False,False,False,True,False,False,False,False,False,False,
     False,True,False,False,False,False,False,False, False]"

definition q65_array where
  "q65_array = IArray [True,True,False,False,True,False,False,False,False,True,True,False,
     False,False,True,False,True,False,False,False,False,False,False,False,False,True,True,
     False,False,True,True,False,False,False,False,True,True,False,False,True,True,False,
     False,False,False,False,False,False,False,True,False,True,False,False,False,True,True
     ,False,False,False,False,True,False,False,True,False]"

lemma sub_q11_array: "i \<in> {..<11} \<Longrightarrow> IArray.sub q11_array i \<longleftrightarrow> i \<in> q11"
  by (simp add: lessThan_nat_numeral lessThan_Suc q11_def q11_array_def, elim disjE; simp)

lemma sub_q63_array: "i \<in> {..<63} \<Longrightarrow> IArray.sub q63_array i \<longleftrightarrow> i \<in> q63"
  by (simp add: lessThan_nat_numeral lessThan_Suc q63_def q63_array_def, elim disjE; simp)

lemma sub_q64_array: "i \<in> {..<64} \<Longrightarrow> IArray.sub q64_array i \<longleftrightarrow> i \<in> q64"
  by (simp add: lessThan_nat_numeral lessThan_Suc q64_def q64_array_def, elim disjE; simp)

lemma sub_q65_array: "i \<in> {..<65} \<Longrightarrow> IArray.sub q65_array i \<longleftrightarrow> i \<in> q65"
  by (simp add: lessThan_nat_numeral lessThan_Suc q65_def q65_array_def, elim disjE; simp)

lemma in_q11_code: "x mod 11 \<in> q11 \<longleftrightarrow> IArray.sub q11_array (x mod 11)"
  by (subst sub_q11_array) auto

lemma in_q63_code: "x mod 63 \<in> q63 \<longleftrightarrow> IArray.sub q63_array (x mod 63)"
  by (subst sub_q63_array) auto

lemma in_q64_code: "x mod 64 \<in> q64 \<longleftrightarrow> IArray.sub q64_array (x mod 64)"
  by (subst sub_q64_array) auto

lemma in_q65_code: "x mod 65 \<in> q65 \<longleftrightarrow> IArray.sub q65_array (x mod 65)"
  by (subst sub_q65_array) auto

definition square_test :: "nat \<Rightarrow> bool" where
  "square_test n =
    (n mod 64 \<in> q64 \<and> (let r = n mod 45045 in
      r mod 63 \<in> q63 \<and> r mod 65 \<in> q65 \<and> r mod 11 \<in> q11 \<and> n = (Discrete.sqrt n)\<^sup>2))"

lemma square_test_code [code]:
  "square_test n =
    (IArray.sub q64_array (n mod 64) \<and> (let r = n mod 45045 in
           IArray.sub q63_array (r mod 63) \<and>
           IArray.sub q65_array (r mod 65) \<and>
           IArray.sub q11_array (r mod 11) \<and> n = (Discrete.sqrt n)\<^sup>2))"
    using in_q11_code [symmetric] in_q63_code [symmetric]
          in_q64_code [symmetric] in_q65_code [symmetric]
  by (simp add: Let_def square_test_def)

lemma square_mod_lower: "m > 0 \<Longrightarrow> (q\<^sup>2 :: nat) mod m = a \<Longrightarrow> \<exists>q' < m. q'\<^sup>2 mod m = a"
  using mod_less_divisor mod_mod_trivial power_mod by blast

lemma q11_upto_def: "q11 = (\<lambda>k. k\<^sup>2 mod 11) ` {..<11}"
  by (simp add: q11_def lessThan_nat_numeral lessThan_Suc insert_commute)

lemma q11_infinite_def: "q11 = (\<lambda>k. k\<^sup>2 mod 11) ` {0..}"
  unfolding q11_upto_def image_def proof (auto, goal_cases)
  case (1 xa)
  show ?case
    using square_mod_lower[of 11 xa "xa\<^sup>2 mod 11"]
      ex_nat_less_eq[of 11 "\<lambda>x. xa\<^sup>2 mod 11 = x\<^sup>2 mod 11"]
    by auto
qed

lemma q63_upto_def: "q63 = (\<lambda>k. k\<^sup>2 mod 63) ` {..<63}"
  by (simp add: q63_def lessThan_nat_numeral lessThan_Suc insert_commute)

lemma q63_infinite_def: "q63 = (\<lambda>k. k\<^sup>2 mod 63) ` {0..}"
  unfolding q63_upto_def image_def proof (auto, goal_cases)
  case (1 xa)
  show ?case
    using square_mod_lower[of 63 xa "xa\<^sup>2 mod 63"]
      ex_nat_less_eq[of 63 "\<lambda>x. xa\<^sup>2 mod 63 = x\<^sup>2 mod 63"]
    by auto
qed

lemma q64_upto_def: "q64 = (\<lambda>k. k\<^sup>2 mod 64) ` {..<64}"
  by (simp add: q64_def lessThan_nat_numeral lessThan_Suc insert_commute)

lemma q64_infinite_def: "q64 = (\<lambda>k. k\<^sup>2 mod 64) ` {0..}"
  unfolding q64_upto_def image_def proof (auto, goal_cases)
  case (1 xa)
  show ?case
    using square_mod_lower[of 64 xa "xa\<^sup>2 mod 64"]
      ex_nat_less_eq[of 64 "\<lambda>x. xa\<^sup>2 mod 64 = x\<^sup>2 mod 64"]
    by auto
qed

lemma q65_upto_def: "q65 = (\<lambda>k. k\<^sup>2 mod 65) ` {..<65}"
  by (simp add: q65_def lessThan_nat_numeral lessThan_Suc insert_commute)

lemma q65_infinite_def: "q65 = (\<lambda>k. k\<^sup>2 mod 65) ` {0..}"
  unfolding q65_upto_def image_def proof (auto, goal_cases)
  case (1 xa)
  show ?case
    using square_mod_lower[of 65 xa "xa\<^sup>2 mod 65"]
      ex_nat_less_eq[of 65 "\<lambda>x. xa\<^sup>2 mod 65 = x\<^sup>2 mod 65"]
    by auto
qed

lemma square_mod_existence:
  fixes n k :: nat
  assumes "\<exists>q. q\<^sup>2 = n"
  shows "\<exists>q. n mod k = q\<^sup>2 mod k"
  using assms by auto

theorem square_test_correct: "square_test n \<longleftrightarrow> is_square n"
proof cases
  assume "is_square n"
  hence  rhs: "\<exists>q. q\<^sup>2 = n" by (auto elim: is_nth_powerE)
  note sq_mod = square_mod_existence[OF this]
  have q64_member: "n mod 64 \<in> q64" using sq_mod[of 64]
    unfolding q64_infinite_def image_def by simp
  let ?r = "n mod 45045"
  have "11 dvd (45045::nat)" "63 dvd (45045::nat)" "65 dvd (45045::nat)" by force+
  then have mod_45045: "?r mod 11 = n mod 11" "?r mod 63 = n mod 63" "?r mod 65 = n mod 65"
    using mod_mod_cancel[of _ 45045 n] by presburger+
  then have "?r mod 11 \<in> q11" "?r mod 63 \<in> q63" "?r mod 65 \<in> q65"
    using sq_mod[of 11] sq_mod[of 63] sq_mod[of 65]
    unfolding q11_infinite_def q63_infinite_def q65_infinite_def image_def mod_45045
    by fast+
  then show ?thesis unfolding square_test_def Let_def using q64_member rhs by auto
next
  assume not_rhs: "\<not>is_square n"
  hence "\<nexists>q. q\<^sup>2 = n" by auto
  then have "(Discrete.sqrt n)\<^sup>2 \<noteq> n" by simp
  then show ?thesis unfolding square_test_def by (auto simp: is_nth_power_def)
qed

definition get_nat_sqrt :: "nat \<Rightarrow> nat option"
  where "get_nat_sqrt n = (if is_square n then Some (Discrete.sqrt n) else None)"

lemma get_nat_sqrt_code [code]:
  "get_nat_sqrt n =
    (if IArray.sub q64_array (n mod 64) \<and> (let r = n mod 45045 in
           IArray.sub q63_array (r mod 63) \<and>
           IArray.sub q65_array (r mod 65) \<and>
           IArray.sub q11_array (r mod 11)) then
       (let x = Discrete.sqrt n in if x\<^sup>2 = n then Some x else None) else None)"
  unfolding get_nat_sqrt_def square_test_correct [symmetric] square_test_def
  using in_q11_code [symmetric] in_q63_code [symmetric]
        in_q64_code [symmetric] in_q65_code [symmetric]
  by (auto split: if_splits simp: Let_def )

end


(*
  File:   Master_Theorem.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

  The Master theorem in a generalised form as derived from the Akra-Bazzi theorem.
*)
section \<open>The Master theorem\<close>
theory Master_Theorem
imports
  "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
  Akra_Bazzi_Library
  Akra_Bazzi
begin

lemma fundamental_theorem_of_calculus_real:
  "a \<le> b \<Longrightarrow> \<forall>x\<in>{a..b}. (f has_real_derivative f' x) (at x within {a..b}) \<Longrightarrow>
      (f' has_integral (f b - f a)) {a..b}"
  by (intro fundamental_theorem_of_calculus ballI)
     (simp_all add: has_field_derivative_iff_has_vector_derivative[symmetric])

lemma integral_powr:
  "y \<noteq> -1 \<Longrightarrow> a \<le> b \<Longrightarrow> a > 0 \<Longrightarrow> integral {a..b} (\<lambda>x. x powr y :: real) =
     inverse (y + 1) * (b powr (y + 1) - a powr (y + 1))"
  by (subst right_diff_distrib, intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros)

lemma integral_ln_powr_over_x:
  "y \<noteq> -1 \<Longrightarrow> a \<le> b \<Longrightarrow> a > 1 \<Longrightarrow> integral {a..b} (\<lambda>x. ln x powr y / x :: real) =
     inverse (y + 1) * (ln b powr (y + 1) - ln a powr (y + 1))"
  by (subst right_diff_distrib, intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros)

lemma integral_one_over_x_ln_x:
  "a \<le> b \<Longrightarrow> a > 1 \<Longrightarrow> integral {a..b} (\<lambda>x. inverse (x * ln x) :: real) = ln (ln b) - ln (ln a)"
  by (intro integral_unique fundamental_theorem_of_calculus_real)
     (auto intro!: derivative_eq_intros simp: field_simps)

lemma akra_bazzi_integral_kurzweil_henstock:
  "akra_bazzi_integral (\<lambda>f a b. f integrable_on {a..b}) (\<lambda>f a b. integral {a..b} f)"
apply unfold_locales
apply (rule integrable_const_ivl)
apply simp
apply (erule integrable_subinterval_real, simp)
apply (blast intro!: integral_le)
apply (rule integral_combine, simp_all) []
done

locale master_theorem_function = akra_bazzi_recursion +
  fixes g :: "nat \<Rightarrow> real"
  assumes f_nonneg_base: "x \<ge> x\<^sub>0 \<Longrightarrow> x < x\<^sub>1 \<Longrightarrow> f x \<ge> 0"
  and     f_rec:         "x \<ge> x\<^sub>1 \<Longrightarrow> f x = g x + (\<Sum>i<k. as!i * f ((ts!i) x))"
  and     g_nonneg:      "x \<ge> x\<^sub>1 \<Longrightarrow> g x \<ge> 0"
  and     ex_pos_a:      "\<exists>a\<in>set as. a > 0"
begin

interpretation akra_bazzi_integral "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f"
  by (rule akra_bazzi_integral_kurzweil_henstock)

sublocale akra_bazzi_function x\<^sub>0 x\<^sub>1 k as bs ts f "\<lambda>f a b. f integrable_on {a..b}"
            "\<lambda>f a b. integral {a..b} f" g
  using f_nonneg_base f_rec g_nonneg ex_pos_a by unfold_locales

context
begin

private lemma g_nonneg': "eventually (\<lambda>x. g x \<ge> 0) at_top"
  using g_nonneg by (force simp: eventually_at_top_linorder)

private lemma g_pos:
  assumes "g \<in> \<Omega>(h)"
  assumes "eventually (\<lambda>x. h x > 0) at_top"
  shows   "eventually (\<lambda>x. g x > 0) at_top"
proof-
  from landau_omega.bigE_nonneg_real[OF assms(1) g_nonneg'] guess c . note c = this
  from assms(2) c(2) show ?thesis
    by eventually_elim (rule less_le_trans[OF mult_pos_pos[OF c(1)]], simp_all)
qed

private lemma f_pos:
  assumes "g \<in> \<Omega>(h)"
  assumes "eventually (\<lambda>x. h x > 0) at_top"
  shows   "eventually (\<lambda>x. f x > 0) at_top"
  using g_pos[OF assms(1,2)] eventually_ge_at_top[of x\<^sub>1]
  by (eventually_elim) (subst f_rec, insert step_ge_x0,
         auto intro!: add_pos_nonneg sum_nonneg mult_nonneg_nonneg[OF a_ge_0] f_nonneg)

lemma bs_lower_bound: "\<exists>C>0. \<forall>b\<in>set bs. C < b"
proof (intro exI conjI ballI)
  from b_pos show A: "Min (set bs) / 2 > 0" by auto
  fix b assume b: "b \<in> set bs"
  from A have "Min (set bs) / 2 < Min (set bs)" by simp
  also from b have "... \<le> b" by simp
  finally show "Min (set bs) / 2 < b" .
qed

private lemma powr_growth2:
  "\<exists>C c2. 0 < c2 \<and> C < Min (set bs) \<and>
      eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c2 * x powr p' \<ge> u powr p') at_top"
proof (intro exI conjI allI ballI)
  define C where "C = Min (set bs) / 2"
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by auto
  thus "C < Min (set bs)" unfolding C_def by simp
  show "max (C powr p') 1 > 0" by simp
  show "eventually (\<lambda>x. \<forall>u\<in>{C * x..x}.
    max ((Min (set bs)/2) powr p') 1 * x powr p' \<ge> u powr p') at_top"
    using eventually_gt_at_top[of "0::real"] apply eventually_elim
  proof clarify
    fix x u assume x: "x > 0" and "u \<in> {C*x..x}"
    hence u: "u \<ge> C*x" "u \<le> x" unfolding C_def by  simp_all
    from u have "u powr p' \<le> max ((C*x) powr p') (x powr p')" using C_pos x
      by (intro powr_upper_bound mult_pos_pos) simp_all
    also from u x C_pos have "max ((C*x) powr p') (x powr p') = x powr p' * max (C powr p') 1"
      by (subst max_mult_left) (simp_all add: powr_mult algebra_simps)
    finally show "u powr p' \<le> max ((Min (set bs)/2) powr p') 1 * x powr p'"
      by (simp add: C_def algebra_simps)
  qed
qed

private lemma powr_growth1:
  "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
      eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * x powr p' \<le> u powr p') at_top"
proof (intro exI conjI allI ballI)
  define C where "C = Min (set bs) / 2"
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by auto
  thus "C < Min (set bs)" unfolding C_def by simp
  from C_pos show "min (C powr p') 1 > 0" by simp
  show "eventually (\<lambda>x. \<forall>u\<in>{C * x..x}.
          min ((Min (set bs)/2) powr p') 1 * x powr p' \<le> u powr p') at_top"
    using eventually_gt_at_top[of "0::real"] apply eventually_elim
  proof clarify
    fix x u assume x: "x > 0" and "u \<in> {C*x..x}"
    hence u: "u \<ge> C*x" "u \<le> x" unfolding C_def by  simp_all
    from u x C_pos have "x powr p' * min (C powr p') 1 = min ((C*x) powr p') (x powr p')"
      by (subst min_mult_left) (simp_all add: powr_mult algebra_simps)
    also from u have "u powr p' \<ge> min ((C*x) powr p') (x powr p')" using C_pos x
      by (intro powr_lower_bound mult_pos_pos) simp_all
    finally show "u powr p' \<ge> min ((Min (set bs)/2) powr p') 1 * x powr p'"
      by (simp add: C_def algebra_simps)
  qed
qed

private lemma powr_ln_powr_lower_bound:
  "a > 1 \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow>
     min (a powr p) (b powr p) * min (ln a powr p') (ln b powr p') \<le> x powr p * ln x powr p'"
  by (intro mult_mono powr_lower_bound) (auto intro: min.coboundedI1)

private lemma powr_ln_powr_upper_bound:
  "a > 1 \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow>
     max (a powr p) (b powr p) * max (ln a powr p') (ln b powr p') \<ge> x powr p * ln x powr p'"
  by (intro mult_mono powr_upper_bound) (auto intro: max.coboundedI1)

private lemma powr_ln_powr_upper_bound':
  "eventually (\<lambda>a. \<forall>b>a. \<exists>c. \<forall>x\<in>{a..b}. x powr p * ln x powr p' \<le> c) at_top"
  by (subst eventually_at_top_dense) (force intro: powr_ln_powr_upper_bound)

private lemma powr_upper_bound':
  "eventually (\<lambda>a::real. \<forall>b>a. \<exists>c. \<forall>x\<in>{a..b}. x powr p' \<le> c) at_top"
  by (subst eventually_at_top_dense) (force intro: powr_upper_bound)

lemmas bounds =
  powr_ln_powr_lower_bound powr_ln_powr_upper_bound powr_ln_powr_upper_bound' powr_upper_bound'

private lemma eventually_ln_const:
  assumes "(C::real) > 0"
  shows   "eventually (\<lambda>x. ln (C*x) / ln x > 1/2) at_top"
proof-
  from tendstoD[OF tendsto_ln_over_ln[of C 1], of "1/2"] assms
    have "eventually (\<lambda>x. \<bar>ln (C*x) / ln x - 1\<bar> < 1/2) at_top" by (simp add: dist_real_def)
  thus ?thesis by eventually_elim linarith
qed

private lemma powr_ln_powr_growth1: "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
  eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * (x powr r * ln x powr r') \<le> u powr r * ln u powr r') at_top"
proof (intro exI conjI)
  let ?C = "Min (set bs) / 2" and ?f = "\<lambda>x. x powr r * ln x powr r'"
  define C where "C = ?C"
  from b_bounds have C_pos: "C > 0" unfolding C_def by simp
  let ?T = "min (C powr r) (1 powr r) * min ((1/2) powr r') (1 powr r')"
  from C_pos show "?T > 0" unfolding min_def by (auto split: if_split)
  from bs_nonempty b_bounds have C_pos: "C > 0" unfolding C_def by simp
  thus "C < Min (set bs)" by (simp add: C_def)

  show "eventually (\<lambda>x. \<forall>u\<in>{C*x..x}. ?T * ?f x \<le> ?f u) at_top"
    using eventually_gt_at_top[of "max 1 (inverse C)"] eventually_ln_const[OF C_pos]
    apply eventually_elim
  proof clarify
    fix x u assume x: "x > max 1 (inverse C)" and u: "u \<in> {C*x..x}"
    hence x': "x > 1" by (simp add: field_simps)
    with C_pos have x_pos: "x > 0" by (simp add: field_simps)
    from x u C_pos have u': "u > 1" by (simp add: field_simps)
    assume A: "ln (C*x) / ln x > 1/2"
    have "min (C powr r) (1 powr r) \<le> (u/x) powr r"
      using x u u' C_pos by (intro powr_lower_bound) (simp_all add: field_simps)
    moreover {
      note A
      also from C_pos x' u u' have "ln (C*x) \<le> ln u" by (subst ln_le_cancel_iff) simp_all
      with x' have "ln (C*x) / ln x \<le> ln u / ln x" by (simp add: field_simps)
      finally have "min ((1/2) powr r') (1 powr r') \<le> (ln u / ln x) powr r'"
        using x u u' C_pos A by (intro powr_lower_bound) simp_all
    }
    ultimately have "?T \<le> (u/x) powr r * (ln u / ln x) powr r'"
      using x_pos by (intro mult_mono) simp_all
    also from x u u' have "... = ?f u / ?f x" by (simp add: powr_divide)
    finally show "?T * ?f x \<le> ?f u" using x' by (simp add: field_simps)
  qed
qed

private lemma powr_ln_powr_growth2: "\<exists>C c1. 0 < c1 \<and> C < Min (set bs) \<and>
  eventually (\<lambda>x. \<forall>u\<in>{C * x..x}. c1 * (x powr r * ln x powr r') \<ge> u powr r * ln u powr r') at_top"
proof (intro exI conjI)
  let ?C = "Min (set bs) / 2" and ?f = "\<lambda>x. x powr r * ln x powr r'"
  define C where "C = ?C"
  let ?T = "max (C powr r) (1 powr r) * max ((1/2) powr r') (1 powr r')"
  show "?T > 0" by simp
  from b_bounds bs_nonempty have C_pos: "C > 0" unfolding C_def by simp
  thus "C < Min (set bs)" by (simp add: C_def)

  show "eventually (\<lambda>x. \<forall>u\<in>{C*x..x}. ?T * ?f x \<ge> ?f u) at_top"
    using eventually_gt_at_top[of "max 1 (inverse C)"] eventually_ln_const[OF C_pos]
    apply eventually_elim
  proof clarify
    fix x u assume x: "x > max 1 (inverse C)" and u: "u \<in> {C*x..x}"
    hence x': "x > 1" by (simp add: field_simps)
    with C_pos have x_pos: "x > 0" by (simp add: field_simps)
    from x u C_pos have u': "u > 1" by (simp add: field_simps)
    assume A: "ln (C*x) / ln x > 1/2"
    from x u u' have "?f u / ?f x = (u/x) powr r * (ln u/ln x) powr r'" by (simp add: powr_divide)
    also {
      have "(u/x) powr r \<le> max (C powr r) (1 powr r)"
        using x u u' C_pos by (intro powr_upper_bound) (simp_all add: field_simps)
      moreover {
        note A
        also from C_pos x' u u' have "ln (C*x) \<le> ln u" by (subst ln_le_cancel_iff) simp_all
        with x' have "ln (C*x) / ln x \<le> ln u / ln x" by (simp add: field_simps)
        finally have "(ln u / ln x) powr r' \<le> max ((1/2) powr r') (1 powr r')"
          using x u u' C_pos A by (intro powr_upper_bound) simp_all
      } ultimately have "(u/x) powr r * (ln u / ln x) powr r' \<le> ?T"
        using x_pos by (intro mult_mono) simp_all
    }
    finally show "?T * ?f x \<ge> ?f u" using x' by (simp add: field_simps)
  qed
qed

lemmas growths = powr_growth1 powr_growth2 powr_ln_powr_growth1 powr_ln_powr_growth2

private lemma master_integrable:
  "\<exists>a::real. \<forall>b\<ge>a. (\<lambda>u. u powr r * ln u powr s / u powr t) integrable_on {a..b}"
  "\<exists>a::real. \<forall>b\<ge>a. (\<lambda>u. u powr r / u powr s) integrable_on {a..b}"
  by (rule exI[of _ 2], force intro!: integrable_continuous_real continuous_intros)+

private lemma master_integral:
  fixes a p p' :: real
  assumes p: "p \<noteq> p'" and a: "a > 0"
  obtains c d where "c \<noteq> 0" "p > p' \<longrightarrow> d \<noteq> 0"
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p' / u powr (p+1)))) \<in>
             \<Theta>(\<lambda>x::nat. d * x powr p + c * x powr p')"
proof-
  define e where "e = a powr (p' - p)"
  from assms have e: "e \<ge> 0" by (simp add: e_def)
  define c where "c = inverse (p' - p)"
  define d where "d = 1 - inverse (p' - p) * e"
  have "c \<noteq> 0" and "p > p' \<longrightarrow> d \<noteq> 0"
    using e p a unfolding c_def d_def by (auto simp: field_simps)
  thus ?thesis
    apply (rule that) apply (rule bigtheta_real_nat_transfer, rule bigthetaI_cong)
    using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x assume x: "x \<ge> a"
    hence "integral {a..x} (\<lambda>u. u powr p' / u powr (p+1)) =
               integral {a..x} (\<lambda>u. u powr (p' - (p + 1)))"
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_diff [symmetric] )
    also have "... = inverse (p' - p) * (x powr (p' - p) - a powr (p' - p))"
      using p x0_less_x1 a x by (simp add: integral_powr)
    also have "x powr p * (1 + ...) = d * x powr p + c * x powr p'"
      using p unfolding c_def d_def by (simp add: algebra_simps powr_diff e_def)
    finally show "x powr p * (1 + integral {a..x} (\<lambda>u. u powr p' / u powr (p+1))) =
                      d * x powr p + c * x powr p'" .
  qed
qed

private lemma master_integral':
  fixes a p p' :: real
  assumes p': "p' \<noteq> 0" and a: "a > 1"
  obtains c d :: real where "p' < 0 \<longrightarrow> c \<noteq> 0" "d \<noteq> 0"
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr (p'-1) / u powr (p+1)))) \<in>
       \<Theta>(\<lambda>x::nat. c * x powr p + d * x powr p * ln x powr p')"
proof-
  define e where "e = ln a powr p'"
  from assms have e: "e > 0" by (simp add: e_def)
  define c where "c = 1 - inverse p' * e"
  define d where "d = inverse p'"
  from assms e have "p' < 0 \<longrightarrow> c \<noteq> 0" "d \<noteq> 0" unfolding c_def d_def by (auto simp: field_simps)
  thus ?thesis
    apply (rule that) apply (rule landau_real_nat_transfer, rule bigthetaI_cong)
    using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x :: real assume x: "x \<ge> a"
    have "integral {a..x} (\<lambda>u. u powr p * ln u powr (p' - 1) / u powr (p + 1)) =
          integral {a..x} (\<lambda>u. ln u powr (p' - 1) / u)" using x a x0_less_x1
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_add)
    also have "... = inverse p' * (ln x powr p' - ln a powr p')"
      using p' x0_less_x1 a(1) x by (simp add: integral_ln_powr_over_x)
    also have "x powr p * (1 + ...) = c * x powr p + d * x powr p * ln x powr p'"
      using p' by (simp add: algebra_simps c_def d_def e_def)
    finally show "x powr p * (1+integral {a..x} (\<lambda>u. u powr p * ln u powr (p'-1) / u powr (p+1))) =
                  c * x powr p + d * x powr p * ln x powr p'" .
  qed
qed

private lemma master_integral'':
  fixes a p p' :: real
  assumes a: "a > 1"
  shows "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1/u powr (p+1)))) \<in>
           \<Theta>(\<lambda>x::nat. x powr p * ln (ln x))"
proof (rule landau_real_nat_transfer)
  have "(\<lambda>x::real. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1/u powr (p+1)))) \<in>
          \<Theta>(\<lambda>x::real. (1 - ln (ln a)) * x powr p + x powr p * ln (ln x))" (is "?f \<in> _")
    apply (rule bigthetaI_cong) using eventually_ge_at_top[of a]
  proof eventually_elim
    fix x assume x: "x \<ge> a"
    have "integral {a..x} (\<lambda>u. u powr p * ln u powr -1 / u powr (p + 1)) =
          integral {a..x} (\<lambda>u. inverse (u * ln u))" using x a x0_less_x1
      by (intro Henstock_Kurzweil_Integration.integral_cong) (simp_all add: powr_add powr_minus field_simps)
    also have "... = ln (ln x) - ln (ln a)"
      using x0_less_x1 a(1) x by (subst integral_one_over_x_ln_x) simp_all
    also have "x powr p * (1 + ...) = (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)"
      by (simp add: algebra_simps)
    finally show "x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr - 1 / u powr (p+1))) =
                    (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)" .
  qed
  also have "(\<lambda>x. (1 - ln (ln a)) * x powr p + x powr p * ln (ln x)) \<in>
                \<Theta>(\<lambda>x. x powr p * ln (ln x))" by simp
  finally show "?f \<in> \<Theta>(\<lambda>a. a powr p * ln (ln a))" .
qed

lemma master1_bigo:
  assumes g_bigo: "g \<in> O(\<lambda>x. real x powr p')"
  assumes less_p': "(\<Sum>i<k. as!i * bs!i powr p') > 1"
  shows "f \<in> O(\<lambda>x. real x powr p)"
proof-
  interpret akra_bazzi_upper x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p'"
    using assms growths g_bigo master_integrable by unfold_locales (assumption | simp)+
  from less_p' have less_p: "p' < p" by (rule p_greaterI)
  from bigo_f[of "0"] guess a . note a = this
  note a(2)
  also from a(1) less_p x0_less_x1 have "p \<noteq> p'" by simp_all
  from master_integral[OF this a(1)] guess c d . note cd = this
  note cd(3)
  also from cd(1,2) less_p
    have "(\<lambda>x::nat. d * real x powr p + c * real x powr p') \<in> \<Theta>(\<lambda>x. real x powr p)" by force
  finally show "f \<in> O(\<lambda>x::nat. x powr p)" .
qed

lemma master1:
  assumes g_bigo: "g \<in> O(\<lambda>x. real x powr p')"
  assumes less_p': "(\<Sum>i<k. as!i * bs!i powr p') > 1"
  assumes f_pos:  "eventually (\<lambda>x. f x > 0) at_top"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p)"
proof (rule bigthetaI)
  interpret akra_bazzi_lower x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>_. 0"
    using assms(1,3) bs_lower_bound by unfold_locales (auto intro: always_eventually)
  from bigomega_f show "f \<in> \<Omega>(\<lambda>x. real x powr p)" by force
qed (fact master1_bigo[OF g_bigo less_p'])

lemma master2_3:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr (p' - 1))"
  assumes p': "p' > 0"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')"
proof-
  have "eventually (\<lambda>x::real. x powr p * ln x powr (p' - 1) > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr (p' - 1)"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of "1"] guess a . note a = this
  note a(2)
  also from a(1) p' have "p' \<noteq> 0" by simp_all
  from master_integral'[OF this a(1), of p] guess c d . note cd = this
  note cd(3)
  also have "(\<lambda>x::nat. c * real x powr p + d * real x powr p * ln (real x) powr p') \<in>
                 \<Theta>(\<lambda>x::nat. x powr p * ln x powr p')" using cd(1,2) p' by force
  finally show "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')" .
qed

lemma master2_1:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr p')"
  assumes p': "p' < -1"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p)"
proof-
  have "eventually (\<lambda>x::real. x powr p * ln x powr p' > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr p'"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of "1"] guess a . note a = this
  note a(2)
  also from a(1) p' have A: "p' + 1 \<noteq> 0" by simp_all
  obtain c d :: real where cd: "c \<noteq> 0" "d \<noteq> 0" and
    "(\<lambda>x::nat. x powr p * (1 + integral {a..x} (\<lambda>u. u powr p * ln u powr p'/ u powr (p+1)))) \<in>
       \<Theta>(\<lambda>x::nat. c * x powr p + d * x powr p * ln x powr (p' + 1))"
    by (rule master_integral'[OF A a(1), of p]) (insert p', simp)
  note this(3)
  also have "(\<lambda>x::nat. c * real x powr p + d * real x powr p * ln (real x) powr (p' + 1)) \<in>
                 \<Theta>(\<lambda>x::nat. x powr p)" using cd(1,2) p' by force
  finally show "f \<in> \<Theta>(\<lambda>x::nat. x powr p)" .
qed

lemma master2_2:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p / ln (real x))"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p * ln (ln (real x)))"
proof-
  have "eventually (\<lambda>x::real. x powr p / ln x > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  moreover from g_bigtheta have g_bigtheta': "g \<in> \<Theta>(\<lambda>x. real x powr p * ln (real x) powr -1)"
    by (rule landau_theta.trans, intro landau_real_nat_transfer) simp
  ultimately interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p * ln x powr -1"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from bigtheta_f[of 1] guess a . note a = this
  note a(2)
  also note master_integral''[OF a(1)]
  finally show "f \<in> \<Theta>(\<lambda>x::nat. x powr p * ln (ln x))" .
qed

lemma master3:
  assumes g_bigtheta: "g \<in> \<Theta>(\<lambda>x. real x powr p')"
  assumes p'_greater': "(\<Sum>i<k. as!i * bs!i powr p') < 1"
  shows "f \<in> \<Theta>(\<lambda>x. real x powr p')"
proof-
  have "eventually (\<lambda>x::real. x powr p' > 0) at_top"
    using eventually_gt_at_top[of "1::real"] by eventually_elim simp
  hence "eventually (\<lambda>x. f x > 0) at_top"
    by (rule f_pos[OF bigthetaD2[OF g_bigtheta] eventually_nat_real])
  then interpret akra_bazzi x\<^sub>0 x\<^sub>1 k as bs ts f
    "\<lambda>f a b. f integrable_on {a..b}" "\<lambda>f a b. integral {a..b} f" g "\<lambda>x. x powr p'"
    using assms growths bounds master_integrable by unfold_locales (assumption | simp)+
  from p'_greater' have p'_greater: "p' > p" by (rule p_lessI)
  from bigtheta_f[of 0] guess a . note a = this
  note a(2)
  also from p'_greater have "p \<noteq> p'" by simp
  from master_integral[OF this a(1)] guess c d . note cd = this
  note cd(3)
  also have "(\<lambda>x::nat. d * x powr p + c * x powr p') \<in> \<Theta>(\<lambda>x::real. x powr p')"
    using p'_greater cd(1,2) by force
  finally show "f \<in> \<Theta>(\<lambda>x. real x powr p')" .
qed

end
end

end


theory berIneq
  imports Complex_Main
begin

theorem BernoulliInequality:
  fixes x :: real
  fixes n:: nat
  assumes "x \<ge> -1"
  shows "(1 + x) ^ n\<ge> 1 + n*x" (is "?P n")
proof (induction n)
  show "?P 0" by auto
next
  fix n :: nat
  assume IH : "?P n"
  show "?P (Suc n)"
  proof -
    from assms have "1+x \<ge> 0" by auto
    then have start :"(1+x)*(1+x) ^ n \<ge> (1+x)*(1+n*x)"
      proof cases
        assume "1+x = 0"
        thus ?thesis using IH  by auto
      next
        assume "\<not>(1+x=0)"
        thus ?thesis using IH assms by auto
      qed
      have "(1+x)*(1+n*x) = (1+n*x + x + n*(x ^ 2))" by algebra
      then have helper: "(1+x) ^ (1+n) \<ge> (1+n*x + x + n*(x ^ 2))" using start by auto
      have "n*(x ^ 2) \<ge> 0" by auto
      then have helper2 : "(1+n*x + x + n*(x ^ 2)) \<ge> (1+n*x + x)" by auto
      then have "(1+x) ^ (1+n) \<ge> (1+n*x + x)" using helper by linarith
      thus ?thesis
        by (smt \<open>(1 + x) * (1 + real n * x) = 1 + real n * x + x + real n * x\<^sup>2\<close> \<open>0 \<le> real n * x\<^sup>2\<close> of_nat_Suc power_Suc semiring_normalization_rules(2) start)
    qed
  qed
end


subsection "Boolean Expressions"

theory BExp imports AExp begin

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

text_raw\<open>\snip{BExpbvaldef}{1}{2}{%\<close>
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw\<open>}%endsnip\<close>

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text\<open>Optimizing constructors:\<close>

text_raw\<open>\snip{BExplessdef}{0}{2}{%\<close>
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{BExpanddef}{2}{2}{%\<close>
fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"
text_raw\<open>}%endsnip\<close>

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

text_raw\<open>\snip{BExpnotdef}{2}{2}{%\<close>
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"
text_raw\<open>}%endsnip\<close>

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text\<open>Now the overall optimizer:\<close>

text_raw\<open>\snip{BExpbsimpdef}{0}{2}{%\<close>
fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw\<open>}%endsnip\<close>

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end