(*  Title:      HOL/Power.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge
*)

section \<open>Exponentiation\<close>

theory Power
  imports Num
begin

subsection \<open>Powers for Arbitrary Monoids\<close>

class power = one + times
begin

primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a"  (infixr "^" 80)
  where
    power_0: "a ^ 0 = 1"
  | power_Suc: "a ^ Suc n = a * a ^ n"

notation (latex output)
  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)

text \<open>Special syntax for squares.\<close>
abbreviation power2 :: "'a \<Rightarrow> 'a"  ("(_\<^sup>2)" [1000] 999)
  where "x\<^sup>2 \<equiv> x ^ 2"

end

context
  includes lifting_syntax
begin

lemma power_transfer [transfer_rule]:
  \<open>(R ===> (=) ===> R) (^) (^)\<close>
    if [transfer_rule]: \<open>R 1 1\<close>
      \<open>(R ===> R ===> R) (*) (*)\<close>
    for R :: \<open>'a::power \<Rightarrow> 'b::power \<Rightarrow> bool\<close>
  by (simp only: power_def [abs_def]) transfer_prover

end

context monoid_mult
begin

subclass power .

lemma power_one [simp]: "1 ^ n = 1"
  by (induct n) simp_all

lemma power_one_right [simp]: "a ^ 1 = a"
  by simp

lemma power_Suc0_right [simp]: "a ^ Suc 0 = a"
  by simp

lemma power_commutes: "a ^ n * a = a * a ^ n"
  by (induct n) (simp_all add: mult.assoc)

lemma power_Suc2: "a ^ Suc n = a ^ n * a"
  by (simp add: power_commutes)

lemma power_add: "a ^ (m + n) = a ^ m * a ^ n"
  by (induct m) (simp_all add: algebra_simps)

lemma power_mult: "a ^ (m * n) = (a ^ m) ^ n"
  by (induct n) (simp_all add: power_add)

lemma power_even_eq: "a ^ (2 * n) = (a ^ n)\<^sup>2"
  by (subst mult.commute) (simp add: power_mult)

lemma power_odd_eq: "a ^ Suc (2*n) = a * (a ^ n)\<^sup>2"
  by (simp add: power_even_eq)

lemma power_numeral_even: "z ^ numeral (Num.Bit0 w) = (let w = z ^ (numeral w) in w * w)"
  by (simp only: numeral_Bit0 power_add Let_def)

lemma power_numeral_odd: "z ^ numeral (Num.Bit1 w) = (let w = z ^ (numeral w) in z * w * w)"
  by (simp only: numeral_Bit1 One_nat_def add_Suc_right add_0_right
      power_Suc power_add Let_def mult.assoc)

lemma power2_eq_square: "a\<^sup>2 = a * a"
  by (simp add: numeral_2_eq_2)

lemma power3_eq_cube: "a ^ 3 = a * a * a"
  by (simp add: numeral_3_eq_3 mult.assoc)

lemma power4_eq_xxxx: "x^4 = x * x * x * x"
  by (simp add: mult.assoc power_numeral_even)

lemma power_numeral_reduce: "x ^ numeral n = x * x ^ pred_numeral n"
  by (simp add: numeral_eq_Suc)

lemma funpow_times_power: "(times x ^^ f x) = times (x ^ f x)"
proof (induct "f x" arbitrary: f)
  case 0
  then show ?case by (simp add: fun_eq_iff)
next
  case (Suc n)
  define g where "g x = f x - 1" for x
  with Suc have "n = g x" by simp
  with Suc have "times x ^^ g x = times (x ^ g x)" by simp
  moreover from Suc g_def have "f x = g x + 1" by simp
  ultimately show ?case
    by (simp add: power_add funpow_add fun_eq_iff mult.assoc)
qed

lemma power_commuting_commutes:
  assumes "x * y = y * x"
  shows "x ^ n * y = y * x ^n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "x ^ Suc n * y = x ^ n * y * x"
    by (subst power_Suc2) (simp add: assms ac_simps)
  also have "\<dots> = y * x ^ Suc n"
    by (simp only: Suc power_Suc2) (simp add: ac_simps)
  finally show ?case .
qed

lemma power_minus_mult: "0 < n \<Longrightarrow> a ^ (n - 1) * a = a ^ n"
  by (simp add: power_commutes split: nat_diff_split)

lemma left_right_inverse_power:
  assumes "x * y = 1"
  shows   "x ^ n * y ^ n = 1"
proof (induct n)
  case (Suc n)
  moreover have "x ^ Suc n * y ^ Suc n = x^n * (x * y) * y^n"
    by (simp add: power_Suc2[symmetric] mult.assoc[symmetric])
  ultimately show ?case by (simp add: assms)
qed simp

end

context comm_monoid_mult
begin

lemma power_mult_distrib [algebra_simps, algebra_split_simps, field_simps, field_split_simps, divide_simps]:
  "(a * b) ^ n = (a ^ n) * (b ^ n)"
  by (induction n) (simp_all add: ac_simps)

end

text \<open>Extract constant factors from powers.\<close>
declare power_mult_distrib [where a = "numeral w" for w, simp]
declare power_mult_distrib [where b = "numeral w" for w, simp]

lemma power_add_numeral [simp]: "a^numeral m * a^numeral n = a^numeral (m + n)"
  for a :: "'a::monoid_mult"
  by (simp add: power_add [symmetric])

lemma power_add_numeral2 [simp]: "a^numeral m * (a^numeral n * b) = a^numeral (m + n) * b"
  for a :: "'a::monoid_mult"
  by (simp add: mult.assoc [symmetric])

lemma power_mult_numeral [simp]: "(a^numeral m)^numeral n = a^numeral (m * n)"
  for a :: "'a::monoid_mult"
  by (simp only: numeral_mult power_mult)

context semiring_numeral
begin

lemma numeral_sqr: "numeral (Num.sqr k) = numeral k * numeral k"
  by (simp only: sqr_conv_mult numeral_mult)

lemma numeral_pow: "numeral (Num.pow k l) = numeral k ^ numeral l"
  by (induct l)
    (simp_all only: numeral_class.numeral.simps pow.simps
      numeral_sqr numeral_mult power_add power_one_right)

lemma power_numeral [simp]: "numeral k ^ numeral l = numeral (Num.pow k l)"
  by (rule numeral_pow [symmetric])

end

context semiring_1
begin

lemma of_nat_power [simp]: "of_nat (m ^ n) = of_nat m ^ n"
  by (induct n) simp_all

lemma zero_power: "0 < n \<Longrightarrow> 0 ^ n = 0"
  by (cases n) simp_all

lemma power_zero_numeral [simp]: "0 ^ numeral k = 0"
  by (simp add: numeral_eq_Suc)

lemma zero_power2: "0\<^sup>2 = 0" (* delete? *)
  by (rule power_zero_numeral)

lemma one_power2: "1\<^sup>2 = 1" (* delete? *)
  by (rule power_one)

lemma power_0_Suc [simp]: "0 ^ Suc n = 0"
  by simp

text \<open>It looks plausible as a simprule, but its effect can be strange.\<close>
lemma power_0_left: "0 ^ n = (if n = 0 then 1 else 0)"
  by (cases n) simp_all

end

context semiring_char_0 begin

lemma numeral_power_eq_of_nat_cancel_iff [simp]:
  "numeral x ^ n = of_nat y \<longleftrightarrow> numeral x ^ n = y"
  using of_nat_eq_iff by fastforce

lemma real_of_nat_eq_numeral_power_cancel_iff [simp]:
  "of_nat y = numeral x ^ n \<longleftrightarrow> y = numeral x ^ n"
  using numeral_power_eq_of_nat_cancel_iff [of x n y] by (metis (mono_tags))

lemma of_nat_eq_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w = of_nat x \<longleftrightarrow> b ^ w = x"
  by (metis of_nat_power of_nat_eq_iff)

lemma of_nat_power_eq_of_nat_cancel_iff[simp]: "of_nat x = (of_nat b) ^ w \<longleftrightarrow> x = b ^ w"
  by (metis of_nat_eq_of_nat_power_cancel_iff)

end

context comm_semiring_1
begin

text \<open>The divides relation.\<close>

lemma le_imp_power_dvd:
  assumes "m \<le> n"
  shows "a ^ m dvd a ^ n"
proof
  from assms have "a ^ n = a ^ (m + (n - m))" by simp
  also have "\<dots> = a ^ m * a ^ (n - m)" by (rule power_add)
  finally show "a ^ n = a ^ m * a ^ (n - m)" .
qed

lemma power_le_dvd: "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
  by (rule dvd_trans [OF le_imp_power_dvd])

lemma dvd_power_same: "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
  by (induct n) (auto simp add: mult_dvd_mono)

lemma dvd_power_le: "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
  by (rule power_le_dvd [OF dvd_power_same])

lemma dvd_power [simp]:
  fixes n :: nat
  assumes "n > 0 \<or> x = 1"
  shows "x dvd (x ^ n)"
  using assms
proof
  assume "0 < n"
  then have "x ^ n = x ^ Suc (n - 1)" by simp
  then show "x dvd (x ^ n)" by simp
next
  assume "x = 1"
  then show "x dvd (x ^ n)" by simp
qed

end

context semiring_1_no_zero_divisors
begin

subclass power .

lemma power_eq_0_iff [simp]: "a ^ n = 0 \<longleftrightarrow> a = 0 \<and> n > 0"
  by (induct n) auto

lemma power_not_zero: "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
  by (induct n) auto

lemma zero_eq_power2 [simp]: "a\<^sup>2 = 0 \<longleftrightarrow> a = 0"
  unfolding power2_eq_square by simp

end

context ring_1
begin

lemma power_minus: "(- a) ^ n = (- 1) ^ n * a ^ n"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  then show ?case
    by (simp del: power_Suc add: power_Suc2 mult.assoc)
qed

lemma power_minus': "NO_MATCH 1 x \<Longrightarrow> (-x) ^ n = (-1)^n * x ^ n"
  by (rule power_minus)

lemma power_minus_Bit0: "(- x) ^ numeral (Num.Bit0 k) = x ^ numeral (Num.Bit0 k)"
  by (induct k, simp_all only: numeral_class.numeral.simps power_add
    power_one_right mult_minus_left mult_minus_right minus_minus)

lemma power_minus_Bit1: "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
  by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)

lemma power2_minus [simp]: "(- a)\<^sup>2 = a\<^sup>2"
  by (fact power_minus_Bit0)

lemma power_minus1_even [simp]: "(- 1) ^ (2*n) = 1"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  then show ?case by (simp add: power_add power2_eq_square)
qed

lemma power_minus1_odd: "(- 1) ^ Suc (2*n) = -1"
  by simp

lemma power_minus_even [simp]: "(-a) ^ (2*n) = a ^ (2*n)"
  by (simp add: power_minus [of a])

end

context ring_1_no_zero_divisors
begin

lemma power2_eq_1_iff: "a\<^sup>2 = 1 \<longleftrightarrow> a = 1 \<or> a = - 1"
  using square_eq_1_iff [of a] by (simp add: power2_eq_square)

end

context idom
begin

lemma power2_eq_iff: "x\<^sup>2 = y\<^sup>2 \<longleftrightarrow> x = y \<or> x = - y"
  unfolding power2_eq_square by (rule square_eq_iff)

end

context semidom_divide
begin

lemma power_diff:
  "a ^ (m - n) = (a ^ m) div (a ^ n)" if "a \<noteq> 0" and "n \<le> m"
proof -
  define q where "q = m - n"
  with \<open>n \<le> m\<close> have "m = q + n" by simp
  with \<open>a \<noteq> 0\<close> q_def show ?thesis
    by (simp add: power_add)
qed

end

context algebraic_semidom
begin

lemma div_power: "b dvd a \<Longrightarrow> (a div b) ^ n = a ^ n div b ^ n"
  by (induct n) (simp_all add: div_mult_div_if_dvd dvd_power_same)

lemma is_unit_power_iff: "is_unit (a ^ n) \<longleftrightarrow> is_unit a \<or> n = 0"
  by (induct n) (auto simp add: is_unit_mult_iff)

lemma dvd_power_iff:
  assumes "x \<noteq> 0"
  shows   "x ^ m dvd x ^ n \<longleftrightarrow> is_unit x \<or> m \<le> n"
proof
  assume *: "x ^ m dvd x ^ n"
  {
    assume "m > n"
    note *
    also have "x ^ n = x ^ n * 1" by simp
    also from \<open>m > n\<close> have "m = n + (m - n)" by simp
    also have "x ^ \<dots> = x ^ n * x ^ (m - n)" by (rule power_add)
    finally have "x ^ (m - n) dvd 1"
      using assms by (subst (asm) dvd_times_left_cancel_iff) simp_all
    with \<open>m > n\<close> have "is_unit x" by (simp add: is_unit_power_iff)
  }
  thus "is_unit x \<or> m \<le> n" by force
qed (auto intro: unit_imp_dvd simp: is_unit_power_iff le_imp_power_dvd)

end

context normalization_semidom_multiplicative
begin

lemma normalize_power: "normalize (a ^ n) = normalize a ^ n"
  by (induct n) (simp_all add: normalize_mult)

lemma unit_factor_power: "unit_factor (a ^ n) = unit_factor a ^ n"
  by (induct n) (simp_all add: unit_factor_mult)

end

context division_ring
begin

text \<open>Perhaps these should be simprules.\<close>
lemma power_inverse [field_simps, field_split_simps, divide_simps]: "inverse a ^ n = inverse (a ^ n)"
proof (cases "a = 0")
  case True
  then show ?thesis by (simp add: power_0_left)
next
  case False
  then have "inverse (a ^ n) = inverse a ^ n"
    by (induct n) (simp_all add: nonzero_inverse_mult_distrib power_commutes)
  then show ?thesis by simp
qed

lemma power_one_over [field_simps, field_split_simps, divide_simps]: "(1 / a) ^ n = 1 / a ^ n"
  using power_inverse [of a] by (simp add: divide_inverse)

end

context field
begin

lemma power_divide [field_simps, field_split_simps, divide_simps]: "(a / b) ^ n = a ^ n / b ^ n"
  by (induct n) simp_all

end

subsection \<open>Exponentiation on ordered types\<close>

context linordered_semidom
begin

lemma zero_less_power [simp]: "0 < a \<Longrightarrow> 0 < a ^ n"
  by (induct n) simp_all

lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
  by (induct n) simp_all

lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
  by (induct n) (auto intro: mult_mono order_trans [of 0 a b])

lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
  using power_mono [of 1 a n] by simp

lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
  using power_mono [of a 1 n] by simp

lemma power_gt1_lemma:
  assumes gt1: "1 < a"
  shows "1 < a * a ^ n"
proof -
  from gt1 have "0 \<le> a"
    by (fact order_trans [OF zero_le_one less_imp_le])
  from gt1 have "1 * 1 < a * 1" by simp
  also from gt1 have "\<dots> \<le> a * a ^ n"
    by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
  finally show ?thesis by simp
qed

lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
  by (simp add: power_gt1_lemma)

lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
  by (cases n) (simp_all add: power_gt1_lemma)

lemma power_le_imp_le_exp:
  assumes gt1: "1 < a"
  shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
proof (induct m arbitrary: n)
  case 0
  show ?case by simp
next
  case (Suc m)
  show ?case
  proof (cases n)
    case 0
    with Suc have "a * a ^ m \<le> 1" by simp
    with gt1 show ?thesis
      by (force simp only: power_gt1_lemma not_less [symmetric])
  next
    case (Suc n)
    with Suc.prems Suc.hyps show ?thesis
      by (force dest: mult_left_le_imp_le simp add: less_trans [OF zero_less_one gt1])
  qed
qed

lemma of_nat_zero_less_power_iff [simp]: "of_nat x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
  by (induct n) auto

text \<open>Surely we can strengthen this? It holds for \<open>0<a<1\<close> too.\<close>
lemma power_inject_exp [simp]:
  \<open>a ^ m = a ^ n \<longleftrightarrow> m = n\<close> if \<open>1 < a\<close>
  using that by (force simp add: order_class.order.antisym power_le_imp_le_exp)

text \<open>
  Can relax the first premise to \<^term>\<open>0<a\<close> in the case of the
  natural numbers.
\<close>
lemma power_less_imp_less_exp: "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
  by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"] power_le_imp_le_exp)

lemma power_strict_mono: "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a ^ n < b ^ n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
    by (cases "n = 0") (auto simp: mult_strict_mono le_less_trans [of 0 a b])
qed

lemma power_mono_iff [simp]:
  shows "\<lbrakk>a \<ge> 0; b \<ge> 0; n>0\<rbrakk> \<Longrightarrow> a ^ n \<le> b ^ n \<longleftrightarrow> a \<le> b"
  using power_mono [of a b] power_strict_mono [of b a] not_le by auto

text\<open>Lemma for \<open>power_strict_decreasing\<close>\<close>
lemma power_Suc_less: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
  by (induct n) (auto simp: mult_strict_left_mono)

lemma power_strict_decreasing: "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ N < a ^ n"
proof (induction N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
     using mult_strict_mono[of a 1 "a ^ N" "a ^ n"]
     by (auto simp add: power_Suc_less less_Suc_eq)
 qed

text \<open>Proof resembles that of \<open>power_strict_decreasing\<close>.\<close>
lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
proof (induction N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    using mult_mono[of a 1 "a^N" "a ^ n"]
    by (auto simp add: le_Suc_eq)
qed

lemma power_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m \<le> b ^ n \<longleftrightarrow> n \<le> m"
  using power_strict_decreasing [of m n b]
  by (auto intro: power_decreasing ccontr)

lemma power_strict_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m < b ^ n \<longleftrightarrow> n < m"
  using power_decreasing_iff [of b m n] unfolding le_less
  by (auto dest: power_strict_decreasing le_neq_implies_less)

lemma power_Suc_less_one: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
  using power_strict_decreasing [of 0 "Suc n" a] by simp

text \<open>Proof again resembles that of \<open>power_strict_decreasing\<close>.\<close>
lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    using mult_mono[of 1 a "a ^ n" "a ^ N"]
    by (auto simp add: le_Suc_eq order_trans [OF zero_le_one])
qed

text \<open>Lemma for \<open>power_strict_increasing\<close>.\<close>
lemma power_less_power_Suc: "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
  by (induct n) (auto simp: mult_strict_left_mono less_trans [OF zero_less_one])

lemma power_strict_increasing: "n < N \<Longrightarrow> 1 < a \<Longrightarrow> a ^ n < a ^ N"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    using mult_strict_mono[of 1 a "a^n" "a^N"]
    by (auto simp add: power_less_power_Suc less_Suc_eq less_trans [OF zero_less_one] less_imp_le)
qed

lemma power_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
  by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)

lemma power_strict_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
  by (blast intro: power_less_imp_less_exp power_strict_increasing)

lemma power_le_imp_le_base:
  assumes le: "a ^ Suc n \<le> b ^ Suc n"
    and "0 \<le> b"
  shows "a \<le> b"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have "b < a" by (simp only: linorder_not_le)
  then have "b ^ Suc n < a ^ Suc n"
    by (simp only: assms(2) power_strict_mono)
  with le show False
    by (simp add: linorder_not_less [symmetric])
qed

lemma power_less_imp_less_base:
  assumes less: "a ^ n < b ^ n"
  assumes nonneg: "0 \<le> b"
  shows "a < b"
proof (rule contrapos_pp [OF less])
  assume "\<not> ?thesis"
  then have "b \<le> a" by (simp only: linorder_not_less)
  from this nonneg have "b ^ n \<le> a ^ n" by (rule power_mono)
  then show "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
qed

lemma power_inject_base: "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
  by (blast intro: power_le_imp_le_base order.antisym eq_refl sym)

lemma power_eq_imp_eq_base: "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
  by (cases n) (simp_all del: power_Suc, rule power_inject_base)

lemma power_eq_iff_eq_base: "0 < n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a ^ n = b ^ n \<longleftrightarrow> a = b"
  using power_eq_imp_eq_base [of a n b] by auto

lemma power2_le_imp_le: "x\<^sup>2 \<le> y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
  unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)

lemma power2_less_imp_less: "x\<^sup>2 < y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
  by (rule power_less_imp_less_base)

lemma power2_eq_imp_eq: "x\<^sup>2 = y\<^sup>2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
  unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp

lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
  using power_decreasing [of 1 "Suc n" a] by simp

lemma power2_eq_iff_nonneg [simp]:
  assumes "0 \<le> x" "0 \<le> y"
  shows "(x ^ 2 = y ^ 2) \<longleftrightarrow> x = y"
using assms power2_eq_imp_eq by blast

lemma of_nat_less_numeral_power_cancel_iff[simp]:
  "of_nat x < numeral i ^ n \<longleftrightarrow> x < numeral i ^ n"
  using of_nat_less_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .

lemma of_nat_le_numeral_power_cancel_iff[simp]:
  "of_nat x \<le> numeral i ^ n \<longleftrightarrow> x \<le> numeral i ^ n"
  using of_nat_le_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .

lemma numeral_power_less_of_nat_cancel_iff[simp]:
  "numeral i ^ n < of_nat x \<longleftrightarrow> numeral i ^ n < x"
  using of_nat_less_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .

lemma numeral_power_le_of_nat_cancel_iff[simp]:
  "numeral i ^ n \<le> of_nat x \<longleftrightarrow> numeral i ^ n \<le> x"
  using of_nat_le_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .

lemma of_nat_le_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w \<le> of_nat x \<longleftrightarrow> b ^ w \<le> x"
  by (metis of_nat_le_iff of_nat_power)

lemma of_nat_power_le_of_nat_cancel_iff[simp]: "of_nat x \<le> (of_nat b) ^ w \<longleftrightarrow> x \<le> b ^ w"
  by (metis of_nat_le_iff of_nat_power)

lemma of_nat_less_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w < of_nat x \<longleftrightarrow> b ^ w < x"
  by (metis of_nat_less_iff of_nat_power)

lemma of_nat_power_less_of_nat_cancel_iff[simp]: "of_nat x < (of_nat b) ^ w \<longleftrightarrow> x < b ^ w"
  by (metis of_nat_less_iff of_nat_power)

lemma power2_nonneg_ge_1_iff:
  assumes "x \<ge> 0"
  shows   "x ^ 2 \<ge> 1 \<longleftrightarrow> x \<ge> 1"
  using assms by (auto intro: power2_le_imp_le)

lemma power2_nonneg_gt_1_iff:
  assumes "x \<ge> 0"
  shows   "x ^ 2 > 1 \<longleftrightarrow> x > 1"
  using assms  by (auto intro: power_less_imp_less_base)

end

text \<open>Some @{typ nat}-specific lemmas:\<close>

lemma mono_ge2_power_minus_self:
  assumes "k \<ge> 2" shows "mono (\<lambda>m. k ^ m - m)"
unfolding mono_iff_le_Suc
proof
  fix n
  have "k ^ n < k ^ Suc n" using power_strict_increasing_iff[of k "n" "Suc n"] assms by linarith
  thus "k ^ n - n \<le> k ^ Suc n - Suc n" by linarith
qed

lemma self_le_ge2_pow[simp]:
  assumes "k \<ge> 2" shows "m \<le> k ^ m"
proof (induction m)
  case 0 show ?case by simp
next
  case (Suc m)
  hence "Suc m \<le> Suc (k ^ m)" by simp
  also have "... \<le> k^m + k^m" using one_le_power[of k m] assms by linarith
  also have "... \<le> k * k^m" by (metis mult_2 mult_le_mono1[OF assms])
  finally show ?case by simp
qed

lemma diff_le_diff_pow[simp]:
  assumes "k \<ge> 2" shows "m - n \<le> k ^ m - k ^ n"
proof (cases "n \<le> m")
  case True
  thus ?thesis
    using monoD[OF mono_ge2_power_minus_self[OF assms] True] self_le_ge2_pow[OF assms, of m]
    by (simp add: le_diff_conv le_diff_conv2)
qed auto

context linordered_ring_strict
begin

lemma sum_squares_eq_zero_iff: "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: add_nonneg_eq_0_iff)

lemma sum_squares_le_zero_iff: "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)

lemma sum_squares_gt_zero_iff: "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  by (simp add: not_le [symmetric] sum_squares_le_zero_iff)

end

context linordered_idom
begin

lemma zero_le_power2 [simp]: "0 \<le> a\<^sup>2"
  by (simp add: power2_eq_square)

lemma zero_less_power2 [simp]: "0 < a\<^sup>2 \<longleftrightarrow> a \<noteq> 0"
  by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)

lemma power2_less_0 [simp]: "\<not> a\<^sup>2 < 0"
  by (force simp add: power2_eq_square mult_less_0_iff)

lemma power_abs: "\<bar>a ^ n\<bar> = \<bar>a\<bar> ^ n" \<comment> \<open>FIXME simp?\<close>
  by (induct n) (simp_all add: abs_mult)

lemma power_sgn [simp]: "sgn (a ^ n) = sgn a ^ n"
  by (induct n) (simp_all add: sgn_mult)

lemma abs_power_minus [simp]: "\<bar>(- a) ^ n\<bar> = \<bar>a ^ n\<bar>"
  by (simp add: power_abs)

lemma zero_less_power_abs_iff [simp]: "0 < \<bar>a\<bar> ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
proof (induct n)
  case 0
  show ?case by simp
next
  case Suc
  then show ?case by (auto simp: zero_less_mult_iff)
qed

lemma zero_le_power_abs [simp]: "0 \<le> \<bar>a\<bar> ^ n"
  by (rule zero_le_power [OF abs_ge_zero])

lemma power2_less_eq_zero_iff [simp]: "a\<^sup>2 \<le> 0 \<longleftrightarrow> a = 0"
  by (simp add: le_less)

lemma abs_power2 [simp]: "\<bar>a\<^sup>2\<bar> = a\<^sup>2"
  by (simp add: power2_eq_square)

lemma power2_abs [simp]: "\<bar>a\<bar>\<^sup>2 = a\<^sup>2"
  by (simp add: power2_eq_square)

lemma odd_power_less_zero: "a < 0 \<Longrightarrow> a ^ Suc (2 * n) < 0"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
    by (simp add: ac_simps power_add power2_eq_square)
  then show ?case
    by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
qed

lemma odd_0_le_power_imp_0_le: "0 \<le> a ^ Suc (2 * n) \<Longrightarrow> 0 \<le> a"
  using odd_power_less_zero [of a n]
  by (force simp add: linorder_not_less [symmetric])

lemma zero_le_even_power'[simp]: "0 \<le> a ^ (2 * n)"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
    by (simp add: ac_simps power_add power2_eq_square)
  then show ?case
    by (simp add: Suc zero_le_mult_iff)
qed

lemma sum_power2_ge_zero: "0 \<le> x\<^sup>2 + y\<^sup>2"
  by (intro add_nonneg_nonneg zero_le_power2)

lemma not_sum_power2_lt_zero: "\<not> x\<^sup>2 + y\<^sup>2 < 0"
  unfolding not_less by (rule sum_power2_ge_zero)

lemma sum_power2_eq_zero_iff: "x\<^sup>2 + y\<^sup>2 = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  unfolding power2_eq_square by (simp add: add_nonneg_eq_0_iff)

lemma sum_power2_le_zero_iff: "x\<^sup>2 + y\<^sup>2 \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less sum_power2_eq_zero_iff not_sum_power2_lt_zero)

lemma sum_power2_gt_zero_iff: "0 < x\<^sup>2 + y\<^sup>2 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  unfolding not_le [symmetric] by (simp add: sum_power2_le_zero_iff)

lemma abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> x\<^sup>2 \<le> y\<^sup>2"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have "\<bar>x\<bar>\<^sup>2 \<le> \<bar>y\<bar>\<^sup>2" by (rule power_mono) simp
  then show ?rhs by simp
next
  assume ?rhs
  then show ?lhs
    by (auto intro!: power2_le_imp_le [OF _ abs_ge_zero])
qed

lemma power2_le_iff_abs_le:
  "y \<ge> 0 \<Longrightarrow> x\<^sup>2 \<le> y\<^sup>2 \<longleftrightarrow> \<bar>x\<bar> \<le> y"
  by (metis abs_le_square_iff abs_of_nonneg)

lemma abs_square_le_1:"x\<^sup>2 \<le> 1 \<longleftrightarrow> \<bar>x\<bar> \<le> 1"
  using abs_le_square_iff [of x 1] by simp

lemma abs_square_eq_1: "x\<^sup>2 = 1 \<longleftrightarrow> \<bar>x\<bar> = 1"
  by (auto simp add: abs_if power2_eq_1_iff)

lemma abs_square_less_1: "x\<^sup>2 < 1 \<longleftrightarrow> \<bar>x\<bar> < 1"
  using  abs_square_eq_1 [of x] abs_square_le_1 [of x] by (auto simp add: le_less)

lemma square_le_1:
  assumes "- 1 \<le> x" "x \<le> 1"
  shows "x\<^sup>2 \<le> 1"
    using assms
    by (metis add.inverse_inverse linear mult_le_one neg_equal_0_iff_equal neg_le_iff_le power2_eq_square power_minus_Bit0)

end

subsection \<open>Miscellaneous rules\<close>

lemma (in linordered_semidom) self_le_power: "1 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a \<le> a ^ n"
  using power_increasing [of 1 n a] power_one_right [of a] by auto

lemma power2_ge_1_iff: "x ^ 2 \<ge> 1 \<longleftrightarrow> x \<ge> 1 \<or> x \<le> (-1 :: 'a :: linordered_idom)"
  using abs_le_square_iff[of 1 x] by (auto simp: abs_if split: if_splits)

lemma (in power) power_eq_if: "p ^ m = (if m=0 then 1 else p * (p ^ (m - 1)))"
  unfolding One_nat_def by (cases m) simp_all

lemma (in comm_semiring_1) power2_sum: "(x + y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 + 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

context comm_ring_1
begin

lemma power2_diff: "(x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

lemma power2_commute: "(x - y)\<^sup>2 = (y - x)\<^sup>2"
  by (simp add: algebra_simps power2_eq_square)

lemma minus_power_mult_self: "(- a) ^ n * (- a) ^ n = a ^ (2 * n)"
  by (simp add: power_mult_distrib [symmetric])
    (simp add: power2_eq_square [symmetric] power_mult [symmetric])

lemma minus_one_mult_self [simp]: "(- 1) ^ n * (- 1) ^ n = 1"
  using minus_power_mult_self [of 1 n] by simp

lemma left_minus_one_mult_self [simp]: "(- 1) ^ n * ((- 1) ^ n * a) = a"
  by (simp add: mult.assoc [symmetric])

end

text \<open>Simprules for comparisons where common factors can be cancelled.\<close>

lemmas zero_compare_simps =
  add_strict_increasing add_strict_increasing2 add_increasing
  zero_le_mult_iff zero_le_divide_iff
  zero_less_mult_iff zero_less_divide_iff
  mult_le_0_iff divide_le_0_iff
  mult_less_0_iff divide_less_0_iff
  zero_le_power2 power2_less_0

subsection \<open>Exponentiation for the Natural Numbers\<close>

lemma nat_one_le_power [simp]: "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
  by (rule one_le_power [of i n, unfolded One_nat_def])

lemma nat_zero_less_power_iff [simp]: "x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
  for x :: nat
  by (induct n) auto

lemma nat_power_eq_Suc_0_iff [simp]: "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
  by (induct m) auto

lemma power_Suc_0 [simp]: "Suc 0 ^ n = Suc 0"
  by simp

text \<open>
  Valid for the naturals, but what if \<open>0 < i < 1\<close>? Premises cannot be
  weakened: consider the case where \<open>i = 0\<close>, \<open>m = 1\<close> and \<open>n = 0\<close>.
\<close>

lemma nat_power_less_imp_less:
  fixes i :: nat
  assumes nonneg: "0 < i"
  assumes less: "i ^ m < i ^ n"
  shows "m < n"
proof (cases "i = 1")
  case True
  with less power_one [where 'a = nat] show ?thesis by simp
next
  case False
  with nonneg have "1 < i" by auto
  from power_strict_increasing_iff [OF this] less show ?thesis ..
qed

lemma power_gt_expt: "n > Suc 0 \<Longrightarrow> n^k > k"
  by (induction k) (auto simp: less_trans_Suc n_less_m_mult_n)

lemma less_exp [simp]:
  \<open>n < 2 ^ n\<close>
  by (simp add: power_gt_expt)

lemma power_dvd_imp_le:
  fixes i :: nat
  assumes "i ^ m dvd i ^ n" "1 < i"
  shows "m \<le> n"
  using assms by (auto intro: power_le_imp_le_exp [OF \<open>1 < i\<close> dvd_imp_le])

lemma dvd_power_iff_le:
  fixes k::nat
  shows "2 \<le> k \<Longrightarrow> ((k ^ m) dvd (k ^ n) \<longleftrightarrow> m \<le> n)"
  using le_imp_power_dvd power_dvd_imp_le by force

lemma power2_nat_le_eq_le: "m\<^sup>2 \<le> n\<^sup>2 \<longleftrightarrow> m \<le> n"
  for m n :: nat
  by (auto intro: power2_le_imp_le power_mono)

lemma power2_nat_le_imp_le:
  fixes m n :: nat
  assumes "m\<^sup>2 \<le> n"
  shows "m \<le> n"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  show ?thesis
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "n < m" by simp
    with assms Suc show False
      by (simp add: power2_eq_square)
  qed
qed

lemma ex_power_ivl1: fixes b k :: nat assumes "b \<ge> 2"
shows "k \<ge> 1 \<Longrightarrow> \<exists>n. b^n \<le> k \<and> k < b^(n+1)" (is "_ \<Longrightarrow> \<exists>n. ?P k n")
proof(induction k)
  case 0 thus ?case by simp
next
  case (Suc k)
  show ?case
  proof cases
    assume "k=0"
    hence "?P (Suc k) 0" using assms by simp
    thus ?case ..
  next
    assume "k\<noteq>0"
    with Suc obtain n where IH: "?P k n" by auto
    show ?case
    proof (cases "k = b^(n+1) - 1")
      case True
      hence "?P (Suc k) (n+1)" using assms
        by (simp add: power_less_power_Suc)
      thus ?thesis ..
    next
      case False
      hence "?P (Suc k) n" using IH by auto
      thus ?thesis ..
    qed
  qed
qed

lemma ex_power_ivl2: fixes b k :: nat assumes "b \<ge> 2" "k \<ge> 2"
  shows "\<exists>n. b^n < k \<and> k \<le> b^(n+1)"
proof -
  have "1 \<le> k - 1" using assms(2) by arith
  from ex_power_ivl1[OF assms(1) this]
  obtain n where "b ^ n \<le> k - 1 \<and> k - 1 < b ^ (n + 1)" ..
  hence "b^n < k \<and> k \<le> b^(n+1)" using assms by auto
  thus ?thesis ..
qed

subsubsection \<open>Cardinality of the Powerset\<close>

lemma card_UNIV_bool [simp]: "card (UNIV :: bool set) = 2"
  unfolding UNIV_bool by simp

lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
proof (induct rule: finite_induct)
  case empty
  show ?case by simp
next
  case (insert x A)
  from \<open>x \<notin> A\<close> have disjoint: "Pow A \<inter> insert x ` Pow A = {}" by blast
  from \<open>x \<notin> A\<close> have inj_on: "inj_on (insert x) (Pow A)"
    unfolding inj_on_def by auto

  have "card (Pow (insert x A)) = card (Pow A \<union> insert x ` Pow A)"
    by (simp only: Pow_insert)
  also have "\<dots> = card (Pow A) + card (insert x ` Pow A)"
    by (rule card_Un_disjoint) (use \<open>finite A\<close> disjoint in simp_all)
  also from inj_on have "card (insert x ` Pow A) = card (Pow A)"
    by (rule card_image)
  also have "\<dots> + \<dots> = 2 * \<dots>" by (simp add: mult_2)
  also from insert(3) have "\<dots> = 2 ^ Suc (card A)" by simp
  also from insert(1,2) have "Suc (card A) = card (insert x A)"
    by (rule card_insert_disjoint [symmetric])
  finally show ?case .
qed

subsection \<open>Code generator tweak\<close>

code_identifier
  code_module Power \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


theory Temporal imports Main
begin
  section{*Linear Temporal Logic*}
  text{*
    In this section we introduce an algebraic axiomatization of Linear Temporal Logic (LTL).
    We model LTL formulas semantically as predicates on traces. For example the LTL formula
    $\alpha = \Box\; \diamondsuit\; (x = 1)$ is modeled as a predicate
    $\alpha : (nat \Rightarrow nat) \Rightarrow bool$, where
    $\alpha \;x = True$ if $x\;i=1$ for infinitely many $i:nat$. In this formula $\Box$
    and $\diamondsuit$ denote the always and eventually operators, respectively.
    Formulas with multiple variables are modeled similarly. For example a formula $\alpha$ in two
    variables is modeled as $\alpha : (nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    and for example $(\Box\; \alpha) \; x\; y$ is defined as $(\forall i . \alpha \; x[i..]\; y[i..])$,
    where $x[i..]\;j = x\;(i+j)$. We would like to construct an algebraic structure (Isabelle class)
    which has the temporal operators as operations, and which has instatiations to
    $(nat \Rightarrow \tv a) \Rightarrow bool$, $(nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    and so on. Ideally our structure should be such that if we have this structure on a type $\tv a::temporal$,
    then we could extend it to $(nat \Rightarrow \tv b) \Rightarrow \tv a$ in a way similar to the
    way Boolean algebras are extended from a type $\tv a::boolean\_algebra$ to $\tv b\Rightarrow \tv a$.
    Unfortunately, if we use for example $\Box$ as primitive operation on our temporal structure,
    then we cannot extend $\Box$ from $\tv a::temporal$ to $(nat \Rightarrow \tv b) \Rightarrow \tv a$. A
    possible extension of $\Box$ could be
      $$(\Box\; \alpha)\;x = \bigwedge_{i:nat} \Box (\alpha\; x[i..]) \mbox{ and } \Box \; b = b$$
    where $\alpha: (nat \Rightarrow \tv b) \Rightarrow \tv a$ and $b:bool$. However, if we apply this
    definition to $\alpha : (nat \Rightarrow \tv a) \Rightarrow (nat \Rightarrow \tv b) \Rightarrow bool$,
    then we get
      $$(\Box\; \alpha) \; x\; y = (\forall i\;j. \alpha \; x[i..]\; y[j..])$$
    which is not correct.

    To evercome this problem we introduce as a primitive operation $!!:\tv a \Rightarrow nat \Rightarrow \tv a$,
    where $\tv a$ is the type of temporal formulas, and $\alpha !! i$ is the formula $\alpha$ at time point $i$.
    If $\alpha$ is a formula in two variables as before, then
      $$(\alpha !! i)\; x\;y = \alpha\; x[i..]\;y[i..].$$
    and we define for example the the operator always by
      $$\Box \alpha = \bigwedge_{i:nat} \alpha !! i$$
  *}
  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

  class temporal = complete_boolean_algebra +
    fixes at :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 150)
    assumes [simp]: "a !! i !! j = a !! (i + j)"
    assumes [simp]: "a !! 0 = a"
    assumes [simp]: "\<top> !! i = \<top>"
    assumes [simp]: "-(a !! i) = (-a) !! i"
    assumes [simp]: "(a \<sqinter> b) !! i = (a !! i) \<sqinter> (b !! i)"
    begin
      definition always :: "'a \<Rightarrow> 'a"  ("\<box> (_)" [900] 900) where
        "\<box> p = (INF i . p !! i)"

      definition eventually :: "'a \<Rightarrow> 'a"  ("\<diamondsuit> (_)" [900] 900) where
        "\<diamondsuit> p = (SUP i . p !! i)"

      definition "next" :: "'a \<Rightarrow> 'a"  ("\<Odot> (_)" [900] 900) where
        "\<Odot> p = p !! (Suc 0)"

      definition until :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "until" 65) where
        "(p until q) = (SUP n . (INFIMUM {i . i < n}  (at p)) \<sqinter> (q !! n))"
    end

text{*
Next lemma, in the context of complete boolean algebras, will be used
to prove $-(p\ until\ -p) = \Box\; p$.
*}
  context complete_boolean_algebra
    begin
      lemma until_always: "(INF n. (SUP i : {i. i < n} . - p i) \<squnion> ((p :: nat \<Rightarrow> 'a) n)) \<le> p n"
        proof -
          have "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF i:{i. i \<le> n}. p i)"
            proof (induction n)
              have "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (SUP i:{i. i < 0}. - p i) \<squnion> p 0"
                by (rule INF_lower, simp)
              also have "... \<le> (INF i:{i. i \<le> 0}. p i)"
                by (simp add: INF_def)
              finally show "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF i:{i. i \<le> 0}. p i)"
                by simp
            next
              fix n::nat assume "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF i : {i. i \<le> n}. p i)"
              also have "\<And> i . i \<le> n \<Longrightarrow> ... \<le> p i" by (rule INF_lower, simp)
              finally have [simp]: "\<And> i . i \<le> n \<Longrightarrow> (INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> p i"
                by simp
              show "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF i : {i. i \<le> Suc n}. p i)"
                proof (rule INF_greatest, safe, cases)
                  fix i::nat
                    assume "i \<le> n" from this show "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> p i" by simp
                next
                  fix i::nat
                    have A: "{i. i \<le> n} = {i . i < Suc n}" by auto
                    have B: "(SUP i:{i. i \<le> n}. - p i) \<le> - (INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n)"
                      by (metis (lifting, mono_tags) `(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF i:{i. i \<le> n}. p i)` compl_mono uminus_INF)
                    assume "i \<le> Suc n" and "\<not> i \<le> n"
                    from this have [simp]: "i = Suc n" by simp
                    have "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> (INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<sqinter> ((SUP i:{i. i \<le> n}. - p i) \<squnion> p (Suc n))"
                      by (simp add: A, rule INF_lower, simp)
                    also have "... \<le> ((INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<sqinter> ((- (INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n)) \<squnion> p (Suc n)))"
                      by (rule inf_mono, simp_all, rule_tac y = "- (INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n)" in order_trans, simp_all add: B)
                    also have "... \<le> p i"
                      by (simp add: inf_sup_distrib1 inf_compl_bot)
                    finally show "(INF n. (SUP i:{i. i < n}. - p i) \<squnion> p n) \<le> p i" by simp
                qed
            qed
        also have "(INF i:{i. i \<le> n}. p i) \<le> p n" by (rule INF_lower, auto)
        finally show "(INF n. (SUP i : {i. i < n} . - p i) \<squnion> ((p :: nat \<Rightarrow> 'a) n)) \<le> p n" by simp
        qed

     end

text{*
  We prove now a number of results of the temporal class.
*}
  context temporal
    begin

      lemma always_less [simp]: "\<box> p \<le> p"
        proof -
          have "\<box> p \<le> p !! 0"
            by (unfold always_def, rule INF_lower, simp)
          also have "p !! 0 = p" by simp
          finally show "\<box> p \<le> p" by simp
        qed

      lemma always_and: "\<box> (p \<sqinter> q) = (\<box> p) \<sqinter> (\<box> q)"
        by (simp add: always_def INF_inf_distrib)

      lemma eventually_or: "\<diamondsuit> (p \<squnion> q) = (\<diamondsuit> p) \<squnion> (\<diamondsuit> q)"
        by (simp add: eventually_def SUP_sup_distrib)

      lemma neg_until_always: "-(p until -p) = \<box> p"
        proof (rule antisym)
          show "- (p until - p) \<le> \<box> p"
           by (simp add: until_def always_def uminus_SUP uminus_INF, rule INF_greatest, cut_tac p = "\<lambda> n . p !! n" in until_always, simp)
        next
          have "\<And> n . \<box> p \<le> p !! n"
            by (simp add: always_def INF_lower)
          also have "\<And> n . p !! n \<le> (SUP x:{i. i < n}. (- p) !! x) \<squnion> p !! n"
            by simp
          finally show "\<box> p \<le> -(p until -p)"
            apply (simp add: until_def uminus_SUP uminus_INF)
            by (rule INF_greatest, simp)
        qed

      lemma neg_always_eventually: "\<box> p = - \<diamondsuit> (- p)"
        by (simp add: fun_eq_iff always_def eventually_def until_def uminus_SUP)

      lemma neg_true_until_always: "-(\<top> until -p) = \<box> p"
        by (simp add: fun_eq_iff always_def until_def uminus_SUP uminus_INF)

      lemma true_until_eventually: "(\<top> until p) = \<diamondsuit> p"
        by (cut_tac p = "-p" in neg_always_eventually, cut_tac p = "-p" in neg_true_until_always, simp)
    end

text{*
  Boolean algebras with $b!!i = b$ form a temporal class.
*}

  instantiation bool :: temporal
    begin
      definition at_bool_def [simp]: "(p::bool) !! i = p"
    instance proof
      qed auto
    end

  type_synonym 'a trace = "nat \<Rightarrow> 'a"

text{*
  Asumming that $\tv a::temporal$ is a type of class $temporal$, and $\tv b$ is an arbitrary type,
  we would like to create the instantiation of $\tv b\ trace \Rightarrow \tv a$ as a temporal
  class. However Isabelle allows only instatiations of functions from a class to another
  class. To solve this problem we introduce a new class called trace with an operation
  $\mathit{suffix}::\tv a \Rightarrow nat \Rightarrow \tv a$ where
  $\mathit{suffix}\;a\;i\;j = (a[i..])\; j = a\;(i+j)$ when
  $a$ is a trace with elements of some type $\tv b$ ($\tv a = nat \Rightarrow \tv b$).
*}

  class trace =
    fixes suffix :: "'a \<Rightarrow> nat \<Rightarrow> 'a" ("_[_ ..]" [80, 15] 80)
    assumes [simp]: "a[i..][j..] = a[i + j..]"
    assumes [simp]: "a[0..] = a"
    begin
      definition "next_trace" :: "'a \<Rightarrow> 'a"  ("\<odot> (_)" [900] 900) where
        "\<odot> p = p[Suc 0..]"
    end

  instantiation "fun" :: (trace, temporal) temporal
    begin
      definition at_fun_def: "(P:: 'a \<Rightarrow> 'b) !! i = (\<lambda> x . (P (x[i..])) !! i)"
      instance proof qed  (simp_all add: at_fun_def add.commute fun_eq_iff le_fun_def)
    end

text{*
  In the last part of our formalization, we need to instantiate the functions
  from $nat$ to some arbitrary type $\tv a$ as a trace class. However, this again is not
  possible using the instatiation mechanism of Isabelle. We solve this problem
  by creating another class called $nat$, and then we instatiate the functions
  from $\tv a::nat$ to $\tv b$ as traces. The class $nat$ is defined such that if we
  have a type $\tv a::nat$, then $\tv a$ is isomorphic to the type $nat$.
*}

  class nat = zero + plus + minus +
    fixes RepNat :: "'a \<Rightarrow> nat"
    fixes AbsNat :: "nat \<Rightarrow> 'a"
    assumes [simp]: "RepNat (AbsNat n) = n"
    and [simp]: "AbsNat (RepNat x) = x"
    and zero_Nat_def: "0 = AbsNat 0"
    and plus_Nat_def: "a + b = AbsNat (RepNat a + RepNat b)"
    and minus_Nat_def: "a - b = AbsNat (RepNat a - RepNat b)"
  begin
    lemma AbsNat_plus: "AbsNat (i + j) = AbsNat i + AbsNat j"
      by (simp add: plus_Nat_def)
    lemma AbsNat_zero [simp]: "AbsNat 0 + i = i"
      by (simp add: plus_Nat_def)

    subclass comm_monoid_diff
      apply (unfold_locales)
        apply (simp_all add: plus_Nat_def zero_Nat_def minus_Nat_def add.assoc)
        by (simp add: add.commute)
  end

text{*
  The type natural numbers is an instantiation of the class $nat$.
*}

  instantiation nat :: nat
    begin
      definition RepNat_nat_def [simp]: "(RepNat:: nat \<Rightarrow> nat) = id"
      definition AbsNat_nat_def [simp]: "(AbsNat:: nat \<Rightarrow> nat) = id"
      instance proof
        qed auto
    end

text{*
  Finally, functions from $\tv a::nat$ to some arbitrary type $\tv b$ are instatiated
  as a trace class.
*}

  instantiation "fun" :: (nat, type) trace
    begin
      definition at_trace_def [simp]: "((t :: 'a \<Rightarrow> 'b)[i..]) j = (t  (AbsNat i + j))"
    instance proof
      qed (simp_all add: fun_eq_iff AbsNat_plus add.assoc)
    end

text{*
  By putting together all class definitions and instatiations introduced so far, we obtain the
  temporal class structure for predicates on traces with arbitrary number of parameters.

  For example in the next lemma $r$ and $r'$ are predicate relations, and the operator
  always is available for them as a consequence of the above construction.
*}

  lemma "(\<box> r) OO (\<box> r') \<le> (\<box> (r OO r'))"
    by (simp add: le_fun_def always_def at_fun_def, auto)

  end


theory DBM
  imports Floyd_Warshall Timed_Automata
begin

chapter \<open>Difference Bound Matrices\<close>

section \<open>Definitions\<close>

text \<open>
  Difference Bound Matrices (DBMs) constrain differences of clocks
  (or more precisely, the difference of values assigned to individual clocks by a valuation).
  The possible constraints are given by the following datatype:
\<close>

datatype ('t::time) DBMEntry = Le 't | Lt 't | INF ("\<infinity>")

text \<open>\noindent This yields a simple definition of DBMs:\<close>

type_synonym 't DBM = "nat \<Rightarrow> nat \<Rightarrow> 't DBMEntry"

text \<open>\noindent
  To relate clocks with rows and columns of
  a DBM, we use a clock numbering \<open>v\<close> of type @{typ "'c \<Rightarrow> nat"} to map clocks to indices.
  DBMs will regularly be  accompanied by a natural number $n$,
  which designates the number of clocks constrained by the matrix.
  To be able to represent the full set of clock constraints with DBMs, we add an imaginary
  clock \<open>\<zero>\<close>, which shall be assigned to 0 in every valuation.
  In the following predicate we explicitly keep track of \<open>\<zero>\<close>.
\<close>

inductive dbm_entry_val :: "('c, 't) cval \<Rightarrow> 'c option \<Rightarrow> 'c option \<Rightarrow> ('t::time) DBMEntry \<Rightarrow> bool"
where
  "u r \<le> d \<Longrightarrow> dbm_entry_val u (Some r) None (Le d)" |
  "-u c \<le> d \<Longrightarrow> dbm_entry_val u None (Some c) (Le d)" |
  "u r < d \<Longrightarrow> dbm_entry_val u (Some r) None (Lt d)" |
  "-u c < d \<Longrightarrow> dbm_entry_val u None (Some c) (Lt d)" |
  "u r - u c \<le> d \<Longrightarrow> dbm_entry_val u (Some r) (Some c) (Le d)" |
  "u r - u c < d \<Longrightarrow> dbm_entry_val u (Some r) (Some c) (Lt d)" |
  "dbm_entry_val _ _ _ \<infinity>"

declare dbm_entry_val.intros[intro]
inductive_cases[elim!]: "dbm_entry_val u None (Some c) (Le d)"
inductive_cases[elim!]: "dbm_entry_val u (Some c) None (Le d)"
inductive_cases[elim!]: "dbm_entry_val u None (Some c) (Lt d)"
inductive_cases[elim!]: "dbm_entry_val u (Some c) None (Lt d)"
inductive_cases[elim!]: "dbm_entry_val u (Some r) (Some c) (Le d)"
inductive_cases[elim!]: "dbm_entry_val u (Some r) (Some c) (Lt d)"

fun dbm_entry_bound :: "('t::time) DBMEntry \<Rightarrow> 't"
where
  "dbm_entry_bound (Le t) = t" |
  "dbm_entry_bound (Lt t) = t" |
  "dbm_entry_bound \<infinity> = 0"

inductive dbm_lt :: "('t::time) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> bool"
("_ \<prec> _" [51, 51] 50)
where
  "dbm_lt (Lt _) \<infinity>" |
  "dbm_lt (Le _) \<infinity>" |
  "a < b  \<Longrightarrow> dbm_lt (Le a) (Le b)" |
  "a < b  \<Longrightarrow> dbm_lt (Le a) (Lt b)" |
  "a \<le> b  \<Longrightarrow> dbm_lt (Lt a) (Le b)" |
  "a < b  \<Longrightarrow> dbm_lt (Lt a) (Lt b)"

declare dbm_lt.intros[intro]

definition dbm_le :: "('t::time) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> bool"
("_ \<preceq> _" [51, 51] 50)
where
  "dbm_le a b \<equiv> (a \<prec> b) \<or> a = b"

text \<open>
  Now a valuation is contained in the zone represented by a DBM if it fulfills all individual
  constraints:
\<close>

definition DBM_val_bounded :: "('c \<Rightarrow> nat) \<Rightarrow> ('c, 't) cval \<Rightarrow> ('t::time) DBM \<Rightarrow> nat \<Rightarrow> bool"
where
  "DBM_val_bounded v u m n \<equiv> Le 0 \<preceq> m 0 0 \<and>
    (\<forall> c. v c \<le> n \<longrightarrow> (dbm_entry_val u None (Some c) (m 0 (v c))
                      \<and> dbm_entry_val u (Some c) None (m (v c) 0)))
    \<and> (\<forall> c1 c2. v c1 \<le> n \<and> v c2 \<le> n \<longrightarrow> dbm_entry_val u (Some c1) (Some c2) (m (v c1) (v c2)))"

abbreviation DBM_val_bounded_abbrev ::
  "('c, 't) cval \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('t::time) DBM \<Rightarrow> bool"
("_ \<turnstile>\<^bsub>_,_\<^esub> _")
where
  "u \<turnstile>\<^bsub>v,n\<^esub> M \<equiv> DBM_val_bounded v u M n"

abbreviation
  "dmin a b \<equiv> if a \<prec> b then a else b"

lemma dbm_le_dbm_min:
  "a \<preceq> b \<Longrightarrow> a = dmin a b" unfolding dbm_le_def
by auto

lemma dbm_lt_asym:
  assumes "e \<prec> f"
  shows "~ f \<prec> e"
using assms
proof (safe, cases e f rule: dbm_lt.cases, goal_cases)
  case 1 from this(2) show ?case using 1(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 2 from this(2) show ?case using 2(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 3 from this(2) show ?case using 3(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 4 from this(2) show ?case using 4(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 5 from this(2) show ?case using 5(3-) by (cases f e rule: dbm_lt.cases) auto
next
  case 6 from this(2) show ?case using 6(3-) by (cases f e rule: dbm_lt.cases) auto
qed

lemma dbm_le_dbm_min2:
  "a \<preceq> b \<Longrightarrow> a = dmin b a"
using dbm_lt_asym by (auto simp: dbm_le_def)

lemma dmb_le_dbm_entry_bound_inf:
  "a \<preceq> b \<Longrightarrow> a = \<infinity> \<Longrightarrow> b = \<infinity>"
apply (auto simp: dbm_le_def)
  apply (cases rule: dbm_lt.cases)
by auto

lemma dbm_not_lt_eq: "\<not> a \<prec> b \<Longrightarrow> \<not> b \<prec> a \<Longrightarrow> a = b"
apply (cases a)
  apply (cases b, fastforce+)+
done

lemma dbm_not_lt_impl: "\<not> a \<prec> b \<Longrightarrow> b \<prec> a \<or> a = b" using dbm_not_lt_eq by auto

lemma "dmin a b = dmin b a"
proof (cases "a \<prec> b")
  case True thus ?thesis by (simp add: dbm_lt_asym)
next
  case False thus ?thesis by (simp add: dbm_not_lt_eq)
qed

lemma dbm_lt_trans: "a \<prec> b \<Longrightarrow> b \<prec> c \<Longrightarrow> a \<prec> c"
proof (cases a b rule: dbm_lt.cases, goal_cases)
  case 1 thus ?case by simp
next
  case 2 from this(2-) show ?case by (cases rule: dbm_lt.cases) simp+
next
  case 3 from this(2-) show ?case by (cases rule: dbm_lt.cases) simp+
next
  case 4 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 5 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 6 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
next
  case 7 from this(2-) show ?case by (cases rule: dbm_lt.cases) auto
qed

lemma aux_3: "\<not> a \<prec> b \<Longrightarrow> \<not> b \<prec> c \<Longrightarrow> a \<prec> c \<Longrightarrow> c = a"
proof goal_cases
  case 1 thus ?case
  proof (cases "c \<prec> b")
    case True
    with \<open>a \<prec> c\<close> have "a \<prec> b" by (rule dbm_lt_trans)
    thus ?thesis using 1 by auto
  next
    case False thus ?thesis using dbm_not_lt_eq 1 by auto
  qed
qed

inductive_cases[elim!]: "\<infinity> \<prec> x"

lemma dbm_lt_asymmetric[simp]: "x \<prec> y \<Longrightarrow> y \<prec> x \<Longrightarrow> False"
by (cases x y rule: dbm_lt.cases) (auto elim: dbm_lt.cases)

lemma le_dbm_le: "Le a \<preceq> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma le_dbm_lt: "Le a \<preceq> Lt b \<Longrightarrow> a < b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma lt_dbm_le: "Lt a \<preceq> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma lt_dbm_lt: "Lt a \<preceq> Lt b \<Longrightarrow> a \<le> b" unfolding dbm_le_def by (auto elim: dbm_lt.cases)

lemma not_dbm_le_le_impl: "\<not> Le a \<prec> Le b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(3) not_less)

lemma not_dbm_lt_le_impl: "\<not> Lt a \<prec> Le b \<Longrightarrow> a > b" by (metis dbm_lt.intros(5) not_less)

lemma not_dbm_lt_lt_impl: "\<not> Lt a \<prec> Lt b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(6) not_less)

lemma not_dbm_le_lt_impl: "\<not> Le a \<prec> Lt b \<Longrightarrow> a \<ge> b" by (metis dbm_lt.intros(4) not_less)

(*>*)

(*<*)

fun dbm_add :: "('t::time) DBMEntry \<Rightarrow> 't DBMEntry \<Rightarrow> 't DBMEntry" (infixl "\<otimes>" 70)
where
  "dbm_add \<infinity>     _      = \<infinity>" |
  "dbm_add _      \<infinity>     = \<infinity>" |
  "dbm_add (Le a) (Le b) = (Le (a+b))" |
  "dbm_add (Le a) (Lt b) = (Lt (a+b))" |
  "dbm_add (Lt a) (Le b) = (Lt (a+b))" |
  "dbm_add (Lt a) (Lt b) = (Lt (a+b))"

thm dbm_add.simps

lemma aux_4: "x \<prec> y \<Longrightarrow> \<not> dbm_add x z \<prec> dbm_add y z \<Longrightarrow> dbm_add x z = dbm_add y z"
by (cases x y rule: dbm_lt.cases) ((cases z), auto)+

lemma aux_5: "\<not> x \<prec> y \<Longrightarrow> dbm_add x z \<prec> dbm_add y z \<Longrightarrow> dbm_add y z = dbm_add x z"
proof -
  assume lt: "dbm_add x z \<prec> dbm_add y z" "\<not> x \<prec> y"
  hence "x = y \<or> y \<prec> x" by (auto simp: dbm_not_lt_eq)
  thus ?thesis
  proof
    assume "x = y" thus ?thesis by simp
  next
    assume "y \<prec> x"
    thus ?thesis
    proof (cases y x rule: dbm_lt.cases, goal_cases)
      case 1 thus ?case using lt by auto
    next
      case 2 thus ?case using lt by auto
    next
      case 3 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 4 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 5 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 6 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    qed
  qed
qed

lemma aux_42: "x \<prec> y \<Longrightarrow> \<not> dbm_add z x \<prec> dbm_add z y \<Longrightarrow> dbm_add z x = dbm_add z y"
by (cases x y rule: dbm_lt.cases) ((cases z), auto)+

lemma aux_52: "\<not> x \<prec> y \<Longrightarrow> dbm_add z x \<prec> dbm_add z y \<Longrightarrow> dbm_add z y = dbm_add z x"
proof -
  assume lt: "dbm_add z x \<prec> dbm_add z y" "\<not> x \<prec> y"
  hence "x = y \<or> y \<prec> x" by (auto simp: dbm_not_lt_eq)
  thus ?thesis
  proof
    assume "x = y" thus ?thesis by simp
  next
    assume "y \<prec> x"
    thus ?thesis
    proof (cases y x rule: dbm_lt.cases, goal_cases)
      case 1 thus ?case using lt by (cases z) fastforce+
    next
      case 2 thus ?case using lt by (cases z) fastforce+
    next
      case 3 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 4 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 5 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    next
      case 6 thus ?case using dbm_lt_asymmetric lt(1) by (cases z) fastforce+
    qed
  qed
qed

lemma dbm_add_not_inf:
  "a \<noteq> \<infinity> \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> dbm_add a b \<noteq> \<infinity>"
by (cases a, auto, cases b, auto, cases b, auto)

lemma dbm_le_not_inf:
  "a \<preceq> b \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> a \<noteq> \<infinity>"
by (cases "a = b") (auto simp: dbm_le_def)

section \<open>DBM Entries Form a Linearly Ordered Abelian Monoid\<close>

instantiation DBMEntry :: (time) linorder
begin
  definition less_eq: "(\<le>) \<equiv> dbm_le"
  definition less: "(<) = dbm_lt"
  instance
  proof ((standard; unfold less less_eq), goal_cases)
    case 1 thus ?case unfolding dbm_le_def using dbm_lt_asymmetric by auto
  next
    case 2 thus ?case by (simp add: dbm_le_def)
  next
    case 3 thus ?case unfolding dbm_le_def using dbm_lt_trans by auto
  next
    case 4 thus ?case unfolding dbm_le_def using dbm_lt_asymmetric by auto
  next
    case 5 thus ?case unfolding dbm_le_def using dbm_not_lt_eq by auto
  qed
end

instantiation DBMEntry :: (time) linordered_ab_monoid_add
begin
  definition mult: "(+) = dbm_add"
  definition neutral: "neutral = Le 0"
  instance proof ((standard; unfold mult neutral less less_eq), goal_cases)
    case (1 a b c) thus ?case by (cases a; cases b; cases c; auto)
  next
    case (2 a b) thus ?case by (cases a; cases b) auto
  next
    case (3 a b c)
    thus ?case unfolding dbm_le_def
    apply safe
     apply (rule dbm_lt.cases)
          apply assumption
    by (cases c; fastforce)+
  next
    case (4 x) thus ?case by (cases x) auto
  next
    case (5 x) thus ?case by (cases x) auto
  qed
end

interpretation linordered_monoid: linordered_ab_monoid_add dbm_add dbm_le dbm_lt "Le 0"
  apply (standard, fold neutral mult less_eq less)
using add.commute add.commute add_left_mono assoc by auto

lemma Le_Le_dbm_lt_D[dest]: "Le a \<prec> Lt b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto
lemma Le_Lt_dbm_lt_D[dest]: "Le a \<prec> Le b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto
lemma Lt_Le_dbm_lt_D[dest]: "Lt a \<prec> Le b \<Longrightarrow> a \<le> b" by (cases rule: dbm_lt.cases) auto
lemma Lt_Lt_dbm_lt_D[dest]: "Lt a \<prec> Lt b \<Longrightarrow> a < b" by (cases rule: dbm_lt.cases) auto

lemma Le_le_LeI[intro]: "a \<le> b \<Longrightarrow> Le a \<le> Le b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LeI[intro]: "a \<le> b \<Longrightarrow> Lt a \<le> Le b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LtI[intro]: "a \<le> b \<Longrightarrow> Lt a \<le> Lt b" unfolding less_eq dbm_le_def by auto
lemma Le_le_LtI[intro]: "a < b \<Longrightarrow> Le a \<le> Lt b" unfolding less_eq dbm_le_def by auto
lemma Lt_lt_LeI: "x \<le> y \<Longrightarrow> Lt x < Le y" unfolding less by auto

lemma Le_le_LeD[dest]: "Le a \<le> Le b \<Longrightarrow> a \<le> b" unfolding dbm_le_def less_eq by auto
lemma Le_le_LtD[dest]: "Le a \<le> Lt b \<Longrightarrow> a < b" unfolding dbm_le_def less_eq by auto
lemma Lt_le_LeD[dest]: "Lt a \<le> Le b \<Longrightarrow> a \<le> b" unfolding less_eq dbm_le_def by auto
lemma Lt_le_LtD[dest]: "Lt a \<le> Lt b \<Longrightarrow> a \<le> b" unfolding less_eq dbm_le_def by auto

lemma inf_not_le_Le[simp]: "\<infinity> \<le> Le x = False" unfolding less_eq dbm_le_def by auto
lemma inf_not_le_Lt[simp]: "\<infinity> \<le> Lt x = False" unfolding less_eq dbm_le_def by auto
lemma inf_not_lt[simp]: "\<infinity> \<prec> x = False" by auto

lemma any_le_inf: "x \<le> \<infinity>" by (metis less_eq dmb_le_dbm_entry_bound_inf le_cases)

section \<open>Basic Properties of DBMs\<close>

subsection \<open>DBMs and Length of Paths\<close>

lemma dbm_entry_val_add_1: "dbm_entry_val u (Some c) (Some d) a \<Longrightarrow>  dbm_entry_val u (Some d) None b
       \<Longrightarrow> dbm_entry_val u (Some c) None (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   apply (simp add: dbm_entry_val.intros(3) diff_less_eq less_le_trans)
  by (metis add_le_less_mono dbm_entry_val.intros(3) diff_add_cancel less_imp_le)
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_2: "dbm_entry_val u None (Some c) a \<Longrightarrow> dbm_entry_val u (Some c) (Some d) b
       \<Longrightarrow> dbm_entry_val u None (Some d) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_3:
  "dbm_entry_val u (Some c) (Some d) a \<Longrightarrow>  dbm_entry_val u (Some d) (Some e) b
   \<Longrightarrow> dbm_entry_val u (Some c) (Some e) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

lemma dbm_entry_val_add_4:
  "dbm_entry_val u (Some c) None a \<Longrightarrow> dbm_entry_val u None (Some d) b
   \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (dbm_add a b)"
proof (cases a, goal_cases)
  case 1 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_semiring(1) apply fastforce
  using add_le_less_mono by fastforce
next
  case 2 thus ?thesis
  apply (cases b)
    apply auto
   using add_mono_thms_linordered_field(3) apply fastforce
  using add_strict_mono by fastforce
next
  case 3 thus ?thesis by (cases b) auto
qed

no_notation dbm_add (infixl "\<otimes>" 70)

lemma DBM_val_bounded_len_1'_aux:
  assumes "DBM_val_bounded v u m n" "v c \<le> n" "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (Some c) None (len m (v c) 0 vs)" using assms
proof (induction vs arbitrary: c)
  case Nil then show ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with Cons have "dbm_entry_val u (Some c') None (len m (v c') 0 vs)" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems c'
  by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) None (m (v c) (v c') + len m (v c') 0 vs)"
  using dbm_entry_val_add_1 unfolding mult by fastforce
  with c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_3'_aux:
  "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> v d \<le> n \<Longrightarrow> \<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)
   \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (len m (v c) (v d) vs)"
proof (induction vs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with Cons have "dbm_entry_val u (Some c') (Some d) (len m (v c') (v d) vs)" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems c'
  by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) (Some d) (m (v c) (v c') + len m (v c') (v d) vs)"
  using dbm_entry_val_add_3 unfolding mult by fastforce
  with c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_2'_aux:
  "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)
  \<Longrightarrow> dbm_entry_val u None (Some c) (len m 0 (v c) vs)"
proof (cases vs, goal_cases)
  case 1 then show ?thesis unfolding DBM_val_bounded_def by auto
next
  case (2 k vs)
  then obtain c' where c': "k > 0" "k \<le> n" "v c' = k" by auto
  with 2 have "dbm_entry_val u (Some c') (Some c) (len m (v c') (v c) vs)"
  using DBM_val_bounded_len_3'_aux by auto
  moreover have "dbm_entry_val u None (Some c') (m 0 (v c'))"
  using 2 c' by (auto simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u None (Some c) (m 0 (v c') + len m (v c') (v c) vs)"
  using dbm_entry_val_add_2 unfolding mult by fastforce
  with 2(4) c' show ?case unfolding DBM_val_bounded_def by simp
qed

lemma cnt_0_D:
  "cnt x xs = 0 \<Longrightarrow> x \<notin> set xs"
apply (induction xs)
 apply simp
apply (rename_tac a xs)
apply (case_tac "x = a")
by simp+

lemma cnt_at_most_1_D:
  "cnt x (xs @ x # ys) \<le> 1 \<Longrightarrow> x \<notin> set xs \<and> x \<notin> set ys"
apply (induction xs)
  apply auto[]
  using cnt_0_D apply force
 apply (rename_tac a xs)
 apply (case_tac "a = x")
  apply simp
 apply simp
done

lemma nat_list_0 [intro]:
  "x \<in> set xs \<Longrightarrow> 0 \<notin> set (xs :: nat list) \<Longrightarrow> x > 0"
by (induction xs) auto

lemma DBM_val_bounded_len':
  fixes v
  defines "vo \<equiv> \<lambda> k. if k = 0 then None else Some (SOME c. v c = k)"
  assumes "DBM_val_bounded v u m n" "cnt 0 (i # j # vs) \<le> 1"
          "\<forall> k \<in> set (i # j # vs). k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (vo i) (vo j) (len m i j vs)"
proof -
  show ?thesis
  proof (cases "\<forall> k \<in> set vs. k > 0")
    case True
    with assms have *: "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)" by auto
    show ?thesis
    proof (cases "i = 0")
      case True
      then have i: "vo i = None" by (simp add: vo_def)
      show ?thesis
      proof (cases "j = 0")
        case True with assms \<open>i = 0\<close> show ?thesis by auto
      next
        case False
        with assms obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with \<open>i = 0\<close> i DBM_val_bounded_len_2'_aux[OF assms(2) _ *] show ?thesis by auto
      qed
    next
      case False
      with assms(4) obtain c1 where c1: "i \<le> n" "v c1 = i" "vo i = Some c1"
      unfolding vo_def by (fastforce intro: someI)
      show ?thesis
      proof (cases "j = 0")
        case True
        with DBM_val_bounded_len_1'_aux[OF assms(2) _ *] c1 show ?thesis by (auto simp: vo_def)
      next
        case False
        with assms obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with c1 DBM_val_bounded_len_3'_aux[OF assms(2) _ _ *] show ?thesis by auto
      qed
    qed
  next
    case False
    then have "\<exists> k \<in> set vs. k = 0" by auto
    then obtain us ws where vs: "vs = us @ 0 # ws" by (meson split_list_last)
    with cnt_at_most_1_D[of 0 "i # j # us"] assms(3) have
      "0 \<notin> set us" "0 \<notin> set ws" "i \<noteq> 0" "j \<noteq> 0"
    by auto
    with vs have vs: "vs = us @ 0 # ws" "\<forall> k \<in> set us. k > 0" "\<forall> k \<in> set ws. k > 0" by auto
    with assms(4) have v:
      "\<forall>k\<in>set us. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)" "\<forall>k\<in>set ws. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)"
    by auto
    from \<open>i \<noteq> 0\<close> \<open>j \<noteq> 0\<close> assms obtain c1 c2 where
      c1: "i \<le> n" "v c1 = i" "vo i = Some c1" and c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
    unfolding vo_def by (fastforce intro: someI)
    with dbm_entry_val_add_4 [OF DBM_val_bounded_len_1'_aux[OF assms(2) _ v(1)] DBM_val_bounded_len_2'_aux[OF assms(2) _ v(2)]]
    have "dbm_entry_val u (Some c1) (Some c2) (dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws))" by auto
    moreover from vs have "len m (v c1) (v c2) vs = dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws)"
    by (simp add: len_comp mult)
    ultimately show ?thesis using c1 c2 by auto
  qed
qed

lemma DBM_val_bounded_len'2:
  fixes v
  assumes "DBM_val_bounded v u m n" "0 \<notin> set vs" "v c \<le> n"
          "\<forall> k \<in> set vs. k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u None (Some c) (len m 0 (v c) vs)"
using DBM_val_bounded_len_2'_aux[OF assms(1,3)] assms(2,4) by fastforce

lemma DBM_val_bounded_len'3:
  fixes v
  assumes "DBM_val_bounded v u m n" "cnt 0 vs \<le> 1" "v c1 \<le> n" "v c2 \<le> n"
          "\<forall> k \<in> set vs. k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (Some c1) (Some c2) (len m (v c1) (v c2) vs)"
proof -
  show ?thesis
  proof (cases "\<forall> k \<in> set vs. k > 0")
    case True
    with assms have "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)" by auto
    with DBM_val_bounded_len_3'_aux[OF assms(1,3,4)] show ?thesis by auto
  next
    case False
    then have "\<exists> k \<in> set vs. k = 0" by auto
    then obtain us ws where vs: "vs = us @ 0 # ws" by (meson split_list_last)
    with cnt_at_most_1_D[of 0 "us"] assms(2) have
      "0 \<notin> set us" "0 \<notin> set ws"
    by auto
    with vs have vs: "vs = us @ 0 # ws" "\<forall> k \<in> set us. k > 0" "\<forall> k \<in> set ws. k > 0" by auto
    with assms(5) have v:
      "\<forall>k\<in>set us. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)" "\<forall>k\<in>set ws. 0 < k \<and> k \<le> n \<and> (\<exists>c. v c = k)"
    by auto
    with dbm_entry_val_add_4 [OF DBM_val_bounded_len_1'_aux[OF assms(1,3) v(1)] DBM_val_bounded_len_2'_aux[OF assms(1,4) v(2)]]
    have "dbm_entry_val u (Some c1) (Some c2) (dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws))" by auto
    moreover from vs have "len m (v c1) (v c2) vs = dbm_add (len m (v c1) 0 us) (len m 0 (v c2) ws)"
    by (simp add: len_comp mult)
    ultimately show ?thesis by auto
  qed
qed

lemma DBM_val_bounded_len'':
  fixes v
  defines "vo \<equiv> \<lambda> k. if k = 0 then None else Some (SOME c. v c = k)"
  assumes "DBM_val_bounded v u m n" "i \<noteq> 0 \<or> j \<noteq> 0"
          "\<forall> k \<in> set (i # j # vs). k > 0 \<longrightarrow> k \<le> n \<and> (\<exists> c. v c = k)"
  shows "dbm_entry_val u (vo i) (vo j) (len m i j vs)" using assms
proof (induction "length vs" arbitrary: i vs rule: less_induct)
  case less
  show ?case
  proof (cases "\<forall> k \<in> set vs. k > 0")
    case True
    with less.prems have *: "\<forall> k \<in> set vs. k > 0 \<and> k \<le> n \<and> (\<exists> c. v c = k)" by auto
    show ?thesis
    proof (cases "i = 0")
      case True
      then have i: "vo i = None" by (simp add: vo_def)
      show ?thesis
      proof (cases "j = 0")
        case True with less.prems \<open>i = 0\<close> show ?thesis by auto
      next
        case False
        with less.prems obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with \<open>i = 0\<close> i DBM_val_bounded_len_2'_aux[OF less.prems(1) _ *] show ?thesis by auto
      qed
    next
      case False
      with less.prems obtain c1 where c1: "i \<le> n" "v c1 = i" "vo i = Some c1"
      unfolding vo_def by (fastforce intro: someI)
      show ?thesis
      proof (cases "j = 0")
        case True
        with DBM_val_bounded_len_1'_aux[OF less.prems(1) _ *] c1 show ?thesis by (auto simp: vo_def)
      next
        case False
        with less.prems obtain c2 where c2: "j \<le> n" "v c2 = j" "vo j = Some c2"
        unfolding vo_def by (fastforce intro: someI)
        with c1 DBM_val_bounded_len_3'_aux[OF less.prems(1) _ _ *] show ?thesis by auto
      qed
    qed
  next
    case False
    then have "\<exists> us ws. vs = us @ 0 # ws \<and> (\<forall> k \<in> set us. k > 0)"
    proof (induction vs)
      case Nil then show ?case by auto
    next
      case (Cons x vs)
      show ?case
      proof (cases "x = 0")
        case True then show ?thesis by fastforce
      next
        case False
        with Cons.prems have "\<not> (\<forall>a\<in>set vs. 0 < a)" by auto
        from Cons.IH[OF this] obtain us ws where "vs = us @ 0 # ws" "\<forall>a\<in>set us. 0 < a" by auto
        with False have "x # vs = (x # us) @ 0 # ws" "\<forall>a\<in>set (x # us). 0 < a" by auto
        then show ?thesis by blast
      qed
    qed
    then obtain us ws where vs: "vs = us @ 0 # ws" "\<forall> k \<in> set us. k > 0" by blast
    then show ?thesis
oops

lemma DBM_val_bounded_len_1: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u (Some c) None (len m (v c) 0 (map v cs))"
proof (induction cs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons c' cs)
  hence "dbm_entry_val u (Some c') None (len m (v c') 0 (map v cs))" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems
  by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) None (m (v c) (v c') + len m (v c') 0 (map v cs))"
  using dbm_entry_val_add_1 unfolding mult by fastforce
  thus ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_3: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> v d \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u (Some c) (Some d) (len m (v c) (v d) (map v cs))"
proof (induction cs arbitrary: c)
  case Nil thus ?case unfolding DBM_val_bounded_def by auto
next
  case (Cons c' cs)
  hence "dbm_entry_val u (Some c') (Some d) (len m (v c') (v d) (map v cs))" by auto
  moreover have "dbm_entry_val u (Some c) (Some c') (m (v c) (v c'))" using Cons.prems
  by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u (Some c) (Some d) (m (v c) (v c') + len m (v c') (v d) (map v cs))"
  using dbm_entry_val_add_3 unfolding mult by fastforce
  thus ?case unfolding DBM_val_bounded_def by simp
qed

lemma DBM_val_bounded_len_2: "DBM_val_bounded v u m n \<Longrightarrow> v c \<le> n \<Longrightarrow> \<forall> c \<in> set cs. v c \<le> n
      \<Longrightarrow> dbm_entry_val u None (Some c) (len m 0 (v c) (map v cs))"
proof (cases cs, goal_cases)
  case 1 thus ?thesis unfolding DBM_val_bounded_def by auto
next
  case (2 c' cs)
  hence "dbm_entry_val u (Some c') (Some c) (len m (v c') (v c) (map v cs))"
  using DBM_val_bounded_len_3 by auto
  moreover have "dbm_entry_val u None (Some c') (m 0 (v c'))"
  using 2 by (simp add: DBM_val_bounded_def)
  ultimately have "dbm_entry_val u None (Some c) (m 0 (v c') + len m (v c') (v c) (map v cs))"
  using dbm_entry_val_add_2 unfolding mult by fastforce
  thus ?case using 2(4) unfolding DBM_val_bounded_def by simp
qed

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Common discrete functions\<close>

theory Discrete
imports Main
begin

subsection \<open>Discrete logarithm\<close>

context
begin

qualified fun log :: "nat \<Rightarrow> nat"
  where [simp del]: "log n = (if n < 2 then 0 else Suc (log (n div 2)))"

lemma log_induct [consumes 1, case_names one double]:
  fixes n :: nat
  assumes "n > 0"
  assumes one: "P 1"
  assumes double: "\<And>n. n \<ge> 2 \<Longrightarrow> P (n div 2) \<Longrightarrow> P n"
  shows "P n"
using \<open>n > 0\<close> proof (induct n rule: log.induct)
  fix n
  assume "\<not> n < 2 \<Longrightarrow>
          0 < n div 2 \<Longrightarrow> P (n div 2)"
  then have *: "n \<ge> 2 \<Longrightarrow> P (n div 2)" by simp
  assume "n > 0"
  show "P n"
  proof (cases "n = 1")
    case True
    with one show ?thesis by simp
  next
    case False
    with \<open>n > 0\<close> have "n \<ge> 2" by auto
    with * have "P (n div 2)" .
    with \<open>n \<ge> 2\<close> show ?thesis by (rule double)
  qed
qed

lemma log_zero [simp]: "log 0 = 0"
  by (simp add: log.simps)

lemma log_one [simp]: "log 1 = 0"
  by (simp add: log.simps)

lemma log_Suc_zero [simp]: "log (Suc 0) = 0"
  using log_one by simp

lemma log_rec: "n \<ge> 2 \<Longrightarrow> log n = Suc (log (n div 2))"
  by (simp add: log.simps)

lemma log_twice [simp]: "n \<noteq> 0 \<Longrightarrow> log (2 * n) = Suc (log n)"
  by (simp add: log_rec)

lemma log_half [simp]: "log (n div 2) = log n - 1"
proof (cases "n < 2")
  case True
  then have "n = 0 \<or> n = 1" by arith
  then show ?thesis by (auto simp del: One_nat_def)
next
  case False
  then show ?thesis by (simp add: log_rec)
qed

lemma log_exp [simp]: "log (2 ^ n) = n"
  by (induct n) simp_all

lemma log_mono: "mono log"
proof
  fix m n :: nat
  assume "m \<le> n"
  then show "log m \<le> log n"
  proof (induct m arbitrary: n rule: log.induct)
    case (1 m)
    then have mn2: "m div 2 \<le> n div 2" by arith
    show "log m \<le> log n"
    proof (cases "m \<ge> 2")
      case False
      then have "m = 0 \<or> m = 1" by arith
      then show ?thesis by (auto simp del: One_nat_def)
    next
      case True then have "\<not> m < 2" by simp
      with mn2 have "n \<ge> 2" by arith
      from True have m2_0: "m div 2 \<noteq> 0" by arith
      with mn2 have n2_0: "n div 2 \<noteq> 0" by arith
      from \<open>\<not> m < 2\<close> "1.hyps" mn2 have "log (m div 2) \<le> log (n div 2)" by blast
      with m2_0 n2_0 have "log (2 * (m div 2)) \<le> log (2 * (n div 2))" by simp
      with m2_0 n2_0 \<open>m \<ge> 2\<close> \<open>n \<ge> 2\<close> show ?thesis by (simp only: log_rec [of m] log_rec [of n]) simp
    qed
  qed
qed

lemma log_exp2_le:
  assumes "n > 0"
  shows "2 ^ log n \<le> n"
  using assms
proof (induct n rule: log_induct)
  case one
  then show ?case by simp
next
  case (double n)
  with log_mono have "log n \<ge> Suc 0"
    by (simp add: log.simps)
  assume "2 ^ log (n div 2) \<le> n div 2"
  with \<open>n \<ge> 2\<close> have "2 ^ (log n - Suc 0) \<le> n div 2" by simp
  then have "2 ^ (log n - Suc 0) * 2 ^ 1 \<le> n div 2 * 2" by simp
  with \<open>log n \<ge> Suc 0\<close> have "2 ^ log n \<le> n div 2 * 2"
    unfolding power_add [symmetric] by simp
  also have "n div 2 * 2 \<le> n" by (cases "even n") simp_all
  finally show ?case .
qed

subsection \<open>Discrete square root\<close>

qualified definition sqrt :: "nat \<Rightarrow> nat"
  where "sqrt n = Max {m. m\<^sup>2 \<le> n}"

lemma sqrt_aux:
  fixes n :: nat
  shows "finite {m. m\<^sup>2 \<le> n}" and "{m. m\<^sup>2 \<le> n} \<noteq> {}"
proof -
  { fix m
    assume "m\<^sup>2 \<le> n"
    then have "m \<le> n"
      by (cases m) (simp_all add: power2_eq_square)
  } note ** = this
  then have "{m. m\<^sup>2 \<le> n} \<subseteq> {m. m \<le> n}" by auto
  then show "finite {m. m\<^sup>2 \<le> n}" by (rule finite_subset) rule
  have "0\<^sup>2 \<le> n" by simp
  then show *: "{m. m\<^sup>2 \<le> n} \<noteq> {}" by blast
qed

lemma sqrt_unique:
  assumes "m^2 \<le> n" "n < (Suc m)^2"
  shows   "Discrete.sqrt n = m"
proof -
  have "m' \<le> m" if "m'^2 \<le> n" for m'
  proof -
    note that
    also note assms(2)
    finally have "m' < Suc m" by (rule power_less_imp_less_base) simp_all
    thus "m' \<le> m" by simp
  qed
  with \<open>m^2 \<le> n\<close> sqrt_aux[of n] show ?thesis unfolding Discrete.sqrt_def
    by (intro antisym Max.boundedI Max.coboundedI) simp_all
qed

lemma sqrt_code[code]: "sqrt n = Max (Set.filter (\<lambda>m. m\<^sup>2 \<le> n) {0..n})"
proof -
  from power2_nat_le_imp_le [of _ n] have "{m. m \<le> n \<and> m\<^sup>2 \<le> n} = {m. m\<^sup>2 \<le> n}" by auto
  then show ?thesis by (simp add: sqrt_def Set.filter_def)
qed

lemma sqrt_inverse_power2 [simp]: "sqrt (n\<^sup>2) = n"
proof -
  have "{m. m \<le> n} \<noteq> {}" by auto
  then have "Max {m. m \<le> n} \<le> n" by auto
  then show ?thesis
    by (auto simp add: sqrt_def power2_nat_le_eq_le intro: antisym)
qed

lemma sqrt_zero [simp]: "sqrt 0 = 0"
  using sqrt_inverse_power2 [of 0] by simp

lemma sqrt_one [simp]: "sqrt 1 = 1"
  using sqrt_inverse_power2 [of 1] by simp

lemma mono_sqrt: "mono sqrt"
proof
  fix m n :: nat
  have *: "0 * 0 \<le> m" by simp
  assume "m \<le> n"
  then show "sqrt m \<le> sqrt n"
    by (auto intro!: Max_mono \<open>0 * 0 \<le> m\<close> finite_less_ub simp add: power2_eq_square sqrt_def)
qed

lemma mono_sqrt': "m \<le> n \<Longrightarrow> Discrete.sqrt m \<le> Discrete.sqrt n"
  using mono_sqrt unfolding mono_def by auto

lemma sqrt_greater_zero_iff [simp]: "sqrt n > 0 \<longleftrightarrow> n > 0"
proof -
  have *: "0 < Max {m. m\<^sup>2 \<le> n} \<longleftrightarrow> (\<exists>a\<in>{m. m\<^sup>2 \<le> n}. 0 < a)"
    by (rule Max_gr_iff) (fact sqrt_aux)+
  show ?thesis
  proof
    assume "0 < sqrt n"
    then have "0 < Max {m. m\<^sup>2 \<le> n}" by (simp add: sqrt_def)
    with * show "0 < n" by (auto dest: power2_nat_le_imp_le)
  next
    assume "0 < n"
    then have "1\<^sup>2 \<le> n \<and> 0 < (1::nat)" by simp
    then have "\<exists>q. q\<^sup>2 \<le> n \<and> 0 < q" ..
    with * have "0 < Max {m. m\<^sup>2 \<le> n}" by blast
    then show "0 < sqrt n" by  (simp add: sqrt_def)
  qed
qed

lemma sqrt_power2_le [simp]: "(sqrt n)\<^sup>2 \<le> n" (* FIXME tune proof *)
proof (cases "n > 0")
  case False then show ?thesis by simp
next
  case True then have "sqrt n > 0" by simp
  then have "mono (times (Max {m. m\<^sup>2 \<le> n}))" by (auto intro: mono_times_nat simp add: sqrt_def)
  then have *: "Max {m. m\<^sup>2 \<le> n} * Max {m. m\<^sup>2 \<le> n} = Max (times (Max {m. m\<^sup>2 \<le> n}) ` {m. m\<^sup>2 \<le> n})"
    using sqrt_aux [of n] by (rule mono_Max_commute)
  have "Max (op * (Max {m. m * m \<le> n}) ` {m. m * m \<le> n}) \<le> n"
    apply (subst Max_le_iff)
    apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
    apply simp
    apply (metis le0 mult_0_right)
    apply auto
    proof -
      fix q
      assume "q * q \<le> n"
      show "Max {m. m * m \<le> n} * q \<le> n"
      proof (cases "q > 0")
        case False then show ?thesis by simp
      next
        case True then have "mono (times q)" by (rule mono_times_nat)
        then have "q * Max {m. m * m \<le> n} = Max (times q ` {m. m * m \<le> n})"
          using sqrt_aux [of n] by (auto simp add: power2_eq_square intro: mono_Max_commute)
        then have "Max {m. m * m \<le> n} * q = Max (times q ` {m. m * m \<le> n})" by (simp add: ac_simps)
        then show ?thesis
          apply simp
          apply (subst Max_le_iff)
          apply auto
          apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
          apply (metis \<open>q * q \<le> n\<close>)
          apply (metis \<open>q * q \<le> n\<close> le_cases mult_le_mono1 mult_le_mono2 order_trans)
          done
      qed
    qed
  with * show ?thesis by (simp add: sqrt_def power2_eq_square)
qed

lemma sqrt_le: "sqrt n \<le> n"
  using sqrt_aux [of n] by (auto simp add: sqrt_def intro: power2_nat_le_imp_le)

end

end


theory hw10
imports Main
begin

datatype trie = LeafF | LeafT | Node "trie * trie"

fun is_trie :: "nat \<Rightarrow> trie \<Rightarrow> bool"
  where
  "is_trie 0 (Node(x,y)) \<longleftrightarrow> False"
| "is_trie 0 _ \<longleftrightarrow> True"
| "is_trie (Suc n) LeafF \<longleftrightarrow> True"
| "is_trie (Suc n) LeafT \<longleftrightarrow> False"
| "is_trie (Suc n) (Node (x,y)) \<longleftrightarrow> is_trie n x \<and> is_trie n y"

text \<open>Hint: The following should evaluate to true!\<close>
value "is_trie 42 LeafF"
value "is_trie 2 (Node (LeafF,Node (LeafT,LeafF)))"
text \<open>Whereas these should be false\<close>
value "is_trie 42 LeafT" -- \<open>Wrong key length\<close>
value "is_trie 2 (Node (LeafT,Node (LeafT,LeafF)))" -- \<open>Wrong key length\<close>
value "is_trie 1 (Node (LeafT,Node (LeafF,LeafF)))" -- \<open>Superfluous node\<close>

fun isin :: "trie \<Rightarrow> bool list \<Rightarrow> bool"
  where
  "isin (Node (x,y)) [] = False"
| "isin LeafT [] = True"
| "isin LeafF _ = False"
| "isin (Node (x,y)) (b#bx) = (if b then isin y bx else isin x bx)"
| "isin LeafT (b#bx) = False"

value "isin (Node (LeafF,Node (LeafT,LeafF))) [True, False]"
value "isin LeafT []"
value "isin LeafF []"

fun ins :: "bool list \<Rightarrow> trie \<Rightarrow> trie"
  where
  "ins [] _ = LeafT"
| "ins (b#bx) LeafF = (if b then (Node (LeafF, ins bx LeafF)) else (Node ((ins bx LeafF), LeafF)))"
| "ins (b#bx) (Node (x,y)) = (if b then (Node (x, ins bx y)) else (Node ((ins bx x),y)))"
| "ins _ x = x"

value "ins [] LeafF"
value "ins [] LeafT"
value "ins [] (Node(LeafF,LeafT))"
value "ins [True] (Node(LeafF,LeafT))"
value "ins [False] (Node(LeafF,LeafT))"
value "ins [False, False] (Node (LeafF,Node (LeafF,LeafT)))"
value "ins [False] LeafF"
value "ins [True,True,True] (Node (LeafF,Node (LeafT,LeafF)))"

lemma aux1: "\<And>b bx x y bs.
       (\<And>bs n. is_trie n y \<Longrightarrow> length bx = n \<Longrightarrow> isin (ins bx y) bs = (bx = bs \<or> isin y bs)) \<Longrightarrow>
       (\<And>bs n. False \<Longrightarrow> is_trie n x \<Longrightarrow> length bx = n \<Longrightarrow> isin (ins bx x) bs = (bx = bs \<or> isin x bs)) \<Longrightarrow>
       b \<Longrightarrow> isin (Node (x, ins bx y)) bs \<Longrightarrow>
             \<not> isin (Node (x, y)) bs \<Longrightarrow> is_trie (length bx) x \<Longrightarrow> is_trie (length bx) y \<Longrightarrow> True # bx = bs"
 proof -
fix b :: bool and bx :: "bool list" and x :: trie and y :: trie and bsa :: "bool list"
assume a1: "isin (Node (x, ins bx y)) bsa"
assume a2: "\<not> isin (Node (x, y)) bsa"
assume a3: "\<And>bs n. \<lbrakk>is_trie n y; length bx = n\<rbrakk> \<Longrightarrow> isin (ins bx y) bs = (bx = bs \<or> isin y bs)"
assume a4: "is_trie (length bx) y"
have "bsa \<noteq> []"
using a1 by force
then show "True # bx = bsa"
  using a4 a3 a2 a1 by (metis (full_types) isin.simps(4) list.exhaust)
qed

lemma isin_ins1:
  assumes "is_trie n t" and "length as = n"
  shows "isin (ins as t) bs = (as = bs \<or> isin t bs)"
proof -
  show ?thesis using assms
    apply (induction as t arbitrary: bs n rule: ins.induct)
       apply (auto split:if_splits)
    using isin.elims(2) apply blast
    using is_trie.simps(1) isin.elims(2) apply blast
           apply (metis (full_types) is_trie.simps(2) is_trie.simps(4) isin.simps(1) isin.simps(3) isin.simps(4) length_0_conv length_Cons list.exhaust)
    using is_trie.elims(3) apply blast
         apply (smt Suc_length_conv ins.simps(2) is_trie.simps(2) is_trie.simps(4) isin.simps(1) isin.simps(3) isin.simps(4) length_0_conv length_Cons list.exhaust list.inject neq_Nil_conv)
    using is_trie.elims(3) apply blast

    using aux1 apply metis
      apply (metis isin.elims(2) isin.simps(4) trie.distinct(5))
     apply (smt isin.elims(2) isin.simps(4) trie.distinct(5))
    by (metis isin.elims(2) isin.simps(4) trie.distinct(5))
qed

lemma isin_ins2:
  assumes "is_trie n t" and "length as = n"
  shows "is_trie n (ins as t)"
proof -
  show ?thesis using assms
   apply (induction as t arbitrary: n rule: ins.induct)
       apply (auto split:if_splits)
    using is_trie.elims(3) apply blast
    using is_trie.elims(3) apply blast
    using is_trie.elims(3) apply blast
    using is_trie.elims(3) by blast
qed

lemma isin_ins:
  assumes "is_trie n t" and "length as = n"
  shows "isin (ins as t) bs = (as = bs \<or> isin t bs)"
    and "is_trie n (ins as t)"
  using assms(1) assms(2) isin_ins1 apply auto[1]
  by (simp add: assms(1) assms(2) isin_ins2)

fun node :: "trie \<times> trie \<Rightarrow> trie" where
  "node (x,y) = (if (x = LeafF \<and> y = LeafF) then LeafF else (Node(x,y)))"

fun delete2 :: "bool list \<Rightarrow> trie \<Rightarrow> trie" where
  "delete2 [] _ = LeafF"
| "delete2 (b#bx) LeafF = LeafF"
| "delete2 (b#bx) (Node (x,y)) = (if b then (node (x, delete2 bx y)) else (node ((delete2 bx x),y)))"
| "delete2 _ x = x"

lemma delaux1:
  assumes "is_trie n t" and "length as = n"
  shows "isin (delete2 as t) bs = (as\<noteq>bs \<and> isin t bs)"
proof -
  show ?thesis using assms
   apply (induction as t arbitrary: bs n rule: delete2.induct)
       apply (auto split!:if_splits)
              apply (metis gen_length_code(1) ins.simps(1) is_trie.simps(2) isin.simps(3) isin_ins1 length_code)
             apply (metis isin.elims(2) isin.simps(4) trie.distinct(5))
            apply (metis isin.elims(2) isin.simps(4) trie.distinct(5))
           apply (metis (full_types) isin.simps(1) isin.simps(3) isin.simps(4) list.exhaust)
          apply (smt isin.elims(2) isin.simps(4) trie.simps(7))
         apply (smt isin.elims(2) isin.simps(4) trie.simps(7))
        apply (metis isin.elims(2) isin.simps(4) trie.distinct(5))
       apply (metis isin.elims(2) isin.simps(4) trie.distinct(5))
      apply (metis (full_types) isin.simps(1) isin.simps(3) isin.simps(4) list.exhaust)
     apply (smt isin.elims(2) isin.simps(4) trie.simps(7))
    by (smt isin.elims(2) isin.simps(4) trie.simps(7))
qed

lemma delaux2:
  assumes "is_trie n t"
  shows"(is_trie n (delete2 as t))"
proof -
 show ?thesis using assms
   apply (induction as t arbitrary: n rule: delete2.induct)
      apply (auto split!:if_splits)
   using is_trie.elims(3) apply blast
   using is_trie.elims(3) apply blast
       apply (metis is_trie.simps(1) is_trie.simps(6) old.nat.exhaust)
      apply (metis is_trie.simps(1) is_trie.simps(6) not0_implies_Suc)
     apply (metis is_trie.elims(2) is_trie.simps(4) trie.simps(7))
    apply (metis is_trie.simps(1) is_trie.simps(6) old.nat.exhaust)
   by (metis is_trie.simps(1) is_trie.simps(6) not0_implies_Suc)
qed

lemma
  assumes "is_trie n t" and "length as = n"
  shows "isin (delete2 as t) bs = (as\<noteq>bs \<and> isin t bs)"
    and "(is_trie n (delete2 as t))"
  using assms(1) assms(2) delaux1 apply blast
  by (simp add: assms(1) delaux2)

end


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

section \<open>Arithmetic lemmas\<close>

theory More_Arithmetic
  imports Main "HOL-Library.Type_Length" "HOL-Library.Bit_Operations"
begin

declare iszero_0 [intro]

declare min.absorb1 [simp] min.absorb2 [simp]

lemma n_less_equal_power_2 [simp]:
  "n < 2 ^ n"
  by (fact less_exp)

lemma min_pm [simp]: "min a b + (a - b) = a"
  for a b :: nat
  by arith

lemma min_pm1 [simp]: "a - b + min a b = a"
  for a b :: nat
  by arith

lemma rev_min_pm [simp]: "min b a + (a - b) = a"
  for a b :: nat
  by arith

lemma rev_min_pm1 [simp]: "a - b + min b a = a"
  for a b :: nat
  by arith

lemma min_minus [simp]: "min m (m - k) = m - k"
  for m k :: nat
  by arith

lemma min_minus' [simp]: "min (m - k) m = m - k"
  for m k :: nat
  by arith

lemma nat_less_power_trans:
  fixes n :: nat
  assumes nv: "n < 2 ^ (m - k)"
  and     kv: "k \<le> m"
  shows "2 ^ k * n < 2 ^ m"
proof (rule order_less_le_trans)
  show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
    by (rule mult_less_mono2 [OF nv zero_less_power]) simp
  show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
    by (subst power_add [symmetric]) simp
qed

lemma nat_le_power_trans:
  fixes n :: nat
  shows "\<lbrakk>n \<le> 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> 2 ^ k * n \<le> 2 ^ m"
  by (metis le_add_diff_inverse mult_le_mono2 semiring_normalization_rules(26))

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 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 power_2_mult_step_le:
  "\<lbrakk>n' \<le> n; 2 ^ n' * k' < 2 ^ n * k\<rbrakk> \<Longrightarrow> 2 ^ n' * (k' + 1) \<le> 2 ^ n * (k::nat)"
  apply (cases "n'=n", simp)
   apply (metis Suc_leI le_refl mult_Suc_right mult_le_mono semiring_normalization_rules(7))
  apply (drule (1) le_neq_trans)
  apply clarsimp
  apply (subgoal_tac "\<exists>m. n = n' + m")
   prefer 2
   apply (simp add: le_Suc_ex)
  apply (clarsimp simp: power_add)
  apply (metis Suc_leI mult.assoc mult_Suc_right nat_mult_le_cancel_disj)
  done

lemma nat_mult_power_less_eq:
  "b > 0 \<Longrightarrow> (a * b ^ n < (b :: nat) ^ m) = (a < b ^ (m - n))"
  using mult_less_cancel2[where m = a and k = "b ^ n" and n="b ^ (m - n)"]
        mult_less_cancel2[where m="a * b ^ (n - m)" and k="b ^ m" and n=1]
  apply (simp only: power_add[symmetric] nat_minus_add_max)
  apply (simp only: power_add[symmetric] nat_minus_add_max ac_simps)
  apply (simp add: max_def split: if_split_asm)
  done

lemma diff_diff_less:
  "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
  by auto

lemma small_powers_of_2:
  \<open>x < 2 ^ (x - 1)\<close> if \<open>x \<ge> 3\<close> for x :: nat
proof -
  define m where \<open>m = x - 3\<close>
  with that have \<open>x = m + 3\<close>
    by simp
  moreover have \<open>m + 3 < 4 * 2 ^ m\<close>
    by (induction m) simp_all
  ultimately show ?thesis
    by simp
qed

end