(*  Title:       Computing Square Roots using the Babylonian Method
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
header {* Executable algorithms for $p$-th roots *}

theory NthRoot_Impl
imports
  Sqrt_Babylonian_Auxiliary
  "../Cauchy/CauchysMeanTheorem"
begin

text {*
We implemented algorithms to decide $\sqrt[p]{n} \in \rats$ and to compute $\lfloor \sqrt[p]{n} \rfloor$.
To this end, we use a variant of Newton iteration which works with integer division instead of floating
point or rational division. To get suitable starting values for the Newton iteration, we also implemented
a function to approximate logarithms.
*}

subsection {* Logarithm *}

text {* For computing the $p$-th root of a number $n$, we must choose a starting value
  in the iteration. Here, we use @{term "2 ^ (nat \<lceil>of_int \<lceil>log 2 n\<rceil> / p\<rceil>)"}.
  Of course, this requires an algorithm to compute logarithms.
  Here, we just multiply with the base, until we exceed the argument. *}

text {* We use a partial efficient algorithm, which does not terminate on
  corner-cases, like $b = 0$ or $p = 1$, and invoke it properly afterwards.
  Then there is a second algorithm which terminates on these corner-cases by additional
  guards and on which we can perform induction.
*}
partial_function (tailrec) log_ceil_impl :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> nat" where
  [code]: "log_ceil_impl b x prod sum = (if prod \<ge> x then sum else log_ceil_impl b x (prod * b) (sum + 1))"

definition log_ceil :: "nat \<Rightarrow> int \<Rightarrow> nat" where
  "log_ceil b x \<equiv> if b > 1 \<and> x \<ge> 0 then log_ceil_impl b x 1 0 else 0"

context
  fixes b :: nat
  assumes b: "b > 1"
begin
function log_ceil_main :: "int \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> nat" where
  "log_ceil_main x prod sum = (if prod > 0 then (if prod \<ge> x then sum else log_ceil_main x (prod * b) (sum + 1)) else 0)"
  by pat_completeness auto

termination by (relation "measure (\<lambda> (x,prod,sum). nat (x + 1 - prod))") (insert b, auto)

lemma log_ceil_impl: "prod > 0 \<Longrightarrow> log_ceil_impl b x prod sum = log_ceil_main x prod sum"
proof (induct x prod sum rule: log_ceil_main.induct)
  case (1 x p s)
  hence id: "(0 < p) = True" using b by auto
  have pos: "Suc 0 < b \<Longrightarrow> 0 < p \<Longrightarrow> 0 < p * int b"
    by (metis Suc_lessD mult_pos_pos of_nat_0_less_iff)
  show ?case unfolding log_ceil_impl.simps[of b x p s] log_ceil_main.simps[of x p s] id if_True
    by (rule if_cong[OF refl refl 1(1)], insert 1(2) b pos, auto)
qed
end

lemma log_ceil[simp]: assumes b: "b > 0" and x: "x > 0"
  shows "log_ceil b x = \<lceil>log b x\<rceil>"
proof (cases "b = 1")
  case True
  hence "log_ceil b x = (0 :: int)" unfolding log_ceil_def by auto
  also have "\<dots> = \<lceil>log b x\<rceil>" unfolding True by (simp add: log_def)
  finally show ?thesis by auto
next
  case False
  with b have b: "b > 1" unfolding b by auto
  def p \<equiv> "1 :: int"
  def s \<equiv> "0 :: nat"
  have "int b ^ s = p" unfolding p_def s_def using x by force
  have inv: "s = 0 \<or> int b ^ (s - 1) < x" unfolding s_def by auto
  hence "int (log_ceil b x) = log_ceil_impl b x 1 0" using x b unfolding log_ceil_def by auto
  also have "\<dots> = log_ceil_main b x p s" using log_ceil_impl[OF b, of 1 x 0] by (simp add: p_def s_def)
  also have "\<dots> = \<lceil>log b x\<rceil>" using `int b ^ s = p` inv x
  proof (induct x p s rule: log_ceil_main.induct[OF b])
    case (1 x p s)
    from 1(4) have x: "x \<ge> 0" by auto
    from 1(2) b have p: "p > 0" by auto
    hence id: "log_ceil_main b x p s = (if x \<le> p then s else log_ceil_main b x (p * int b) (s + 1))"
      unfolding log_ceil_main.simps[OF b, of x p s] by auto
    show ?case
    proof (cases "x \<le> p")
      case True
      have b0: "b > (0 :: real)" and b1: "b \<noteq> (1 :: real)" "b > (1 :: real)" using b by auto
      from True[folded 1(2)] have low: "x \<le> int b ^ s" by auto
      from 1(3) have up: "s = 0 \<or> s \<noteq> 0 \<and> int b ^ (s - 1) < x" by auto
      from True have id: "int (log_ceil_main b x p s) = s" unfolding id by simp
      from low have "real x \<le> real b ^ s"
        by (metis real_of_int_le_iff real_of_int_of_nat_eq real_of_int_power)
      hence "log b x \<le> log b (real b ^ s)"
        using log_le_cancel_iff[of b x "real b ^ s"] b x 1(4)
        by (metis less_eq_real_def not_le real_of_int_gt_zero_cancel_iff real_of_nat_1 real_of_nat_ge_zero real_of_nat_less_iff zero_le_power)
      also have "\<dots> = s" using b by simp
      also have "\<dots> = real_of_int (int s)"
        by (metis real_eq_of_int real_of_int_def real_of_int_of_nat_eq)
      finally have low: "log b x \<le> of_int (int s)" .
      show ?thesis unfolding id
      proof (rule sym, rule ceiling_unique[OF _ low])
        from up show "real_of_int (int s) - 1 < log b x"
        proof
          assume "s = 0"
          have "log b x \<ge> 0" using b 1(4) by simp
          with `s = 0` show ?thesis by auto
        next
          def ss \<equiv> "s - 1"
          assume *: "s \<noteq> 0 \<and> int b ^ (s - 1) < x"
          hence "real_of_int (int s) - 1 = of_int (int (ss + 1)) - 1" unfolding ss_def by auto
          also have "\<dots> = ss"
            by (metis add_diff_cancel of_int_of_nat_eq of_nat_1 real_of_nat_add real_of_nat_def)
          finally have id: "real_of_int (int s) - 1 = ss" .
          have "0 < real (int b ^ ss)" "0 < real x" using b 1(4) by auto
          note log_mono = log_less_cancel_iff[OF b1(2) this]
          from * have up: "int b ^ ss < x" unfolding ss_def by auto
          hence "real (int b ^ ss) < x" by fast
          from this[folded log_mono] have "log b (real (int b ^ ss)) < log b x" .
          also have "real (int b ^ ss) = real b ^ ss" by simp
          also have "log b (real b ^ ss) = ss" using b by simp
          finally show ?thesis unfolding id .
        qed
      qed
    next
      case False
      hence "x > p" by auto
      with id have id: "log_ceil_main b x p s = log_ceil_main b x (p * int b) (s + 1)" by auto
      from 1(2) have prod: "(int b) ^ (s + 1) = p * int b" by auto
      show ?thesis unfolding id
        by (rule 1(1)[OF p False prod _ 1(4)], insert False 1(2), auto)
    qed
  qed
  finally show ?thesis .
qed

subsection {* Computing the $p$-th root of an integer number *}

text {* Using the logarithm, we can define an executable version of the
  intended  starting value. Its main property is the inequality
  @{term "(start_value x p) ^ p \<ge> x"}, i.e., the start value is larger
  than the p-th root. This property is essential, since our algorithm will abort
  as soon as we fall below the p-th root. *}

definition start_value :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "start_value n p = 2 ^ (nat \<lceil>of_int (log_ceil 2 n) / rat_of_nat p\<rceil>)"

lemma start_value_main: assumes x: "x \<ge> 0" and p: "p > 0"
  shows "x \<le> (start_value x p)^p \<and> start_value x p \<ge> 0"
proof (cases "x = 0")
  case True
  with p show ?thesis unfolding start_value_def True by simp
next
  case False
  with x have x: "x > 0" by auto
  def l2x \<equiv> "\<lceil>log 2 x\<rceil>"
  def pow \<equiv> "nat \<lceil>rat_of_int l2x / of_nat p\<rceil>"
  have "root p x = x powr (1 / p)" by (rule root_powr_inverse, insert x p, auto)
  also have "\<dots> = (2 powr (log 2 x)) powr (1 / p)" using powr_log_cancel[of 2 x] x by auto
  also have "\<dots> = 2 powr (log 2 x * (1 / p))" by (rule powr_powr)
  also have "log 2 x * (1 / p) = log 2 x / p" using p by auto
  finally have r: "root p x = 2 powr (log 2 x / p)" .
  have lp: "log 2 x \<ge> 0" using x by auto
  hence l2pos: "l2x \<ge> 0" by (auto simp: l2x_def)
  have "log 2 x / p \<le> l2x / p" using x p unfolding l2x_def
    by (metis divide_right_mono real_of_int_ceiling_ge real_of_nat_ge_zero)
  also have "\<dots> \<le> \<lceil>l2x / (p :: real)\<rceil>" by simp
  also have "l2x / real p = l2x / real_of_rat (of_nat p)"
    by (metis of_rat_of_nat_eq real_eq_of_nat real_of_nat_def)
  also have "real l2x = real_of_rat (of_int l2x)"
    by (metis of_rat_of_int_eq real_eq_of_int real_of_int_def)
  also have "real_of_rat (of_int l2x) / real_of_rat (of_nat p) = real_of_rat (rat_of_int l2x / of_nat p)"
    by (metis of_rat_divide)
  also have "\<lceil>real_of_rat (rat_of_int l2x / rat_of_nat p)\<rceil> = \<lceil>rat_of_int l2x / of_nat p\<rceil>"
    by simp
  also have "\<lceil>rat_of_int l2x / of_nat p\<rceil> \<le> real pow" unfolding pow_def by auto
  finally have le: "log 2 x / p \<le> pow" .
  from powr_mono[OF le, of 2, folded r]
  have "root p x \<le> 2 powr pow" by auto
  also have "\<dots> = 2 ^ pow" by (rule powr_realpow, auto)
  also have "\<dots> = real ((2 :: int) ^ pow)" by simp
  also have "pow = (nat \<lceil>of_int (log_ceil 2 x) / rat_of_nat p\<rceil>)"
    unfolding pow_def l2x_def using x by simp
  also have "real ((2 :: int) ^ \<dots> ) = start_value x p" unfolding start_value_def  by simp
  finally have less: "root p x \<le> start_value x p" .
  have "0 \<le> root p x" using p x by auto
  also have "\<dots> \<le> start_value x p" by (rule less)
  finally have start: "0 \<le> start_value x p" by simp
  from power_mono[OF less, of p] have "root p (real x) ^ p \<le> real (start_value x p) ^ p" using p x by auto
  also have "\<dots> = start_value x p ^ p" by simp
  also have "root p (real x) ^ p = x" using p x by force
  finally have "x \<le> (start_value x p) ^ p" by presburger
  with start show ?thesis by auto
qed

lemma start_value: assumes x: "x \<ge> 0" and p: "p > 0" shows "x \<le> (start_value x p) ^ p" "start_value x p \<ge> 0"
  using start_value_main[OF x p] by auto

text {* We now define the Newton iteration to compute the $p$-th root. We are working on the integers,
  where every @{term "op /"} is replaced by @{term "op div"}. We are proving several things within
  a locale which ensures that $p > 0$, and where $pm = p - 1$.
  *}

locale fixed_root =
  fixes p pm :: nat
  assumes p: "p = Suc pm"
begin

function root_newton_int_main :: "int \<Rightarrow> int \<Rightarrow> int \<times> bool" where
  "root_newton_int_main x n = (if (x < 0 \<or> n < 0) then (0,False) else (if x ^ p \<le> n then (x, x ^ p = n)
    else root_newton_int_main ((n div (x ^ pm) + x * int pm) div (int p)) n))"
    by pat_completeness auto
end

text {* For the executable algorithm we omit the guard and use a let-construction *}

partial_function (tailrec) root_int_main' :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<times> bool" where
  [code]: "root_int_main' pm ipm ip x n = (let xpm = x^pm; xp = xpm * x in if xp \<le> n then (x, xp = n)
    else root_int_main' pm ipm ip ((n div xpm + x * ipm) div ip) n)"

text {* In the following algorithm, we
  start the iteration.
  It will compute @{term "\<lfloor>root p n\<rfloor>"} and a boolean to indicate whether the root is exact. *}

definition root_int_main :: "nat \<Rightarrow> int \<Rightarrow> int \<times> bool" where
  "root_int_main p n \<equiv> if p = 0 then (1,n = 1) else
     let pm = p - 1
       in root_int_main' pm (int pm) (int p) (start_value n p) n"

text {* Once we have proven soundness of @{const fixed_root.root_newton_int_main} and equivalence
  to @{const root_int_main}, it
  is easy to assemble the following algorithm which computes all roots for arbitrary integers. *}

definition root_int :: "nat \<Rightarrow> int \<Rightarrow> int list" where
  "root_int p x \<equiv> if p = 0 then [] else
    if x = 0 then [0] else
      let e = even p; s = sgn x; x' = abs x
      in if x < 0 \<and> e then [] else case root_int_main p x' of (y,True) \<Rightarrow> if e then [y,-y] else [s * y] | _ \<Rightarrow> []"

text {* We start with proving termination of @{const fixed_root.root_newton_int_main}. *}

context fixed_root
begin
lemma iteration_mono_eq: assumes xn: "x ^ p = (n :: int)"
  shows "(n div x ^ pm + x * int pm) div int p = x"
proof -
  have [simp]: "\<And> n. (x + x * n) = x * (1 + n)" by (auto simp: field_simps)
  show ?thesis unfolding xn[symmetric] p by simp
qed

lemma p0: "p \<noteq> 0" unfolding p by auto

text {* The following property is the essential property for
  proving termination of @{const "root_newton_int_main"}.
*}
lemma iteration_mono_less: assumes x: "x \<ge> 0"
  and n: "n \<ge> 0"
  and xn: "x ^ p > (n :: int)"
  shows "(n div x ^ pm + x * int pm) div int p < x"
proof -
  let ?sx = "(n div x ^ pm + x * int pm) div int p"
  from xn have xn_le: "x ^ p \<ge> n" by auto
  from xn x n have x0: "x > 0"
    by (metis neq_iff not_less p0 power_eq_0_iff)
  from p have xp: "x ^ p = x * x ^ pm" by auto
  have "n div x ^ pm * x ^ pm \<le> n" unfolding mod_div_equality_int
    using transfer_nat_int_function_closures x n
    by simp
  also have "\<dots> \<le> x ^ p" using xn by auto
  finally have le: "n div x ^ pm \<le> x" using x x0 unfolding xp by simp
  have "?sx \<le> (x^p div x ^ pm + x * int pm) div int p"
    by (rule zdiv_mono1, insert le p0, unfold xp, auto)
  also have "x^p div x ^ pm = x" unfolding xp by auto
  also have "x + x * int pm = x * int p" unfolding p by (auto simp: field_simps)
  also have "x * int p div int p = x" using p by force
  finally have le: "?sx \<le> x" .
  {
    assume "?sx = x"
    from arg_cong[OF this, of "\<lambda> x. x * int p"]
    have "x * int p \<le> (n div x ^ pm + x * int pm) div (int p) * int p" using p0 by simp
    also have "\<dots> \<le> n div x ^ pm + x * int pm"
      unfolding mod_div_equality_int using p by auto
    finally have "n div x^pm \<ge> x" by (auto simp: p field_simps)
    from mult_right_mono[OF this, of "x ^ pm"]
    have ge: "n div x^pm * x^pm \<ge> x^p" unfolding xp using x by auto
    from mod_div_equality[of n "x^pm"] have "n div x^pm * x^pm = n - n mod x^pm" by arith
    from ge[unfolded this]
    have le: "x^p \<le> n - n mod x^pm" .
    have ge: "n mod x^pm \<ge> 0" using n x transfer_nat_int_function_closures by auto
    from le ge
    have "n \<ge> x^p" by auto
    with xn have False by auto
  }
  with le show ?thesis unfolding p by fastforce
qed

lemma iteration_mono_lesseq: assumes x: "x \<ge> 0" and n: "n \<ge> 0" and xn: "x ^ p \<ge> (n :: int)"
  shows "(n div x ^ pm + x * int pm) div int p \<le> x"
proof (cases "x ^ p = n")
  case True
  from iteration_mono_eq[OF this] show ?thesis by simp
next
  case False
  with assms have "x ^ p > n" by auto
  from iteration_mono_less[OF x n this]
  show ?thesis by simp
qed

termination (* of root_newton_int_main *)
proof -
  let ?mm = "\<lambda> x  n :: int. nat x"
  let ?m1 = "\<lambda> (x,n). ?mm x n"
  let ?m = "measures [?m1]"
  show ?thesis
  proof (relation ?m)
    fix x n :: int
    assume "\<not> x ^ p \<le> n"
    hence x: "x ^ p > n" by auto
    assume "\<not> (x < 0 \<or> n < 0)"
    hence x_n: "x \<ge> 0" "n \<ge> 0" by auto
    from x x_n have x0: "x > 0" using p by (cases "x = 0", auto)
    from iteration_mono_less[OF x_n x] x0
    show "(((n div x ^ pm + x * int pm) div int p, n), x, n) \<in> ?m" by auto
  qed auto
qed

text {* We next prove that @{const root_int_main'} is a correct implementation of @{const root_newton_int_main}.
We additionally prove that the result is always positive, a lower bound, and that the returned boolean indicates
whether the result has a root or not. We prove all these results in one go, so that we can share the
inductive proof.
 *}

abbreviation root_main' where "root_main' \<equiv> root_int_main' pm (int pm) (int p)"

lemmas root_main'_simps = root_int_main'.simps[of pm "int pm" "int p"]

lemma root_main'_newton_pos: "x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow>
  root_main' x n = root_newton_int_main x n \<and> (root_main' x n = (y,b) \<longrightarrow> y \<ge> 0 \<and> y^p \<le> n \<and> b = (y^p = n))"
proof (induct x n rule: root_newton_int_main.induct)
  case (1 x n)
  have pm_x[simp]: "x ^ pm * x = x ^ p" unfolding p by simp
  from 1 have id: "(x < 0 \<or> n < 0) = False" by auto
  note d = root_main'_simps[of x n] root_newton_int_main.simps[of x n] id if_False Let_def
  show ?case
  proof (cases "x ^ p \<le> n")
    case True
    thus ?thesis unfolding d using 1(2) by auto
  next
    case False
    hence id: "(x ^ p \<le> n) = False" by simp
    from 1(3) 1(2) have not: "\<not> (x < 0 \<or> n < 0)" by auto
    show ?thesis unfolding d id pm_x
      by (rule 1(1)[OF not False _ 1(3)], unfold p, insert 1(2,3),
      metis Divides.transfer_nat_int_function_closures(1) add_nonneg_nonneg of_nat_0_le_iff split_mult_pos_le zero_le_power)
  qed
qed

lemma root_main': "x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_main' x n = root_newton_int_main x n"
  using root_main'_newton_pos by blast

lemma root_main'_pos: "x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_main' x n = (y,b) \<Longrightarrow> y \<ge> 0"
  using root_main'_newton_pos by blast

lemma root_main'_sound: "x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_main' x n = (y,b) \<Longrightarrow> b = (y ^ p = n)"
  using root_main'_newton_pos by blast

text {* In order to prove completeness of the algorithms, we provide sharp upper and lower bounds
  for @{const root_main'}. For the upper bounds, we use Cauchy's mean theorem where we added
  the non-strict variant to Porter's formalization of this theorem. *}

lemma root_main'_lower: "x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_main' x n = (y,b) \<Longrightarrow> y ^ p \<le> n"
  using root_main'_newton_pos by blast

lemma root_newton_int_main_upper:
  shows "y ^ p \<ge> n \<Longrightarrow> y \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_newton_int_main y n = (x,b) \<Longrightarrow> n < (x + 1) ^ p"
proof (induct y n rule: root_newton_int_main.induct)
  case (1 y n)
  from 1(3) have y0: "y \<ge> 0" .
  from 1(4) have n0: "n \<ge> 0" .
  def y' \<equiv> "(n div (y ^ pm) + y * int pm) div (int p)"
  from y0 n0 have y'0: "y' \<ge> 0" unfolding y'_def
    by (metis Divides.transfer_nat_int_function_closures(1) add_increasing nonneg_int_cases zero_zle_int zmult_int zpower_int)
  let ?rt = "root_newton_int_main"
  from 1(5) have rt: "?rt y n = (x,b)" by auto
  from y0 n0 have not: "\<not> (y < 0 \<or> n < 0)" "(y < 0 \<or> n < 0) = False" by auto
  note rt = rt[unfolded root_newton_int_main.simps[of y n] not(2) if_False, folded y'_def]
  note IH = 1(1)[folded y'_def, OF not(1) _ _ y'0 n0]
  show ?case
  proof (cases "y ^ p \<le> n")
    case False note yyn = this
    with rt have rt: "?rt y' n = (x,b)" by simp
    show ?thesis
    proof (cases "n \<le> y' ^ p")
      case True
      show ?thesis
        by (rule IH[OF False True rt])
    next
      case False
      with rt have x: "x = y'" unfolding root_newton_int_main.simps[of y' n]
        using n0 y'0 by simp
      from yyn have yyn: "y^p > n" by simp
      from False have yyn': "n > y' ^ p" by auto
      {
        assume pm: "pm = 0"
        have y': "y' = n" unfolding y'_def p pm by simp
        with yyn' have False unfolding p pm by auto
      }
      hence pm0: "pm > 0" by auto
      show ?thesis
      proof (cases "n = 0")
        case True
        thus ?thesis unfolding p
          by (metis False y'0 zero_le_power)
      next
        case False note n00 = this
        let ?y = "of_int y :: real"
        let ?n = "of_int n :: real"
        from yyn n0 have y00: "y \<noteq> 0" unfolding p by auto
        from y00 y0 have y0: "?y > 0" by auto
        from n0 False have n0: "?n > 0" by auto
        def Y \<equiv> "?y * of_int pm"
        def NY \<equiv> "?n / ?y ^ pm"
        note pos_intro = divide_nonneg_pos add_nonneg_nonneg mult_nonneg_nonneg
        have NY0: "NY > 0" unfolding NY_def using y0 n0
          by (metis NY_def zero_less_divide_iff zero_less_power)
        let ?ls = "NY # replicate pm ?y"
        have prod: "\<Prod>:replicate pm ?y = ?y ^ pm "
          by (induct pm, auto)
        have sum: "\<Sum>:replicate pm ?y = Y" unfolding Y_def
          by (induct pm, auto simp: field_simps)
        have pos: "pos ?ls" unfolding pos_def using NY0 y0 by auto
        have "root p ?n = gmean ?ls" unfolding gmean_def using y0
          by (auto simp: p NY_def prod)
        also have "\<dots> < mean ?ls"
        proof (rule CauchysMeanTheorem_Less[OF pos het_gt_0I])
          show "NY \<in> set ?ls" by simp
          from pm0 show "?y \<in> set ?ls" by simp
          have "NY < ?y"
          proof -
            from yyn have less: "?n < ?y ^ Suc pm" unfolding p
              by (metis of_int_less_iff of_int_power)
            have "NY < ?y ^ Suc pm / ?y ^ pm" unfolding NY_def
              by (rule divide_strict_right_mono[OF less], insert y0, auto)
            thus ?thesis using y0 by auto
          qed
          thus "NY \<noteq> ?y" by blast
        qed
        also have "\<dots> = (NY + Y) / real p"
          by (simp add: mean_def sum p)
        finally have *: "root p ?n < (NY + Y) / real p" .
        have "?n = (root p ?n)^p" using n0
          by (metis neq0_conv p0 real_root_pow_pos)
        also have "\<dots> < ((NY + Y) / real p)^p"
          by (rule power_strict_mono[OF *], insert n0 p, auto)
        finally have ineq1: "?n < ((NY + Y) / real p)^p" by auto
        {
          def s \<equiv> "n div y ^ pm + y * int pm"
          def S \<equiv> "NY + Y"
          have Y0: "Y \<ge> 0" using y0 unfolding Y_def
            by (metis "1.prems"(2) mult_nonneg_nonneg of_int_0_le_iff zero_zle_int)
          have S0: "S > 0" using NY0 Y0 unfolding S_def by auto
          from p have p0: "p > 0" by auto
          have "?n / ?y ^ pm  < of_int (floor (?n / ?y^pm)) + 1"
            by (rule divide_less_floor1)
          also have "floor (?n / ?y ^ pm) = n div y^pm"
            unfolding div_is_floor_divide_real by (metis of_int_power)
          finally have "NY < of_int (n div y ^ pm) + 1" unfolding NY_def by simp
          hence less: "S < of_int s + 1" unfolding Y_def s_def S_def by simp
          { (* by sledgehammer *)
            have f1: "\<forall>x\<^sub>0. rat_of_int \<lfloor>rat_of_nat x\<^sub>0\<rfloor> = rat_of_nat x\<^sub>0"
              using of_int_of_nat_eq by simp
            have f2: "\<forall>x\<^sub>0. real_of_int \<lfloor>rat_of_nat x\<^sub>0\<rfloor> = real x\<^sub>0"
              using of_int_of_nat_eq real_eq_of_nat by auto
            have f3: "\<forall>x\<^sub>0 x\<^sub>1. \<lfloor>rat_of_int x\<^sub>0 / rat_of_int x\<^sub>1\<rfloor> = \<lfloor>real_of_int x\<^sub>0 / real_of_int x\<^sub>1\<rfloor>"
              using div_is_floor_divide_rat div_is_floor_divide_real by simp
            have f4: "0 < \<lfloor>rat_of_nat p\<rfloor>"
              using p by simp
            have "\<lfloor>S\<rfloor> \<le> s" using less floor_le_iff by auto
            hence "\<lfloor>rat_of_int \<lfloor>S\<rfloor> / rat_of_nat p\<rfloor> \<le> \<lfloor>rat_of_int s / rat_of_nat p\<rfloor>"
              using f1 f3 f4 by (metis div_is_floor_divide_real zdiv_mono1)
            hence "\<lfloor>S / real p\<rfloor> \<le> \<lfloor>rat_of_int s / rat_of_nat p\<rfloor>"
              using f1 f2 f3 f4 by (metis div_is_floor_divide_real floor_div_pos_int)
            hence "S / real p \<le> real_of_int (s div int p) + 1"
              using f1 f3 by (metis div_is_floor_divide_real floor_le_iff floor_of_nat less_eq_real_def)
          }
          hence "S / real p \<le> of_int(s div p) + 1" .
          note this[unfolded S_def s_def]
        }
        hence ge: "of_int y' + 1 \<ge> (NY + Y) / p" unfolding y'_def
          by simp
        have pos1: "(NY + Y) / p \<ge> 0" unfolding Y_def NY_def
          by (intro divide_nonneg_pos add_nonneg_nonneg mult_nonneg_nonneg,
          insert y0 n0 p0, auto)
        have pos2: "of_int y' + (1 :: rat) \<ge> 0" using y'0 by auto
        have ineq2: "(of_int y' + 1) ^ p \<ge> ((NY + Y) / p) ^ p"
          by (rule power_mono[OF ge pos1])
        from order.strict_trans2[OF ineq1 ineq2]
        have "?n < of_int ((x + 1) ^ p)" unfolding x
          by (metis of_int_1 of_int_add of_int_power)
        thus "n < (x + 1) ^ p " by simp
      qed
    qed
  next
    case True
    with rt have x: "x = y" by simp
    with 1(2) True have n: "n = y ^ p" by auto
    show ?thesis unfolding n x using y0 unfolding p
      by (metis add_le_less_mono add_less_cancel_left lessI less_add_one monoid_add_class.add.right_neutral ordered_cancel_comm_monoid_diff_class.le_iff_add power_strict_mono)
  qed
qed

lemma root_main'_upper:
  "x ^ p \<ge> n \<Longrightarrow> x \<ge> 0 \<Longrightarrow> n \<ge> 0 \<Longrightarrow> root_main' x n = (y,b) \<Longrightarrow> n < (y + 1) ^ p"
  using root_newton_int_main_upper[of n x y b] root_main'[of x n] by auto
end

text {* Now we can prove all the nice properties of @{const root_int_main}. *}

lemma root_int_main_all: assumes n: "n \<ge> 0"
  and rm: "root_int_main p n = (y,b)"
  shows "y \<ge> 0 \<and> b = (y ^ p = n) \<and> (p > 0 \<longrightarrow> y ^ p \<le> n \<and> n < (y + 1)^p)
    \<and> (p > 0 \<longrightarrow> x \<ge> 0 \<longrightarrow> x ^ p = n \<longrightarrow> y = x \<and> b)"
proof (cases "p = 0")
  case True
  with rm[unfolded root_int_main_def]
  have y: "y = 1" and b: "b = (n = 1)" by auto
  show ?thesis unfolding True y b using n by auto
next
  case False
  from False have p_0: "p > 0" by auto
  from False have "(p = 0) = False" by simp
  from rm[unfolded root_int_main_def this Let_def]
  have rm: "root_int_main' (p - 1) (int (p - 1)) (int p) (start_value n p) n = (y,b)" by simp
  from start_value[OF n p_0] have start: "n \<le> (start_value n p)^p" "0 \<le> start_value n p" by auto
  interpret fixed_root p "p - 1"
    by (unfold_locales, insert False, auto)
  from root_main'_pos[OF start(2) n rm] have y: "y \<ge> 0" .
  from root_main'_sound[OF start(2) n rm] have b: "b = (y ^ p = n)" .
  from root_main'_lower[OF start(2) n rm] have low: "y ^ p \<le> n" .
  from root_main'_upper[OF start n rm] have up: "n < (y + 1) ^ p" .
  {
    assume n: "x ^ p = n" and x: "x \<ge> 0"
    with low up have low: "y ^ p \<le> x ^ p" and up: "x ^ p < (y+1) ^ p" by auto
    from power_strict_mono[of x y, OF _ x p_0] low have x: "x \<ge> y" by arith
    from power_mono[of "(y + 1)" x p] y up have y: "y \<ge> x" by arith
    from x y have "x = y" by auto
    with b n
    have "y = x \<and> b" by auto
  }
  thus ?thesis using b low up y by auto
qed

lemma root_int_main: assumes n: "n \<ge> 0"
  and rm: "root_int_main p n = (y,b)"
  shows "y \<ge> 0" "b = (y ^ p = n)" "p > 0 \<Longrightarrow> y ^ p \<le> n" "p > 0 \<Longrightarrow> n < (y + 1)^p"
    "p > 0 \<Longrightarrow> x \<ge> 0 \<Longrightarrow> x ^ p = n \<Longrightarrow> y = x \<and> b"
  using root_int_main_all[OF n rm, of x] by blast+

lemma root_int[simp]: assumes p: "p \<noteq> 0 \<or> x \<noteq> 1"
  shows "set (root_int p x) = {y . y ^ p = x}"
proof (cases "p = 0")
  case True
  with p have "x \<noteq> 1" by auto
  thus ?thesis unfolding root_int_def True by auto
next
  case False
  hence p: "(p = 0) = False" and p0: "p > 0" by auto
  note d = root_int_def p if_False Let_def
  show ?thesis
  proof (cases "x = 0")
    case True
    thus ?thesis unfolding d using p0 by auto
  next
    case False
    hence x: "(x = 0) = False" by auto
    show ?thesis
    proof (cases "x < 0 \<and> even p")
      case True
      hence left: "set (root_int p x) = {}" unfolding d by auto
      {
        fix y
        assume x: "y ^ p = x"
        with True have "y ^ p < 0 \<and> even p" by auto
        hence False by presburger
      }
      with left show ?thesis by auto
    next
      case False
      with x p have cond: "(x = 0) = False" "(x < 0 \<and> even p) = False" by auto
      obtain y b where rt: "root_int_main p \<bar>x\<bar> = (y,b)" by force
      have "abs x \<ge> 0" by auto
      note rm = root_int_main[OF this rt]
      have "?thesis =
        (set (case root_int_main p \<bar>x\<bar> of (y, True) \<Rightarrow> if even p then [y, - y] else [sgn x * y] | (y, False) \<Rightarrow> []) =
        {y. y ^ p = x})" unfolding d cond by blast
      also have "(case root_int_main p \<bar>x\<bar> of (y, True) \<Rightarrow> if even p then [y, - y] else [sgn x * y] | (y, False) \<Rightarrow> [])
        = (if b then if even p then [y, - y] else [sgn x * y] else [])" (is "_ = ?lhs")
        unfolding rt by auto
      also have "set ?lhs = {y. y ^ p = x}" (is "_ = ?rhs")
      proof -
        {
          fix z
          assume idx: "z ^ p = x"
          hence eq: "(abs z) ^ p = abs x" by (metis power_abs)
          from idx x p0 have z: "z \<noteq> 0" unfolding p by auto
          have "(y, b) = (\<bar>z\<bar>, True)"
            using rm(5)[OF p0 _ eq] by auto
          hence id: "y = abs z" "b = True" by auto
          have "z \<in> set ?lhs" unfolding id using z by (auto simp: idx[symmetric], cases "z < 0", auto)
        }
        moreover
        {
          fix z
          assume z: "z \<in> set ?lhs"
          hence b: "b = True" by (cases b, auto)
          note z = z[unfolded b if_True]
          from rm(2) b have yx: "y ^ p = \<bar>x\<bar>" by auto
          from rm(1) have y: "y \<ge> 0" .
          from False have "odd p \<or> even p \<and> x \<ge> 0" by auto
          hence "z \<in> ?rhs"
          proof
            assume odd: "odd p"
            with z have "z = sgn x * y" by auto
            hence "z ^ p = (sgn x * y) ^ p" by auto
            also have "\<dots> = sgn x ^ p * y ^ p" unfolding power_mult_distrib by auto
            also have "\<dots> = sgn x ^ p * abs x" unfolding yx by simp
            also have "sgn x ^ p = sgn x" using x odd by auto
            also have "sgn x * abs x = x" by (rule mult_sgn_abs)
            finally show "z \<in> ?rhs" by auto
          next
            assume even: "even p \<and> x \<ge> 0"
            from z even have "z = y \<or> z = -y" by auto
            hence id: "abs z = y" using y by auto
            with yx x even have z: "z \<noteq> 0" using p0 by (cases "y = 0", auto)
            have "z ^ p = (sgn z * abs z) ^ p" by (simp add: mult_sgn_abs)
            also have "\<dots> = (sgn z * y) ^ p" using id by auto
            also have "\<dots> = (sgn z)^p * y ^ p" unfolding power_mult_distrib  by simp
            also have "\<dots> = sgn z ^ p * x" unfolding yx using even by auto
            also have "sgn z ^ p = 1" using even z by (auto)
            finally show "z \<in> ?rhs" by auto
          qed
        }
        ultimately show ?thesis by blast
      qed
      finally show ?thesis by auto
    qed
  qed
qed

lemma root_int_pos: assumes x: "x \<ge> 0" and ri: "root_int p x = y # ys"
  shows "y \<ge> 0"
proof -
  from x have abs: "abs x = x" by auto
  note ri = ri[unfolded root_int_def Let_def abs]
  from ri have p: "(p = 0) = False" by (cases p, auto)
  note ri = ri[unfolded p if_False]
  show ?thesis
  proof (cases "x = 0")
    case True
    with ri show ?thesis by auto
  next
    case False
    hence "(x = 0) = False" "(x < 0 \<and> even p) = False" using x by auto
    note ri = ri[unfolded this if_False]
    obtain y' b' where r: "root_int_main p x = (y',b')" by force
    note ri = ri[unfolded this]
    hence y: "y = (if even p then y' else sgn x * y')" by (cases b', auto)
    from root_int_main(1)[OF x r] have y': "0 \<le> y'" .
    thus ?thesis unfolding y using x False by auto
  qed
qed

subsection {* Floor and ceiling of roots *}

text {* Using the bounds for @{const root_int_main} we can easily design
  algorithms which compute @{term "floor (root p x)"} and @{term "ceiling (root p x)"}.
  To this end, we first develop algorithms for non-negative @{term x}, and later on
  these are used for the general case. *}

definition "root_int_floor_pos p x = (if p = 0 then 0 else fst (root_int_main p x))"
definition "root_int_ceiling_pos p x = (if p = 0 then 0 else (case root_int_main p x of (y,b) \<Rightarrow> if b then y else y + 1))"

lemma root_int_floor_pos_lower: assumes p0: "p \<noteq> 0" and x: "x \<ge> 0"
  shows "root_int_floor_pos p x ^ p \<le> x"
  using root_int_main(3)[OF x, of p] p0 unfolding root_int_floor_pos_def
  by (cases "root_int_main p x", auto)

lemma root_int_floor_pos_pos: assumes x: "x \<ge> 0"
  shows "root_int_floor_pos p x \<ge> 0"
  using root_int_main(1)[OF x, of p]
  unfolding root_int_floor_pos_def
  by (cases "root_int_main p x", auto)

lemma root_int_floor_pos_upper: assumes p0: "p \<noteq> 0" and x: "x \<ge> 0"
  shows "(root_int_floor_pos p x + 1) ^ p > x"
  using root_int_main(4)[OF x, of p] p0 unfolding root_int_floor_pos_def
  by (cases "root_int_main p x", auto)

lemma root_int_floor_pos: assumes x: "x \<ge> 0"
  shows "root_int_floor_pos p x = floor (root p (real x))"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: root_int_floor_pos_def)
next
  case False
  hence p: "p > 0" by auto
  let ?s1 = "real_of_int (root_int_floor_pos p x)"
  let ?s2 = "root p (real x)"
  from x have s1: "?s1 \<ge> 0"
    by (metis of_int_0_le_iff root_int_floor_pos_pos)
  from x have s2: "?s2 \<ge> 0"
    by (metis real_of_int_ge_zero_cancel_iff real_root_pos_pos_le)
  from s1 have s11: "?s1 + 1 \<ge> 0" by auto
  have id: "?s2 ^ p = real x" using x
    by (metis p real_of_int_ge_zero_cancel_iff real_root_pow_pos2)
  show ?thesis
  proof (rule floor_unique[symmetric])
    show "?s1 \<le> ?s2"
      unfolding compare_pow_le_iff[OF p s1 s2, symmetric]
      unfolding id
      using root_int_floor_pos_lower[OF False x]
      by (metis of_int_le_iff of_int_power real_eq_of_int)
    show "?s2 < ?s1 + 1"
      unfolding compare_pow_less_iff[OF p s2 s11, symmetric]
      unfolding id
      using root_int_floor_pos_upper[OF False x]
      by (metis real_of_int_add real_of_int_def real_of_int_less_iff real_of_int_power real_of_one)
  qed
qed

lemma root_int_ceiling_pos: assumes x: "x \<ge> 0"
  shows "root_int_ceiling_pos p x = ceiling (root p (real x))"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: root_int_ceiling_pos_def)
next
  case False
  hence p: "p > 0" by auto
  obtain y b where s: "root_int_main p x = (y,b)" by force
  note rm = root_int_main[OF x s]
  note rm = rm(1-2) rm(3-5)[OF p]
  from rm(1) have y: "y \<ge> 0" by simp
  let ?s = "root_int_ceiling_pos p x"
  let ?sx = "root p (real x)"
  note d = root_int_ceiling_pos_def
  show ?thesis
  proof (cases b)
    case True
    hence id: "?s = y" unfolding s d using p by auto
    from rm(2) True have xy: "x = y ^ p" by auto
    show ?thesis unfolding id unfolding xy using y
      by (metis ceiling_real_of_int p real_of_int_le_iff real_of_int_power real_of_int_zero_cancel real_root_power_cancel)
  next
    case False
    hence id: "?s = root_int_floor_pos p x + 1" unfolding d root_int_floor_pos_def
      using s p by simp
    from False have x0: "x \<noteq> 0" using rm(5)[of 0] using s unfolding root_int_main_def Let_def using p
      by (cases "x = 0", auto)
    show ?thesis unfolding id root_int_floor_pos[OF x]
    proof (rule ceiling_unique[symmetric])
      show "?sx \<le> real_of_int (\<lfloor>root p (real x)\<rfloor> + 1)"
        by (metis real_of_int_add real_of_int_def real_of_int_floor_add_one_ge real_of_one)
      let ?l = "real_of_int (\<lfloor>root p (real x)\<rfloor> + 1) - 1"
      let ?m = "real_of_int \<lfloor>root p (real x)\<rfloor>"
      have "?l = ?m" by simp
      also have "\<dots> < ?sx"
      proof -
        have le: "?m \<le> ?sx" by (rule of_int_floor_le)
        have neq: "?m \<noteq> ?sx"
        proof
          assume "?m = ?sx"
          hence "?m ^ p = ?sx ^ p" by simp
          also have "\<dots> = real x" using x False
            by (metis p real_root_ge_0_iff real_root_pow_pos2 root_int_floor_pos root_int_floor_pos_pos zero_le_floor zero_less_Suc)
          finally have xs: "x = \<lfloor>root p (real x)\<rfloor> ^ p"
            by (metis floor_power floor_real_of_int real_of_int_def)
          hence "\<lfloor>root p (real x)\<rfloor> \<in> set (root_int p x)" using p by simp
          hence "root_int p x \<noteq> []" by force
          with s False `p \<noteq> 0` x x0 show False unfolding root_int_def
            by (cases p, auto)
        qed
        from le neq show ?thesis by arith
      qed
      finally show "?l < ?sx" .
    qed
  qed
qed

definition "root_int_floor p x = (if x \<ge> 0 then root_int_floor_pos p x else - root_int_ceiling_pos p (- x))"
definition "root_int_ceiling p x = (if x \<ge> 0 then root_int_ceiling_pos p x else - root_int_floor_pos p (- x))"

lemma root_int_ceiling[simp]: "root_int_ceiling p x = ceiling (root p (real x))"
proof -
  note d = root_int_ceiling_def
  show ?thesis
  proof (cases "x \<ge> 0")
    case True
    with root_int_ceiling_pos[OF True] show ?thesis unfolding d by simp
  next
    case False
    hence "- x \<ge> 0" by auto
    from False root_int_floor_pos[OF this, of p] show ?thesis unfolding d
      by (simp add: real_root_minus floor_minus)
  qed
qed

subsection {* Downgrading algorithms to the naturals *}

definition root_nat_floor :: "nat \<Rightarrow> nat \<Rightarrow> int" where
  "root_nat_floor p x = root_int_floor_pos p (int x)"

definition root_nat_ceiling :: "nat \<Rightarrow> nat \<Rightarrow> int" where
  "root_nat_ceiling p x = root_int_ceiling_pos p (int x)"

definition root_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "root_nat p x = map nat (take 1 (root_int p x))"

lemma root_nat_floor [simp]: "root_nat_floor p x = floor (root p (real x))"
  unfolding root_nat_floor_def using root_int_floor_pos[of "int x" p]
  by auto

lemma root_nat_floor_lower: assumes p0: "p \<noteq> 0"
  shows "root_nat_floor p x ^ p \<le> x"
  using root_int_floor_pos_lower[OF p0, of x] unfolding root_nat_floor_def by auto

lemma root_nat_floor_upper: assumes p0: "p \<noteq> 0"
  shows "(root_nat_floor p x + 1) ^ p > x"
  using root_int_floor_pos_upper[OF p0, of x] unfolding root_nat_floor_def by auto

lemma root_nat_ceiling [simp]: "root_nat_ceiling p x = ceiling (root p x)"
  unfolding root_nat_ceiling_def using root_int_ceiling_pos[of x p]
  by auto

lemma root_nat: assumes p0: "p \<noteq> 0 \<or> x \<noteq> 1"
  shows "set (root_nat p x) = { y. y ^ p = x}"
proof -
  {
    fix y
    assume "y \<in> set (root_nat p x)"
    note y = this[unfolded root_nat_def]
    then obtain yi ys where ri: "root_int p x = yi # ys" by (cases "root_int p x", auto)
    with y have y: "y = nat yi" by auto
    from root_int_pos[OF _ ri] have yi: "0 \<le> yi" by auto
    from root_int[of p "int x"] p0 ri have "yi ^ p = x" by auto
    from arg_cong[OF this, of nat] yi have "nat yi ^ p = x"
      by (metis nat_int nat_power_eq)
    hence "y \<in> {y. y ^ p = x}" using y by auto
  }
  moreover
  {
    fix y
    assume yx: "y ^ p = x"
    hence y: "int y ^ p = int x"
      by (metis of_nat_power)
    hence "set (root_int p (int x)) \<noteq> {}" using root_int[of p "int x"] p0
      by (metis (mono_tags) One_nat_def `y ^ p = x` empty_Collect_eq nat_power_eq_Suc_0_iff)
    then obtain yi ys where ri: "root_int p (int x) = yi # ys"
      by (cases "root_int p (int x)", auto)
    from root_int_pos[OF _ this] have yip: "yi \<ge> 0" by auto
    from root_int[of p "int x", unfolded ri] p0 have yi: "yi ^ p = int x" by auto
    with y have "int y ^ p = yi ^ p" by auto
    from arg_cong[OF this, of nat] have id: "y ^ p = nat yi ^ p"
      by (metis `y ^ p = x` nat_int nat_power_eq yi yip)
    {
      assume p: "p \<noteq> 0"
      hence p0: "p > 0" by auto
      obtain yy b where rm: "root_int_main p (int x) = (yy,b)" by force
      from root_int_main(5)[OF _ rm p0 _ y] have "yy = int y" and "b = True" by auto
      note rm = rm[unfolded this]
      hence "y \<in> set (root_nat p x)"
        unfolding root_nat_def p root_int_def using p0 p yx
        by (cases p, auto)
    }
    moreover
    {
      assume p: "p = 0"
      with p0 have "x \<noteq> 1" by auto
      with y p have False by auto
    }
    ultimately have "y \<in> set (root_nat p x)" by auto
  }
  ultimately show ?thesis by blast
qed

subsection {* Upgrading algorithms to the rationals *}

text {* The main observation to lift everything from the integers to the rationals is the fact, that one
  can reformulate $\frac{a}{b}^{1/p}$ as $\frac{(ab^{p-1})^{1/p}}b$. *}

definition root_rat_floor :: "nat \<Rightarrow> rat \<Rightarrow> int" where
  "root_rat_floor p x \<equiv> case quotient_of x of (a,b) \<Rightarrow> root_int_floor p (a * b^(p - 1)) div b"

definition root_rat_ceiling :: "nat \<Rightarrow> rat \<Rightarrow> int" where
  "root_rat_ceiling p x \<equiv> - (root_rat_floor p (-x))"

definition root_rat :: "nat \<Rightarrow> rat \<Rightarrow> rat list" where
  "root_rat p x \<equiv> case quotient_of x of (a,b) \<Rightarrow> concat
  (map (\<lambda> rb. map (\<lambda> ra. of_int ra / rat_of_int rb) (root_int p a)) (take 1 (root_int p b)))"

lemma root_rat_reform: assumes q: "quotient_of x = (a,b)"
  shows "root p (real_of_rat x) = root p (of_int (a * b ^ (p - 1))) / of_int b"
proof (cases "p = 0")
  case False
  from quotient_of_denom_pos[OF q] have b: "0 < b" by auto
  hence b: "0 < real b" by auto
  from quotient_of_div[OF q] have x: "root p (real_of_rat x) = root p (a / b)"
    by (metis of_rat_divide of_rat_of_int_eq real_of_int_def)
  also have "a / b = a * real b ^ (p - 1) / real b ^ p" using b False
    by (cases p, auto simp: field_simps)
  also have "root p \<dots> = root p (a * real b ^ (p - 1)) / root p (real b ^ p)" by (rule real_root_divide)
  also have "root p (real b ^ p) = of_int b" using False b
    by (metis neq0_conv real_root_pow_pos real_root_power real_eq_of_int)
  also have "a * real b ^ (p - 1) = of_int (a * b ^ (p - 1))"
    by (metis real_of_int_def real_of_int_mult real_of_int_power)
  finally show ?thesis .
qed auto

lemma root_rat_floor [simp]: "root_rat_floor p x = floor (root p (of_rat x))"
proof -
  obtain a b where q: "quotient_of x = (a,b)" by force
  from quotient_of_denom_pos[OF q] have b: "b > 0" .
  show ?thesis
    unfolding root_rat_floor_def q split root_int_floor
    unfolding root_rat_reform[OF q]
    unfolding floor_div_pos_int[OF b] real_eq_of_int ..
qed

lemma root_rat_ceiling [simp]: "root_rat_ceiling p x = ceiling (root p (of_rat x))"
  unfolding
    root_rat_ceiling_def
    ceiling_def
    real_root_minus
    root_rat_floor
    of_rat_minus
    ..

lemma root_rat[simp]: assumes p: "p \<noteq> 0 \<or> x \<noteq> 1"
  shows "set (root_rat p x) = { y. y ^ p = x}"
proof (cases "p = 0")
  case False
  note p = this
  obtain a b where q: "quotient_of x = (a,b)" by force
  note x = quotient_of_div[OF q]
  have b: "b > 0" by (rule quotient_of_denom_pos[OF q])
  note d = root_rat_def q split set_concat set_map
  {
    fix q
    assume "q \<in> set (root_rat p x)"
    note mem = this[unfolded d]
    from mem obtain rb xs where rb: "root_int p b = Cons rb xs" by (cases "root_int p b", auto)
    note mem = mem[unfolded this]
    from mem obtain ra where ra: "ra \<in> set (root_int p a)" and q: "q = of_int ra / of_int rb"
      by (cases "root_int p a", auto)
    from rb have "rb \<in> set (root_int p b)" by auto
    with ra p have rb: "b = rb ^ p" and ra: "a = ra ^ p" by auto
    have "q \<in> {y. y ^ p = x}" unfolding q x ra rb by (auto simp: power_divide of_int_power)
  }
  moreover
  {
    fix q
    assume "q \<in> {y. y ^ p = x}"
    hence "q ^ p = of_int a / of_int b" unfolding x by auto
    hence eq: "of_int b * q ^ p = of_int a" using b by auto
    obtain z n where quo: "quotient_of q = (z,n)" by force
    note qzn = quotient_of_div[OF quo]
    have n: "n > 0" using quotient_of_denom_pos[OF quo] .
    from eq[unfolded qzn] have "rat_of_int b * of_int z^p / of_int n^p = of_int a"
      unfolding power_divide by simp
    from arg_cong[OF this, of "\<lambda> x. x * of_int n^p"] n have "rat_of_int b * of_int z^p = of_int a * of_int n ^ p"
      by auto
    also have "rat_of_int b * of_int z^p = rat_of_int (b * z^p)" unfolding of_int_mult of_int_power ..
    also have "of_int a * rat_of_int n ^ p = of_int (a * n ^ p)" unfolding of_int_mult of_int_power ..
    finally have id: "a * n ^ p = b * z ^ p" by linarith
    from quotient_of_coprime[OF quo] have cop: "coprime (z ^ p) (n ^ p)"
       by (metis gcd_int.commute coprime_exp_int)
    from coprime_crossproduct_int[OF quotient_of_coprime[OF q] this] arg_cong[OF id, of abs]
    have "\<bar>n ^ p\<bar> = \<bar>b\<bar>"
      by (simp add: field_simps abs_mult)
    with n b have bnp: "b = n ^ p" by auto
    hence rn: "n \<in> set (root_int p b)" using p by auto
    then obtain rb rs where rb: "root_int p b = Cons rb rs" by (cases "root_int p b", auto)
    from id[folded bnp] b have "a = z ^ p" by auto
    hence a: "z \<in> set (root_int p a)" using p by auto
    from root_int_pos[OF _ rb] b have rb0: "rb \<ge> 0" by auto
    from root_int[OF disjI1[OF p], of b] rb have "rb ^ p = b" by auto
    with bnp have id: "rb ^ p = n ^ p" by auto
    have "rb = n" by (rule power_eq_imp_eq_base[OF id], insert n rb0 p, auto)
    with rb have b: "n \<in> set (take 1 (root_int p b))" by auto
    have "q \<in> set (root_rat p x)" unfolding d qzn using b a by auto
  }
  ultimately show ?thesis by blast
next
  case True
  with p have x: "x \<noteq> 1" by auto
  obtain a b where q: "quotient_of x = (a,b)" by force
  show ?thesis unfolding True root_rat_def q split root_int_def using x
    by auto
qed

end


theory FiniteListGraph_Impl
imports
  FiniteListGraph
  (*"../../Collections/ICF/impl/RBTSetImpl" (*red black trees*)*)
    "HOL-Library.RBT_Impl"
    "HOL-Library.RBT"
  "HOL-Library.Product_Lexorder"
  (*maybe import the following only at the end*)
  Efficient_Distinct
  "HOL-Library.Code_Target_Nat"
begin

text \<open>A graph's well-formed-ness can be tested with an executable function.\<close>
  fun wf_list_graph_impl::"'v list \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "wf_list_graph_impl V [] = True" |
    "wf_list_graph_impl V ((v1,v2)#Es) = (v1 \<in> set V \<and> v2 \<in> set V \<and> wf_list_graph_impl V Es)"

  lemma wf_list_graph_impl_axioms_locale_props:
    "wf_list_graph_impl V E \<longleftrightarrow> fst` set E \<subseteq> set V \<and> snd` set E \<subseteq> set V"
  by (induction E) auto

definition rbt_fromlist :: "'a list \<Rightarrow> ('a::linorder, unit) RBT.rbt" where
  "rbt_fromlist ls \<equiv> RBT.bulkload (map (\<lambda>l. (l, ())) ls)"
definition "rbt_contains a rbt \<equiv> RBT.lookup rbt a \<noteq> None"

lemma rbt_contains: "rbt_contains a (rbt_fromlist V) \<longleftrightarrow> a \<in> set V"
  apply(simp add: rbt_contains_def rbt_fromlist_def)
  apply(induction V)
   by(simp)+

  (*making the \<in> more efficient*)
  fun wf_list_graph_impl_rs::"('v::linorder,unit) RBT.rbt \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> bool" where
    "wf_list_graph_impl_rs V [] = True" |
    "wf_list_graph_impl_rs V ((v1,v2)#Es) = (rbt_contains v1 V \<and> rbt_contains v2 V \<and> wf_list_graph_impl_rs V Es)"

 lemma[code]: "wf_list_graph_impl V E = wf_list_graph_impl_rs (rbt_fromlist V) E"
   apply(induction E)
    apply(simp; fail)
   apply(rename_tac e Es)
   apply(case_tac e)
   by(simp add: rbt_contains)

  lemma[code]: "FiniteListGraph.wf_list_graph_axioms G = wf_list_graph_impl (nodesL G) (edgesL G)"
    by(simp add: FiniteListGraph.wf_list_graph_axioms_def wf_list_graph_impl_axioms_locale_props)

  text\<open>The list implementation matches the @{term "wf_graph"} definition\<close>
  theorem wf_list_graph_iff_wf_graph:
    "wf_graph (list_graph_to_graph G) \<longleftrightarrow> wf_list_graph_axioms G"
  apply(unfold list_graph_to_graph_def wf_graph_def wf_list_graph_axioms_def wf_list_graph_impl_axioms_locale_props)
    by simp
  corollary wf_list_graph_iff_wf_graph_simplified:
  "wf_graph \<lparr>nodes = set (nodesL G), edges = set (edgesL G)\<rparr> \<longleftrightarrow> wf_list_graph_axioms G"
  apply(simp add: wf_list_graph_iff_wf_graph[unfolded list_graph_to_graph_def, simplified])
  done

text \<open>Code examples.\<close>
  definition wf_graph_example where
  "wf_graph_example \<equiv> \<lparr> nodesL = [1::nat,4,6], edgesL = [(1,4), (1,6), (6,4)] \<rparr>"

  value "wf_list_graph wf_graph_example"

  definition wf_graph_impl_example where
  "wf_graph_impl_example \<equiv> wf_list_graph wf_graph_example"

  export_code wf_list_graph empty add_node delete_node add_edge delete_edge checking Scala

end


theory Simplificacion1
imports Main
begin

section {* Seguimiento de la simplificación  *}

lemma "rev [x] = [x]"
using [[simp_trace]]
apply simp
done

text {* El resultado de la traza es
     proof (prove)
     goal:
     No subgoals!
     [1]SIMPLIFIER INVOKED ON THE FOLLOWING TERM:
     rev [x] = [x]
     [1]Applying instance of rewrite rule "??.unknown":
     rev (?x1 # ?xs1) \<equiv> rev ?xs1 @ [?x1]
     [1]Rewriting:
     rev [x] \<equiv> rev [] @ [x]
     [1]Applying instance of rewrite rule "??.unknown":
     rev [] \<equiv> []
     [1]Rewriting:
     rev [] \<equiv> []
     [1]Applying instance of rewrite rule "List.append.append_Nil":
     [] @ ?y \<equiv> ?y
     [1]Rewriting:
     [] @ [x] \<equiv> [x]
     [1]Applying instance of rewrite rule "HOL.simp_thms_6":
     ?x1 = ?x1 \<equiv> True
     [1]Rewriting:
     [x] = [x] \<equiv> True

  El significado de la traza es
       (rev [x]      = [x])
     = (rev [] @ [x] = [x])     [por "rev (x1 # xs1) = rev xs1 @ [x1]"]
     = ([]     @ [x] = [x])     [por "rev [] = []"]
     = ([x]          = [x])     [por List.append.append_Nil]
     = True                     [por HOL.simp_thms_6]
*}

text{* Ejemplo de simplificación no condicional *}
lemma "(ys @ [] = []) =
       (ys = [])"
apply simp
done

text{* Ejemplo de simplificación usando supuestos *}
lemma "\<lbrakk> xs @ zs = ys @ xs
       ; [] @ xs = [] @ [] \<rbrakk>
       \<Longrightarrow> ys = zs"
apply simp
done

lemma
  "\<lbrakk>  0 + n           = n
   ; (Suc m) + n     = Suc (m + n)
   ; (Suc m \<le> Suc n) = (m \<le> n)
   ; (0 \<le> m)         = True \<rbrakk>
   \<Longrightarrow> 0 + Suc 0 \<le> (Suc 0) + x"
apply simp
done

text {* Ejemplo de simplificación con reglas auxiliares *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply (simp add: algebra_simps)
done

text {* Las reglas de algebra_simps son
  (a + b) + c = a + (b + c)
  a + b = b + a
  b + (a + c) = a + (b + c)
  (a * b) * c = a * (b * c)
  a * b = b * a
  b * (a * c) = a * (b * c)
  a - (b - c) = a - (b + c)
  a + (b - c) = a + b - c
  (a - b = c) = (a = c + b)
  (a = c - b) = (a + b = c)
  a - (b - c) = (a + c) - b
  (a - b) + c = (a + c) - b
  (a - b < c) = (a < c + b)
  (a < c - b) = (a + b < c)
  (a - b \<le> c) = (a \<le> c + b)
  (a \<le> c - b) = (a + b \<le> c)
  (a + b) * c = a * c + b * c
  a * (b + c) = a * b + a * c
  a * (b - c) = a * b - a * c
  (b - c) * a = b * a - c * a
  a * (b - c) = a * b - a * c
  (a - b) * c = a * c - b * c
*}
thm algebra_simps [no_vars]

text {* Declaración de reglas como de simplificación *}
declare algebra_simps [simp]

text {* Ejemplo de simplificación con declaradas como simplificadores *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply simp
done

end


theory T168
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Snoc
  imports Main
begin

text \<open>Define a primitive recursive function @{text snoc} that appends an element
at the \emph{right} end of a list. Do not use @{text"@"} itself.\<close>

fun snoc :: "'a list => 'a => 'a list"
  where
"snoc [] c = [c]" |
"snoc (x#xs) c = x # (snoc xs c)"

text \<open>Prove the following theorem:\<close>

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
  apply (induction xs) by auto

text \<open>Hint: you need to prove a suitable lemma first.\<close>

end


(*<*)
theory ex09tmpl
  imports Main "HOL-Data_Structures.RBT_Set"
begin
(*>*)

text {* \ExerciseSheet{9}{8.~6.~2018} *}

text \<open>\Exercise{Indicate Unchanged by Option}

  Write an insert function for red-black trees that either inserts the element
  and returns a new tree, or returns None if the element was already in the tree
\<close>

term map_option

fun ins' :: "'a::linorder \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt option"
where
"ins' x Leaf = Some (R Leaf x Leaf)" |
"ins' x (B l a r) =
  (case cmp x a of
     LT \<Rightarrow> (case ins' x l of None \<Rightarrow> None | Some l' \<Rightarrow> Some (baliL l' a r)) |
     GT \<Rightarrow> (case ins' x r of None \<Rightarrow> None | Some r' \<Rightarrow> Some (baliR l a r')) |
     EQ \<Rightarrow> None)" |
"ins' x (R l a r) =
  (case cmp x a of
    LT \<Rightarrow> (case ins' x l of None \<Rightarrow> None | Some l' \<Rightarrow> Some (R l' a r)) |
    GT \<Rightarrow> (case ins' x r of None \<Rightarrow> None | Some r' \<Rightarrow> Some (R l a r')) |
    EQ \<Rightarrow> None)"

lemma [simp]: "\<lbrakk>invc l\<rbrakk> \<Longrightarrow> baliL l a r = B l a r"
  by (cases "(l,a,r)" rule: baliL.cases; simp)

lemma X1: "invc t \<Longrightarrow> case ins' x t of None \<Rightarrow> ins x t = t | Some t' \<Rightarrow> ins x t = t'"
  by (induction x t rule: ins'.induct) (auto split: option.split)

lemma [simp]: "size (baliR l x r) = size l + size r + 1"
  apply (cases "(l,x,r)" rule: baliR.cases) by auto

lemma [simp]: "size (baliL l x r) = size l + size r + 1"
  apply (cases "(l,x,r)" rule: baliL.cases) by auto

lemma X2: "invc t \<Longrightarrow> ins' x t = Some t' \<Longrightarrow> size t < size t'"
  apply (induction x t arbitrary: t' rule: ins'.induct)
  apply (auto split: option.splits if_splits)
  done

lemma "invc t \<Longrightarrow> case ins' x t of None \<Rightarrow> ins x t = t | Some t' \<Rightarrow> ins x t = t' \<and> t\<noteq>t'"
  using X1[of t x] X2[of t x] by (auto split: option.split)

(*<*)
end
(*>*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Word Alignment"

theory Aligned
imports
  Word_Lib
  HOL_Lemmas
  More_Divides
begin

definition
  is_aligned :: "'a :: len word \<Rightarrow> nat \<Rightarrow> bool" where
  "is_aligned ptr n \<equiv> 2^n dvd unat ptr"

lemma is_aligned_mask: "(is_aligned w n) = (w && mask n = 0)"
  unfolding is_aligned_def by (rule and_mask_dvd_nat)

lemma is_aligned_to_bl:
  "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
  apply (simp add: is_aligned_mask eq_zero_set_bl)
  apply (clarsimp simp: in_set_conv_nth word_size)
  apply (simp add: to_bl_nth word_size cong: conj_cong)
  apply (simp add: diff_diff_less)
  apply safe
   apply (case_tac "n \<le> LENGTH('a)")
    prefer 2
    apply (rule_tac x=i in exI)
    apply clarsimp
   apply (subgoal_tac "\<exists>j < LENGTH('a). j < n \<and> LENGTH('a) - n + j = i")
    apply (erule exE)
    apply (rule_tac x=j in exI)
    apply clarsimp
   apply (thin_tac "w !! t" for t)
   apply (rule_tac x="i + n - LENGTH('a)" in exI)
   apply clarsimp
   apply arith
  apply (rule_tac x="LENGTH('a) - n + i" in exI)
  apply clarsimp
  apply arith
  done

lemma unat_power_lower [simp]:
  assumes nv: "n < LENGTH('a::len)"
  shows "unat ((2::'a::len word) ^ n) = 2 ^ n"
  by (simp add: assms nat_power_eq uint_2p_alt unat_def)

lemma power_overflow:
  "n \<ge> LENGTH('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
  by simp

lemma is_alignedI [intro?]:
  fixes x::"'a::len word"
  assumes xv: "x = 2 ^ n * k"
  shows   "is_aligned x n"
proof cases
  assume nv: "n < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_def
  proof (rule dvdI [where k = "unat k mod 2 ^ (LENGTH('a) - n)"])
    from xv
    have "unat x = (unat (2::word32) ^ n * unat k) mod 2 ^ LENGTH('a)"
      using nv
      by (subst (asm) word_unat.Rep_inject [symmetric], simp,
          subst unat_word_ariths, simp)

    also have "\<dots> =  2 ^ n * (unat k mod 2 ^ (LENGTH('a) - n))" using nv
      by (simp add: mult_mod_right power_add [symmetric] add_diff_inverse)

    finally show "unat x = 2 ^ n * (unat k mod 2 ^ (LENGTH('a) - n))" .
  qed
next
  assume "\<not> n < LENGTH('a)"
  with xv
  show ?thesis by (simp add: not_less power_overflow is_aligned_def)
qed

lemma is_aligned_weaken:
  "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
  unfolding is_aligned_def
  by (erule dvd_trans [rotated]) (simp add: le_imp_power_dvd)

lemma nat_power_less_diff:
  assumes lt: "(2::nat) ^ n * q < 2 ^ m"
  shows "q < 2 ^ (m - n)"
  using lt
proof (induct n arbitrary: m)
  case 0
  then show ?case by simp
next
  case (Suc n)

  have ih: "\<And>m. 2 ^ n * q < 2 ^ m \<Longrightarrow> q < 2 ^ (m - n)"
    and prem: "2 ^ Suc n * q < 2 ^ m" by fact+

  show ?case
  proof (cases m)
    case 0
    then show ?thesis using Suc by simp
  next
    case (Suc m')
    then show ?thesis using prem
      by (simp add: ac_simps ih)
  qed
qed

lemma is_alignedE_pre:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  shows        rl: "\<exists>q. w = 2 ^ n * (of_nat q) \<and> q < 2 ^ (LENGTH('a) - n)"
proof -
  from aligned obtain q where wv: "unat w = 2 ^ n * q"
    unfolding is_aligned_def ..

  show ?thesis
  proof (rule exI, intro conjI)
    show "q < 2 ^ (LENGTH('a) - n)"
    proof (rule nat_power_less_diff)
      have "unat w < 2 ^ size w" unfolding word_size ..
      then have "unat w < 2 ^ LENGTH('a)" by simp
      with wv show "2 ^ n * q < 2 ^ LENGTH('a)" by simp
    qed

    have r: "of_nat (2 ^ n) = (2::word32) ^ n"
      by (induct n) simp+

    from wv have "of_nat (unat w) = of_nat (2 ^ n * q)" by simp
    then have "w = of_nat (2 ^ n * q)" by (subst word_unat.Rep_inverse [symmetric])
    then show "w = 2 ^ n * (of_nat q)" by (simp add: r)
  qed
qed

lemma is_alignedE:
  "\<lbrakk>is_aligned (w::'a::len word) n;
    \<And>q. \<lbrakk>w = 2 ^ n * (of_nat q); q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto dest: is_alignedE_pre)

lemma is_aligned_replicate:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  and          nv: "n \<le> LENGTH('a)"
  shows   "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
proof -
  from nv have rl: "\<And>q. q < 2 ^ (LENGTH('a) - n) \<Longrightarrow>
      to_bl (2 ^ n * (of_nat q :: 'a word)) =
      drop n (to_bl (of_nat q :: 'a word)) @ replicate n False"
    by (metis bl_shiftl le_antisym min_def shiftl_t2n wsst_TYs(3))
  show ?thesis using aligned
    by (auto simp: rl elim: is_alignedE)
qed

lemma is_aligned_drop:
  fixes w::"'a::len word"
  assumes "is_aligned w n" "n \<le> LENGTH('a)"
  shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
proof -
  have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
    by (rule is_aligned_replicate) fact+
  then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
  also have "\<dots> = replicate n False" by simp
  finally show ?thesis .
qed

lemma less_is_drop_replicate:
  fixes x::"'a::len word"
  assumes lt: "x < 2 ^ n"
  shows   "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
  by (metis assms bl_and_mask' less_mask_eq)

lemma is_aligned_add_conv:
  fixes off::"'a::len word"
  assumes aligned: "is_aligned w n"
  and        offv: "off < 2 ^ n"
  shows    "to_bl (w + off) =
   (take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
proof cases
  assume nv: "n \<le> LENGTH('a)"
  show ?thesis
  proof (subst aligned_bl_add_size, simp_all only: word_size)
    show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
      by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)

    from offv show "take (LENGTH('a) - n) (to_bl off) =
                    replicate (LENGTH('a) - n) False"
      by (subst less_is_drop_replicate, assumption) simp
  qed fact
next
  assume "\<not> n \<le> LENGTH('a)"
  with offv show ?thesis by (simp add: power_overflow)
qed

lemma aligned_add_aligned:
  fixes x::"'a::len word"
  assumes aligned1: "is_aligned x n"
  and     aligned2: "is_aligned y m"
  and           lt: "m \<le> n"
  shows   "is_aligned (x + y) m"
proof cases
  assume nlt: "n < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_def dvd_def
  proof -
    from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
      and q2v: "q2 < 2 ^ (LENGTH('a) - m)"
      by (auto elim: is_alignedE)

    from lt obtain k where kv: "m + k = n" by (auto simp: le_iff_add)
    with aligned1 obtain q1 where xv: "x = 2 ^ (m + k) * of_nat q1"
      and q1v: "q1 < 2 ^ (LENGTH('a) - (m + k))"
      by (auto elim: is_alignedE)

    have l1: "2 ^ (m + k) * q1 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q1v])
         (subst kv, rule order_less_imp_le [OF nlt])

    have l2: "2 ^ m * q2 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q2v],
          rule order_less_imp_le [OF order_le_less_trans])
         fact+

    have "x = of_nat (2 ^ (m + k) *  q1)" using xv
      by simp

    moreover have "y = of_nat (2 ^ m * q2)" using yv
      by simp

    ultimately have upls: "unat x + unat y = 2 ^ m * (2 ^ k * q1 + q2)"
    proof -
      have f1: "unat x = 2 ^ (m + k) * q1"
        by (metis (no_types) \<open>x = of_nat (2 ^ (m + k) * q1)\<close> l1 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      have "unat y = 2 ^ m * q2"
        by (metis (no_types) \<open>y = of_nat (2 ^ m * q2)\<close> l2 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      then show ?thesis
        using f1 by (simp add: power_add semiring_normalization_rules(34))
    qed

    (* (2 ^ k * q1 + q2) *)
    show "\<exists>d. unat (x + y) = 2 ^ m * d"
    proof (cases "unat x + unat y < 2 ^ LENGTH('a)")
      case True

      have "unat (x + y) = unat x + unat y"
        by (subst unat_plus_if', rule if_P) fact

      also have "\<dots> = 2 ^ m * (2 ^ k * q1 + q2)" by (rule upls)
      finally show ?thesis ..
    next
      case False
      then have "unat (x + y) = (unat x + unat y) mod 2 ^ LENGTH('a)"
        by (subst unat_word_ariths(1)) simp

      also have "\<dots> = (2 ^ m * (2 ^ k * q1 + q2)) mod 2 ^ LENGTH('a)"
        by (subst upls, rule refl)

      also
      have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (LENGTH('a) - m))"
      proof -
        have "m \<le> len_of (TYPE('a))"
          by (meson le_trans less_imp_le_nat lt nlt)
        then show ?thesis
          by (metis mult_mod_right ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
      qed

      finally show ?thesis ..
    qed
  qed
next
  assume "\<not> n < LENGTH('a)"
  with assms
  show ?thesis by (simp add: not_less power_overflow is_aligned_mask mask_def)
qed

corollary aligned_sub_aligned:
  "\<lbrakk>is_aligned (x::'a::len word) n; is_aligned y m; m \<le> n\<rbrakk>
   \<Longrightarrow> is_aligned (x - y) m"
  apply (simp del: add_uminus_conv_diff add:diff_conv_add_uminus)
  apply (erule aligned_add_aligned, simp_all)
  apply (erule is_alignedE)
  apply (rule_tac k="- of_nat q" in is_alignedI)
  apply simp
  done

lemma is_aligned_shift:
  fixes k::"'a::len word"
  shows "is_aligned (k << m) m"
proof cases
  assume mv: "m < LENGTH('a)"
  from mv obtain q where mq: "m + q = LENGTH('a)" and "0 < q"
    by (auto dest: less_imp_add_positive)

  have "(2::nat) ^ m dvd unat (k << m)"
  proof
    have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
      by (rule div_mult_mod_eq)

    have "unat (k << m) = unat (2 ^ m * k)" by (simp add: shiftl_t2n)
    also have "\<dots> = (2 ^ m * unat k) mod (2 ^ LENGTH('a))" using mv
      by (subst unat_word_ariths(2))+ simp
    also have "\<dots> = 2 ^ m * (unat k mod 2 ^ q)"
      by (subst mq [symmetric], subst power_add, subst mod_mult2_eq) simp
    finally show "unat (k << m) = 2 ^ m * (unat k mod 2 ^ q)" .
  qed

  then show ?thesis by (unfold is_aligned_def)
next
  assume "\<not> m < LENGTH('a)"
  then show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def
                  shiftl_zero_size word_size)
qed

lemma aligned_mod_eq_0:
  fixes p::"'a::len word"
  assumes al: "is_aligned p sz"
  shows   "p mod 2 ^ sz = 0"
proof cases
  assume szv: "sz < LENGTH('a)"
  with al
  show ?thesis
    unfolding is_aligned_def
    by (simp add: and_mask_dvd_nat p2_gt_0 word_mod_2p_is_mask)
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def word_mod_by_0)
qed

lemma is_aligned_triv: "is_aligned (2 ^ n ::'a::len word) n"
  by (rule is_alignedI [where k = 1], simp)

lemma is_aligned_mult_triv1: "is_aligned (2 ^ n * x  ::'a::len word) n"
  by (rule is_alignedI [OF refl])

lemma is_aligned_mult_triv2: "is_aligned (x * 2 ^ n ::'a::len word) n"
  by (subst mult.commute, simp add: is_aligned_mult_triv1)

lemma word_power_less_0_is_0:
  fixes x :: "'a::len word"
  shows "x < a ^ 0 \<Longrightarrow> x = 0" by simp

lemma nat_add_offset_less:
  fixes x :: nat
  assumes yv: "y < 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y < 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n" and "0 < qy"
    by (auto dest: less_imp_add_positive)

  have "x * 2 ^ n + y < x * 2 ^ n + 2 ^ n" by simp fact+
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y < 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap:
  fixes off :: "'a::len word"
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "unat ptr + unat off < 2 ^ LENGTH('a)"
proof -
  have szv: "sz < LENGTH('a)"
  using off p2_gt_0 word_neq_0_conv by fastforce

  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv by clarsimp
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q ::'a::len word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
         apply (simp_all)
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
         apply (subst unat_power_lower [OF szv])
         apply (subst uq)
         apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + unat off < 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_less [OF _ qv])
        apply (rule order_less_le_trans [OF unat_mono [OF off] order_eq_refl])
         apply simp_all
        done
    qed
  qed
qed

lemma is_aligned_no_wrap':
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "ptr \<le> ptr + off"
  by (subst no_plus_overflow_unat_size, subst word_size, rule is_aligned_no_wrap) fact+

lemma is_aligned_no_overflow':
  fixes p :: "'a::len word"
  assumes al: "is_aligned p n"
  shows "p \<le> p + (2 ^ n - 1)"
proof cases
  assume "n<LENGTH('a)"
  with al
  have "2^n - (1::'a::len word) < 2^n"
    by (simp add: word_less_nat_alt unat_sub_if_size)
  with al
  show ?thesis by (rule is_aligned_no_wrap')
next
  assume "\<not> n<LENGTH('a)"
  with al
  show ?thesis
  by (simp add: not_less power_overflow is_aligned_mask mask_2pm1)
qed

lemma replicate_not_True:
  "\<And>n. xs = replicate n False \<Longrightarrow> True \<notin> set xs"
  by (induct xs) auto

lemma is_aligned_replicateI:
  "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
  apply (simp add: is_aligned_to_bl word_size)
  apply (subgoal_tac "length addr = LENGTH('a) - n")
   apply (simp add: replicate_not_True)
  apply (drule arg_cong [where f=length])
  apply simp
  done

lemma to_bl_2p:
  "n < LENGTH('a) \<Longrightarrow>
   to_bl ((2::'a::len word) ^ n) =
   replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
  apply (subst shiftl_1 [symmetric])
  apply (subst bl_shiftl)
  apply (simp add: to_bl_1 min_def word_size)
  done

lemma map_zip_replicate_False_xor:
  "n = length xs \<Longrightarrow> map (\<lambda>(x, y). x = (\<not> y)) (zip xs (replicate n False)) = xs"
  by (induct xs arbitrary: n, auto)

lemma drop_minus_lem:
  "\<lbrakk> n \<le> length xs; 0 < n; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - n) xs = rev xs ! (n - 1)  # drop (Suc (n' - n)) xs"
proof (induct xs arbitrary: n n')
  case Nil then show ?case by simp
next
  case (Cons y ys)
  from Cons.prems
  show ?case
    apply simp
    apply (cases "n = Suc (length ys)")
     apply (simp add: nth_append)
    apply (simp add: Suc_diff_le Cons.hyps nth_append)
    apply clarsimp
    apply arith
    done
qed

lemma drop_minus:
  "\<lbrakk> n < length xs; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - Suc n) xs = rev xs ! n  # drop (n' - n) xs"
  apply (subst drop_minus_lem)
     apply simp
    apply simp
   apply simp
  apply simp
  apply (cases "length xs", simp)
  apply (simp add: Suc_diff_le)
  done

lemma xor_2p_to_bl:
  fixes x::"'a::len word"
  shows "to_bl (x xor 2^n) =
  (if n < LENGTH('a)
   then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
   else to_bl x)"
proof -
  have x: "to_bl x = take (LENGTH('a)-Suc n) (to_bl x) @ drop (LENGTH('a)-Suc n) (to_bl x)"
    by simp

  show ?thesis
  apply simp
  apply (rule conjI)
   apply (clarsimp simp: word_size)
   apply (simp add: bl_word_xor to_bl_2p)
   apply (subst x)
   apply (subst zip_append)
    apply simp
   apply (simp add: map_zip_replicate_False_xor drop_minus)
  apply (auto simp add: word_size nth_w2p intro!: word_eqI)
  done
qed

lemma aligned_add_xor:
  assumes al: "is_aligned (x::'a::len word) n'" and le: "n < n'"
  shows "(x + 2^n) xor 2^n = x"
proof cases
  assume "n' < LENGTH('a)"
  with assms show ?thesis
  apply -
  apply (rule word_bl.Rep_eqD)
  apply (subst xor_2p_to_bl)
  apply simp
  apply (subst is_aligned_add_conv, simp, simp add: word_less_nat_alt)+
  apply (simp add: to_bl_2p nth_append)
  apply (cases "n' = Suc n")
   apply simp
   apply (subst is_aligned_replicate [where n="Suc n", simplified, symmetric]; simp)
  apply (subgoal_tac "\<not> LENGTH('a) - Suc n \<le> LENGTH('a) - n'")
   prefer 2
   apply arith
  apply (subst replicate_Suc [symmetric])
  apply (subst replicate_add [symmetric])
  apply (simp add: is_aligned_replicate [simplified, symmetric])
  done
next
  assume "\<not> n' < LENGTH('a)"
  with al show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow)
qed

lemma is_aligned_0 [simp]:
  "is_aligned p 0"
  by (simp add: is_aligned_def)

lemma is_aligned_replicateD:
  "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
     \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
               \<and> length xs = size w - n"
  apply (subst is_aligned_replicate, assumption+)
  apply (rule exI, rule conjI, rule refl)
  apply (simp add: word_size)
  done

lemma is_aligned_add_multI:
  fixes p :: "'a::len word"
  shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n) n'"
  apply (erule aligned_add_aligned)
  apply (auto intro: is_alignedI [where k="x"])
  done

lemma unat_of_nat_len:
  "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
  by (simp add: word_size unat_of_nat)

lemma is_aligned_no_wrap''':
  fixes ptr :: "'a::len word"
  shows"\<lbrakk> is_aligned ptr sz; sz < LENGTH('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ LENGTH('a)"
  apply (drule is_aligned_no_wrap[where off="of_nat off"])
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (subst unat_of_nat)
   apply (rule mod_less_eq_dividend)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma aligned_small_is_0:
  "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
  apply (erule is_aligned_get_word_bits)
   apply (frule is_aligned_add_conv [rotated, where w=0])
    apply (simp add: is_aligned_def)
   apply simp
   apply (drule is_aligned_replicateD)
    apply simp
   apply (clarsimp simp: word_size)
   apply (subst (asm) replicate_add [symmetric])
   apply (drule arg_cong[where f="of_bl :: bool list \<Rightarrow> 'a::len word"])
   apply simp
  apply (simp only: replicate.simps[symmetric, where x=False]
                    drop_replicate)
  done

corollary is_aligned_less_sz:
  "\<lbrakk>is_aligned a sz; a \<noteq> 0\<rbrakk> \<Longrightarrow> \<not> a < 2 ^ sz"
  by (rule notI, drule(1) aligned_small_is_0, erule(1) notE)

lemma aligned_at_least_t2n_diff:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y\<rbrakk> \<Longrightarrow> x \<le> y - 2 ^ n"
  apply (erule is_aligned_get_word_bits[where p=y])
   apply (rule ccontr)
   apply (clarsimp simp: linorder_not_le)
   apply (subgoal_tac "y - x = 0")
    apply clarsimp
   apply (rule aligned_small_is_0)
    apply (erule(1) aligned_sub_aligned)
    apply simp
   apply unat_arith
  apply simp
  done

lemma word_sub_1_le:
  "x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
  apply (subst no_ulen_sub)
  apply simp
  apply (cases "uint x = 0")
   apply (simp add: uint_0_iff)
  apply (insert uint_ge_0[where x=x])
  apply arith
  done

lemma is_aligned_no_overflow'':
  "\<lbrakk>is_aligned x n; x + 2 ^ n \<noteq> 0\<rbrakk> \<Longrightarrow> x \<le> x + 2 ^ n"
  apply (frule is_aligned_no_overflow')
  apply (erule order_trans)
  apply (simp add: field_simps)
  apply (erule word_sub_1_le)
  done

lemma is_aligned_nth:
  "is_aligned p m = (\<forall>n < m. \<not>p !! n)"
  apply (clarsimp simp: is_aligned_mask bang_eq word_size)
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "n < size p")
    apply (simp add: word_size)
   apply (drule test_bit_size)
   apply simp
  apply clarsimp
  done

lemma range_inter:
  "({a..b} \<inter> {c..d} = {}) = (\<forall>x. \<not>(a \<le> x \<and> x \<le> b \<and> c \<le> x \<and> x \<le> d))"
  by auto

lemma aligned_inter_non_empty:
  "\<lbrakk> {p..p + (2 ^ n - 1)} \<inter> {p..p + 2 ^ m - 1} = {};
     is_aligned p n; is_aligned p m\<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp only: range_inter)
  apply (erule_tac x=p in allE)
  apply simp
  apply (erule impE)
   apply (erule is_aligned_no_overflow')
  apply (erule notE)
  apply (erule is_aligned_no_overflow)
  done

lemma not_aligned_mod_nz:
  assumes al: "\<not> is_aligned a n"
  shows "a mod 2 ^ n \<noteq> 0"
proof cases
  assume "n < LENGTH('a)"
  with al
  show ?thesis
    apply (simp add: is_aligned_def dvd_eq_mod_eq_0 word_arith_nat_mod)
    apply (erule of_nat_neq_0)
    apply (rule order_less_trans)
     apply (rule mod_less_divisor)
     apply simp
    apply simp
    done
next
  assume "\<not> n < LENGTH('a)"
  with al
  show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow
                  word_less_nat_alt word_mod_by_0)
qed

lemma nat_add_offset_le:
  fixes x :: nat
  assumes yv: "y \<le> 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y \<le> 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n"
    by (auto simp: le_iff_add)

  have "x * 2 ^ n + y \<le> x * 2 ^ n + 2 ^ n"
    using yv xv by simp
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y \<le> 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap_le:
  fixes ptr::"'a::len word"
  assumes al: "is_aligned ptr sz"
  and    szv: "sz < LENGTH('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ LENGTH('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      apply (clarsimp)
      apply (erule le_SucE)
       apply (simp add: unat_of_nat)
      apply (simp add: less_eq_Suc_le [symmetric] unat_of_nat)
      done
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q :: 'a word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
        apply simp_all
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
        apply (subst unat_power_lower [OF szv])
        apply (subst uq)
        apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + off \<le> 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_le [OF off qv])
        apply simp
        done
    qed
  qed
qed

lemma is_aligned_neg_mask:
  "m \<le> n \<Longrightarrow> is_aligned (x && ~~ (mask n)) m"
  by (metis and_not_mask is_aligned_shift is_aligned_weaken)

lemma unat_minus:
  "unat (- (x :: 'a :: len word)) = (if x = 0 then 0 else 2 ^ size x - unat x)"
  using unat_sub_if_size[where x="2 ^ size x" and y=x]
  by (simp add: unat_eq_0 word_size)

lemma is_aligned_minus:
  "is_aligned p n \<Longrightarrow> is_aligned (- p) n"
  apply (clarsimp simp: is_aligned_def unat_minus word_size word_neq_0_conv)
  apply (rule dvd_diff_nat, simp_all)
  apply (rule le_imp_power_dvd)
  apply (fold is_aligned_def)
  apply (erule_tac Q="0<p" in contrapos_pp)
  apply (clarsimp simp add: is_aligned_mask mask_def power_overflow)
  done

lemma add_mask_lower_bits:
  "\<lbrakk>is_aligned (x :: 'a :: len word) n;
    \<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'\<rbrakk> \<Longrightarrow> x + p && ~~ (mask n) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI)
   apply (clarsimp simp: word_size is_aligned_nth)
   apply (erule_tac x=na in allE)+
   apply simp
  apply (rule word_eqI)
  apply (clarsimp simp: word_size is_aligned_nth word_ops_nth_size le_def)
  apply blast
  done

lemma is_aligned_andI1:
  "is_aligned x n \<Longrightarrow> is_aligned (x && y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_andI2:
  "is_aligned y n \<Longrightarrow> is_aligned (x && y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_shiftl:
  "is_aligned w (n - m) \<Longrightarrow> is_aligned (w << m) n"
  by (simp add: is_aligned_nth nth_shiftl)

lemma is_aligned_shiftr:
  "is_aligned w (n + m) \<Longrightarrow> is_aligned (w >> m) n"
  by (simp add: is_aligned_nth nth_shiftr)

lemma is_aligned_shiftl_self:
  "is_aligned (p << n) n"
  by (rule is_aligned_shift)

lemma is_aligned_neg_mask_eq:
  "is_aligned p n \<Longrightarrow> p && ~~ (mask n) = p"
  by (metis add.left_neutral is_aligned_mask word_plus_and_or_coroll2)

lemma is_aligned_shiftr_shiftl:
  "is_aligned w n \<Longrightarrow> w >> n << n = w"
  by (metis and_not_mask is_aligned_neg_mask_eq)

lemma aligned_shiftr_mask_shiftl:
  "is_aligned x n \<Longrightarrow> ((x >> n) && mask v) << n = x && mask (v + n)"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftl nth_shiftr)
  apply (subgoal_tac "\<forall>m. x !! m \<longrightarrow> m \<ge> n")
   apply auto[1]
  apply (clarsimp simp: is_aligned_mask)
  apply (drule_tac x=m in word_eqD)
  apply (frule test_bit_size)
  apply (simp add: word_size)
  done

lemma mask_zero:
  "is_aligned x a \<Longrightarrow> x && mask a = 0"
  by (metis is_aligned_mask)

lemma is_aligned_neg_mask_eq_concrete:
  "\<lbrakk> is_aligned p n; msk && ~~(mask n) = ~~(mask n) \<rbrakk>
   \<Longrightarrow> p && msk = p"
  by (metis word_bw_assocs(1) word_bw_comms(1) is_aligned_neg_mask_eq)

lemma is_aligned_and_not_zero:
  "\<lbrakk> is_aligned n k; n \<noteq> 0 \<rbrakk> \<Longrightarrow> 2 ^ k \<le> n"
  using is_aligned_less_sz leI by blast

lemma is_aligned_and_2_to_k:
  "(n && 2 ^ k - 1) = 0 \<Longrightarrow> is_aligned (n :: 'a :: len word) k"
  by (simp add: is_aligned_mask mask_def)

lemma is_aligned_power2:
  "b \<le> a \<Longrightarrow> is_aligned (2 ^ a) b"
  by (metis is_aligned_triv is_aligned_weaken)

lemma aligned_sub_aligned':
  "\<lbrakk> is_aligned (a :: 'a :: len word) n; is_aligned b n; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> is_aligned (a - b) n"
  by (simp add: aligned_sub_aligned)

lemma is_aligned_neg_mask_weaken:
  "\<lbrakk> is_aligned p n; m \<le> n \<rbrakk> \<Longrightarrow> p && ~~(mask m) = p"
   using is_aligned_neg_mask_eq is_aligned_weaken by blast

lemma is_aligned_neg_mask2[simp]:
  "is_aligned (a && ~~(mask n)) n"
  by (simp add: and_not_mask is_aligned_shift)

end


header {*\isaheader{Specification of Unique Priority Queues}*}
theory PrioUniqueSpec
imports ICF_Spec_Base
begin

(*@intf PrioUnique
  @abstype ('e \<rightharpoonup> 'a::linorder)
  Priority queues without duplicate elements. This interface defines a
  decrease-key operation.
*)

text {*
  We define unique priority queues, where each element may occur at most once.
  We provide operations to get and remove the element with the minimum priority,
  as well as to access and change an elements priority (decrease-key operation).

  Unique priority queues are abstracted to maps from elements to priorities.
*}
locale uprio =
  fixes \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes invar :: "'s \<Rightarrow> bool"

locale uprio_no_invar = uprio +
  assumes invar[simp, intro!]: "\<And>s. invar s"

locale uprio_finite = uprio +
  assumes finite_correct:
  "invar s \<Longrightarrow> finite (dom (\<alpha> s))"

subsection "Basic Upriority Queue Functions"

subsubsection "Empty Queue"
locale uprio_empty = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
  "invar (empty ())"
  "\<alpha> (empty ()) = Map.empty"

subsubsection "Emptiness Predicate"
locale uprio_isEmpty = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
  "invar s \<Longrightarrow> (isEmpty s) = (\<alpha> s = Map.empty)"

subsubsection "Find and Remove Minimal Element"
locale uprio_pop = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes pop :: "'s \<Rightarrow> ('e \<times> 'a \<times> 's)"
  assumes pop_correct:
  "\<lbrakk>invar s; \<alpha> s \<noteq> Map.empty; pop s = (e,a,s')\<rbrakk> \<Longrightarrow>
    invar s' \<and>
    \<alpha> s' = (\<alpha> s)(e := None) \<and>
    (\<alpha> s) e = Some a \<and>
    (\<forall>y \<in> ran (\<alpha> s). a \<le> y)"
begin

  lemma popE:
    assumes
    "invar s"
    "\<alpha> s \<noteq> Map.empty"
    obtains e a s' where
    "pop s = (e, a, s')"
    "invar s'"
    "\<alpha> s' = (\<alpha> s)(e := None)"
    "(\<alpha> s) e = Some a"
    "(\<forall>y \<in> ran (\<alpha> s). a \<le> y)"
    using assms
    apply (cases "pop s")
    apply (drule (2) pop_correct)
    apply blast
    done

end

subsubsection "Insert"
text {*
  If an existing element is inserted, its priority will be overwritten.
  This can be used to implement a decrease-key operation.
*}
(* TODO: Implement decrease-key generic algorithm, and specify decrease-key operation here! *)
locale uprio_insert = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes insert :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  assumes insert_correct:
  "invar s \<Longrightarrow> invar (insert s e a)"
  "invar s \<Longrightarrow> \<alpha> (insert s e a) = (\<alpha> s)(e \<mapsto> a)"

subsubsection "Distinct Insert"
text {*
  This operation only allows insertion of elements
  that are not yet in the queue.
*}
locale uprio_distinct_insert = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes insert :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  assumes distinct_insert_correct:
  "\<lbrakk>invar s; e \<notin> dom (\<alpha> s)\<rbrakk> \<Longrightarrow> invar (insert s e a)"
  "\<lbrakk>invar s; e \<notin> dom (\<alpha> s)\<rbrakk> \<Longrightarrow> \<alpha> (insert s e a) = (\<alpha> s)(e \<mapsto> a)"

subsubsection "Looking up Priorities"
locale uprio_prio = uprio +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a::linorder)"
  fixes prio :: "'s \<Rightarrow> 'e \<Rightarrow> 'a option"
  assumes prio_correct:
  "invar s \<Longrightarrow> prio s e = (\<alpha> s) e"

subsection "Record Based Interface"

record ('e, 'a, 's) uprio_ops =
  upr_\<alpha> :: "'s \<Rightarrow> ('e \<rightharpoonup> 'a)"
  upr_invar :: "'s \<Rightarrow> bool"
  upr_empty :: "unit \<Rightarrow> 's"
  upr_isEmpty :: "'s \<Rightarrow> bool"
  upr_insert :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  upr_pop :: "'s \<Rightarrow> ('e \<times> 'a \<times> 's)"
  upr_prio :: "'s \<Rightarrow> 'e \<Rightarrow> 'a option"

locale StdUprioDefs =
  fixes ops :: "('e,'a::linorder,'s, 'more) uprio_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == upr_\<alpha> ops"
  abbreviation invar where "invar == upr_invar ops"
  abbreviation empty where "empty == upr_empty ops"
  abbreviation isEmpty where "isEmpty == upr_isEmpty ops"
  abbreviation insert where "insert == upr_insert ops"
  abbreviation pop where "pop == upr_pop ops"
  abbreviation prio where "prio == upr_prio ops"
end

locale StdUprio =  StdUprioDefs ops +
  uprio_finite \<alpha> invar +
  uprio_empty \<alpha> invar empty +
  uprio_isEmpty \<alpha> invar isEmpty +
  uprio_insert \<alpha> invar insert +
  uprio_pop \<alpha> invar pop +
  uprio_prio \<alpha> invar prio
  for ops
begin
  lemmas correct =
    finite_correct
    empty_correct
    isEmpty_correct
    insert_correct
    prio_correct
end

locale StdUprio_no_invar = StdUprio + uprio_no_invar \<alpha> invar

end