section "Permutation Lemmas"

theory PermutationLemmas
imports "HOL-Library.Permutation" "HOL-Library.Multiset"
begin

  \<comment> \<open>following function is very close to that in multisets- now we can make the connection that x <~~> y iff the multiset of x is the same as that of y\<close>

subsection "perm, count equivalence"

primrec count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "count x [] = 0"
| "count x (y#ys) = (if x=y then 1 else 0) + count x ys"

lemma perm_count: "A <~~> B \<Longrightarrow> (\<forall> x. count x A = count x B)"
  by(induct set: perm) auto

lemma count_0: "(\<forall>x. count x B = 0) = (B = [])"
  by(induct B) auto

lemma count_Suc: "count a B = Suc m \<Longrightarrow> a : set B"
  apply(induct B)
   apply auto
  apply(case_tac "a = aa")
   apply auto
  done

lemma count_append: "count a (xs@ys) = count a xs + count a ys"
  by(induct xs) auto

lemma count_perm: "!! B. (\<forall> x. count x A = count x B) \<Longrightarrow> A <~~> B"
  apply(induct A)
  apply(simp add: count_0)
proof -
  fix a list B
  assume a: "\<And>B. \<forall>x. count x list = count x B \<Longrightarrow> list <~~> B"
    and b: "\<forall>x. count x (a # list) = count x B"
  from b have "a : set B"
    apply auto
    apply (drule_tac x=a in spec, simp) apply(metis count_Suc) done
  from split_list[OF this] obtain xs ys where B: "B = xs@a#ys" by blast
  let ?B' = "xs@ys"
  from b have "\<forall>x. count x list = count x ?B'" by(simp add: count_append B)
  from a[OF this] have c: "list <~~> xs@ys" .
  hence "a#list <~~> a#(xs@ys)" by rule
  also have "a#(xs@ys) <~~> xs@a#ys" by(rule perm_append_Cons)
  also (perm.trans) note B[symmetric]
  finally show "a # list <~~> B" .
qed

lemma perm_count_conv: "A <~~> B = (\<forall> x. count x A = count x B)"
  apply(blast intro!: perm_count count_perm) done

subsection "Properties closed under Perm and Contr hold for x iff hold for remdups x"

lemma remdups_append: "y : set ys --> remdups (ws@y#ys) = remdups (ws@ys)"
  apply (induct ws, simp)
  apply (case_tac "y = a", simp, simp)
  done

lemma perm_contr': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr'[rule_format]: "! x xs. P(x#x#xs) = P (x#xs)"
  shows "! xs. length xs = n --> (P xs = P (remdups xs))"
  apply(induct n rule: nat_less_induct)
proof (safe)
  fix xs :: "'a list"
  assume a[rule_format]: "\<forall>m<length xs. \<forall>ys. length ys = m \<longrightarrow> P ys = P (remdups ys)"
  show "P xs = P (remdups xs)"
  proof (cases "distinct xs")
    case True
    thus ?thesis by(simp add:distinct_remdups_id)
  next
    case False
    from not_distinct_decomp[OF this] obtain ws ys zs y where xs: "xs = ws@[y]@ys@[y]@zs" by force
    have "P xs = P (ws@[y]@ys@[y]@zs)" by (simp add: xs)
    also have "... = P ([y,y]@ws@ys@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
    also have "... = P ([y]@ws@ys@zs)" apply simp apply(rule contr') done
    also have "... = P (ws@ys@[y]@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
    also have "... = P (remdups (ws@ys@[y]@zs))"
      apply(rule a) by(auto simp: xs)
    also have "(remdups (ws@ys@[y]@zs)) = (remdups xs)"
      apply(simp add: xs remdups_append) done
    finally show "P xs = P (remdups xs)" .
  qed
qed

lemma perm_contr: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr': "! x xs. P(x#x#xs) = P (x#xs)"
  shows "(P xs = P (remdups xs))"
  apply(rule perm_contr'[OF perm contr', rule_format]) by force

subsection "List properties closed under Perm, Weak and Contr are monotonic in the set of the list"

definition
  rem :: "'a => 'a list => 'a list" where
  "rem x xs = filter (%y. y ~= x) xs"

lemma rem: "x ~: set (rem x xs)"
  by(simp add: rem_def)

lemma length_rem: "length (rem x xs) <= length xs"
  by(simp add: rem_def)

lemma rem_notin: "x ~: set xs ==> rem x xs = xs"
  apply(simp add: rem_def)
  apply(rule filter_True)
  apply force
  done

lemma perm_weak_filter': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and weak[rule_format]: "! x xs. P xs --> P (x#xs)"
  shows "! ys. P (ys@filter Q xs) --> P (ys@xs)"
  apply (induct xs, simp, rule)
  apply rule
  apply simp
  apply (case_tac "Q a", simp)
   apply(drule_tac x="ys@[a]" in spec) apply simp
  apply simp
  apply(drule_tac x="ys@[a]" in spec) apply simp
  apply(erule impE)
   apply(subgoal_tac "(ys @ a # filter Q xs) <~~> a#ys@filter Q xs")
    apply(simp add: perm)
    apply(rule weak) apply simp
   apply(rule perm_sym) apply(rule perm_append_Cons)
  .

lemma perm_weak_filter: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and weak: "! x xs. P xs --> P (x#xs)"
  shows "P (filter Q xs) ==> P xs"
  using perm_weak_filter'[OF perm weak, rule_format, of "[]", simplified]
  by blast

  \<comment> \<open>right, now in a position to prove that in presence of perm, contr and weak, set x leq set y and x : ded implies y : ded\<close>

lemma perm_weak_contr_mono:
  assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr: "! x xs. P (x#x#xs) --> P (x#xs)"
  and weak: "! x xs. P xs --> P (x#xs)"
  and xy: "set x <= set y"
  and Px : "P x"
  shows "P y"
proof -
  from contr weak have contr': "! x xs. P(x#x#xs) = P (x#xs)" by blast

  define y' where "y' = filter (% z. z : set x) y"
  from xy have "set x = set y'" apply(simp add: y'_def) apply blast done
  hence rxry': "remdups x <~~> remdups y'" by(simp add: perm_remdups_iff_eq_set)

  from Px perm_contr[OF perm contr'] have Prx: "P (remdups x)" by simp
  with rxry' have "P (remdups y')" by(simp add: perm)

  with perm_contr[OF perm contr'] have "P y'" by simp
  thus "P y"
    apply(simp add: y'_def)
    apply(rule perm_weak_filter[OF perm weak]) .
qed

(* No, not used
subsection "Following used in Soundness"

primrec multiset_of_list :: "'a list \<Rightarrow> 'a multiset"
where
  "multiset_of_list [] = {#}"
| "multiset_of_list (x#xs) = {#x#} + multiset_of_list xs"

lemma count_count[symmetric]: "count x A = Multiset.count (multiset_of_list A) x"
  by (induct A) simp_all

lemma perm_multiset: "A <~~> B = (multiset_of_list A = multiset_of_list B)"
  apply(simp add: perm_count_conv)
  apply(simp add: multiset_eq_iff)
  apply(simp add: count_count)
  done

lemma set_of_multiset_of_list: "set_of (multiset_of_list A) = set A"
  by (induct A) auto
*)
end


text \<open>Extensions to Discrete.thy, in particular an implementation of square root by bisection\<close>

theory Discrete_Extensions
  imports "HOL-Library.Discrete" "HOL-Eisbach.Eisbach"
begin

(* Internal 'loop' for the algorithm, takes lower and upper bound for root, returns root *)
function dsqrt' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "dsqrt' y L R = (if Suc L < R then let M = (L+R) div 2 in if M*M \<le> y then dsqrt' y M R else dsqrt' y L M else L)"
  by auto
termination by (relation "Wellfounded.measure (\<lambda>(y,L,R). R - L)") auto

declare dsqrt'.simps[simp del]

(* Probably not better... *)
lemma dsqrt'_simps[]:
  "Suc L < R \<Longrightarrow> ((L+R) div 2)^2 \<le> y \<Longrightarrow> dsqrt' y L R = dsqrt' y ((L+R) div 2) R"
  "Suc L < R \<Longrightarrow> ((L+R) div 2)^2 > y \<Longrightarrow> dsqrt' y L R = dsqrt' y L ((L+R) div 2)"
  "Suc L \<ge> R \<Longrightarrow> dsqrt' y L R = L"
  by (simp_all add: dsqrt'.simps power2_eq_square Let_def)

definition dsqrt :: "nat \<Rightarrow> nat" where
  "dsqrt y = dsqrt' y 0 (Suc y)"

(* I am still not sure if there is a better way to state multiple simultaneous goals for induction*)
lemma dsqrt'_correct':
  "(0::nat) \<le> L \<Longrightarrow> L < R \<Longrightarrow> L\<^sup>2 \<le> y \<Longrightarrow> y < R\<^sup>2 \<Longrightarrow> (dsqrt' y L R)\<^sup>2 \<le> y \<and> y < (Suc (dsqrt' y L R))\<^sup>2"
proof (induction y L R rule: dsqrt'.induct)
  case (1 y L R)
  then show ?case
  proof(cases "Suc L < R")
    case True
    then show ?thesis
      (*Real proof needed*)
      by (smt (verit, ccfv_threshold) "1.IH"(1) "1.IH"(2) "1.prems"(3) "1.prems"(4) dsqrt'_simps(1)
          dsqrt'_simps(2) le_sqrt_iff less_eq_nat.simps(1) linorder_not_le order_trans power2_eq_square)
  next
    case False
    hence "Suc L = R"
      using 1 by linarith
    then show ?thesis
      using "1.prems" False by (fastforce simp add: dsqrt'.simps)
  qed
qed

(* This is what I would like *)
lemma dsqrt'_correct'':
  assumes "(0::nat) \<le> L" "L < R" "L\<^sup>2 \<le> y" "y < R\<^sup>2"
  shows "(dsqrt' y L R)\<^sup>2 \<le> y" "y < (Suc (dsqrt' y L R))\<^sup>2"
  using assms dsqrt'_correct' by blast+

lemma dsqrt_correct':
  "(dsqrt y)\<^sup>2 \<le> y" "y < (Suc (dsqrt y))\<^sup>2"
  unfolding dsqrt_def by (all \<open>rule dsqrt'_correct''\<close>) (simp_all add: power2_eq_square)

corollary dsqrt_correct: "dsqrt y = Discrete.sqrt y"
  by (intro sqrt_unique[symmetric] dsqrt_correct')

end


(* The types of finite sets and bags *)
theory FSets_Bags
imports "../NonFreeInput"
begin

(* Datatype of finite sets: *)
nonfree_datatype 'a fset = Emp | Ins 'a "'a fset"
where
  Ins1: "Ins a (Ins a A) = Ins a A"
| Ins2: "Ins a1 (Ins a2 A) = Ins a2 (Ins a1 A)"

declare Ins1[simp]

(* Datatype of bags: *)
nonfree_datatype 'a bag = BEmp | BIns 'a "'a bag"
where BIns: "BIns a1 (BIns a2 B) = BIns a2 (BIns a1 B)"

nonfree_primrec fset_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset"
where
  "fset_map f Emp = Emp"
| "fset_map f (Ins a A) = Ins (f a) (fset_map f A)"
by (auto simp: Ins1 Ins2)

nonfree_primrec bag_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a bag \<Rightarrow> 'b bag"
where
  "bag_map f BEmp = BEmp"
| "bag_map f (BIns a B) = BIns (f a) (bag_map f B)"
by (auto simp: BIns)

(* Membership of an item in a finite set *)
nonfree_primrec mem :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool"
where
  "mem a Emp = False"
| "mem a (Ins b B) = (a = b \<or> mem a B)"
by auto

lemma mem_Ins[simp]: "mem a A \<Longrightarrow> Ins a A = A"
by (induction arbitrary: a rule: fset_induct) (auto simp: Ins2)

(* Multiplicity of an item in bag *)
nonfree_primrec mult :: "'a \<Rightarrow> 'a bag \<Rightarrow> nat"
where
  "mult a BEmp = 0"
| "mult a (BIns b B) = (if a = b then Suc (mult a B) else mult a B)"
by (auto simp: BIns)

(* Flattening operator from bags to finite sets *)
nonfree_primrec flat :: "'a bag \<Rightarrow> 'a fset"
where
  "flat BEmp = Emp"
| "flat (BIns a B) = Ins a (flat B)"
by (auto simp: Ins2)

lemma mem_flat_mult[simp]: "mem a (flat A) \<longleftrightarrow> mult a A \<noteq> 0"
by (induction rule: bag_induct) auto

(* Embedding of finite sets into bags *)
nonfree_primrec embed :: "'a fset \<Rightarrow> 'a bag"
where
  "embed Emp = BEmp"
| "embed (Ins a A) = (if mult a (embed A) = 0 then BIns a (embed A) else embed A)"
by (auto simp: BIns)

lemma mult_embed_mem[simp]: "mult a (embed A) \<noteq> 0 \<longleftrightarrow> mem a A"
by (induction rule: fset_induct) auto

(* Cardinal of finite sets: *)
nonfree_primrec card1 :: "'a fset \<Rightarrow> 'a fset * nat"
where
  "card1 Emp = (Emp, 0)"
| "card1 (Ins a A) = (case card1 A of (A,n) \<Rightarrow> (Ins a A, if mem a A then n else Suc n))"
by (auto simp: Ins2)

lemma card1: "card1 A = (A',n) \<Longrightarrow> A = A'"
by (induct arbitrary: A' n rule: fset_induct) (auto split: prod.splits)

definition card :: "'a fset \<Rightarrow> nat" where "card \<equiv> snd o card1"

lemma card_simps[simp]:
  "card Emp = 0"
  "card (Ins a A) = (if mem a A then card A else Suc (card A))"
unfolding card_def using card1 by (auto split: prod.splits)

(* Sum of a numeric function over a finite set: *)
nonfree_primrec sum1 :: "('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> 'a fset \<times> nat"
where
  "sum1 f Emp = (Emp, 0)"
| "sum1 f (Ins a A) = (case sum1 f A of (A,n) \<Rightarrow> (Ins a A, if mem a A then n else n + f a))"
by (auto simp: Ins2)

lemma sum1: "sum1 f A = (A',n) \<Longrightarrow> A = A'"
by (induct arbitrary: A' n rule: fset_induct) (auto split: prod.splits)

definition sum :: " ('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> nat" where "sum f \<equiv> snd o sum1 f"

lemma sum_simps[simp]:
  "sum f Emp = 0"
  "sum f (Ins a A) = (if mem a A then sum f A else sum f A + f a)"
unfolding sum_def using sum1 by (auto split: prod.splits)

(* Sum of a numeric function over a bag: *)
nonfree_primrec bsum' :: "('a \<Rightarrow> nat) \<Rightarrow> 'a bag \<Rightarrow> nat"
where
  "bsum' f BEmp = 0"
| "bsum' f (BIns a B) = bsum' f B + f a"
by auto

(* More generally: Sum of a commutative-monoid-valed function over a bag: *)
nonfree_primrec bsum :: "('a \<Rightarrow> 'b::comm_monoid_add) \<Rightarrow> 'a bag \<Rightarrow> 'b"
where
  "bsum f BEmp = 0"
| "bsum f (BIns a B) = bsum f B + f a"
by (auto simp: algebra_simps)

(* Embedding of finite sets as sets: *)
nonfree_primrec asSet :: "'a fset \<Rightarrow> 'a set"
where
  "asSet Emp = {}"
| "asSet (Ins a A) = insert a (asSet A)"
by auto

lemma in_asSet[simp]: "a \<in> asSet F \<longleftrightarrow> mem a F"
by (induction F) auto

lemma mem_ex_Ins: "mem a F \<Longrightarrow> \<exists> F'. \<not> mem a F' \<and> F = Ins a F'"
by (induction F) (metis Ins2 mem.simps mem_Ins)+

lemma finite_asSet[simp, intro]: "finite (asSet A)"
by (induction rule: fset_induct) auto

lemma finite_imp_asSet: "finite A \<Longrightarrow> (\<exists> F. A = asSet F)"
by (induction rule: finite_induct) (metis asSet.simps)+

lemma asSet_eq_emp[simp]: "asSet F = {} \<Longrightarrow> Emp = F"
by (induction F) auto

lemma asSet_inj[simp]: "asSet F1 = asSet F2 \<longleftrightarrow> F1 = F2"
proof(safe, induction F1 arbitrary: F2)
  fix a F1 F2 assume IH: "\<And>F2. asSet F1 = asSet F2 \<Longrightarrow> F1 = F2"
  and e: "asSet (Ins a F1) = asSet F2"
  hence "mem a F2" by auto
  then obtain F2' where F2': "\<not> mem a F2'" and F2: "F2 = Ins a F2'" using mem_ex_Ins[of a F2] by blast
  show "Ins a F1 = F2"
  proof(cases "mem a F1")
    case False
    hence "asSet F1 = asSet F2'" using e F2' unfolding F2 by auto
    thus ?thesis unfolding F2 using IH by auto
  qed(insert e IH, auto)
qed auto

definition asFset :: "'a set \<Rightarrow> 'a fset" where
"asFset A \<equiv> SOME F. asSet F = A"

lemma asSet_asFset[simp]:
assumes "finite A"  shows "asSet (asFset A) = A"
unfolding asFset_def apply(rule someI_ex) using finite_imp_asSet[OF assms] by blast

lemma asFset_asSet[simp]: "asFset (asSet A) = A"
by (metis asSet_asFset asSet_inj finite_asSet)

lemma asFset_emp[simp]: "asFset {} = Emp"
by (metis asFset_asSet asSet.simps)

lemma asFset_insert[simp]: "finite A \<Longrightarrow> asFset (insert a A) = Ins a (asFset A)"
by (metis asFset_asSet asSet.simps finite_imp_asSet)

(* ACIU view: *)
definition "Singl a \<equiv> Ins a Emp"

nonfree_primrec Uni :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
where
  "Uni Emp = (\<lambda> B. B)"
| "Uni (Ins a A) = (\<lambda> B. Ins a (Uni A B))"
by (auto simp: Ins2)

lemma Uni_Emp[simp]: "Uni Emp B = B"
and Uni_Ins[simp]: "Uni (Ins a A) B = Ins a (Uni A B)"
by auto

declare Uni.simps[simp del]

lemma Uni_Emp2[simp]: "Uni A Emp = A"
by(induction A) auto

lemma Uni_Ins2[simp]: "Uni A (Ins b B) = Ins b (Uni A B)"
by (induction A) (auto simp: Ins2)

lemma Uni_assoc: "Uni (Uni A B) C = Uni A (Uni B C)"
by (induction A) auto

lemma Uni_com: "Uni A B = Uni B A"
by (induction A) auto

lemma Uni_idem[simp]: "Uni A A = A"
by (induction A) auto

lemma Ins_not_Emp[simp]: "Ins a A \<noteq> Emp"
by (induct A) (metis mem.simps)+

lemma Singl_not_Emp[simp]: "Singl a \<noteq> Emp"
unfolding Singl_def by simp

lemma Uni_eq_Emp[simp]: "Uni A B = Emp \<longleftrightarrow> A = Emp \<and> B = Emp"
by (induct A) auto

lemma mem_Uni[simp]: "mem a (Uni A B) \<longleftrightarrow> mem a A \<or> mem a B"
by (induction A) auto

lemma asFset_Uni[simp]:
assumes "finite A" and "finite B"
shows "asFset (A \<union> B) = Uni (asFset A) (asFset B)"
using assms by (induct) auto

lemma asFset_eq_Emp[simp]: assumes "finite A"  shows "asFset A = Emp \<longleftrightarrow> A = {}"
using assms by (induction, auto)

end


 (*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof(s) of concept for algebraically founded lists of bits\<close>

theory Bit_Lists
  imports
    "HOL-Library.Word" "HOL-Library.More_List"
begin

subsection \<open>Fragments of algebraic bit representations\<close>

context comm_semiring_1
begin

abbreviation (input) unsigned_of_bits :: "bool list \<Rightarrow> 'a"
  where "unsigned_of_bits \<equiv> horner_sum of_bool 2"

lemma unsigned_of_bits_replicate_False [simp]:
  "unsigned_of_bits (replicate n False) = 0"
  by (induction n) simp_all

end

context unique_euclidean_semiring_with_bit_shifts
begin

lemma unsigned_of_bits_append [simp]:
  "unsigned_of_bits (bs @ cs) = unsigned_of_bits bs
    + push_bit (length bs) (unsigned_of_bits cs)"
  by (induction bs) (simp_all add: push_bit_double,
    simp_all add: algebra_simps)

lemma unsigned_of_bits_take [simp]:
  "unsigned_of_bits (take n bs) = take_bit n (unsigned_of_bits bs)"
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  then show ?case
    by (cases n) (simp_all add: ac_simps take_bit_Suc)
qed

lemma unsigned_of_bits_drop [simp]:
  "unsigned_of_bits (drop n bs) = drop_bit n (unsigned_of_bits bs)"
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  then show ?case
    by (cases n) (simp_all add: drop_bit_Suc)
qed

lemma bit_unsigned_of_bits_iff:
  \<open>bit (unsigned_of_bits bs) n \<longleftrightarrow> nth_default False bs n\<close>
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  then show ?case
    by (cases n) (simp_all add: bit_Suc)
qed

primrec n_bits_of :: "nat \<Rightarrow> 'a \<Rightarrow> bool list"
  where
    "n_bits_of 0 a = []"
  | "n_bits_of (Suc n) a = odd a # n_bits_of n (a div 2)"

lemma n_bits_of_eq_iff:
  "n_bits_of n a = n_bits_of n b \<longleftrightarrow> take_bit n a = take_bit n b"
  apply (induction n arbitrary: a b)
   apply (auto elim!: evenE oddE simp add: take_bit_Suc mod_2_eq_odd)
    apply (metis dvd_triv_right even_plus_one_iff odd_iff_mod_2_eq_one)
   apply (metis dvd_triv_right even_plus_one_iff odd_iff_mod_2_eq_one)
  done

lemma take_n_bits_of [simp]:
  "take m (n_bits_of n a) = n_bits_of (min m n) a"
proof -
  define q and v and w where "q = min m n" and "v = m - q" and "w = n - q"
  then have "v = 0 \<or> w = 0"
    by auto
  then have "take (q + v) (n_bits_of (q + w) a) = n_bits_of q a"
    by (induction q arbitrary: a) auto
  with q_def v_def w_def show ?thesis
    by simp
qed

lemma unsigned_of_bits_n_bits_of [simp]:
  "unsigned_of_bits (n_bits_of n a) = take_bit n a"
  by (induction n arbitrary: a) (simp_all add: ac_simps take_bit_Suc mod_2_eq_odd)

end

subsection \<open>Syntactic bit representation\<close>

class bit_representation =
  fixes bits_of :: "'a \<Rightarrow> bool list"
    and of_bits :: "bool list \<Rightarrow> 'a"
  assumes of_bits_of [simp]: "of_bits (bits_of a) = a"

text \<open>Unclear whether a \<^typ>\<open>bool\<close> instantiation is needed or not\<close>

instantiation nat :: bit_representation
begin

fun bits_of_nat :: "nat \<Rightarrow> bool list"
  where "bits_of (n::nat) =
    (if n = 0 then [] else odd n # bits_of (n div 2))"

lemma bits_of_nat_simps [simp]:
  "bits_of (0::nat) = []"
  "n > 0 \<Longrightarrow> bits_of n = odd n # bits_of (n div 2)" for n :: nat
  by simp_all

declare bits_of_nat.simps [simp del]

definition of_bits_nat :: "bool list \<Rightarrow> nat"
  where [simp]: "of_bits_nat = unsigned_of_bits"
  \<comment> \<open>remove simp\<close>

instance proof
  show "of_bits (bits_of n) = n" for n :: nat
    by (induction n rule: nat_bit_induct) simp_all
qed

end

lemma bit_of_bits_nat_iff:
  \<open>bit (of_bits bs :: nat) n \<longleftrightarrow> nth_default False bs n\<close>
  by (simp add: bit_unsigned_of_bits_iff)

lemma bits_of_Suc_0 [simp]:
  "bits_of (Suc 0) = [True]"
  by simp

lemma bits_of_1_nat [simp]:
  "bits_of (1 :: nat) = [True]"
  by simp

lemma bits_of_nat_numeral_simps [simp]:
  "bits_of (numeral Num.One :: nat) = [True]" (is ?One)
  "bits_of (numeral (Num.Bit0 n) :: nat) = False # bits_of (numeral n :: nat)" (is ?Bit0)
  "bits_of (numeral (Num.Bit1 n) :: nat) = True # bits_of (numeral n :: nat)" (is ?Bit1)
proof -
  show ?One
    by simp
  define m :: nat where "m = numeral n"
  then have "m > 0" and *: "numeral n = m" "numeral (Num.Bit0 n) = 2 * m" "numeral (Num.Bit1 n) = Suc (2 * m)"
    by simp_all
  from \<open>m > 0\<close> show ?Bit0 ?Bit1
    by (simp_all add: *)
qed

lemma unsigned_of_bits_of_nat [simp]:
  "unsigned_of_bits (bits_of n) = n" for n :: nat
  using of_bits_of [of n] by simp

instantiation int :: bit_representation
begin

fun bits_of_int :: "int \<Rightarrow> bool list"
  where "bits_of_int k = odd k #
    (if k = 0 \<or> k = - 1 then [] else bits_of_int (k div 2))"

lemma bits_of_int_simps [simp]:
  "bits_of (0 :: int) = [False]"
  "bits_of (- 1 :: int) = [True]"
  "k \<noteq> 0 \<Longrightarrow> k \<noteq> - 1 \<Longrightarrow> bits_of k = odd k # bits_of (k div 2)" for k :: int
  by simp_all

lemma bits_of_not_Nil [simp]:
  "bits_of k \<noteq> []" for k :: int
  by simp

declare bits_of_int.simps [simp del]

definition of_bits_int :: "bool list \<Rightarrow> int"
  where "of_bits_int bs = (if bs = [] \<or> \<not> last bs then unsigned_of_bits bs
    else unsigned_of_bits bs - 2 ^ length bs)"

lemma of_bits_int_simps [simp]:
  "of_bits [] = (0 :: int)"
  "of_bits [False] = (0 :: int)"
  "of_bits [True] = (- 1 :: int)"
  "of_bits (bs @ [b]) = (unsigned_of_bits bs :: int) - (2 ^ length bs) * of_bool b"
  "of_bits (False # bs) = 2 * (of_bits bs :: int)"
  "bs \<noteq> [] \<Longrightarrow> of_bits (True # bs) = 1 + 2 * (of_bits bs :: int)"
  by (simp_all add: of_bits_int_def push_bit_of_1)

instance proof
  show "of_bits (bits_of k) = k" for k :: int
    by (induction k rule: int_bit_induct) simp_all
qed

lemma bits_of_1_int [simp]:
  "bits_of (1 :: int) = [True, False]"
  by simp

lemma bits_of_int_numeral_simps [simp]:
  "bits_of (numeral Num.One :: int) = [True, False]" (is ?One)
  "bits_of (numeral (Num.Bit0 n) :: int) = False # bits_of (numeral n :: int)" (is ?Bit0)
  "bits_of (numeral (Num.Bit1 n) :: int) = True # bits_of (numeral n :: int)" (is ?Bit1)
  "bits_of (- numeral (Num.Bit0 n) :: int) = False # bits_of (- numeral n :: int)" (is ?nBit0)
  "bits_of (- numeral (Num.Bit1 n) :: int) = True # bits_of (- numeral (Num.inc n) :: int)" (is ?nBit1)
proof -
  show ?One
    by simp
  define k :: int where "k = numeral n"
  then have "k > 0" and *: "numeral n = k" "numeral (Num.Bit0 n) = 2 * k" "numeral (Num.Bit1 n) = 2 * k + 1"
    "numeral (Num.inc n) = k + 1"
    by (simp_all add: add_One)
  have "- (2 * k) div 2 = - k" "(- (2 * k) - 1) div 2 = - k - 1"
    by simp_all
  with \<open>k > 0\<close> show ?Bit0 ?Bit1 ?nBit0 ?nBit1
    by (simp_all add: *)
qed

lemma bit_of_bits_int_iff:
  \<open>bit (of_bits bs :: int) n \<longleftrightarrow> nth_default (bs \<noteq> [] \<and> last bs) bs n\<close>
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  then show ?case
    by (cases n; cases b; cases bs) (simp_all add: bit_Suc)
qed

lemma of_bits_append [simp]:
  "of_bits (bs @ cs) = of_bits bs + push_bit (length bs) (of_bits cs :: int)"
    if "bs \<noteq> []" "\<not> last bs"
using that proof (induction bs rule: list_nonempty_induct)
  case (single b)
  then show ?case
    by simp
next
  case (cons b bs)
  then show ?case
    by (cases b) (simp_all add: push_bit_double)
qed

lemma of_bits_replicate_False [simp]:
  "of_bits (replicate n False) = (0 :: int)"
  by (auto simp add: of_bits_int_def)

lemma of_bits_drop [simp]:
  "of_bits (drop n bs) = drop_bit n (of_bits bs :: int)"
    if "n < length bs"
using that proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by simp
  next
    case (Suc n)
    with Cons.prems have "bs \<noteq> []"
      by auto
    with Suc Cons.IH [of n] Cons.prems show ?thesis
      by (cases b) (simp_all add: drop_bit_Suc)
  qed
qed

end

lemma unsigned_of_bits_eq_of_bits:
  "unsigned_of_bits bs = (of_bits (bs @ [False]) :: int)"
  by (simp add: of_bits_int_def)

unbundle word.lifting

instantiation word :: (len) bit_representation
begin

lift_definition bits_of_word :: "'a word \<Rightarrow> bool list"
  is "n_bits_of LENGTH('a)"
  by (simp add: n_bits_of_eq_iff)

lift_definition of_bits_word :: "bool list \<Rightarrow> 'a word"
  is unsigned_of_bits .

instance proof
  fix a :: "'a word"
  show "of_bits (bits_of a) = a"
    by transfer simp
qed

end

lifting_update word.lifting
lifting_forget word.lifting

subsection \<open>Bit representations with bit operations\<close>

class semiring_bit_representation = semiring_bit_operations + bit_representation +
  assumes and_eq: "length bs = length cs \<Longrightarrow>
      of_bits bs AND of_bits cs = of_bits (map2 (\<and>) bs cs)"
    and or_eq: "length bs = length cs \<Longrightarrow>
      of_bits bs OR of_bits cs = of_bits (map2 (\<or>) bs cs)"
    and xor_eq: "length bs = length cs \<Longrightarrow>
      of_bits bs XOR of_bits cs = of_bits (map2 (\<noteq>) bs cs)"
    and push_bit_eq: "push_bit n a = of_bits (replicate n False @ bits_of a)"
    and drop_bit_eq: "n < length (bits_of a) \<Longrightarrow> drop_bit n a = of_bits (drop n (bits_of a))"

class ring_bit_representation = ring_bit_operations + semiring_bit_representation +
  assumes not_eq: "not = of_bits \<circ> map Not \<circ> bits_of"

instance nat :: semiring_bit_representation
  by standard (simp_all add: bit_eq_iff bit_unsigned_of_bits_iff nth_default_map2 [of _ _ _ False False]
    bit_and_iff bit_or_iff bit_xor_iff)

instance int :: ring_bit_representation
proof
  {
    fix bs cs :: \<open>bool list\<close>
    assume \<open>length bs = length cs\<close>
    then have \<open>cs = [] \<longleftrightarrow> bs = []\<close>
      by auto
    with \<open>length bs = length cs\<close> have \<open>zip bs cs \<noteq> [] \<and> last (map2 (\<and>) bs cs) \<longleftrightarrow> (bs \<noteq> [] \<and> last bs) \<and> (cs \<noteq> [] \<and> last cs)\<close>
      and \<open>zip bs cs \<noteq> [] \<and> last (map2 (\<or>) bs cs) \<longleftrightarrow> (bs \<noteq> [] \<and> last bs) \<or> (cs \<noteq> [] \<and> last cs)\<close>
      and \<open>zip bs cs \<noteq> [] \<and> last (map2 (\<noteq>) bs cs) \<longleftrightarrow> ((bs \<noteq> [] \<and> last bs) \<noteq> (cs \<noteq> [] \<and> last cs))\<close>
      by (auto simp add: last_map last_zip zip_eq_Nil_iff prod_eq_iff)
    then show \<open>of_bits bs AND of_bits cs = (of_bits (map2 (\<and>) bs cs) :: int)\<close>
      and \<open>of_bits bs OR of_bits cs = (of_bits (map2 (\<or>) bs cs) :: int)\<close>
      and \<open>of_bits bs XOR of_bits cs = (of_bits (map2 (\<noteq>) bs cs) :: int)\<close>
      by (simp_all add: fun_eq_iff bit_eq_iff bit_and_iff bit_or_iff bit_xor_iff bit_not_iff bit_of_bits_int_iff \<open>length bs = length cs\<close> nth_default_map2 [of bs cs _ \<open>bs \<noteq> [] \<and> last bs\<close> \<open>cs \<noteq> [] \<and> last cs\<close>])
  }
  show \<open>push_bit n k = of_bits (replicate n False @ bits_of k)\<close>
    for k :: int and n :: nat
    by (cases "n = 0") simp_all
  show \<open>drop_bit n k = of_bits (drop n (bits_of k))\<close>
    if \<open>n < length (bits_of k)\<close> for k :: int and n :: nat
    using that by simp
  show \<open>(not :: int \<Rightarrow> _) = of_bits \<circ> map Not \<circ> bits_of\<close>
  proof (rule sym, rule ext)
    fix k :: int
    show \<open>(of_bits \<circ> map Not \<circ> bits_of) k = NOT k\<close>
      by (induction k rule: int_bit_induct) (simp_all add: not_int_def)
  qed
qed

end


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

section\<open>Case Study: A Context Free Grammar\<close>

text\<open>\label{sec:CFG}
\index{grammars!defining inductively|(}%
Grammars are nothing but shorthands for inductive definitions of nonterminals
which represent sets of strings. For example, the production
$A \to B c$ is short for
\[ w \in B \Longrightarrow wc \in A \]
This section demonstrates this idea with an example
due to Hopcroft and Ullman, a grammar for generating all words with an
equal number of $a$'s and~$b$'s:
\begin{eqnarray}
S &\to& \epsilon \mid b A \mid a B \nonumber\\
A &\to& a S \mid b A A \nonumber\\
B &\to& b S \mid a B B \nonumber
\end{eqnarray}
At the end we say a few words about the relationship between
the original proof @{cite \<open>p.\ts81\<close> HopcroftUllman} and our formal version.

We start by fixing the alphabet, which consists only of \<^term>\<open>a\<close>'s
and~\<^term>\<open>b\<close>'s:
\<close>

datatype alfa = a | b

text\<open>\noindent
For convenience we include the following easy lemmas as simplification rules:
\<close>

text\<open>\noindent
Words over this alphabet are of type \<^typ>\<open>alfa list\<close>, and
the three nonterminals are declared as sets of such words.
The productions above are recast as a \emph{mutual} inductive
definition\index{inductive definition!simultaneous}
of \<^term>\<open>S\<close>, \<^term>\<open>A\<close> and~\<^term>\<open>B\<close>:
\<close>

inductive_set
  S :: "alfa list set" and
  A :: "alfa list set" and
  B :: "alfa list set"
where
  "[] \<in> S"
| "w \<in> A \<Longrightarrow> b#w \<in> S"
| "w \<in> B \<Longrightarrow> a#w \<in> S"

| "w \<in> S        \<Longrightarrow> a#w   \<in> A"
| "\<lbrakk> v\<in>A; w\<in>A \<rbrakk> \<Longrightarrow> b#v@w \<in> A"

| "w \<in> S            \<Longrightarrow> b#w   \<in> B"
| "\<lbrakk> v \<in> B; w \<in> B \<rbrakk> \<Longrightarrow> a#v@w \<in> B"

text\<open>\noindent
First we show that all words in \<^term>\<open>S\<close> contain the same number of \<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s. Since the definition of \<^term>\<open>S\<close> is by mutual
induction, so is the proof: we show at the same time that all words in
\<^term>\<open>A\<close> contain one more \<^term>\<open>a\<close> than \<^term>\<open>b\<close> and all words in \<^term>\<open>B\<close> contain one more \<^term>\<open>b\<close> than \<^term>\<open>a\<close>.
\<close>

lemma correctness:
  "(w \<in> S \<longrightarrow> size[x\<leftarrow>w. x=a] = size[x\<leftarrow>w. x=b])     \<and>
   (w \<in> A \<longrightarrow> size[x\<leftarrow>w. x=a] = size[x\<leftarrow>w. x=b] + 1) \<and>
   (w \<in> B \<longrightarrow> size[x\<leftarrow>w. x=b] = size[x\<leftarrow>w. x=a] + 1)"

txt\<open>\noindent
These propositions are expressed with the help of the predefined \<^term>\<open>filter\<close> function on lists, which has the convenient syntax \<open>[x\<leftarrow>xs. P
x]\<close>, the list of all elements \<^term>\<open>x\<close> in \<^term>\<open>xs\<close> such that \<^prop>\<open>P x\<close>
holds. Remember that on lists \<open>size\<close> and \<open>length\<close> are synonymous.

The proof itself is by rule induction and afterwards automatic:
\<close>

by (rule S_A_B.induct, auto)

text\<open>\noindent
This may seem surprising at first, and is indeed an indication of the power
of inductive definitions. But it is also quite straightforward. For example,
consider the production $A \to b A A$: if $v,w \in A$ and the elements of $A$
contain one more $a$ than~$b$'s, then $bvw$ must again contain one more $a$
than~$b$'s.

As usual, the correctness of syntactic descriptions is easy, but completeness
is hard: does \<^term>\<open>S\<close> contain \emph{all} words with an equal number of
\<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s? It turns out that this proof requires the
following lemma: every string with two more \<^term>\<open>a\<close>'s than \<^term>\<open>b\<close>'s can be cut somewhere such that each half has one more \<^term>\<open>a\<close> than
\<^term>\<open>b\<close>. This is best seen by imagining counting the difference between the
number of \<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s starting at the left end of the
word. We start with 0 and end (at the right end) with 2. Since each move to the
right increases or decreases the difference by 1, we must have passed through
1 on our way from 0 to 2. Formally, we appeal to the following discrete
intermediate value theorem @{thm[source]nat0_intermed_int_val}
@{thm[display,margin=60]nat0_intermed_int_val[no_vars]}
where \<^term>\<open>f\<close> is of type \<^typ>\<open>nat \<Rightarrow> int\<close>, \<^typ>\<open>int\<close> are the integers,
\<open>\<bar>.\<bar>\<close> is the absolute value function\footnote{See
Table~\ref{tab:ascii} in the Appendix for the correct \textsc{ascii}
syntax.}, and \<^term>\<open>1::int\<close> is the integer 1 (see \S\ref{sec:numbers}).

First we show that our specific function, the difference between the
numbers of \<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s, does indeed only change by 1 in every
move to the right. At this point we also start generalizing from \<^term>\<open>a\<close>'s
and \<^term>\<open>b\<close>'s to an arbitrary property \<^term>\<open>P\<close>. Otherwise we would have
to prove the desired lemma twice, once as stated above and once with the
roles of \<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s interchanged.
\<close>

lemma step1: "\<forall>i < size w.
  \<bar>(int(size[x\<leftarrow>take (i+1) w. P x])-int(size[x\<leftarrow>take (i+1) w. \<not>P x]))
   - (int(size[x\<leftarrow>take i w. P x])-int(size[x\<leftarrow>take i w. \<not>P x]))\<bar> \<le> 1"

txt\<open>\noindent
The lemma is a bit hard to read because of the coercion function
\<open>int :: nat \<Rightarrow> int\<close>. It is required because \<^term>\<open>size\<close> returns
a natural number, but subtraction on type~\<^typ>\<open>nat\<close> will do the wrong thing.
Function \<^term>\<open>take\<close> is predefined and \<^term>\<open>take i xs\<close> is the prefix of
length \<^term>\<open>i\<close> of \<^term>\<open>xs\<close>; below we also need \<^term>\<open>drop i xs\<close>, which
is what remains after that prefix has been dropped from \<^term>\<open>xs\<close>.

The proof is by induction on \<^term>\<open>w\<close>, with a trivial base case, and a not
so trivial induction step. Since it is essentially just arithmetic, we do not
discuss it.
\<close>

apply(induct_tac w)
apply(auto simp add: abs_if take_Cons split: nat.split)
done

text\<open>
Finally we come to the above-mentioned lemma about cutting in half a word with two more elements of one sort than of the other sort:
\<close>

lemma part1:
 "size[x\<leftarrow>w. P x] = size[x\<leftarrow>w. \<not>P x]+2 \<Longrightarrow>
  \<exists>i\<le>size w. size[x\<leftarrow>take i w. P x] = size[x\<leftarrow>take i w. \<not>P x]+1"

txt\<open>\noindent
This is proved by \<open>force\<close> with the help of the intermediate value theorem,
instantiated appropriately and with its first premise disposed of by lemma
@{thm[source]step1}:
\<close>

apply(insert nat0_intermed_int_val[OF step1, of "P" "w" "1"])
by force

text\<open>\noindent

Lemma @{thm[source]part1} tells us only about the prefix \<^term>\<open>take i w\<close>.
An easy lemma deals with the suffix \<^term>\<open>drop i w\<close>:
\<close>

lemma part2:
  "\<lbrakk>size[x\<leftarrow>take i w @ drop i w. P x] =
    size[x\<leftarrow>take i w @ drop i w. \<not>P x]+2;
    size[x\<leftarrow>take i w. P x] = size[x\<leftarrow>take i w. \<not>P x]+1\<rbrakk>
   \<Longrightarrow> size[x\<leftarrow>drop i w. P x] = size[x\<leftarrow>drop i w. \<not>P x]+1"
by(simp del: append_take_drop_id)

text\<open>\noindent
In the proof we have disabled the normally useful lemma
\begin{isabelle}
@{thm append_take_drop_id[no_vars]}
\rulename{append_take_drop_id}
\end{isabelle}
to allow the simplifier to apply the following lemma instead:
@{text[display]"[x\<in>xs@ys. P x] = [x\<in>xs. P x] @ [x\<in>ys. P x]"}

To dispose of trivial cases automatically, the rules of the inductive
definition are declared simplification rules:
\<close>

declare S_A_B.intros[simp]

text\<open>\noindent
This could have been done earlier but was not necessary so far.

The completeness theorem tells us that if a word has the same number of
\<^term>\<open>a\<close>'s and \<^term>\<open>b\<close>'s, then it is in \<^term>\<open>S\<close>, and similarly
for \<^term>\<open>A\<close> and \<^term>\<open>B\<close>:
\<close>

theorem completeness:
  "(size[x\<leftarrow>w. x=a] = size[x\<leftarrow>w. x=b]     \<longrightarrow> w \<in> S) \<and>
   (size[x\<leftarrow>w. x=a] = size[x\<leftarrow>w. x=b] + 1 \<longrightarrow> w \<in> A) \<and>
   (size[x\<leftarrow>w. x=b] = size[x\<leftarrow>w. x=a] + 1 \<longrightarrow> w \<in> B)"

txt\<open>\noindent
The proof is by induction on \<^term>\<open>w\<close>. Structural induction would fail here
because, as we can see from the grammar, we need to make bigger steps than
merely appending a single letter at the front. Hence we induct on the length
of \<^term>\<open>w\<close>, using the induction rule @{thm[source]length_induct}:
\<close>

apply(induct_tac w rule: length_induct)
apply(rename_tac w)

txt\<open>\noindent
The \<open>rule\<close> parameter tells \<open>induct_tac\<close> explicitly which induction
rule to use. For details see \S\ref{sec:complete-ind} below.
In this case the result is that we may assume the lemma already
holds for all words shorter than \<^term>\<open>w\<close>. Because the induction step renames
the induction variable we rename it back to \<open>w\<close>.

The proof continues with a case distinction on \<^term>\<open>w\<close>,
on whether \<^term>\<open>w\<close> is empty or not.
\<close>

apply(case_tac w)
 apply(simp_all)
(*<*)apply(rename_tac x v)(*>*)

txt\<open>\noindent
Simplification disposes of the base case and leaves only a conjunction
of two step cases to be proved:
if \<^prop>\<open>w = a#v\<close> and @{prop[display]"size[x\<in>v. x=a] = size[x\<in>v. x=b]+2"} then
\<^prop>\<open>b#v \<in> A\<close>, and similarly for \<^prop>\<open>w = b#v\<close>.
We only consider the first case in detail.

After breaking the conjunction up into two cases, we can apply
@{thm[source]part1} to the assumption that \<^term>\<open>w\<close> contains two more \<^term>\<open>a\<close>'s than \<^term>\<open>b\<close>'s.
\<close>

apply(rule conjI)
 apply(clarify)
 apply(frule part1[of "\<lambda>x. x=a", simplified])
 apply(clarify)
txt\<open>\noindent
This yields an index \<^prop>\<open>i \<le> length v\<close> such that
@{prop[display]"length [x\<leftarrow>take i v . x = a] = length [x\<leftarrow>take i v . x = b] + 1"}
With the help of @{thm[source]part2} it follows that
@{prop[display]"length [x\<leftarrow>drop i v . x = a] = length [x\<leftarrow>drop i v . x = b] + 1"}
\<close>

 apply(drule part2[of "\<lambda>x. x=a", simplified])
  apply(assumption)

txt\<open>\noindent
Now it is time to decompose \<^term>\<open>v\<close> in the conclusion \<^prop>\<open>b#v \<in> A\<close>
into \<^term>\<open>take i v @ drop i v\<close>,
\<close>

 apply(rule_tac n1=i and t=v in subst[OF append_take_drop_id])

txt\<open>\noindent
(the variables \<^term>\<open>n1\<close> and \<^term>\<open>t\<close> are the result of composing the
theorems @{thm[source]subst} and @{thm[source]append_take_drop_id})
after which the appropriate rule of the grammar reduces the goal
to the two subgoals \<^prop>\<open>take i v \<in> A\<close> and \<^prop>\<open>drop i v \<in> A\<close>:
\<close>

 apply(rule S_A_B.intros)

txt\<open>
Both subgoals follow from the induction hypothesis because both \<^term>\<open>take i
v\<close> and \<^term>\<open>drop i v\<close> are shorter than \<^term>\<open>w\<close>:
\<close>

  apply(force simp add: min_less_iff_disj)
 apply(force split: nat_diff_split)

txt\<open>
The case \<^prop>\<open>w = b#v\<close> is proved analogously:
\<close>

apply(clarify)
apply(frule part1[of "\<lambda>x. x=b", simplified])
apply(clarify)
apply(drule part2[of "\<lambda>x. x=b", simplified])
 apply(assumption)
apply(rule_tac n1=i and t=v in subst[OF append_take_drop_id])
apply(rule S_A_B.intros)
 apply(force simp add: min_less_iff_disj)
by(force simp add: min_less_iff_disj split: nat_diff_split)

text\<open>
We conclude this section with a comparison of our proof with
Hopcroft\index{Hopcroft, J. E.} and Ullman's\index{Ullman, J. D.}
@{cite \<open>p.\ts81\<close> HopcroftUllman}.
For a start, the textbook
grammar, for no good reason, excludes the empty word, thus complicating
matters just a little bit: they have 8 instead of our 7 productions.

More importantly, the proof itself is different: rather than
separating the two directions, they perform one induction on the
length of a word. This deprives them of the beauty of rule induction,
and in the easy direction (correctness) their reasoning is more
detailed than our \<open>auto\<close>. For the hard part (completeness), they
consider just one of the cases that our \<open>simp_all\<close> disposes of
automatically. Then they conclude the proof by saying about the
remaining cases: ``We do this in a manner similar to our method of
proof for part (1); this part is left to the reader''. But this is
precisely the part that requires the intermediate value theorem and
thus is not at all similar to the other cases (which are automatic in
Isabelle). The authors are at least cavalier about this point and may
even have overlooked the slight difficulty lurking in the omitted
cases.  Such errors are found in many pen-and-paper proofs when they
are scrutinized formally.%
\index{grammars!defining inductively|)}
\<close>

(*<*)end(*>*)


(*  Title:      HOL/Hahn_Banach/Vector_Space.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Vector spaces\<close>

theory Vector_Space
imports Complex_Main Bounds
begin

subsection \<open>Signature\<close>

text \<open>
  For the definition of real vector spaces a type @{typ 'a} of the
  sort @{text "{plus, minus, zero}"} is considered, on which a real
  scalar multiplication @{text \<cdot>} is declared.
\<close>

consts
  prod :: "real \<Rightarrow> 'a::{plus,minus,zero} \<Rightarrow> 'a"  (infixr "\<cdot>" 70)

subsection \<open>Vector space laws\<close>

text \<open>
  A \emph{vector space} is a non-empty set @{text V} of elements from
  @{typ 'a} with the following vector space laws: The set @{text V} is
  closed under addition and scalar multiplication, addition is
  associative and commutative; @{text "- x"} is the inverse of @{text
  x} w.~r.~t.~addition and @{text 0} is the neutral element of
  addition.  Addition and multiplication are distributive; scalar
  multiplication is associative and the real number @{text "1"} is
  the neutral element of scalar multiplication.
\<close>

locale vectorspace =
  fixes V
  assumes non_empty [iff, intro?]: "V \<noteq> {}"
    and add_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y \<in> V"
    and mult_closed [iff]: "x \<in> V \<Longrightarrow> a \<cdot> x \<in> V"
    and add_assoc: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y) + z = x + (y + z)"
    and add_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = y + x"
    and diff_self [simp]: "x \<in> V \<Longrightarrow> x - x = 0"
    and add_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 + x = x"
    and add_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y"
    and add_mult_distrib2: "x \<in> V \<Longrightarrow> (a + b) \<cdot> x = a \<cdot> x + b \<cdot> x"
    and mult_assoc: "x \<in> V \<Longrightarrow> (a * b) \<cdot> x = a \<cdot> (b \<cdot> x)"
    and mult_1 [simp]: "x \<in> V \<Longrightarrow> 1 \<cdot> x = x"
    and negate_eq1: "x \<in> V \<Longrightarrow> - x = (- 1) \<cdot> x"
    and diff_eq1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = x + - y"
begin

lemma negate_eq2: "x \<in> V \<Longrightarrow> (- 1) \<cdot> x = - x"
  by (rule negate_eq1 [symmetric])

lemma negate_eq2a: "x \<in> V \<Longrightarrow> -1 \<cdot> x = - x"
  by (simp add: negate_eq1)

lemma diff_eq2: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + - y = x - y"
  by (rule diff_eq1 [symmetric])

lemma diff_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y \<in> V"
  by (simp add: diff_eq1 negate_eq1)

lemma neg_closed [iff]: "x \<in> V \<Longrightarrow> - x \<in> V"
  by (simp add: negate_eq1)

lemma add_left_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> x + (y + z) = y + (x + z)"
proof -
  assume xyz: "x \<in> V"  "y \<in> V"  "z \<in> V"
  then have "x + (y + z) = (x + y) + z"
    by (simp only: add_assoc)
  also from xyz have "\<dots> = (y + x) + z" by (simp only: add_commute)
  also from xyz have "\<dots> = y + (x + z)" by (simp only: add_assoc)
  finally show ?thesis .
qed

theorems add_ac = add_assoc add_commute add_left_commute

text \<open>The existence of the zero element of a vector space
  follows from the non-emptiness of carrier set.\<close>

lemma zero [iff]: "0 \<in> V"
proof -
  from non_empty obtain x where x: "x \<in> V" by blast
  then have "0 = x - x" by (rule diff_self [symmetric])
  also from x x have "\<dots> \<in> V" by (rule diff_closed)
  finally show ?thesis .
qed

lemma add_zero_right [simp]: "x \<in> V \<Longrightarrow>  x + 0 = x"
proof -
  assume x: "x \<in> V"
  from this and zero have "x + 0 = 0 + x" by (rule add_commute)
  also from x have "\<dots> = x" by (rule add_zero_left)
  finally show ?thesis .
qed

lemma mult_assoc2: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = (a * b) \<cdot> x"
  by (simp only: mult_assoc)

lemma diff_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x - y) = a \<cdot> x - a \<cdot> y"
  by (simp add: diff_eq1 negate_eq1 add_mult_distrib1 mult_assoc2)

lemma diff_mult_distrib2: "x \<in> V \<Longrightarrow> (a - b) \<cdot> x = a \<cdot> x - (b \<cdot> x)"
proof -
  assume x: "x \<in> V"
  have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
    by simp
  also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
    by (simp add: negate_eq1 mult_assoc2)
  also from x have "\<dots> = a \<cdot> x - (b \<cdot> x)"
    by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemmas distrib =
  add_mult_distrib1 add_mult_distrib2
  diff_mult_distrib1 diff_mult_distrib2

text \<open>\medskip Further derived laws:\<close>

lemma mult_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 \<cdot> x = 0"
proof -
  assume x: "x \<in> V"
  have "0 \<cdot> x = (1 - 1) \<cdot> x" by simp
  also have "\<dots> = (1 + - 1) \<cdot> x" by simp
  also from x have "\<dots> =  1 \<cdot> x + (- 1) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = x + (- 1) \<cdot> x" by simp
  also from x have "\<dots> = x + - x" by (simp add: negate_eq2a)
  also from x have "\<dots> = x - x" by (simp add: diff_eq2)
  also from x have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma mult_zero_right [simp]: "a \<cdot> 0 = (0::'a)"
proof -
  have "a \<cdot> 0 = a \<cdot> (0 - (0::'a))" by simp
  also have "\<dots> =  a \<cdot> 0 - a \<cdot> 0"
    by (rule diff_mult_distrib1) simp_all
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma minus_mult_cancel [simp]: "x \<in> V \<Longrightarrow> (- a) \<cdot> - x = a \<cdot> x"
  by (simp add: negate_eq1 mult_assoc2)

lemma add_minus_left_eq_diff: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + y = y - x"
proof -
  assume xy: "x \<in> V"  "y \<in> V"
  then have "- x + y = y + - x" by (simp add: add_commute)
  also from xy have "\<dots> = y - x" by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemma add_minus [simp]: "x \<in> V \<Longrightarrow> x + - x = 0"
  by (simp add: diff_eq2)

lemma add_minus_left [simp]: "x \<in> V \<Longrightarrow> - x + x = 0"
  by (simp add: diff_eq2 add_commute)

lemma minus_minus [simp]: "x \<in> V \<Longrightarrow> - (- x) = x"
  by (simp add: negate_eq1 mult_assoc2)

lemma minus_zero [simp]: "- (0::'a) = 0"
  by (simp add: negate_eq1)

lemma minus_zero_iff [simp]:
  assumes x: "x \<in> V"
  shows "(- x = 0) = (x = 0)"
proof
  from x have "x = - (- x)" by simp
  also assume "- x = 0"
  also have "- \<dots> = 0" by (rule minus_zero)
  finally show "x = 0" .
next
  assume "x = 0"
  then show "- x = 0" by simp
qed

lemma add_minus_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + (- x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + (x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_distrib [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - (x + y) = - x + - y"
  by (simp add: negate_eq1 add_mult_distrib1)

lemma diff_zero [simp]: "x \<in> V \<Longrightarrow> x - 0 = x"
  by (simp add: diff_eq1)

lemma diff_zero_right [simp]: "x \<in> V \<Longrightarrow> 0 - x = - x"
  by (simp add: diff_eq1)

lemma add_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x + y = x + z) = (y = z)"
proof
  from y have "y = 0 + y" by simp
  also from x y have "\<dots> = (- x + x) + y" by simp
  also from x y have "\<dots> = - x + (x + y)" by (simp add: add.assoc)
  also assume "x + y = x + z"
  also from x z have "- x + (x + z) = - x + x + z" by (simp add: add.assoc)
  also from x z have "\<dots> = z" by simp
  finally show "y = z" .
next
  assume "y = z"
  then show "x + y = x + z" by (simp only:)
qed

lemma add_right_cancel: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (y + x = z + x) = (y = z)"
  by (simp only: add_commute add_left_cancel)

lemma add_assoc_cong:
  "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x' \<in> V \<Longrightarrow> y' \<in> V \<Longrightarrow> z \<in> V
    \<Longrightarrow> x + y = x' + y' \<Longrightarrow> x + (y + z) = x' + (y' + z)"
  by (simp only: add_assoc [symmetric])

lemma mult_left_commute: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = b \<cdot> a \<cdot> x"
  by (simp add: mult.commute mult_assoc2)

lemma mult_zero_uniq:
  assumes x: "x \<in> V"  "x \<noteq> 0" and ax: "a \<cdot> x = 0"
  shows "a = 0"
proof (rule classical)
  assume a: "a \<noteq> 0"
  from x a have "x = (inverse a * a) \<cdot> x" by simp
  also from \<open>x \<in> V\<close> have "\<dots> = inverse a \<cdot> (a \<cdot> x)" by (rule mult_assoc)
  also from ax have "\<dots> = inverse a \<cdot> 0" by simp
  also have "\<dots> = 0" by simp
  finally have "x = 0" .
  with \<open>x \<noteq> 0\<close> show "a = 0" by contradiction
qed

lemma mult_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and a: "a \<noteq> 0"
  shows "(a \<cdot> x = a \<cdot> y) = (x = y)"
proof
  from x have "x = 1 \<cdot> x" by simp
  also from a have "\<dots> = (inverse a * a) \<cdot> x" by simp
  also from x have "\<dots> = inverse a \<cdot> (a \<cdot> x)"
    by (simp only: mult_assoc)
  also assume "a \<cdot> x = a \<cdot> y"
  also from a y have "inverse a \<cdot> \<dots> = y"
    by (simp add: mult_assoc2)
  finally show "x = y" .
next
  assume "x = y"
  then show "a \<cdot> x = a \<cdot> y" by (simp only:)
qed

lemma mult_right_cancel:
  assumes x: "x \<in> V" and neq: "x \<noteq> 0"
  shows "(a \<cdot> x = b \<cdot> x) = (a = b)"
proof
  from x have "(a - b) \<cdot> x = a \<cdot> x - b \<cdot> x"
    by (simp add: diff_mult_distrib2)
  also assume "a \<cdot> x = b \<cdot> x"
  with x have "a \<cdot> x - b \<cdot> x = 0" by simp
  finally have "(a - b) \<cdot> x = 0" .
  with x neq have "a - b = 0" by (rule mult_zero_uniq)
  then show "a = b" by simp
next
  assume "a = b"
  then show "a \<cdot> x = b \<cdot> x" by (simp only:)
qed

lemma eq_diff_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x = z - y) = (x + y = z)"
proof
  assume "x = z - y"
  then have "x + y = z - y + y" by simp
  also from y z have "\<dots> = z + - y + y"
    by (simp add: diff_eq1)
  also have "\<dots> = z + (- y + y)"
    by (rule add_assoc) (simp_all add: y z)
  also from y z have "\<dots> = z + 0"
    by (simp only: add_minus_left)
  also from z have "\<dots> = z"
    by (simp only: add_zero_right)
  finally show "x + y = z" .
next
  assume "x + y = z"
  then have "z - y = (x + y) - y" by simp
  also from x y have "\<dots> = x + y + - y"
    by (simp add: diff_eq1)
  also have "\<dots> = x + (y + - y)"
    by (rule add_assoc) (simp_all add: x y)
  also from x y have "\<dots> = x" by simp
  finally show "x = z - y" ..
qed

lemma add_minus_eq_minus:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x + y = 0"
  shows "x = - y"
proof -
  from x y have "x = (- y + y) + x" by simp
  also from x y have "\<dots> = - y + (x + y)" by (simp add: add_ac)
  also note xy
  also from y have "- y + 0 = - y" by simp
  finally show "x = - y" .
qed

lemma add_minus_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x - y = 0"
  shows "x = y"
proof -
  from x y xy have eq: "x + - y = 0" by (simp add: diff_eq1)
  with _ _ have "x = - (- y)"
    by (rule add_minus_eq_minus) (simp_all add: x y)
  with x y show "x = y" by simp
qed

lemma add_diff_swap:
  assumes vs: "a \<in> V"  "b \<in> V"  "c \<in> V"  "d \<in> V"
    and eq: "a + b = c + d"
  shows "a - c = d - b"
proof -
  from assms have "- c + (a + b) = - c + (c + d)"
    by (simp add: add_left_cancel)
  also have "\<dots> = d" using \<open>c \<in> V\<close> \<open>d \<in> V\<close> by (rule minus_add_cancel)
  finally have eq: "- c + (a + b) = d" .
  from vs have "a - c = (- c + (a + b)) + - b"
    by (simp add: add_ac diff_eq1)
  also from vs eq have "\<dots>  = d + - b"
    by (simp add: add_right_cancel)
  also from vs have "\<dots> = d - b" by (simp add: diff_eq2)
  finally show "a - c = d - b" .
qed

lemma vs_add_cancel_21:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"  "u \<in> V"
  shows "(x + (y + z) = y + u) = (x + z = u)"
proof
  from vs have "x + z = - y + y + (x + z)" by simp
  also have "\<dots> = - y + (y + (x + z))"
    by (rule add_assoc) (simp_all add: vs)
  also from vs have "y + (x + z) = x + (y + z)"
    by (simp add: add_ac)
  also assume "x + (y + z) = y + u"
  also from vs have "- y + (y + u) = u" by simp
  finally show "x + z = u" .
next
  assume "x + z = u"
  with vs show "x + (y + z) = y + u"
    by (simp only: add_left_commute [of x])
qed

lemma add_cancel_end:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"
  shows "(x + (y + z) = y) = (x = - z)"
proof
  assume "x + (y + z) = y"
  with vs have "(x + z) + y = 0 + y" by (simp add: add_ac)
  with vs have "x + z = 0" by (simp only: add_right_cancel add_closed zero)
  with vs show "x = - z" by (simp add: add_minus_eq_minus)
next
  assume eq: "x = - z"
  then have "x + (y + z) = - z + (y + z)" by simp
  also have "\<dots> = y + (- z + z)" by (rule add_left_commute) (simp_all add: vs)
  also from vs have "\<dots> = y"  by simp
  finally show "x + (y + z) = y" .
qed

end

end


(*  Title:      HOL/Number_Theory/Cong.thy
    Authors:    Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
                Thomas M. Rasmussen, Jeremy Avigad

Defines congruence (notation: [x = y] (mod z)) for natural numbers and
integers.

This file combines and revises a number of prior developments.

The original theories "GCD" and "Primes" were by Christophe Tabacznyj
and Lawrence C. Paulson, based on @{cite davenport92}. They introduced
gcd, lcm, and prime for the natural numbers.

The original theory "IntPrimes" was by Thomas M. Rasmussen, and
extended gcd, lcm, primes to the integers. Amine Chaieb provided
another extension of the notions to the integers, and added a number
of results to "Primes" and "GCD".

The original theory, "IntPrimes", by Thomas M. Rasmussen, defined and
developed the congruence relations on the integers. The notion was
extended to the natural numbers by Chaieb. Jeremy Avigad combined
these, revised and tidied them, made the development uniform for the
natural numbers and the integers, and added a number of new theorems.
*)

section {* Congruence *}

theory Cong
imports Primes
begin

subsection {* Turn off @{text One_nat_def} *}

lemma power_eq_one_eq_nat [simp]: "((x::nat)^m = 1) = (m = 0 | x = 1)"
  by (induct m) auto

declare mod_pos_pos_trivial [simp]

subsection {* Main definitions *}

class cong =
  fixes cong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("(1[_ = _] '(()mod _'))")
begin

abbreviation notcong :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  ("(1[_ \<noteq> _] '(()mod _'))")
  where "notcong x y m \<equiv> \<not> cong x y m"

end

(* definitions for the natural numbers *)

instantiation nat :: cong
begin

definition cong_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "cong_nat x y m = ((x mod m) = (y mod m))"

instance ..

end

(* definitions for the integers *)

instantiation int :: cong
begin

definition cong_int :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "cong_int x y m = ((x mod m) = (y mod m))"

instance ..

end

subsection {* Set up Transfer *}

lemma transfer_nat_int_cong:
  "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> m >= 0 \<Longrightarrow>
    ([(nat x) = (nat y)] (mod (nat m))) = ([x = y] (mod m))"
  unfolding cong_int_def cong_nat_def
  by (metis Divides.transfer_int_nat_functions(2) nat_0_le nat_mod_distrib)

declare transfer_morphism_nat_int[transfer add return:
    transfer_nat_int_cong]

lemma transfer_int_nat_cong:
  "[(int x) = (int y)] (mod (int m)) = [x = y] (mod m)"
  apply (auto simp add: cong_int_def cong_nat_def)
  apply (auto simp add: zmod_int [symmetric])
  done

declare transfer_morphism_int_nat[transfer add return:
    transfer_int_nat_cong]

subsection {* Congruence *}

(* was zcong_0, etc. *)
lemma cong_0_nat [simp, presburger]: "([(a::nat) = b] (mod 0)) = (a = b)"
  unfolding cong_nat_def by auto

lemma cong_0_int [simp, presburger]: "([(a::int) = b] (mod 0)) = (a = b)"
  unfolding cong_int_def by auto

lemma cong_1_nat [simp, presburger]: "[(a::nat) = b] (mod 1)"
  unfolding cong_nat_def by auto

lemma cong_Suc_0_nat [simp, presburger]: "[(a::nat) = b] (mod Suc 0)"
  unfolding cong_nat_def by auto

lemma cong_1_int [simp, presburger]: "[(a::int) = b] (mod 1)"
  unfolding cong_int_def by auto

lemma cong_refl_nat [simp]: "[(k::nat) = k] (mod m)"
  unfolding cong_nat_def by auto

lemma cong_refl_int [simp]: "[(k::int) = k] (mod m)"
  unfolding cong_int_def by auto

lemma cong_sym_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
  unfolding cong_nat_def by auto

lemma cong_sym_int: "[(a::int) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
  unfolding cong_int_def by auto

lemma cong_sym_eq_nat: "[(a::nat) = b] (mod m) = [b = a] (mod m)"
  unfolding cong_nat_def by auto

lemma cong_sym_eq_int: "[(a::int) = b] (mod m) = [b = a] (mod m)"
  unfolding cong_int_def by auto

lemma cong_trans_nat [trans]:
    "[(a::nat) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
  unfolding cong_nat_def by auto

lemma cong_trans_int [trans]:
    "[(a::int) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
  unfolding cong_int_def by auto

lemma cong_add_nat:
    "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
  unfolding cong_nat_def  by (metis mod_add_cong)

lemma cong_add_int:
    "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
  unfolding cong_int_def  by (metis mod_add_cong)

lemma cong_diff_int:
    "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a - c = b - d] (mod m)"
  unfolding cong_int_def  by (metis mod_diff_cong)

lemma cong_diff_aux_int:
  "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow>
   (a::int) >= c \<Longrightarrow> b >= d \<Longrightarrow> [tsub a c = tsub b d] (mod m)"
  by (metis cong_diff_int tsub_eq)

lemma cong_diff_nat:
  assumes"[a = b] (mod m)" "[c = d] (mod m)" "(a::nat) >= c" "b >= d"
  shows "[a - c = b - d] (mod m)"
  using assms by (rule cong_diff_aux_int [transferred])

lemma cong_mult_nat:
    "[(a::nat) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
  unfolding cong_nat_def  by (metis mod_mult_cong)

lemma cong_mult_int:
    "[(a::int) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
  unfolding cong_int_def  by (metis mod_mult_cong)

lemma cong_exp_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
  by (induct k) (auto simp add: cong_mult_nat)

lemma cong_exp_int: "[(x::int) = y] (mod n) \<Longrightarrow> [x^k = y^k] (mod n)"
  by (induct k) (auto simp add: cong_mult_int)

lemma cong_setsum_nat [rule_format]:
    "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
      [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply (auto intro: cong_add_nat)
  done

lemma cong_setsum_int [rule_format]:
    "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
      [(SUM x:A. f x) = (SUM x:A. g x)] (mod m)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply (auto intro: cong_add_int)
  done

lemma cong_setprod_nat [rule_format]:
    "(ALL x: A. [((f x)::nat) = g x] (mod m)) \<longrightarrow>
      [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply (auto intro: cong_mult_nat)
  done

lemma cong_setprod_int [rule_format]:
    "(ALL x: A. [((f x)::int) = g x] (mod m)) \<longrightarrow>
      [(PROD x:A. f x) = (PROD x:A. g x)] (mod m)"
  apply (cases "finite A")
  apply (induct set: finite)
  apply (auto intro: cong_mult_int)
  done

lemma cong_scalar_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
  by (rule cong_mult_nat) simp_all

lemma cong_scalar_int: "[(a::int)= b] (mod m) \<Longrightarrow> [a * k = b * k] (mod m)"
  by (rule cong_mult_int) simp_all

lemma cong_scalar2_nat: "[(a::nat)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
  by (rule cong_mult_nat) simp_all

lemma cong_scalar2_int: "[(a::int)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
  by (rule cong_mult_int) simp_all

lemma cong_mult_self_nat: "[(a::nat) * m = 0] (mod m)"
  unfolding cong_nat_def by auto

lemma cong_mult_self_int: "[(a::int) * m = 0] (mod m)"
  unfolding cong_int_def by auto

lemma cong_eq_diff_cong_0_int: "[(a::int) = b] (mod m) = [a - b = 0] (mod m)"
  by (metis cong_add_int cong_diff_int cong_refl_int diff_add_cancel diff_self)

lemma cong_eq_diff_cong_0_aux_int: "a >= b \<Longrightarrow>
    [(a::int) = b] (mod m) = [tsub a b = 0] (mod m)"
  by (subst tsub_eq, assumption, rule cong_eq_diff_cong_0_int)

lemma cong_eq_diff_cong_0_nat:
  assumes "(a::nat) >= b"
  shows "[a = b] (mod m) = [a - b = 0] (mod m)"
  using assms by (rule cong_eq_diff_cong_0_aux_int [transferred])

lemma cong_diff_cong_0'_nat:
  "[(x::nat) = y] (mod n) \<longleftrightarrow>
    (if x <= y then [y - x = 0] (mod n) else [x - y = 0] (mod n))"
  by (metis cong_eq_diff_cong_0_nat cong_sym_nat nat_le_linear)

lemma cong_altdef_nat: "(a::nat) >= b \<Longrightarrow> [a = b] (mod m) = (m dvd (a - b))"
  apply (subst cong_eq_diff_cong_0_nat, assumption)
  apply (unfold cong_nat_def)
  apply (simp add: dvd_eq_mod_eq_0 [symmetric])
  done

lemma cong_altdef_int: "[(a::int) = b] (mod m) = (m dvd (a - b))"
  by (metis cong_int_def zmod_eq_dvd_iff)

lemma cong_abs_int: "[(x::int) = y] (mod abs m) = [x = y] (mod m)"
  by (simp add: cong_altdef_int)

lemma cong_square_int:
  fixes a::int
  shows "\<lbrakk> prime p; 0 < a; [a * a = 1] (mod p) \<rbrakk>
    \<Longrightarrow> [a = 1] (mod p) \<or> [a = - 1] (mod p)"
  apply (simp only: cong_altdef_int)
  apply (subst prime_dvd_mult_eq_int [symmetric], assumption)
  apply (auto simp add: field_simps)
  done

lemma cong_mult_rcancel_int:
    "coprime k (m::int) \<Longrightarrow> [a * k = b * k] (mod m) = [a = b] (mod m)"
  by (metis cong_altdef_int left_diff_distrib coprime_dvd_mult_iff_int gcd_int.commute)

lemma cong_mult_rcancel_nat:
    "coprime k (m::nat) \<Longrightarrow> [a * k = b * k] (mod m) = [a = b] (mod m)"
  by (metis cong_mult_rcancel_int [transferred])

lemma cong_mult_lcancel_nat:
    "coprime k (m::nat) \<Longrightarrow> [k * a = k * b ] (mod m) = [a = b] (mod m)"
  by (simp add: mult.commute cong_mult_rcancel_nat)

lemma cong_mult_lcancel_int:
    "coprime k (m::int) \<Longrightarrow> [k * a = k * b] (mod m) = [a = b] (mod m)"
  by (simp add: mult.commute cong_mult_rcancel_int)

(* was zcong_zgcd_zmult_zmod *)
lemma coprime_cong_mult_int:
  "[(a::int) = b] (mod m) \<Longrightarrow> [a = b] (mod n) \<Longrightarrow> coprime m n
    \<Longrightarrow> [a = b] (mod m * n)"
by (metis divides_mult_int cong_altdef_int)

lemma coprime_cong_mult_nat:
  assumes "[(a::nat) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
  shows "[a = b] (mod m * n)"
  by (metis assms coprime_cong_mult_int [transferred])

lemma cong_less_imp_eq_nat: "0 \<le> (a::nat) \<Longrightarrow>
    a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
  by (auto simp add: cong_nat_def)

lemma cong_less_imp_eq_int: "0 \<le> (a::int) \<Longrightarrow>
    a < m \<Longrightarrow> 0 \<le> b \<Longrightarrow> b < m \<Longrightarrow> [a = b] (mod m) \<Longrightarrow> a = b"
  by (auto simp add: cong_int_def)

lemma cong_less_unique_nat:
    "0 < (m::nat) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
  by (auto simp: cong_nat_def) (metis mod_less_divisor mod_mod_trivial)

lemma cong_less_unique_int:
    "0 < (m::int) \<Longrightarrow> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
  by (auto simp: cong_int_def)  (metis mod_mod_trivial pos_mod_conj)

lemma cong_iff_lin_int: "([(a::int) = b] (mod m)) = (\<exists>k. b = a + m * k)"
  apply (auto simp add: cong_altdef_int dvd_def)
  apply (rule_tac [!] x = "-k" in exI, auto)
  done

lemma cong_iff_lin_nat:
   "([(a::nat) = b] (mod m)) \<longleftrightarrow> (\<exists>k1 k2. b + k1 * m = a + k2 * m)" (is "?lhs = ?rhs")
proof (rule iffI)
  assume eqm: ?lhs
  show ?rhs
  proof (cases "b \<le> a")
    case True
    then show ?rhs using eqm
      by (metis cong_altdef_nat dvd_def le_add_diff_inverse add_0_right mult_0 mult.commute)
  next
    case False
    then show ?rhs using eqm
      apply (subst (asm) cong_sym_eq_nat)
      apply (auto simp: cong_altdef_nat)
      apply (metis add_0_right add_diff_inverse dvd_div_mult_self less_or_eq_imp_le mult_0)
      done
  qed
next
  assume ?rhs
  then show ?lhs
    by (metis cong_nat_def mod_mult_self2 mult.commute)
qed

lemma cong_gcd_eq_int: "[(a::int) = b] (mod m) \<Longrightarrow> gcd a m = gcd b m"
  by (metis cong_int_def gcd_red_int)

lemma cong_gcd_eq_nat:
    "[(a::nat) = b] (mod m) \<Longrightarrow>gcd a m = gcd b m"
  by (metis assms cong_gcd_eq_int [transferred])

lemma cong_imp_coprime_nat: "[(a::nat) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow> coprime b m"
  by (auto simp add: cong_gcd_eq_nat)

lemma cong_imp_coprime_int: "[(a::int) = b] (mod m) \<Longrightarrow> coprime a m \<Longrightarrow> coprime b m"
  by (auto simp add: cong_gcd_eq_int)

lemma cong_cong_mod_nat: "[(a::nat) = b] (mod m) = [a mod m = b mod m] (mod m)"
  by (auto simp add: cong_nat_def)

lemma cong_cong_mod_int: "[(a::int) = b] (mod m) = [a mod m = b mod m] (mod m)"
  by (auto simp add: cong_int_def)

lemma cong_minus_int [iff]: "[(a::int) = b] (mod -m) = [a = b] (mod m)"
  by (metis cong_iff_lin_int minus_equation_iff mult_minus_left mult_minus_right)

(*
lemma mod_dvd_mod_int:
    "0 < (m::int) \<Longrightarrow> m dvd b \<Longrightarrow> (a mod b mod m) = (a mod m)"
  apply (unfold dvd_def, auto)
  apply (rule mod_mod_cancel)
  apply auto
  done

lemma mod_dvd_mod:
  assumes "0 < (m::nat)" and "m dvd b"
  shows "(a mod b mod m) = (a mod m)"

  apply (rule mod_dvd_mod_int [transferred])
  using assms apply auto
  done
*)

lemma cong_add_lcancel_nat:
    "[(a::nat) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin_nat)

lemma cong_add_lcancel_int:
    "[(a::int) + x = a + y] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin_int)

lemma cong_add_rcancel_nat: "[(x::nat) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin_nat)

lemma cong_add_rcancel_int: "[(x::int) + a = y + a] (mod n) \<longleftrightarrow> [x = y] (mod n)"
  by (simp add: cong_iff_lin_int)

lemma cong_add_lcancel_0_nat: "[(a::nat) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  by (simp add: cong_iff_lin_nat)

lemma cong_add_lcancel_0_int: "[(a::int) + x = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  by (simp add: cong_iff_lin_int)

lemma cong_add_rcancel_0_nat: "[x + (a::nat) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  by (simp add: cong_iff_lin_nat)

lemma cong_add_rcancel_0_int: "[x + (a::int) = a] (mod n) \<longleftrightarrow> [x = 0] (mod n)"
  by (simp add: cong_iff_lin_int)

lemma cong_dvd_modulus_nat: "[(x::nat) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow>
    [x = y] (mod n)"
  apply (auto simp add: cong_iff_lin_nat dvd_def)
  apply (rule_tac x="k1 * k" in exI)
  apply (rule_tac x="k2 * k" in exI)
  apply (simp add: field_simps)
  done

lemma cong_dvd_modulus_int: "[(x::int) = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow> [x = y] (mod n)"
  by (auto simp add: cong_altdef_int dvd_def)

lemma cong_dvd_eq_nat: "[(x::nat) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
  unfolding cong_nat_def by (auto simp add: dvd_eq_mod_eq_0)

lemma cong_dvd_eq_int: "[(x::int) = y] (mod n) \<Longrightarrow> n dvd x \<longleftrightarrow> n dvd y"
  unfolding cong_int_def by (auto simp add: dvd_eq_mod_eq_0)

lemma cong_mod_nat: "(n::nat) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
  by (simp add: cong_nat_def)

lemma cong_mod_int: "(n::int) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
  by (simp add: cong_int_def)

lemma mod_mult_cong_nat: "(a::nat) ~= 0 \<Longrightarrow> b ~= 0
    \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
  by (simp add: cong_nat_def mod_mult2_eq  mod_add_left_eq)

lemma neg_cong_int: "([(a::int) = b] (mod m)) = ([-a = -b] (mod m))"
  by (metis cong_int_def minus_minus zminus_zmod)

lemma cong_modulus_neg_int: "([(a::int) = b] (mod m)) = ([a = b] (mod -m))"
  by (auto simp add: cong_altdef_int)

lemma mod_mult_cong_int: "(a::int) ~= 0 \<Longrightarrow> b ~= 0
    \<Longrightarrow> [x mod (a * b) = y] (mod a) \<longleftrightarrow> [x = y] (mod a)"
  apply (cases "b > 0", simp add: cong_int_def mod_mod_cancel mod_add_left_eq)
  apply (subst (1 2) cong_modulus_neg_int)
  apply (unfold cong_int_def)
  apply (subgoal_tac "a * b = (-a * -b)")
  apply (erule ssubst)
  apply (subst zmod_zmult2_eq)
  apply (auto simp add: mod_add_left_eq mod_minus_right div_minus_right)
  apply (metis mod_diff_left_eq mod_diff_right_eq mod_mult_self1_is_0 semiring_numeral_div_class.diff_zero)+
  done

lemma cong_to_1_nat: "([(a::nat) = 1] (mod n)) \<Longrightarrow> (n dvd (a - 1))"
  apply (cases "a = 0", force)
  by (metis cong_altdef_nat leI less_one)

lemma cong_0_1_nat': "[(0::nat) = Suc 0] (mod n) = (n = Suc 0)"
  unfolding cong_nat_def by auto

lemma cong_0_1_nat: "[(0::nat) = 1] (mod n) = (n = 1)"
  unfolding cong_nat_def by auto

lemma cong_0_1_int: "[(0::int) = 1] (mod n) = ((n = 1) | (n = -1))"
  unfolding cong_int_def by (auto simp add: zmult_eq_1_iff)

lemma cong_to_1'_nat: "[(a::nat) = 1] (mod n) \<longleftrightarrow>
    a = 0 \<and> n = 1 \<or> (\<exists>m. a = 1 + m * n)"
  apply (cases "n = 1")
  apply auto [1]
  apply (drule_tac x = "a - 1" in spec)
  apply force
  apply (cases "a = 0", simp add: cong_0_1_nat)
  apply (rule iffI)
  apply (metis cong_to_1_nat dvd_def monoid_mult_class.mult.right_neutral mult.commute mult_eq_if)
  apply (metis cong_add_lcancel_0_nat cong_mult_self_nat)
  done

lemma cong_le_nat: "(y::nat) <= x \<Longrightarrow> [x = y] (mod n) \<longleftrightarrow> (\<exists>q. x = q * n + y)"
  by (metis cong_altdef_nat Nat.le_imp_diff_is_add dvd_def mult.commute)

lemma cong_solve_nat: "(a::nat) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
  apply (cases "n = 0")
  apply force
  apply (frule bezout_nat [of a n], auto)
  by (metis cong_add_rcancel_0_nat cong_mult_self_nat mult.commute)

lemma cong_solve_int: "(a::int) \<noteq> 0 \<Longrightarrow> EX x. [a * x = gcd a n] (mod n)"
  apply (cases "n = 0")
  apply (cases "a \<ge> 0")
  apply auto
  apply (rule_tac x = "-1" in exI)
  apply auto
  apply (insert bezout_int [of a n], auto)
  by (metis cong_iff_lin_int mult.commute)

lemma cong_solve_dvd_nat:
  assumes a: "(a::nat) \<noteq> 0" and b: "gcd a n dvd d"
  shows "EX x. [a * x = d] (mod n)"
proof -
  from cong_solve_nat [OF a] obtain x where "[a * x = gcd a n](mod n)"
    by auto
  then have "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
    by (elim cong_scalar2_nat)
  also from b have "(d div gcd a n) * gcd a n = d"
    by (rule dvd_div_mult_self)
  also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
    by auto
  finally show ?thesis
    by auto
qed

lemma cong_solve_dvd_int:
  assumes a: "(a::int) \<noteq> 0" and b: "gcd a n dvd d"
  shows "EX x. [a * x = d] (mod n)"
proof -
  from cong_solve_int [OF a] obtain x where "[a * x = gcd a n](mod n)"
    by auto
  then have "[(d div gcd a n) * (a * x) = (d div gcd a n) * gcd a n] (mod n)"
    by (elim cong_scalar2_int)
  also from b have "(d div gcd a n) * gcd a n = d"
    by (rule dvd_div_mult_self)
  also have "(d div gcd a n) * (a * x) = a * (d div gcd a n * x)"
    by auto
  finally show ?thesis
    by auto
qed

lemma cong_solve_coprime_nat: "coprime (a::nat) n \<Longrightarrow> EX x. [a * x = 1] (mod n)"
  apply (cases "a = 0")
  apply force
  apply (metis cong_solve_nat)
  done

lemma cong_solve_coprime_int: "coprime (a::int) n \<Longrightarrow> EX x. [a * x = 1] (mod n)"
  apply (cases "a = 0")
  apply auto
  apply (cases "n \<ge> 0")
  apply auto
  apply (metis cong_solve_int)
  done

lemma coprime_iff_invertible_nat: "m > 0 \<Longrightarrow> coprime a m = (EX x. [a * x = Suc 0] (mod m))"
  apply (auto intro: cong_solve_coprime_nat simp: One_nat_def)
  apply (metis cong_Suc_0_nat cong_solve_nat gcd_nat.left_neutral)
  apply (metis One_nat_def cong_gcd_eq_nat coprime_lmult_nat
      gcd_lcm_complete_lattice_nat.inf_bot_right gcd_nat.commute)
  done

lemma coprime_iff_invertible_int: "m > (0::int) \<Longrightarrow> coprime a m = (EX x. [a * x = 1] (mod m))"
  apply (auto intro: cong_solve_coprime_int)
  apply (metis cong_int_def coprime_mul_eq_int gcd_1_int gcd_int.commute gcd_red_int)
  done

lemma coprime_iff_invertible'_nat: "m > 0 \<Longrightarrow> coprime a m =
    (EX x. 0 \<le> x & x < m & [a * x = Suc 0] (mod m))"
  apply (subst coprime_iff_invertible_nat)
  apply auto
  apply (auto simp add: cong_nat_def)
  apply (metis mod_less_divisor mod_mult_right_eq)
  done

lemma coprime_iff_invertible'_int: "m > (0::int) \<Longrightarrow> coprime a m =
    (EX x. 0 <= x & x < m & [a * x = 1] (mod m))"
  apply (subst coprime_iff_invertible_int)
  apply (auto simp add: cong_int_def)
  apply (metis mod_mult_right_eq pos_mod_conj)
  done

lemma cong_cong_lcm_nat: "[(x::nat) = y] (mod a) \<Longrightarrow>
    [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
  apply (cases "y \<le> x")
  apply (metis cong_altdef_nat lcm_least_nat)
  apply (metis cong_altdef_nat cong_diff_cong_0'_nat lcm_semilattice_nat.sup.bounded_iff le0 minus_nat.diff_0)
  done

lemma cong_cong_lcm_int: "[(x::int) = y] (mod a) \<Longrightarrow>
    [x = y] (mod b) \<Longrightarrow> [x = y] (mod lcm a b)"
  by (auto simp add: cong_altdef_int lcm_least_int) [1]

lemma cong_cong_setprod_coprime_nat [rule_format]: "finite A \<Longrightarrow>
    (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
    (ALL i:A. [(x::nat) = y] (mod m i)) \<longrightarrow>
      [x = y] (mod (PROD i:A. m i))"
  apply (induct set: finite)
  apply auto
  apply (metis coprime_cong_mult_nat gcd_semilattice_nat.inf_commute setprod_coprime_nat)
  done

lemma cong_cong_setprod_coprime_int [rule_format]: "finite A \<Longrightarrow>
    (ALL i:A. (ALL j:A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
    (ALL i:A. [(x::int) = y] (mod m i)) \<longrightarrow>
      [x = y] (mod (PROD i:A. m i))"
  apply (induct set: finite)
  apply auto
  apply (metis coprime_cong_mult_int gcd_int.commute setprod_coprime_int)
  done

lemma binary_chinese_remainder_aux_nat:
  assumes a: "coprime (m1::nat) m2"
  shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
    [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
proof -
  from cong_solve_coprime_nat [OF a] obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
    by auto
  from a have b: "coprime m2 m1"
    by (subst gcd_commute_nat)
  from cong_solve_coprime_nat [OF b] obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
    by auto
  have "[m1 * x1 = 0] (mod m1)"
    by (subst mult.commute, rule cong_mult_self_nat)
  moreover have "[m2 * x2 = 0] (mod m2)"
    by (subst mult.commute, rule cong_mult_self_nat)
  moreover note one two
  ultimately show ?thesis by blast
qed

lemma binary_chinese_remainder_aux_int:
  assumes a: "coprime (m1::int) m2"
  shows "EX b1 b2. [b1 = 1] (mod m1) \<and> [b1 = 0] (mod m2) \<and>
    [b2 = 0] (mod m1) \<and> [b2 = 1] (mod m2)"
proof -
  from cong_solve_coprime_int [OF a] obtain x1 where one: "[m1 * x1 = 1] (mod m2)"
    by auto
  from a have b: "coprime m2 m1"
    by (subst gcd_commute_int)
  from cong_solve_coprime_int [OF b] obtain x2 where two: "[m2 * x2 = 1] (mod m1)"
    by auto
  have "[m1 * x1 = 0] (mod m1)"
    by (subst mult.commute, rule cong_mult_self_int)
  moreover have "[m2 * x2 = 0] (mod m2)"
    by (subst mult.commute, rule cong_mult_self_int)
  moreover note one two
  ultimately show ?thesis by blast
qed

lemma binary_chinese_remainder_nat:
  assumes a: "coprime (m1::nat) m2"
  shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  from binary_chinese_remainder_aux_nat [OF a] obtain b1 b2
      where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
            "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
    by blast
  let ?x = "u1 * b1 + u2 * b2"
  have "[?x = u1 * 1 + u2 * 0] (mod m1)"
    apply (rule cong_add_nat)
    apply (rule cong_scalar2_nat)
    apply (rule `[b1 = 1] (mod m1)`)
    apply (rule cong_scalar2_nat)
    apply (rule `[b2 = 0] (mod m1)`)
    done
  then have "[?x = u1] (mod m1)" by simp
  have "[?x = u1 * 0 + u2 * 1] (mod m2)"
    apply (rule cong_add_nat)
    apply (rule cong_scalar2_nat)
    apply (rule `[b1 = 0] (mod m2)`)
    apply (rule cong_scalar2_nat)
    apply (rule `[b2 = 1] (mod m2)`)
    done
  then have "[?x = u2] (mod m2)" by simp
  with `[?x = u1] (mod m1)` show ?thesis by blast
qed

lemma binary_chinese_remainder_int:
  assumes a: "coprime (m1::int) m2"
  shows "EX x. [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  from binary_chinese_remainder_aux_int [OF a] obtain b1 b2
    where "[b1 = 1] (mod m1)" and "[b1 = 0] (mod m2)" and
          "[b2 = 0] (mod m1)" and "[b2 = 1] (mod m2)"
    by blast
  let ?x = "u1 * b1 + u2 * b2"
  have "[?x = u1 * 1 + u2 * 0] (mod m1)"
    apply (rule cong_add_int)
    apply (rule cong_scalar2_int)
    apply (rule `[b1 = 1] (mod m1)`)
    apply (rule cong_scalar2_int)
    apply (rule `[b2 = 0] (mod m1)`)
    done
  then have "[?x = u1] (mod m1)" by simp
  have "[?x = u1 * 0 + u2 * 1] (mod m2)"
    apply (rule cong_add_int)
    apply (rule cong_scalar2_int)
    apply (rule `[b1 = 0] (mod m2)`)
    apply (rule cong_scalar2_int)
    apply (rule `[b2 = 1] (mod m2)`)
    done
  then have "[?x = u2] (mod m2)" by simp
  with `[?x = u1] (mod m1)` show ?thesis by blast
qed

lemma cong_modulus_mult_nat: "[(x::nat) = y] (mod m * n) \<Longrightarrow>
    [x = y] (mod m)"
  apply (cases "y \<le> x")
  apply (simp add: cong_altdef_nat)
  apply (erule dvd_mult_left)
  apply (rule cong_sym_nat)
  apply (subst (asm) cong_sym_eq_nat)
  apply (simp add: cong_altdef_nat)
  apply (erule dvd_mult_left)
  done

lemma cong_modulus_mult_int: "[(x::int) = y] (mod m * n) \<Longrightarrow>
    [x = y] (mod m)"
  apply (simp add: cong_altdef_int)
  apply (erule dvd_mult_left)
  done

lemma cong_less_modulus_unique_nat:
    "[(x::nat) = y] (mod m) \<Longrightarrow> x < m \<Longrightarrow> y < m \<Longrightarrow> x = y"
  by (simp add: cong_nat_def)

lemma binary_chinese_remainder_unique_nat:
  assumes a: "coprime (m1::nat) m2"
    and nz: "m1 \<noteq> 0" "m2 \<noteq> 0"
  shows "EX! x. x < m1 * m2 \<and> [x = u1] (mod m1) \<and> [x = u2] (mod m2)"
proof -
  from binary_chinese_remainder_nat [OF a] obtain y where
      "[y = u1] (mod m1)" and "[y = u2] (mod m2)"
    by blast
  let ?x = "y mod (m1 * m2)"
  from nz have less: "?x < m1 * m2"
    by auto
  have one: "[?x = u1] (mod m1)"
    apply (rule cong_trans_nat)
    prefer 2
    apply (rule `[y = u1] (mod m1)`)
    apply (rule cong_modulus_mult_nat)
    apply (rule cong_mod_nat)
    using nz apply auto
    done
  have two: "[?x = u2] (mod m2)"
    apply (rule cong_trans_nat)
    prefer 2
    apply (rule `[y = u2] (mod m2)`)
    apply (subst mult.commute)
    apply (rule cong_modulus_mult_nat)
    apply (rule cong_mod_nat)
    using nz apply auto
    done
  have "ALL z. z < m1 * m2 \<and> [z = u1] (mod m1) \<and> [z = u2] (mod m2) \<longrightarrow> z = ?x"
  proof clarify
    fix z
    assume "z < m1 * m2"
    assume "[z = u1] (mod m1)" and  "[z = u2] (mod m2)"
    have "[?x = z] (mod m1)"
      apply (rule cong_trans_nat)
      apply (rule `[?x = u1] (mod m1)`)
      apply (rule cong_sym_nat)
      apply (rule `[z = u1] (mod m1)`)
      done
    moreover have "[?x = z] (mod m2)"
      apply (rule cong_trans_nat)
      apply (rule `[?x = u2] (mod m2)`)
      apply (rule cong_sym_nat)
      apply (rule `[z = u2] (mod m2)`)
      done
    ultimately have "[?x = z] (mod m1 * m2)"
      by (auto intro: coprime_cong_mult_nat a)
    with `z < m1 * m2` `?x < m1 * m2` show "z = ?x"
      apply (intro cong_less_modulus_unique_nat)
      apply (auto, erule cong_sym_nat)
      done
  qed
  with less one two show ?thesis by auto
 qed

lemma chinese_remainder_aux_nat:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> nat"
  assumes fin: "finite A"
    and cop: "ALL i : A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
  shows "EX b. (ALL i : A. [b i = 1] (mod m i) \<and> [b i = 0] (mod (PROD j : A - {i}. m j)))"
proof (rule finite_set_choice, rule fin, rule ballI)
  fix i
  assume "i : A"
  with cop have "coprime (PROD j : A - {i}. m j) (m i)"
    by (intro setprod_coprime_nat, auto)
  then have "EX x. [(PROD j : A - {i}. m j) * x = 1] (mod m i)"
    by (elim cong_solve_coprime_nat)
  then obtain x where "[(PROD j : A - {i}. m j) * x = 1] (mod m i)"
    by auto
  moreover have "[(PROD j : A - {i}. m j) * x = 0]
    (mod (PROD j : A - {i}. m j))"
    by (subst mult.commute, rule cong_mult_self_nat)
  ultimately show "\<exists>a. [a = 1] (mod m i) \<and> [a = 0]
      (mod setprod m (A - {i}))"
    by blast
qed

lemma chinese_remainder_nat:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> nat"
    and u :: "'a \<Rightarrow> nat"
  assumes fin: "finite A"
    and cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
  shows "EX x. (ALL i:A. [x = u i] (mod m i))"
proof -
  from chinese_remainder_aux_nat [OF fin cop] obtain b where
    bprop: "ALL i:A. [b i = 1] (mod m i) \<and>
      [b i = 0] (mod (PROD j : A - {i}. m j))"
    by blast
  let ?x = "SUM i:A. (u i) * (b i)"
  show "?thesis"
  proof (rule exI, clarify)
    fix i
    assume a: "i : A"
    show "[?x = u i] (mod m i)"
    proof -
      from fin a have "?x = (SUM j:{i}. u j * b j) +
          (SUM j:A-{i}. u j * b j)"
        by (subst setsum.union_disjoint [symmetric], auto intro: setsum.cong)
      then have "[?x = u i * b i + (SUM j:A-{i}. u j * b j)] (mod m i)"
        by auto
      also have "[u i * b i + (SUM j:A-{i}. u j * b j) =
                  u i * 1 + (SUM j:A-{i}. u j * 0)] (mod m i)"
        apply (rule cong_add_nat)
        apply (rule cong_scalar2_nat)
        using bprop a apply blast
        apply (rule cong_setsum_nat)
        apply (rule cong_scalar2_nat)
        using bprop apply auto
        apply (rule cong_dvd_modulus_nat)
        apply (drule (1) bspec)
        apply (erule conjE)
        apply assumption
        apply rule
        using fin a apply auto
        done
      finally show ?thesis
        by simp
    qed
  qed
qed

lemma coprime_cong_prod_nat [rule_format]: "finite A \<Longrightarrow>
    (ALL i: A. (ALL j: A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<longrightarrow>
      (ALL i: A. [(x::nat) = y] (mod m i)) \<longrightarrow>
         [x = y] (mod (PROD i:A. m i))"
  apply (induct set: finite)
  apply auto
  apply (metis coprime_cong_mult_nat mult.commute setprod_coprime_nat)
  done

lemma chinese_remainder_unique_nat:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> nat"
    and u :: "'a \<Rightarrow> nat"
  assumes fin: "finite A"
    and nz: "ALL i:A. m i \<noteq> 0"
    and cop: "ALL i:A. (ALL j : A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
  shows "EX! x. x < (PROD i:A. m i) \<and> (ALL i:A. [x = u i] (mod m i))"
proof -
  from chinese_remainder_nat [OF fin cop]
  obtain y where one: "(ALL i:A. [y = u i] (mod m i))"
    by blast
  let ?x = "y mod (PROD i:A. m i)"
  from fin nz have prodnz: "(PROD i:A. m i) \<noteq> 0"
    by auto
  then have less: "?x < (PROD i:A. m i)"
    by auto
  have cong: "ALL i:A. [?x = u i] (mod m i)"
    apply auto
    apply (rule cong_trans_nat)
    prefer 2
    using one apply auto
    apply (rule cong_dvd_modulus_nat)
    apply (rule cong_mod_nat)
    using prodnz apply auto
    apply rule
    apply (rule fin)
    apply assumption
    done
  have unique: "ALL z. z < (PROD i:A. m i) \<and>
      (ALL i:A. [z = u i] (mod m i)) \<longrightarrow> z = ?x"
  proof (clarify)
    fix z
    assume zless: "z < (PROD i:A. m i)"
    assume zcong: "(ALL i:A. [z = u i] (mod m i))"
    have "ALL i:A. [?x = z] (mod m i)"
      apply clarify
      apply (rule cong_trans_nat)
      using cong apply (erule bspec)
      apply (rule cong_sym_nat)
      using zcong apply auto
      done
    with fin cop have "[?x = z] (mod (PROD i:A. m i))"
      apply (intro coprime_cong_prod_nat)
      apply auto
      done
    with zless less show "z = ?x"
      apply (intro cong_less_modulus_unique_nat)
      apply (auto, erule cong_sym_nat)
      done
  qed
  from less cong unique show ?thesis by blast
qed

end


(*  Title:      HOL/Parity.thy
    Author:     Jeremy Avigad
    Author:     Jacques D. Fleuriot
*)

section \<open>Parity in rings and semirings\<close>

theory Parity
  imports Nat_Transfer
begin

subsection \<open>Ring structures with parity and \<open>even\<close>/\<open>odd\<close> predicates\<close>

class semiring_parity = comm_semiring_1_cancel + numeral +
  assumes odd_one [simp]: "\<not> 2 dvd 1"
  assumes odd_even_add: "\<not> 2 dvd a \<Longrightarrow> \<not> 2 dvd b \<Longrightarrow> 2 dvd a + b"
  assumes even_multD: "2 dvd a * b \<Longrightarrow> 2 dvd a \<or> 2 dvd b"
  assumes odd_ex_decrement: "\<not> 2 dvd a \<Longrightarrow> \<exists>b. a = b + 1"
begin

subclass semiring_numeral ..

abbreviation even :: "'a \<Rightarrow> bool"
  where "even a \<equiv> 2 dvd a"

abbreviation odd :: "'a \<Rightarrow> bool"
  where "odd a \<equiv> \<not> 2 dvd a"

lemma even_zero [simp]: "even 0"
  by (fact dvd_0_right)

lemma even_plus_one_iff [simp]: "even (a + 1) \<longleftrightarrow> odd a"
  by (auto simp add: dvd_add_right_iff intro: odd_even_add)

lemma evenE [elim?]:
  assumes "even a"
  obtains b where "a = 2 * b"
  using assms by (rule dvdE)

lemma oddE [elim?]:
  assumes "odd a"
  obtains b where "a = 2 * b + 1"
proof -
  from assms obtain b where *: "a = b + 1"
    by (blast dest: odd_ex_decrement)
  with assms have "even (b + 2)" by simp
  then have "even b" by simp
  then obtain c where "b = 2 * c" ..
  with * have "a = 2 * c + 1" by simp
  with that show thesis .
qed

lemma even_times_iff [simp]: "even (a * b) \<longleftrightarrow> even a \<or> even b"
  by (auto dest: even_multD)

lemma even_numeral [simp]: "even (numeral (Num.Bit0 n))"
proof -
  have "even (2 * numeral n)"
    unfolding even_times_iff by simp
  then have "even (numeral n + numeral n)"
    unfolding mult_2 .
  then show ?thesis
    unfolding numeral.simps .
qed

lemma odd_numeral [simp]: "odd (numeral (Num.Bit1 n))"
proof
  assume "even (numeral (num.Bit1 n))"
  then have "even (numeral n + numeral n + 1)"
    unfolding numeral.simps .
  then have "even (2 * numeral n + 1)"
    unfolding mult_2 .
  then have "2 dvd numeral n * 2 + 1"
    by (simp add: ac_simps)
  then have "2 dvd 1"
    using dvd_add_times_triv_left_iff [of 2 "numeral n" 1] by simp
  then show False by simp
qed

lemma even_add [simp]: "even (a + b) \<longleftrightarrow> (even a \<longleftrightarrow> even b)"
  by (auto simp add: dvd_add_right_iff dvd_add_left_iff odd_even_add)

lemma odd_add [simp]: "odd (a + b) \<longleftrightarrow> (\<not> (odd a \<longleftrightarrow> odd b))"
  by simp

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

end

class ring_parity = ring + semiring_parity
begin

subclass comm_ring_1 ..

lemma even_minus [simp]: "even (- a) \<longleftrightarrow> even a"
  by (fact dvd_minus_iff)

lemma even_diff [simp]: "even (a - b) \<longleftrightarrow> even (a + b)"
  using even_add [of a "- b"] by simp

end

subsection \<open>Instances for @{typ nat} and @{typ int}\<close>

lemma even_Suc_Suc_iff [simp]: "2 dvd Suc (Suc n) \<longleftrightarrow> 2 dvd n"
  using dvd_add_triv_right_iff [of 2 n] by simp

lemma even_Suc [simp]: "2 dvd Suc n \<longleftrightarrow> \<not> 2 dvd n"
  by (induct n) auto

lemma even_diff_nat [simp]: "2 dvd (m - n) \<longleftrightarrow> m < n \<or> 2 dvd (m + n)"
  for m n :: nat
proof (cases "n \<le> m")
  case True
  then have "m - n + n * 2 = m + n" by (simp add: mult_2_right)
  moreover have "2 dvd (m - n) \<longleftrightarrow> 2 dvd (m - n + n * 2)" by simp
  ultimately have "2 dvd (m - n) \<longleftrightarrow> 2 dvd (m + n)" by (simp only:)
  then show ?thesis by auto
next
  case False
  then show ?thesis by simp
qed

instance nat :: semiring_parity
proof
  show "\<not> 2 dvd (1 :: nat)"
    by (rule notI, erule dvdE) simp
next
  fix m n :: nat
  assume "\<not> 2 dvd m"
  moreover assume "\<not> 2 dvd n"
  ultimately have *: "2 dvd Suc m \<and> 2 dvd Suc n"
    by simp
  then have "2 dvd (Suc m + Suc n)"
    by (blast intro: dvd_add)
  also have "Suc m + Suc n = m + n + 2"
    by simp
  finally show "2 dvd (m + n)"
    using dvd_add_triv_right_iff [of 2 "m + n"] by simp
next
  fix m n :: nat
  assume *: "2 dvd (m * n)"
  show "2 dvd m \<or> 2 dvd n"
  proof (rule disjCI)
    assume "\<not> 2 dvd n"
    then have "2 dvd (Suc n)" by simp
    then obtain r where "Suc n = 2 * r" ..
    moreover from * obtain s where "m * n = 2 * s" ..
    then have "2 * s + m = m * Suc n" by simp
    ultimately have " 2 * s + m = 2 * (m * r)"
      by (simp add: algebra_simps)
    then have "m = 2 * (m * r - s)" by simp
    then show "2 dvd m" ..
  qed
next
  fix n :: nat
  assume "\<not> 2 dvd n"
  then show "\<exists>m. n = m + 1"
    by (cases n) simp_all
qed

lemma odd_pos: "odd n \<Longrightarrow> 0 < n"
  for n :: nat
  by (auto elim: oddE)

lemma Suc_double_not_eq_double: "Suc (2 * m) \<noteq> 2 * n"
  for m n :: nat
proof
  assume "Suc (2 * m) = 2 * n"
  moreover have "odd (Suc (2 * m))" and "even (2 * n)"
    by simp_all
  ultimately show False by simp
qed

lemma double_not_eq_Suc_double: "2 * m \<noteq> Suc (2 * n)"
  for m n :: nat
  using Suc_double_not_eq_double [of n m] by simp

lemma even_diff_iff [simp]: "2 dvd (k - l) \<longleftrightarrow> 2 dvd (k + l)"
  for k l :: int
  using dvd_add_times_triv_right_iff [of 2 "k - l" l] by (simp add: mult_2_right)

lemma even_abs_add_iff [simp]: "2 dvd (\<bar>k\<bar> + l) \<longleftrightarrow> 2 dvd (k + l)"
  for k l :: int
  by (cases "k \<ge> 0") (simp_all add: ac_simps)

lemma even_add_abs_iff [simp]: "2 dvd (k + \<bar>l\<bar>) \<longleftrightarrow> 2 dvd (k + l)"
  for k l :: int
  using even_abs_add_iff [of l k] by (simp add: ac_simps)

lemma odd_Suc_minus_one [simp]: "odd n \<Longrightarrow> Suc (n - Suc 0) = n"
  by (auto elim: oddE)

instance int :: ring_parity
proof
  show "\<not> 2 dvd (1 :: int)"
    by (simp add: dvd_int_unfold_dvd_nat)
next
  fix k l :: int
  assume "\<not> 2 dvd k"
  moreover assume "\<not> 2 dvd l"
  ultimately have "2 dvd (nat \<bar>k\<bar> + nat \<bar>l\<bar>)"
    by (auto simp add: dvd_int_unfold_dvd_nat intro: odd_even_add)
  then have "2 dvd (\<bar>k\<bar> + \<bar>l\<bar>)"
    by (simp add: dvd_int_unfold_dvd_nat nat_add_distrib)
  then show "2 dvd (k + l)"
    by simp
next
  fix k l :: int
  assume "2 dvd (k * l)"
  then show "2 dvd k \<or> 2 dvd l"
    by (simp add: dvd_int_unfold_dvd_nat even_multD nat_abs_mult_distrib)
next
  fix k :: int
  have "k = (k - 1) + 1" by simp
  then show "\<exists>l. k = l + 1" ..
qed

lemma even_int_iff [simp]: "even (int n) \<longleftrightarrow> even n"
  by (simp add: dvd_int_iff)

lemma even_nat_iff: "0 \<le> k \<Longrightarrow> even (nat k) \<longleftrightarrow> even k"
  by (simp add: even_int_iff [symmetric])

subsection \<open>Parity and powers\<close>

context ring_1
begin

lemma power_minus_even [simp]: "even n \<Longrightarrow> (- a) ^ n = a ^ n"
  by (auto elim: evenE)

lemma power_minus_odd [simp]: "odd n \<Longrightarrow> (- a) ^ n = - (a ^ n)"
  by (auto elim: oddE)

lemma neg_one_even_power [simp]: "even n \<Longrightarrow> (- 1) ^ n = 1"
  by simp

lemma neg_one_odd_power [simp]: "odd n \<Longrightarrow> (- 1) ^ n = - 1"
  by simp

end

context linordered_idom
begin

lemma zero_le_even_power: "even n \<Longrightarrow> 0 \<le> a ^ n"
  by (auto elim: evenE)

lemma zero_le_odd_power: "odd n \<Longrightarrow> 0 \<le> a ^ n \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: power_even_eq zero_le_mult_iff elim: oddE)

lemma zero_le_power_eq: "0 \<le> a ^ n \<longleftrightarrow> even n \<or> odd n \<and> 0 \<le> a"
  by (auto simp add: zero_le_even_power zero_le_odd_power)

lemma zero_less_power_eq: "0 < a ^ n \<longleftrightarrow> n = 0 \<or> even n \<and> a \<noteq> 0 \<or> odd n \<and> 0 < a"
proof -
  have [simp]: "0 = a ^ n \<longleftrightarrow> a = 0 \<and> n > 0"
    unfolding power_eq_0_iff [of a n, symmetric] by blast
  show ?thesis
    unfolding less_le zero_le_power_eq by auto
qed

lemma power_less_zero_eq [simp]: "a ^ n < 0 \<longleftrightarrow> odd n \<and> a < 0"
  unfolding not_le [symmetric] zero_le_power_eq by auto

lemma power_le_zero_eq: "a ^ n \<le> 0 \<longleftrightarrow> n > 0 \<and> (odd n \<and> a \<le> 0 \<or> even n \<and> a = 0)"
  unfolding not_less [symmetric] zero_less_power_eq by auto

lemma power_even_abs: "even n \<Longrightarrow> \<bar>a\<bar> ^ n = a ^ n"
  using power_abs [of a n] by (simp add: zero_le_even_power)

lemma power_mono_even:
  assumes "even n" and "\<bar>a\<bar> \<le> \<bar>b\<bar>"
  shows "a ^ n \<le> b ^ n"
proof -
  have "0 \<le> \<bar>a\<bar>" by auto
  with \<open>\<bar>a\<bar> \<le> \<bar>b\<bar>\<close> have "\<bar>a\<bar> ^ n \<le> \<bar>b\<bar> ^ n"
    by (rule power_mono)
  with \<open>even n\<close> show ?thesis
    by (simp add: power_even_abs)
qed

lemma power_mono_odd:
  assumes "odd n" and "a \<le> b"
  shows "a ^ n \<le> b ^ n"
proof (cases "b < 0")
  case True
  with \<open>a \<le> b\<close> have "- b \<le> - a" and "0 \<le> - b" by auto
  then have "(- b) ^ n \<le> (- a) ^ n" by (rule power_mono)
  with \<open>odd n\<close> show ?thesis by simp
next
  case False
  then have "0 \<le> b" by auto
  show ?thesis
  proof (cases "a < 0")
    case True
    then have "n \<noteq> 0" and "a \<le> 0" using \<open>odd n\<close> [THEN odd_pos] by auto
    then have "a ^ n \<le> 0" unfolding power_le_zero_eq using \<open>odd n\<close> by auto
    moreover from \<open>0 \<le> b\<close> have "0 \<le> b ^ n" by auto
    ultimately show ?thesis by auto
  next
    case False
    then have "0 \<le> a" by auto
    with \<open>a \<le> b\<close> show ?thesis
      using power_mono by auto
  qed
qed

lemma (in comm_ring_1) uminus_power_if: "(- x) ^ n = (if even n then x^n else - (x ^ n))"
  by auto

text \<open>Simplify, when the exponent is a numeral\<close>

lemma zero_le_power_eq_numeral [simp]:
  "0 \<le> a ^ numeral w \<longleftrightarrow> even (numeral w :: nat) \<or> odd (numeral w :: nat) \<and> 0 \<le> a"
  by (fact zero_le_power_eq)

lemma zero_less_power_eq_numeral [simp]:
  "0 < a ^ numeral w \<longleftrightarrow>
    numeral w = (0 :: nat) \<or>
    even (numeral w :: nat) \<and> a \<noteq> 0 \<or>
    odd (numeral w :: nat) \<and> 0 < a"
  by (fact zero_less_power_eq)

lemma power_le_zero_eq_numeral [simp]:
  "a ^ numeral w \<le> 0 \<longleftrightarrow>
    (0 :: nat) < numeral w \<and>
    (odd (numeral w :: nat) \<and> a \<le> 0 \<or> even (numeral w :: nat) \<and> a = 0)"
  by (fact power_le_zero_eq)

lemma power_less_zero_eq_numeral [simp]:
  "a ^ numeral w < 0 \<longleftrightarrow> odd (numeral w :: nat) \<and> a < 0"
  by (fact power_less_zero_eq)

lemma power_even_abs_numeral [simp]:
  "even (numeral w :: nat) \<Longrightarrow> \<bar>a\<bar> ^ numeral w = a ^ numeral w"
  by (fact power_even_abs)

end

subsubsection \<open>Tool setup\<close>

declare transfer_morphism_int_nat [transfer add return: even_int_iff]

end