(*  Title:      HOL/HOLCF/Completion.thy
    Author:     Brian Huffman
*)

section {* Defining algebraic domains by ideal completion *}

theory Completion
imports Plain_HOLCF
begin

subsection {* Ideals over a preorder *}

locale preorder =
  fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
  assumes r_refl: "x \<preceq> x"
  assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
begin

definition
  ideal :: "'a set \<Rightarrow> bool" where
  "ideal A = ((\<exists>x. x \<in> A) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z) \<and>
    (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"

lemma idealI:
  assumes "\<exists>x. x \<in> A"
  assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
  assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
  shows "ideal A"
unfolding ideal_def using assms by fast

lemma idealD1:
  "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
unfolding ideal_def by fast

lemma idealD2:
  "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
unfolding ideal_def by fast

lemma idealD3:
  "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
unfolding ideal_def by fast

lemma ideal_principal: "ideal {x. x \<preceq> z}"
apply (rule idealI)
apply (rule_tac x=z in exI)
apply (fast intro: r_refl)
apply (rule_tac x=z in bexI, fast)
apply (fast intro: r_refl)
apply (fast intro: r_trans)
done

lemma ex_ideal: "\<exists>A. A \<in> {A. ideal A}"
by (fast intro: ideal_principal)

text {* The set of ideals is a cpo *}

lemma ideal_UN:
  fixes A :: "nat \<Rightarrow> 'a set"
  assumes ideal_A: "\<And>i. ideal (A i)"
  assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
  shows "ideal (\<Union>i. A i)"
 apply (rule idealI)
   apply (cut_tac idealD1 [OF ideal_A], fast)
  apply (clarify, rename_tac i j)
  apply (drule subsetD [OF chain_A [OF max.cobounded1]])
  apply (drule subsetD [OF chain_A [OF max.cobounded2]])
  apply (drule (1) idealD2 [OF ideal_A])
  apply blast
 apply clarify
 apply (drule (1) idealD3 [OF ideal_A])
 apply fast
done

lemma typedef_ideal_po:
  fixes Abs :: "'a set \<Rightarrow> 'b::below"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, po_class)"
 apply (intro_classes, unfold below)
   apply (rule subset_refl)
  apply (erule (1) subset_trans)
 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
 apply (erule (1) subset_antisym)
done

lemma
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes S: "chain S"
  shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
    and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
proof -
  have 1: "ideal (\<Union>i. Rep (S i))"
    apply (rule ideal_UN)
     apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
    apply (subst below [symmetric])
    apply (erule chain_mono [OF S])
    done
  hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
    by (simp add: type_definition.Abs_inverse [OF type])
  show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
    apply (rule is_lubI)
     apply (rule is_ubI)
     apply (simp add: below 2, fast)
    apply (simp add: below 2 is_ub_def, fast)
    done
  hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
    by (rule lub_eqI)
  show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
    by (simp add: 4 2)
qed

lemma typedef_ideal_cpo:
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, cpo_class)"
by (default, rule exI, erule typedef_ideal_lub [OF type below])

end

interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
apply unfold_locales
apply (rule below_refl)
apply (erule (1) below_trans)
done

subsection {* Lemmas about least upper bounds *}

lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
apply (erule exE, drule is_lub_lub)
apply (drule is_lubD1)
apply (erule (1) is_ubD)
done

lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
by (erule exE, drule is_lub_lub, erule is_lubD2)

subsection {* Locale for ideal completion *}

locale ideal_completion = preorder +
  fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
  fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
  assumes ideal_rep: "\<And>x. ideal (rep x)"
  assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
  assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
  assumes belowI: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
begin

lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
apply (frule bin_chain)
apply (drule rep_lub)
apply (simp only: lub_eqI [OF is_lub_bin_chain])
apply (rule subsetI, rule UN_I [where a=0], simp_all)
done

lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
by (rule iffI [OF rep_mono belowI])

lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
unfolding below_def rep_principal
by (auto intro: r_refl elim: idealD3 [OF ideal_rep])

lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
by (simp add: principal_below_iff_mem_rep rep_principal)

lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
unfolding po_eq_conv [where 'a='b] principal_below_iff ..

lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
unfolding po_eq_conv below_def by auto

lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
by (simp only: principal_below_iff)

lemma ch2ch_principal [simp]:
  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
by (simp add: chainI principal_mono)

subsubsection {* Principal ideals approximate all elements *}

lemma compact_principal [simp]: "compact (principal a)"
by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)

text {* Construct a chain whose lub is the same as a given ideal *}

lemma obtain_principal_chain:
  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
proof -
  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
    using countable ..
  def enum \<equiv> "\<lambda>i. THE a. count a = i"
  have enum_count [simp]: "\<And>x. enum (count x) = x"
    unfolding enum_def by (simp add: inj_eq [OF inj])
  def a \<equiv> "LEAST i. enum i \<in> rep x"
  def b \<equiv> "\<lambda>i. LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
  def c \<equiv> "\<lambda>i j. LEAST k. enum k \<in> rep x \<and> enum i \<preceq> enum k \<and> enum j \<preceq> enum k"
  def P \<equiv> "\<lambda>i. \<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i"
  def X \<equiv> "rec_nat a (\<lambda>n i. if P i then c i (b i) else i)"
  have X_0: "X 0 = a" unfolding X_def by simp
  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
    unfolding X_def by simp
  have a_mem: "enum a \<in> rep x"
    unfolding a_def
    apply (rule LeastI_ex)
    apply (cut_tac ideal_rep [of x])
    apply (drule idealD1)
    apply (clarify, rename_tac a)
    apply (rule_tac x="count a" in exI, simp)
    done
  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
    unfolding P_def b_def by (erule LeastI2_ex, simp)
  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
    unfolding c_def
    apply (drule (1) idealD2 [OF ideal_rep], clarify)
    apply (rule_tac a="count z" in LeastI2, simp, simp)
    done
  have X_mem: "\<And>n. enum (X n) \<in> rep x"
    apply (induct_tac n)
    apply (simp add: X_0 a_mem)
    apply (clarsimp simp add: X_Suc, rename_tac n)
    apply (simp add: b c)
    done
  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
    apply (clarsimp simp add: X_Suc r_refl)
    apply (simp add: b c X_mem)
    done
  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
    unfolding b_def by (drule not_less_Least, simp)
  have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
    apply (induct_tac n)
    apply (clarsimp simp add: X_0 a_def)
    apply (drule_tac k=0 in Least_le, simp add: r_refl)
    apply (clarsimp, rename_tac n k)
    apply (erule le_SucE)
    apply (rule r_trans [OF _ X_chain], simp)
    apply (case_tac "P (X n)", simp add: X_Suc)
    apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
    apply (simp only: less_Suc_eq_le)
    apply (drule spec, drule (1) mp, simp add: b X_mem)
    apply (simp add: c X_mem)
    apply (drule (1) less_b)
    apply (erule r_trans)
    apply (simp add: b c X_mem)
    apply (simp add: X_Suc)
    apply (simp add: P_def)
    done
  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
    by (simp add: X_chain)
  have 2: "x = (\<Squnion>n. principal (enum (X n)))"
    apply (simp add: eq_iff rep_lub 1 rep_principal)
    apply (auto, rename_tac a)
    apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
    apply (rule_tac x=i in exI, simp add: X_covers)
    apply (rule_tac x="count a" in exI, simp)
    apply (erule idealD3 [OF ideal_rep])
    apply (rule X_mem)
    done
  from 1 2 show ?thesis ..
qed

lemma principal_induct:
  assumes adm: "adm P"
  assumes P: "\<And>a. P (principal a)"
  shows "P x"
apply (rule obtain_principal_chain [of x])
apply (simp add: admD [OF adm] P)
done

lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
apply (rule obtain_principal_chain [of x])
apply (drule adm_compact_neq [OF _ cont_id])
apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
apply (drule (2) admD2, fast, simp)
done

subsection {* Defining functions in terms of basis elements *}

definition
  extension :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
  "extension = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"

lemma extension_lemma:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "\<exists>u. f ` rep x <<| u"
proof -
  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
  and x: "x = (\<Squnion>i. principal (Y i))"
    by (rule obtain_principal_chain [of x])
  have chain: "chain (\<lambda>i. f (Y i))"
    by (rule chainI, simp add: f_mono Y)
  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
    by (simp add: x rep_lub Y rep_principal)
  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
    apply (rule is_lubI)
    apply (rule ub_imageI, rename_tac a)
    apply (clarsimp simp add: rep_x)
    apply (drule f_mono)
    apply (erule below_lub [OF chain])
    apply (rule lub_below [OF chain])
    apply (drule_tac x="Y n" in ub_imageD)
    apply (simp add: rep_x, fast intro: r_refl)
    apply assumption
    done
  thus ?thesis ..
qed

lemma extension_beta:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>x = lub (f ` rep x)"
unfolding extension_def
proof (rule beta_cfun)
  have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
    using f_mono by (rule extension_lemma)
  show cont: "cont (\<lambda>x. lub (f ` rep x))"
    apply (rule contI2)
     apply (rule monofunI)
     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
     apply (rule is_ub_thelub_ex [OF lub imageI])
     apply (erule (1) subsetD [OF rep_mono])
    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
    apply (simp add: rep_lub, clarify)
    apply (erule rev_below_trans [OF is_ub_thelub])
    apply (erule is_ub_thelub_ex [OF lub imageI])
    done
qed

lemma extension_principal:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>(principal a) = f a"
apply (subst extension_beta, erule f_mono)
apply (subst rep_principal)
apply (rule lub_eqI)
apply (rule is_lub_maximal)
apply (rule ub_imageI)
apply (simp add: f_mono)
apply (rule imageI)
apply (simp add: r_refl)
done

lemma extension_mono:
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
  assumes below: "\<And>a. f a \<sqsubseteq> g a"
  shows "extension f \<sqsubseteq> extension g"
 apply (rule cfun_belowI)
 apply (simp only: extension_beta f_mono g_mono)
 apply (rule is_lub_thelub_ex)
  apply (rule extension_lemma, erule f_mono)
 apply (rule ub_imageI, rename_tac a)
 apply (rule below_trans [OF below])
 apply (rule is_ub_thelub_ex)
  apply (rule extension_lemma, erule g_mono)
 apply (erule imageI)
done

lemma cont_extension:
  assumes f_mono: "\<And>a b x. a \<preceq> b \<Longrightarrow> f x a \<sqsubseteq> f x b"
  assumes f_cont: "\<And>a. cont (\<lambda>x. f x a)"
  shows "cont (\<lambda>x. extension (\<lambda>a. f x a))"
 apply (rule contI2)
  apply (rule monofunI)
  apply (rule extension_mono, erule f_mono, erule f_mono)
  apply (erule cont2monofunE [OF f_cont])
 apply (rule cfun_belowI)
 apply (rule principal_induct, simp)
 apply (simp only: contlub_cfun_fun)
 apply (simp only: extension_principal f_mono)
 apply (simp add: cont2contlubE [OF f_cont])
done

end

lemma (in preorder) typedef_ideal_completion:
  fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
  shows "ideal_completion r principal Rep"
proof
  interpret type_definition Rep Abs "{S. ideal S}" by fact
  fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
  show "ideal (Rep x)"
    using Rep [of x] by simp
  show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
    using type below by (rule typedef_ideal_rep_lub)
  show "Rep (principal a) = {b. b \<preceq> a}"
    by (simp add: principal Abs_inverse ideal_principal)
  show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
    by (simp only: below)
  show "\<exists>f::'a \<Rightarrow> nat. inj f"
    by (rule countable)
qed

end


(* Title:      Relative Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Relative Domain\<close>

theory Relative_Domain

imports Tests

begin

class Z =
  fixes Z :: "'a"

class relative_domain_semiring = idempotent_left_semiring + dom + Z +
  assumes d_restrict : "x \<le> d(x) * x \<squnion> Z"
  assumes d_mult_d   : "d(x * y) = d(x * d(y))"
  assumes d_below_one: "d(x) \<le> 1"
  assumes d_Z        : "d(Z) = bot"
  assumes d_dist_sup : "d(x \<squnion> y) = d(x) \<squnion> d(y)"
  assumes d_export   : "d(d(x) * y) = d(x) * d(y)"
begin

lemma d_plus_one:
  "d(x) \<squnion> 1 = 1"
  by (simp add: d_below_one sup_absorb2)

text \<open>Theorem 44.2\<close>

lemma d_zero:
  "d(bot) = bot"
  by (metis d_Z d_export mult_left_zero)

text \<open>Theorem 44.3\<close>

lemma d_involutive:
  "d(d(x)) = d(x)"
  by (metis d_mult_d mult_left_one)

lemma d_fixpoint:
  "(\<exists>y . x = d(y)) \<longleftrightarrow> x = d(x)"
  using d_involutive by auto

lemma d_type:
  "\<forall>P . (\<forall>x . x = d(x) \<longrightarrow> P(x)) \<longleftrightarrow> (\<forall>x . P(d(x)))"
  by (metis d_involutive)

text \<open>Theorem 44.4\<close>

lemma d_mult_sub:
  "d(x * y) \<le> d(x)"
  by (smt (verit, ccfv_threshold) d_plus_one d_dist_sup d_mult_d le_iff_sup mult.right_neutral mult_left_sub_dist_sup_right sup_commute)

lemma d_sub_one:
  "x \<le> 1 \<Longrightarrow> x \<le> d(x) \<squnion> Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone mult_1_right order_trans)

lemma d_one:
  "d(1) \<squnion> Z = 1 \<squnion> Z"
  by (meson d_sub_one d_below_one order.trans preorder_one_closed sup.cobounded1 sup_same_context)

text \<open>Theorem 44.8\<close>

lemma d_strict:
  "d(x) = bot \<longleftrightarrow> x \<le> Z"
  by (metis sup_commute sup_bot_right d_Z d_dist_sup d_restrict le_iff_sup mult_left_zero)

text \<open>Theorem 44.1\<close>

lemma d_isotone:
  "x \<le> y \<Longrightarrow> d(x) \<le> d(y)"
  using d_dist_sup sup_right_divisibility by force

lemma d_plus_left_upper_bound:
  "d(x) \<le> d(x \<squnion> y)"
  by (simp add: d_isotone)

lemma d_idempotent:
  "d(x) * d(x) = d(x)"
  by (smt (verit, ccfv_threshold) d_involutive d_mult_sub d_Z d_dist_sup d_export d_restrict le_iff_sup sup_bot_left sup_commute)

text \<open>Theorem 44.12\<close>

lemma d_least_left_preserver:
  "x \<le> d(y) * x \<squnion> Z \<longleftrightarrow> d(x) \<le> d(y)"
  apply (rule iffI)
  apply (smt (z3) comm_monoid.comm_neutral d_involutive d_mult_sub d_plus_left_upper_bound d_Z d_dist_sup order_trans sup_absorb2 sup_bot.comm_monoid_axioms)
  by (smt (verit, del_insts) d_restrict mult_right_dist_sup sup.cobounded1 sup.orderE sup_assoc sup_commute)

text \<open>Theorem 44.9\<close>

lemma d_weak_locality:
  "x * y \<le> Z \<longleftrightarrow> x * d(y) \<le> Z"
  by (metis d_mult_d d_strict)

lemma d_sup_closed:
  "d(d(x) \<squnion> d(y)) = d(x) \<squnion> d(y)"
  by (simp add: d_involutive d_dist_sup)

lemma d_mult_closed:
  "d(d(x) * d(y)) = d(x) * d(y)"
  using d_export d_mult_d by auto

lemma d_mult_left_lower_bound:
  "d(x) * d(y) \<le> d(x)"
  by (metis d_export d_involutive d_mult_sub)

lemma d_mult_left_absorb_sup:
  "d(x) * (d(x) \<squnion> d(y)) = d(x)"
  by (smt d_sup_closed d_export d_idempotent d_involutive d_mult_sub order.eq_iff mult_left_sub_dist_sup_left)

lemma d_sup_left_absorb_mult:
  "d(x) \<squnion> d(x) * d(y) = d(x)"
  using d_mult_left_lower_bound sup.absorb_iff1 by auto

lemma d_commutative:
  "d(x) * d(y) = d(y) * d(x)"
  by (metis sup_commute order.antisym d_sup_left_absorb_mult d_below_one d_export d_mult_left_absorb_sup mult_assoc mult_left_isotone mult_left_one)

lemma d_mult_greatest_lower_bound:
  "d(x) \<le> d(y) * d(z) \<longleftrightarrow> d(x) \<le> d(y) \<and> d(x) \<le> d(z)"
  by (metis d_commutative d_idempotent d_mult_left_lower_bound mult_isotone order_trans)

lemma d_sup_left_dist_mult:
  "d(x) \<squnion> d(y) * d(z) = (d(x) \<squnion> d(y)) * (d(x) \<squnion> d(z))"
  by (metis sup_assoc d_commutative d_dist_sup d_idempotent d_mult_left_absorb_sup mult_right_dist_sup)

lemma d_order:
  "d(x) \<le> d(y) \<longleftrightarrow> d(x) = d(x) * d(y)"
  by (metis d_mult_greatest_lower_bound d_mult_left_absorb_sup le_iff_sup order_refl)

text \<open>Theorem 44.6\<close>

lemma Z_mult_decreasing:
  "Z * x \<le> Z"
  by (metis d_mult_sub bot.extremum d_strict order.eq_iff)

text \<open>Theorem 44.5\<close>

lemma d_below_d_one:
  "d(x) \<le> d(1)"
  by (metis d_mult_sub mult_left_one)

text \<open>Theorem 44.7\<close>

lemma d_relative_Z:
  "d(x) * x \<squnion> Z = x \<squnion> Z"
  by (metis sup_ge1 sup_same_context d_below_one d_restrict mult_isotone mult_left_one)

lemma Z_left_zero_above_one:
  "1 \<le> x \<Longrightarrow> Z * x = Z"
  by (metis Z_mult_decreasing order.eq_iff mult_right_isotone mult_1_right)

text \<open>Theorem 44.11\<close>

lemma kat_4:
  "d(x) * y = d(x) * y * d(z) \<Longrightarrow> d(x) * y \<le> y * d(z)"
  by (metis d_below_one mult_left_isotone mult_left_one)

lemma kat_4_equiv:
  "d(x) * y = d(x) * y * d(z) \<longleftrightarrow> d(x) * y \<le> y * d(z)"
  apply (rule iffI)
  apply (simp add: kat_4)
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_right_isotone)
  by (metis d_below_one mult_right_isotone mult_1_right)

lemma kat_4_equiv_opp:
  "y * d(x) = d(z) * y * d(x) \<longleftrightarrow> y * d(x) \<le> d(z) * y"
  apply (rule iffI)
  using d_below_one mult_right_isotone apply fastforce
  apply (rule order.antisym)
  apply (metis d_idempotent mult_assoc mult_left_isotone)
  by (metis d_below_one mult_left_isotone mult_left_one)

text \<open>Theorem 44.10\<close>

lemma d_restrict_iff_1:
  "d(x) * y \<le> z \<longleftrightarrow> d(x) * y \<le> d(x) * z"
  by (smt (verit, del_insts) d_below_one d_idempotent mult_assoc mult_left_isotone mult_left_one mult_right_isotone order_trans)

(* independence of axioms, checked in relative_domain_semiring without the respective axiom: *)
proposition d_restrict : "x \<le> d(x) * x \<squnion> Z" (* nitpick [expect=genuine,card=2] *) oops
proposition d_mult_d   : "d(x * y) = d(x * d(y))" (* nitpick [expect=genuine,card=3] *) oops
proposition d_below_one: "d(x) \<le> 1" (* nitpick [expect=genuine,card=3] *) oops
proposition d_Z        : "d(Z) = bot" (* nitpick [expect=genuine,card=2] *) oops
proposition d_dist_sup : "d(x \<squnion> y) = d(x) \<squnion> d(y)" (* nitpick [expect=genuine,card=3] *) oops
proposition d_export   : "d(d(x) * y) = d(x) * d(y)" (* nitpick [expect=genuine,card=5] *) oops

end

typedef (overloaded) 'a dImage = "{ x::'a::relative_domain_semiring . (\<exists>y::'a . x = d(y)) }"
  by auto

lemma simp_dImage[simp]:
  "\<exists>y . Rep_dImage x = d(y)"
  using Rep_dImage by simp

setup_lifting type_definition_dImage

text \<open>Theorem 44\<close>

instantiation dImage :: (relative_domain_semiring) bounded_distrib_lattice
begin

lift_definition sup_dImage :: "'a dImage \<Rightarrow> 'a dImage \<Rightarrow> 'a dImage" is sup
  by (metis d_dist_sup)

lift_definition inf_dImage :: "'a dImage \<Rightarrow> 'a dImage \<Rightarrow> 'a dImage" is times
  by (metis d_export)

lift_definition bot_dImage :: "'a dImage" is bot
  by (metis d_zero)

lift_definition top_dImage :: "'a dImage" is "d(1)"
  by auto

lift_definition less_eq_dImage :: "'a dImage \<Rightarrow> 'a dImage \<Rightarrow> bool" is less_eq .

lift_definition less_dImage :: "'a dImage \<Rightarrow> 'a dImage \<Rightarrow> bool" is less .

instance
  apply intro_classes
  apply (simp add: less_dImage.rep_eq less_eq_dImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_dImage.rep_eq)
  using less_eq_dImage.rep_eq apply simp
  apply (simp add: Rep_dImage_inject less_eq_dImage.rep_eq)
  apply (metis (mono_tags) d_involutive d_mult_sub inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq order_refl simp_dImage)
  apply (metis (mono_tags) d_mult_greatest_lower_bound inf_dImage.rep_eq less_eq_dImage.rep_eq simp_dImage)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: less_eq_dImage.rep_eq sup_dImage.rep_eq)
  apply (simp add: bot_dImage.rep_eq less_eq_dImage.rep_eq)
  apply (smt (z3) d_below_d_one less_eq_dImage.rep_eq simp_dImage top_dImage.rep_eq)
  by (smt (z3) inf_dImage.rep_eq sup_dImage.rep_eq simp_dImage Rep_dImage_inject d_sup_left_dist_mult)

end

class bounded_relative_domain_semiring = relative_domain_semiring + bounded_idempotent_left_semiring
begin

lemma Z_top:
  "Z * top = Z"
  by (simp add: Z_left_zero_above_one)

lemma d_restrict_top:
  "x \<le> d(x) * top \<squnion> Z"
  by (metis sup_left_isotone d_restrict mult_right_isotone order_trans top_greatest)

proposition d_one_one: "d(1) = 1" nitpick [expect=genuine,card=2] oops

end

class relative_domain_semiring_split = relative_domain_semiring +
  assumes split_Z: "x * (y \<squnion> Z) \<le> x * y \<squnion> Z"
begin

lemma d_restrict_iff:
  "(x \<le> y \<squnion> Z) \<longleftrightarrow> (x \<le> d(x) * y \<squnion> Z)"
proof -
  have "x \<le> y \<squnion> Z \<longrightarrow> x \<le> d(x) * (y \<squnion> Z) \<squnion> Z"
    by (smt sup_left_isotone d_restrict le_iff_sup mult_left_sub_dist_sup_left order_trans)
  hence "x \<le> y \<squnion> Z \<longrightarrow> x \<le> d(x) * y \<squnion> Z"
    by (meson le_supI order_lesseq_imp split_Z sup.cobounded2)
  thus ?thesis
    by (meson d_restrict_iff_1 le_supI mult_left_sub_dist_sup_left order_lesseq_imp sup.cobounded2)
qed

end

class relative_antidomain_semiring = idempotent_left_semiring + dom + Z + uminus +
  assumes a_restrict  : "-x * x \<le> Z"
  assumes a_mult_d    : "-(x * y) = -(x * --y)"
  assumes a_complement: "-x * --x = bot"
  assumes a_Z         : "-Z = 1"
  assumes a_export    : "-(--x * y) = -x \<squnion> -y"
  assumes a_dist_sup  : "-(x \<squnion> y) = -x * -y"
  assumes d_def       : "d(x) = --x"
begin

notation
  uminus ("a")

text \<open>Theorem 45.7\<close>

lemma a_complement_one:
  "--x \<squnion> -x = 1"
  by (metis a_Z a_complement a_export a_mult_d mult_left_one)

text \<open>Theorem 45.5 and Theorem 45.6\<close>

lemma a_d_closed:
  "d(a(x)) = a(x)"
  by (metis a_mult_d d_def mult_left_one)

lemma a_below_one:
  "a(x) \<le> 1"
  using a_complement_one sup_right_divisibility by auto

lemma a_export_a:
  "a(a(x) * y) = d(x) \<squnion> a(y)"
  by (metis a_d_closed a_export d_def)

lemma a_sup_absorb:
  "(x \<squnion> a(y)) * a(a(y)) = x * a(a(y))"
  by (simp add: a_complement mult_right_dist_sup)

text \<open>Theorem 45.10\<close>

lemma a_greatest_left_absorber:
  "a(x) * y \<le> Z \<longleftrightarrow> a(x) \<le> a(y)"
  apply (rule iffI)
  apply (smt a_Z a_sup_absorb a_dist_sup a_export_a a_mult_d sup_commute d_def le_iff_sup mult_left_one)
  by (meson a_restrict mult_isotone order.refl order_trans)

lemma a_plus_left_lower_bound:
  "a(x \<squnion> y) \<le> a(x)"
  by (metis a_greatest_left_absorber a_restrict sup_commute mult_left_sub_dist_sup_right order_trans)

text \<open>Theorem 45.2\<close>

subclass relative_domain_semiring
  apply unfold_locales
  apply (smt (verit) a_Z a_complement_one a_restrict sup_commute sup_ge1 case_split_left d_def order_trans)
  using a_mult_d d_def apply force
  apply (simp add: a_below_one d_def)
  apply (metis a_Z a_complement d_def mult_left_one)
  apply (simp add: a_export_a a_dist_sup d_def)
  using a_dist_sup a_export d_def by auto

text \<open>Theorem 45.1\<close>

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (metis a_dist_sup sup_commute)
  apply (smt a_complement a_d_closed a_export_a sup_bot_right d_sup_left_dist_mult)
  apply (metis a_d_closed a_dist_sup d_def)
  apply (rule the_equality[THEN sym])
  apply (simp add: a_complement)
  apply (simp add: a_complement)
  using a_d_closed a_Z d_Z d_def apply force
  using a_export a_mult_d apply fastforce
  apply (metis a_d_closed d_order)
  by (simp add: less_le_not_le)

lemma a_plus_mult_d:
  "-(x * y) \<squnion> -(x * --y) = -(x * --y)"
  using a_mult_d by auto

lemma a_mult_d_2:
  "a(x * y) = a(x * d(y))"
  using a_mult_d d_def by auto

lemma a_3:
  "a(x) * a(y) * d(x \<squnion> y) = bot"
  by (metis a_complement a_dist_sup d_def)

lemma a_fixpoint:
  "\<forall>x . (a(x) = x \<longrightarrow> (\<forall>y . y = bot))"
  by (metis a_complement_one mult_1_left mult_left_zero order.refl sup.order_iff tests_dual.one_def)

text \<open>Theorem 45.9\<close>

lemma a_strict:
  "a(x) = 1 \<longleftrightarrow> x \<le> Z"
  by (metis a_Z d_def d_strict order.refl tests_dual.sba_dual.double_negation)

lemma d_complement_zero:
  "d(x) * a(x) = bot"
  by (simp add: d_def tests_dual.sub_commutative)

lemma a_complement_zero:
  "a(x) * d(x) = bot"
  by (simp add: d_def)

lemma a_shunting_zero:
  "a(x) * d(y) = bot \<longleftrightarrow> a(x) \<le> a(y)"
  by (simp add: d_def tests_dual.sba_dual.less_eq_inf_bot)

lemma a_antitone:
  "x \<le> y \<Longrightarrow> a(y) \<le> a(x)"
  using a_plus_left_lower_bound sup_commute sup_right_divisibility by fastforce

lemma a_mult_deMorgan:
  "a(a(x) * a(y)) = d(x \<squnion> y)"
  by (simp add: a_dist_sup d_def)

lemma a_mult_deMorgan_1:
  "a(a(x) * a(y)) = d(x) \<squnion> d(y)"
  by (simp add: a_mult_deMorgan d_dist_sup)

lemma a_mult_deMorgan_2:
  "a(d(x) * d(y)) = a(x) \<squnion> a(y)"
  using a_export d_def by auto

lemma a_plus_deMorgan:
  "a(a(x) \<squnion> a(y)) = d(x) * d(y)"
  by (simp add: a_dist_sup d_def)

lemma a_plus_deMorgan_1:
  "a(d(x) \<squnion> d(y)) = a(x) * a(y)"
  by (simp add: a_dist_sup d_def)

text \<open>Theorem 45.8\<close>

lemma a_mult_left_upper_bound:
  "a(x) \<le> a(x * y)"
  using a_shunting_zero d_def d_mult_sub tests_dual.less_eq_sup_top by auto

text \<open>Theorem 45.6\<close>

lemma d_a_closed:
  "a(d(x)) = a(x)"
  by (simp add: d_def)

lemma a_export_d:
  "a(d(x) * y) = a(x) \<squnion> a(y)"
  by (simp add: a_export d_def)

lemma a_7:
  "d(x) * a(d(y) \<squnion> d(z)) = d(x) * a(y) * a(z)"
  by (simp add: a_plus_deMorgan_1 mult_assoc)

lemma d_a_shunting:
  "d(x) * a(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z) \<squnion> d(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_d_shunting:
  "d(x) * d(y) \<le> d(z) \<longleftrightarrow> d(x) \<le> d(z) \<squnion> a(y)"
  by (simp add: d_def tests_dual.sba_dual.shunting_right)

lemma d_cancellation_1:
  "d(x) \<le> d(y) \<squnion> (d(x) * a(y))"
  by (smt (z3) a_d_closed d_a_shunting d_export eq_refl sup_commute)

lemma d_cancellation_2:
  "(d(z) \<squnion> d(y)) * a(y) \<le> d(z)"
  by (metis d_a_shunting d_dist_sup eq_refl)

lemma a_sup_closed:
  "d(a(x) \<squnion> a(y)) = a(x) \<squnion> a(y)"
  using a_mult_deMorgan tests_dual.sub_inf_def by auto

lemma a_mult_closed:
  "d(a(x) * a(y)) = a(x) * a(y)"
  using d_def tests_dual.sub_sup_closed by auto

lemma d_a_shunting_zero:
  "d(x) * a(y) = bot \<longleftrightarrow> d(x) \<le> d(y)"
  using a_shunting_zero d_def by force

lemma d_d_shunting_zero:
  "d(x) * d(y) = bot \<longleftrightarrow> d(x) \<le> a(y)"
  using d_a_shunting_zero d_def by auto

lemma d_compl_intro:
  "d(x) \<squnion> d(y) = d(x) \<squnion> a(x) * d(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma a_compl_intro:
  "a(x) \<squnion> a(y) = a(x) \<squnion> d(x) * a(y)"
  by (simp add: d_def tests_dual.sba_dual.sup_complement_intro)

lemma kat_2:
  "y * a(z) \<le> a(x) * y \<Longrightarrow> d(x) * y * a(z) = bot"
  by (metis d_complement_zero order.eq_iff mult_assoc mult_left_zero mult_right_isotone bot_least)

text \<open>Theorem 45.4\<close>

lemma kat_2_equiv:
  "y * a(z) \<le> a(x) * y \<longleftrightarrow> d(x) * y * a(z) = bot"
  apply (rule iffI)
  apply (simp add: kat_2)
  by (smt (verit, best) a_Z a_below_one a_complement_one case_split_left d_def mult_assoc mult_right_isotone mult_1_right bot_least)

lemma kat_3_equiv_opp:
  "a(z) * y * d(x) = bot \<longleftrightarrow> y * d(x) = d(z) * y * d(x)"
  using kat_2_equiv d_def kat_4_equiv_opp by auto

text \<open>Theorem 45.4\<close>

lemma kat_3_equiv_opp_2:
  "d(z) * y * a(x) = bot \<longleftrightarrow> y * a(x) = a(z) * y * a(x)"
  by (metis a_d_closed kat_3_equiv_opp d_def)

lemma kat_equiv_6:
  "d(x) * y * a(z) = d(x) * y * bot \<longleftrightarrow> d(x) * y * a(z) \<le> y * bot"
  by (metis d_restrict_iff_1 order.eq_iff mult_left_sub_dist_sup_right tests_dual.sba_dual.sup_right_unit mult_assoc)

lemma d_one_one:
  "d(1) = 1"
  by (simp add: d_def)

lemma case_split_left_sup:
  "-p * x \<le> y \<and> --p * x \<le> z \<Longrightarrow> x \<le> y \<squnion> z"
  by (smt (z3) a_complement_one case_split_left order_lesseq_imp sup.cobounded2 sup_ge1)

lemma test_mult_left_sub_dist_shunt:
  "-p * (--p * x \<squnion> Z) \<le> Z"
  by (simp add: a_greatest_left_absorber a_Z a_dist_sup a_export)

lemma test_mult_left_dist_shunt:
  "-p * (--p * x \<squnion> Z) = -p * Z"
  by (smt (verit, ccfv_SIG) order.antisym mult_left_sub_dist_sup_right sup.orderE tests_dual.sba_dual.sup_idempotent mult_assoc test_mult_left_sub_dist_shunt tests_dual.sup_absorb)

(* independence of axioms, checked in relative_antidomain_semiring without the respective axiom: *)
proposition a_restrict  : "-x * x \<le> Z" (* nitpick [expect=genuine,card=3] *) oops
proposition a_mult_d    : "-(x * y) = -(x * --y)" (* nitpick [expect=genuine,card=3] *) oops
proposition a_complement: "-x * --x = bot" (* nitpick [expect=genuine,card=2] *) oops
proposition a_Z         : "-Z = 1" (* nitpick [expect=genuine,card=2] *) oops
proposition a_export    : "-(--x * y) = -x \<squnion> -y" (* nitpick [expect=genuine,card=5] *) oops
proposition a_dist_sup  : "-(x \<squnion> y) = -x * -y" (* nitpick [expect=genuine,card=3] *) oops
proposition d_def       : "d(x) = --x" (* nitpick [expect=genuine,card=2] *) oops

end

typedef (overloaded) 'a aImage = "{ x::'a::relative_antidomain_semiring . (\<exists>y::'a . x = a(y)) }"
  by auto

lemma simp_aImage[simp]:
  "\<exists>y . Rep_aImage x = a(y)"
  using Rep_aImage by simp

setup_lifting type_definition_aImage

text \<open>Theorem 45.3\<close>

instantiation aImage :: (relative_antidomain_semiring) boolean_algebra
begin

lift_definition sup_aImage :: "'a aImage \<Rightarrow> 'a aImage \<Rightarrow> 'a aImage" is sup
  using tests_dual.sba_dual.sba_dual.inf_closed by auto

lift_definition inf_aImage :: "'a aImage \<Rightarrow> 'a aImage \<Rightarrow> 'a aImage" is times
  using tests_dual.sba_dual.inf_closed by auto

lift_definition minus_aImage :: "'a aImage \<Rightarrow> 'a aImage \<Rightarrow> 'a aImage" is "\<lambda>x y . x * a(y)"
  using tests_dual.sba_dual.inf_closed by blast

lift_definition uminus_aImage :: "'a aImage \<Rightarrow> 'a aImage" is a
  by auto

lift_definition bot_aImage :: "'a aImage" is bot
  by (metis tests_dual.sba_dual.sba_dual.complement_bot)

lift_definition top_aImage :: "'a aImage" is 1
  using a_Z by auto

lift_definition less_eq_aImage :: "'a aImage \<Rightarrow> 'a aImage \<Rightarrow> bool" is less_eq .

lift_definition less_aImage :: "'a aImage \<Rightarrow> 'a aImage \<Rightarrow> bool" is less .

instance
  apply intro_classes
  apply (simp add: less_aImage.rep_eq less_eq_aImage.rep_eq less_le_not_le)
  apply (simp add: less_eq_aImage.rep_eq)
  using less_eq_aImage.rep_eq apply simp
  apply (simp add: Rep_aImage_inject less_eq_aImage.rep_eq)
  apply (metis (mono_tags) a_below_one inf_aImage.rep_eq less_eq_aImage.rep_eq mult.right_neutral mult_right_isotone simp_aImage)
  apply (metis (mono_tags, lifting) less_eq_aImage.rep_eq a_d_closed a_export bot.extremum_unique inf_aImage.rep_eq kat_equiv_6 mult.assoc mult.left_neutral mult_left_isotone mult_left_zero simp_aImage sup.cobounded1 tests_dual.sba_dual.sba_dual.complement_top)
  apply (smt (z3) less_eq_aImage.rep_eq inf_aImage.rep_eq mult_isotone simp_aImage tests_dual.sba_dual.inf_idempotent)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  apply (simp add: less_eq_aImage.rep_eq sup_aImage.rep_eq)
  using less_eq_aImage.rep_eq sup_aImage.rep_eq apply force
  apply (simp add: less_eq_aImage.rep_eq bot_aImage.rep_eq)
  apply (smt (z3) less_eq_aImage.rep_eq a_below_one simp_aImage top_aImage.rep_eq)
  apply (metis (mono_tags, lifting) tests_dual.sba_dual.sba_dual.inf_left_dist_sup Rep_aImage_inject inf_aImage.rep_eq sup_aImage.rep_eq simp_aImage)
  apply (smt (z3) inf_aImage.rep_eq uminus_aImage.rep_eq Rep_aImage_inject a_complement bot_aImage.rep_eq simp_aImage)
  apply (smt (z3) top_aImage.rep_eq Rep_aImage_inject a_complement_one simp_aImage sup_aImage.rep_eq sup_commute uminus_aImage.rep_eq)
  by (metis (mono_tags) inf_aImage.rep_eq Rep_aImage_inject minus_aImage.rep_eq uminus_aImage.rep_eq)

end

class bounded_relative_antidomain_semiring = relative_antidomain_semiring + bounded_idempotent_left_semiring
begin

subclass bounded_relative_domain_semiring ..

lemma a_top:
  "a(top) = bot"
  by (metis a_plus_left_lower_bound bot_unique sup_right_top tests_dual.sba_dual.complement_top)

lemma d_top:
  "d(top) = 1"
  using a_top d_def by auto

lemma shunting_top_1:
  "-p * x \<le> y \<Longrightarrow> x \<le> --p * top \<squnion> y"
  by (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)

lemma shunting_Z:
  "-p * x \<le> Z \<longleftrightarrow> x \<le> --p * top \<squnion> Z"
  apply (rule iffI)
  apply (simp add: shunting_top_1)
  by (smt a_top a_Z a_antitone a_dist_sup a_export a_greatest_left_absorber sup_commute sup_bot_right mult_left_one)

proposition a_left_dist_sup: "-p * (y \<squnion> z) = -p * y \<squnion> -p * z" nitpick [expect=genuine,card=7] oops
proposition shunting_top: "-p * x \<le> y \<longleftrightarrow> x \<le> --p * top \<squnion> y" nitpick [expect=genuine,card=7] oops

end

class relative_left_zero_antidomain_semiring = relative_antidomain_semiring + idempotent_left_zero_semiring
begin

lemma kat_3:
  "d(x) * y * a(z) = bot \<Longrightarrow> d(x) * y = d(x) * y * d(z)"
  by (metis d_def mult_1_right mult_left_dist_sup sup_monoid.add_0_left tests_dual.inf_complement)

lemma a_a_below:
  "a(a(x)) * y \<le> y"
  using d_def d_restrict_iff_1 by auto

lemma kat_equiv_5:
  "d(x) * y \<le> y * d(z) \<longleftrightarrow> d(x) * y * a(z) = d(x) * y * bot"
proof
  assume "d(x) * y \<le> y * d(z)"
  thus "d(x) * y * a(z) = d(x) * y * bot"
    by (metis d_complement_zero kat_4_equiv mult_assoc)
next
  assume "d(x) * y * a(z) = d(x) * y * bot"
  hence "a(a(x)) * y * a(z) \<le> y * a(a(z))"
    by (simp add: a_a_below d_def mult_isotone)
  thus "d(x) * y \<le> y * d(z)"
    by (metis a_a_below a_complement_one case_split_right d_def mult_isotone order_refl)
qed

lemma case_split_right_sup:
  "x * -p \<le> y \<Longrightarrow> x * --p \<le> z \<Longrightarrow> x \<le> y \<squnion> z"
  by (smt (verit, ccfv_SIG) a_complement_one order.trans mult_1_right mult_left_dist_sup sup_commute sup_right_isotone)

end

class bounded_relative_left_zero_antidomain_semiring = relative_left_zero_antidomain_semiring + bounded_idempotent_left_zero_semiring
begin

lemma shunting_top:
  "-p * x \<le> y \<longleftrightarrow> x \<le> --p * top \<squnion> y"
  apply (rule iffI)
  apply (metis sup_commute case_split_left_sup mult_right_isotone top_greatest)
  by (metis a_complement sup_bot_left sup_right_divisibility mult_assoc mult_left_dist_sup mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone order_trans tests_dual.inf_left_unit)

end

end


(* Title:  Digraph_Component_Vwalk.thy
   Author: Lars Noschinski, TU München
*)

theory Digraph_Component_Vwalk
imports
  Digraph_Component
  Vertex_Walk
begin

section {* Lemmas for Vertex Walks *}

lemma vwalkI_subgraph:
  assumes "vwalk p H"
  assumes "subgraph H G"
  shows "vwalk p G"
proof
  show "set p \<subseteq> verts G" and "p \<noteq> []"
    using assms by (auto simp add: subgraph_def vwalk_def)

  have "set (vwalk_arcs p) \<subseteq> arcs_ends H"
    using assms by (simp add: vwalk_def)
  also have "\<dots> \<subseteq> arcs_ends G"
    using `subgraph H G` by (rule arcs_ends_mono)
  finally show "set (vwalk_arcs p) \<subseteq> arcs_ends G" .
qed

lemma vpathI_subgraph:
  assumes "vpath p G"
  assumes "subgraph G H"
  shows "vpath p H"
using assms by (auto intro: vwalkI_subgraph)

lemma (in loopfree_digraph) vpathI_arc:
  assumes "(a,b) \<in> arcs_ends G"
  shows "vpath [a,b] G"
using assms
by (intro vpathI vwalkI) (auto intro: adj_in_verts adj_not_same)

end


theory GCL_Examples
  imports GCL_Syntax
begin

record euclids =
  x :: nat
  y :: nat

lemma euclids: "\<turnstile> \<lbrace> `x = xo \<and> `y = yo \<rbrace>
    inv gcd xo yo = gcd `x `y
    do [
      `x > `y \<rightarrow> `x := `x - `y,
      `x < `y \<rightarrow> `y := `y - `x
    ] od
  \<lbrace> `x = gcd xo yo \<and> `x = `y \<rbrace>"
  apply hoare
  using gcd_diff1_nat gcd_nat.commute by auto

hide_const x y

record max =
  x :: nat
  y :: nat
  z :: nat

lemma max: "\<turnstile> \<lbrace> True \<rbrace>
    if [
      `x \<ge> `y \<rightarrow> `z := `x,
      `y \<ge> `x \<rightarrow> `z := `y
    ] fi
  \<lbrace> `z = max `x `y \<rbrace>"
  by hoare auto

hide_const x y z

record handshake_state = pc_state +
  x :: bool
  y :: bool
  c :: bool

lemma "\<turnstile> \<lbrace> \<not>`c \<rbrace>
    inv (
      (`pcX = 0 \<longrightarrow> `x \<longrightarrow> \<not> `c) \<and>
      (`pcX = 1 \<longrightarrow> (`x \<longrightarrow> \<not> `c) \<and> (`y \<longrightarrow> `c)) \<and>
      (`pcX = 2 \<longrightarrow> `y \<longrightarrow> `c) \<and>
      (`pcX = 3 \<longrightarrow> `c) \<and>
      (`pcX = 4 \<longrightarrow> `x \<and> `c) \<and>

      (`pcY \<le> 1 \<longrightarrow> \<not> `c) \<and>
      (`pcY = 1 \<longrightarrow> `x \<longrightarrow> `pcX > 1) \<and>
      (`pcY \<ge> 2 \<longrightarrow> `c) \<and>
      (`pcY = 4 \<longrightarrow> `y \<and> `c) \<and>

      (`pcX = 2 \<and> `pcY = 2 \<longrightarrow> `x \<or> `y) \<and>
      (`pcX \<le> 1 \<longrightarrow> `pcY \<le> 2) \<and>
      (`pcY \<le> 1 \<longrightarrow> `pcX \<le> 2)
    )
    0 =: `y := False ;;
    1 =: `x := True ;;
    2 =: wait `y ;;
    3 =: `x := True
      \<parallel>
    0 =: `x := False ;;
    1 =: `y := True; `c := True ;;
    2 =: wait `x ;;
    3 =: `y := True; `c := True
  \<lbrace> `x \<and> `y \<and> `c \<rbrace>"
  apply transform
apply hoare
by force+

hide_const x y c x

record mutual_incl_protocol = pc_state +
  x :: int
  y :: int
  c :: bool

lemma "\<turnstile> \<lbrace> `x = 0 \<and> `y = 0 \<and> `c \<rbrace>
    inv (
      (`x \<le> `y) \<and> (`y \<le> `x + 1) \<and>

      (`pcX \<le> 1 \<longrightarrow>  `c \<and> (`x = `y)) \<and>
      (`pcX = 2 \<longrightarrow> \<not>`c \<or> (`x + 1 = `y)) \<and>
      (`pcX = 3 \<longrightarrow> `c \<and> (`x + 1 = `y)) \<and>

      (`pcY \<le> 1 \<longrightarrow> `c \<or> (`x = `y)) \<and>
      (`pcY = 2 \<longrightarrow> \<not>`c \<and> (`x = `y)) \<and>
      (`pcY = 3 \<longrightarrow> \<not>`c \<and> (`x + 1 = `y))
    )
    0 =: while True do
            (* Critical Section 1 *)
           1 =: `c := False ;;
           2 =: wait `c ;;
           3 =: `x := `x + 1
         od
      \<parallel>
    0 =: while True do
           1 =: wait (\<not> `c) ;;
            (* Critical Section 2 *)
           2 =: `y := `y + 1 ;;
           3 =: `c := True
         od
  \<lbrace> True \<rbrace>"
  apply transform
  apply hoare
  by force+

lemma "\<turnstile> \<lbrace> `x = 0 \<and> `y = 0 \<and> `c \<rbrace>
    inv (
      (`x \<le> `y) \<and> (`y \<le> `x + 1) \<and>
      (`pcX \<le> 1 \<longrightarrow>  `c \<and> (`x = `y)) \<and>
      (`pcX = 2 \<longrightarrow> \<not>`c \<or> (`x + 1 = `y)) \<and>
      (`pcX = 3 \<longrightarrow> `c \<and> (`x + 1 = `y)) \<and>
      (`pcY \<le> 1 \<longrightarrow> `c \<or> (`x = `y)) \<and>
      (`pcY = 2 \<longrightarrow> \<not>`c \<and> (`x = `y)) \<and>
      (`pcY = 3 \<longrightarrow> \<not>`c \<and> (`x + 1 = `y))
    )
    0 =: while `x = `y  do
            (* Critical Section 1 *)
           1 =: `c := False ;;
           2 =: wait `c ;;
           3 =: `x := `x + 1
         od
      \<parallel>
    0 =: while `x = `y do
           1 =: wait (\<not> `c) ;;
            (* Critical Section 2 *)
           2 =: `y := `y + 1 ;;
           3 =: `c := True
         od
  \<lbrace> True \<rbrace>"
  apply transform
  apply hoare
  by force+

hide_const x y pcX pcY c

end


(* Author: R. Thiemann *)
section \<open>Elimination of CARD('n)\<close>

text \<open>In the following theory we provide a method which modifies theorems
  of the form $P[CARD('n)]$ into $n != 0 \Longrightarrow P[n]$, so that they can more
  easily be applied.

  Known issues: there might be problems with nested meta-implications and meta-quantification.\<close>

theory Cancel_Card_Constraint
imports
  "HOL-Types_To_Sets.Types_To_Sets"
  "HOL-Library.Cardinality"
begin

lemma n_zero_nonempty: "n \<noteq> 0 \<Longrightarrow> {0 ..< n :: nat} \<noteq> {}" by auto

lemma type_impl_card_n: assumes "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< n :: nat}"
  shows "class.finite (TYPE('a)) \<and> CARD('a) = n"
proof -
  from assms obtain rep :: "'a \<Rightarrow> nat" and abs :: "nat \<Rightarrow> 'a" where t: "type_definition rep abs {0 ..< n}" by auto
  have "card (UNIV :: 'a set) = card {0 ..< n}" using t by (rule type_definition.card)
  also have "\<dots> = n" by auto
  finally have bn: "CARD ('a) = n" .
  have "finite (abs ` {0 ..< n})" by auto
  also have "abs ` {0 ..< n} = UNIV" using t by (rule type_definition.Abs_image)
  finally have "class.finite (TYPE('a))" unfolding class.finite_def .
  with bn show ?thesis by blast
qed

ML_file \<open>cancel_card_constraint.ML\<close>

(* below you find an example what the attribute cancel_card_constraint can do and how
   it works internally *)

(*
(* input: some type based lemma with CARD inside, like t0 *)
consts P :: "nat \<Rightarrow> nat \<Rightarrow> bool"
axiomatization where t0: "P (CARD ('a :: finite)) (CARD('a) * m)"

(* t0 is converted into a property without the cardinality constraint via the new attribute *)
lemma t_1_to_6: "n \<noteq> 0 \<Longrightarrow> P n (n * m)"
  by (rule t0[cancel_card_constraint])

(* The internal steps are as follows. *)

(* 1st step: pull out CARD and introduce new variable n *)
lemma t1: "CARD('a :: finite) = n \<Longrightarrow> P n (n * m)"
  using t0[where 'a = 'a] by blast

(* 2nd step: get rid of sorts *)
lemma t2: "class.finite TYPE('a) \<Longrightarrow> CARD('a) = n \<Longrightarrow> P n (n * m)"
  by (rule t1[internalize_sort "?'a::finite"])

(* 3rd step: restructure thm so that first two assumptions are merged into one *)
lemma t3: "class.finite TYPE('a) \<and> CARD('a) = n \<Longrightarrow> P n (n * m)"
  using t2 by blast

(* 4th step: choose an appropriate carrier set *)
lemma t4: "\<exists>Rep Abs. type_definition Rep Abs {0..<n} \<Longrightarrow> P n (n * m)"
  by (rule t3[OF type_impl_card_n])

(* 5th step: cancel type definition *)
lemma t5: "{0..<n} \<noteq> {} \<Longrightarrow> P n (n * m)"
  by (rule t4[cancel_type_definition])

(* 6th step: simplify non-empty assumption to obtain final theorem *)
lemma t6: "n \<noteq> 0 \<Longrightarrow> P n (n * m)"
  by (rule t5[OF n_zero_nonempty])
*)

end


(*  Title:      HOL/ex/Simproc_Tests.thy
    Author:     Brian Huffman
*)

section {* Testing of arithmetic simprocs *}

theory Simproc_Tests
imports Main
begin

text {*
  This theory tests the various simprocs defined in @{file
  "~~/src/HOL/Nat.thy"} and @{file "~~/src/HOL/Numeral_Simprocs.thy"}.
  Many of the tests are derived from commented-out code originally
  found in @{file "~~/src/HOL/Tools/numeral_simprocs.ML"}.
*}

subsection {* ML bindings *}

ML {*
  fun test ctxt ps =
    CHANGED (asm_simp_tac (put_simpset HOL_basic_ss ctxt addsimprocs ps) 1)
*}

subsection {* Cancellation simprocs from @{text Nat.thy} *}

notepad begin
  fix a b c d :: nat
  {
    assume "b = Suc c" have "a + b = Suc (c + a)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_sums}] *}) fact
  next
    assume "b < Suc c" have "a + b < Suc (c + a)"
      by (tactic {* test @{context} [@{simproc natless_cancel_sums}] *}) fact
  next
    assume "b \<le> Suc c" have "a + b \<le> Suc (c + a)"
      by (tactic {* test @{context} [@{simproc natle_cancel_sums}] *}) fact
  next
    assume "b - Suc c = d" have "a + b - Suc (c + a) = d"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_sums}] *}) fact
  }
end

schematic_lemma "\<And>(y::?'b::size). size (?x::?'a::size) \<le> size y + size ?x"
  by (tactic {* test @{context} [@{simproc natle_cancel_sums}] *}) (rule le0)
(* TODO: test more simprocs with schematic variables *)

subsection {* Abelian group cancellation simprocs *}

notepad begin
  fix a b c u :: "'a::ab_group_add"
  {
    assume "(a + 0) - (b + 0) = u" have "(a + c) - (b + c) = u"
      by (tactic {* test @{context} [@{simproc group_cancel_diff}] *}) fact
  next
    assume "a + 0 = b + 0" have "a + c = b + c"
      by (tactic {* test @{context} [@{simproc group_cancel_eq}] *}) fact
  }
end
(* TODO: more tests for Groups.group_cancel_{add,diff,eq,less,le} *)

subsection {* @{text int_combine_numerals} *}

(* FIXME: int_combine_numerals often unnecessarily regroups addition
and rewrites subtraction to negation. Ideally it should behave more
like Groups.abel_cancel_sum, preserving the shape of terms as much as
possible. *)

notepad begin
  fix a b c d oo uu i j k l u v w x y z :: "'a::comm_ring_1"
  {
    assume "a + - b = u" have "(a + c) - (b + c) = u"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "10 + (2 * l + oo) = uu"
    have "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = uu"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-3 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 15 = y"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "7 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 5 = y"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-4 * (u * v) + (2 * x + y) = w"
    have "(2*x - (u*v) + y) - v*3*u = w"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "2 * x * u * v + y = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u*4 = w"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-3 * (u * v) + (- (x * u * v) + - y) = w"
    have "u*v - (x*u*v + (u*v)*4 + y) = w"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "a + - c = d"
    have "a + -(b+c) + b = d"
      apply (simp only: minus_add_distrib)
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-2 * b + (a + - c) = d"
    have "a + -(b+c) - b = d"
      apply (simp only: minus_add_distrib)
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-7 + (i + (j + (k + (- u + - y)))) = z"
    have "(i + j + -2 + k) - (u + 5 + y) = z"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "-27 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - 15 = y"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "27 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - -15 = y"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  next
    assume "3 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - -15 = y"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}] *}) fact
  }
end

subsection {* @{text inteq_cancel_numerals} *}

notepad begin
  fix i j k u vv w y z w' y' z' :: "'a::comm_ring_1"
  {
    assume "u = 0" have "2*u = u"
      by (tactic {* test @{context} [@{simproc inteq_cancel_numerals}] *}) fact
(* conclusion matches Rings.ring_1_no_zero_divisors_class.mult_cancel_right2 *)
  next
    assume "i + (j + k) = 3 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic {* test @{context} [@{simproc inteq_cancel_numerals}] *}) fact
  next
    assume "7 + (j + (i + k)) = y"
    have "(i + j*2 + 12 + k) = j + 5 + y"
      by (tactic {* test @{context} [@{simproc inteq_cancel_numerals}] *}) fact
  next
    assume "u + (6*z + (4*y + 6*w)) = 6*z' + (4*y' + (6*w' + vv))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic {* test @{context} [@{simproc int_combine_numerals}, @{simproc inteq_cancel_numerals}] *}) fact
  }
end

subsection {* @{text intless_cancel_numerals} *}

notepad begin
  fix b c i j k u y :: "'a::linordered_idom"
  {
    assume "y < 2 * b" have "y - b < b"
      by (tactic {* test @{context} [@{simproc intless_cancel_numerals}] *}) fact
  next
    assume "c + y < 4 * b" have "y - (3*b + c) < b - 2*c"
      by (tactic {* test @{context} [@{simproc intless_cancel_numerals}] *}) fact
  next
    assume "i + (j + k) < 8 + (u + y)"
    have "(i + j + -3 + k) < u + 5 + y"
      by (tactic {* test @{context} [@{simproc intless_cancel_numerals}] *}) fact
  next
    assume "9 + (i + (j + k)) < u + y"
    have "(i + j + 3 + k) < u + -6 + y"
      by (tactic {* test @{context} [@{simproc intless_cancel_numerals}] *}) fact
  }
end

subsection {* @{text ring_eq_cancel_numeral_factor} *}

notepad begin
  fix x y :: "'a::{idom,ring_char_0}"
  {
    assume "3*x = 4*y" have "9*x = 12 * y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  next
    assume "-3*x = 4*y" have "-99*x = 132 * y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  next
    assume "111*x = -44*y" have "999*x = -396 * y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  next
    assume "11*x = 9*y" have "-99*x = -81 * y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  next
    assume "2*x = y" have "-2 * x = -1 * y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  next
    assume "2*x = y" have "-2 * x = -y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_numeral_factor}] *}) fact
  }
end

subsection {* @{text int_div_cancel_numeral_factors} *}

notepad begin
  fix x y z :: "'a::{semiring_div,comm_ring_1,ring_char_0}"
  {
    assume "(3*x) div (4*y) = z" have "(9*x) div (12*y) = z"
      by (tactic {* test @{context} [@{simproc int_div_cancel_numeral_factors}] *}) fact
  next
    assume "(-3*x) div (4*y) = z" have "(-99*x) div (132*y) = z"
      by (tactic {* test @{context} [@{simproc int_div_cancel_numeral_factors}] *}) fact
  next
    assume "(111*x) div (-44*y) = z" have "(999*x) div (-396*y) = z"
      by (tactic {* test @{context} [@{simproc int_div_cancel_numeral_factors}] *}) fact
  next
    assume "(11*x) div (9*y) = z" have "(-99*x) div (-81*y) = z"
      by (tactic {* test @{context} [@{simproc int_div_cancel_numeral_factors}] *}) fact
  next
    assume "(2*x) div y = z"
    have "(-2 * x) div (-1 * y) = z"
      by (tactic {* test @{context} [@{simproc int_div_cancel_numeral_factors}] *}) fact
  }
end

subsection {* @{text ring_less_cancel_numeral_factor} *}

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x < 4*y" have "9*x < 12 * y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  next
    assume "-3*x < 4*y" have "-99*x < 132 * y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  next
    assume "111*x < -44*y" have "999*x < -396 * y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  next
    assume "9*y < 11*x" have "-99*x < -81 * y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  next
    assume "y < 2*x" have "-2 * x < -y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  next
    assume "23*y < x" have "-x < -23 * y"
      by (tactic {* test @{context} [@{simproc ring_less_cancel_numeral_factor}] *}) fact
  }
end

subsection {* @{text ring_le_cancel_numeral_factor} *}

notepad begin
  fix x y :: "'a::linordered_idom"
  {
    assume "3*x \<le> 4*y" have "9*x \<le> 12 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "-3*x \<le> 4*y" have "-99*x \<le> 132 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "111*x \<le> -44*y" have "999*x \<le> -396 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "9*y \<le> 11*x" have "-99*x \<le> -81 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "y \<le> 2*x" have "-2 * x \<le> -1 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "23*y \<le> x" have "-x \<le> -23 * y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "y \<le> 0" have "0 \<le> y * -2"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  next
    assume "- x \<le> y" have "- (2 * x) \<le> 2*y"
      by (tactic {* test @{context} [@{simproc ring_le_cancel_numeral_factor}] *}) fact
  }
end

subsection {* @{text divide_cancel_numeral_factor} *}

notepad begin
  fix x y z :: "'a::{field_inverse_zero,ring_char_0}"
  {
    assume "(3*x) / (4*y) = z" have "(9*x) / (12 * y) = z"
      by (tactic {* test @{context} [@{simproc divide_cancel_numeral_factor}] *}) fact
  next
    assume "(-3*x) / (4*y) = z" have "(-99*x) / (132 * y) = z"
      by (tactic {* test @{context} [@{simproc divide_cancel_numeral_factor}] *}) fact
  next
    assume "(111*x) / (-44*y) = z" have "(999*x) / (-396 * y) = z"
      by (tactic {* test @{context} [@{simproc divide_cancel_numeral_factor}] *}) fact
  next
    assume "(11*x) / (9*y) = z" have "(-99*x) / (-81 * y) = z"
      by (tactic {* test @{context} [@{simproc divide_cancel_numeral_factor}] *}) fact
  next
    assume "(2*x) / y = z" have "(-2 * x) / (-1 * y) = z"
      by (tactic {* test @{context} [@{simproc divide_cancel_numeral_factor}] *}) fact
  }
end

subsection {* @{text ring_eq_cancel_factor} *}

notepad begin
  fix a b c d k x y :: "'a::idom"
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  next
    assume "b = 0 \<or> a*c = 1" have "a*(b*c) = b"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d*x" have "a*(b*c) = d*b*(x*a)"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic {* test @{context} [@{simproc ring_eq_cancel_factor}] *}) fact
  }
end

subsection {* @{text int_div_cancel_factor} *}

notepad begin
  fix a b c d k uu x y :: "'a::semiring_div"
  {
    assume "(if k = 0 then 0 else x div y) = uu"
    have "(x*k) div (k*y) = uu"
      by (tactic {* test @{context} [@{simproc int_div_cancel_factor}] *}) fact
  next
    assume "(if k = 0 then 0 else 1 div y) = uu"
    have "(k) div (k*y) = uu"
      by (tactic {* test @{context} [@{simproc int_div_cancel_factor}] *}) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) div b = uu"
      by (tactic {* test @{context} [@{simproc int_div_cancel_factor}] *}) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic {* test @{context} [@{simproc int_div_cancel_factor}] *}) fact
  }
end

lemma shows "a*(b*c)/(y*z) = d*(b::'a::linordered_field_inverse_zero)*(x*a)/z"
oops -- "FIXME: need simproc to cover this case"

subsection {* @{text divide_cancel_factor} *}

notepad begin
  fix a b c d k uu x y :: "'a::field_inverse_zero"
  {
    assume "(if k = 0 then 0 else x / y) = uu"
    have "(x*k) / (k*y) = uu"
      by (tactic {* test @{context} [@{simproc divide_cancel_factor}] *}) fact
  next
    assume "(if k = 0 then 0 else 1 / y) = uu"
    have "(k) / (k*y) = uu"
      by (tactic {* test @{context} [@{simproc divide_cancel_factor}] *}) fact
  next
    assume "(if b = 0 then 0 else a * c / 1) = uu"
    have "(a*(b*c)) / b = uu"
      by (tactic {* test @{context} [@{simproc divide_cancel_factor}] *}) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c / (d * x)) = uu"
    have "(a*(b*c)) / (d*b*(x*a)) = uu"
      by (tactic {* test @{context} [@{simproc divide_cancel_factor}] *}) fact
  }
end

lemma
  fixes a b c d x y z :: "'a::linordered_field_inverse_zero"
  shows "a*(b*c)/(y*z) = d*(b)*(x*a)/z"
oops -- "FIXME: need simproc to cover this case"

subsection {* @{text linordered_ring_less_cancel_factor} *}

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < y*z"
      by (tactic {* test @{context} [@{simproc linordered_ring_less_cancel_factor}] *}) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < z*y"
      by (tactic {* test @{context} [@{simproc linordered_ring_less_cancel_factor}] *}) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < y*z"
      by (tactic {* test @{context} [@{simproc linordered_ring_less_cancel_factor}] *}) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < z*y"
      by (tactic {* test @{context} [@{simproc linordered_ring_less_cancel_factor}] *}) fact
  next
    txt "This simproc now uses the simplifier to prove that terms to
      be canceled are positive/negative."
    assume z_pos: "0 < z"
    assume "x < y" have "z*x < z*y"
      by (tactic {* CHANGED (asm_simp_tac (put_simpset HOL_basic_ss @{context}
        addsimprocs [@{simproc linordered_ring_less_cancel_factor}]
        addsimps [@{thm z_pos}]) 1) *}) fact
  }
end

subsection {* @{text linordered_ring_le_cancel_factor} *}

notepad begin
  fix x y z :: "'a::linordered_idom"
  {
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> x*z \<le> y*z"
      by (tactic {* test @{context} [@{simproc linordered_ring_le_cancel_factor}] *}) fact
  next
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> z*x \<le> z*y"
      by (tactic {* test @{context} [@{simproc linordered_ring_le_cancel_factor}] *}) fact
  }
end

subsection {* @{text field_combine_numerals} *}

notepad begin
  fix x y z uu :: "'a::{field_inverse_zero,ring_char_0}"
  {
    assume "5 / 6 * x = uu" have "x / 2 + x / 3 = uu"
      by (tactic {* test @{context} [@{simproc field_combine_numerals}] *}) fact
  next
    assume "6 / 9 * x + y = uu" have "x / 3 + y + x / 3 = uu"
      by (tactic {* test @{context} [@{simproc field_combine_numerals}] *}) fact
  next
    assume "9 / 9 * x = uu" have "2 * x / 3 + x / 3 = uu"
      by (tactic {* test @{context} [@{simproc field_combine_numerals}] *}) fact
  next
    assume "y + z = uu"
    have "x / 2 + y - 3 * x / 6 + z = uu"
      by (tactic {* test @{context} [@{simproc field_combine_numerals}] *}) fact
  next
    assume "1 / 15 * x + y = uu"
    have "7 * x / 5 + y - 4 * x / 3 = uu"
      by (tactic {* test @{context} [@{simproc field_combine_numerals}] *}) fact
  }
end

lemma
  fixes x :: "'a::{linordered_field_inverse_zero}"
  shows "2/3 * x + x / 3 = uu"
apply (tactic {* test @{context} [@{simproc field_combine_numerals}] *})?
oops -- "FIXME: test fails"

subsection {* @{text nat_combine_numerals} *}

notepad begin
  fix i j k m n u :: nat
  {
    assume "4*k = u" have "k + 3*k = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  next
    (* FIXME "Suc (i + 3) \<equiv> i + 4" *)
    assume "4 * Suc 0 + i = u" have "Suc (i + 3) = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  next
    (* FIXME "Suc (i + j + 3 + k) \<equiv> i + j + 4 + k" *)
    assume "4 * Suc 0 + (i + (j + k)) = u" have "Suc (i + j + 3 + k) = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  next
    assume "2 * j + 4 * k = u" have "k + j + 3*k + j = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  next
    assume "6 * Suc 0 + (5 * (i * j) + (4 * k + i)) = u"
    have "Suc (j*i + i + k + 5 + 3*k + i*j*4) = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  next
    assume "5 * (m * n) = u" have "(2*n*m) + (3*(m*n)) = u"
      by (tactic {* test @{context} [@{simproc nat_combine_numerals}] *}) fact
  }
end

subsection {* @{text nateq_cancel_numerals} *}

notepad begin
  fix i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "Suc 0 * u = 0" have "2*u = (u::nat)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * u = Suc 0" have "2*u = Suc (u)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "i + (j + k) = 3 * Suc 0 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = u + 5 + y"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "11 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = Suc (u + y)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "i + (j + k) = 2 * Suc 0 + (u + y)"
    have "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * u + (2 * y + 3 * z) = Suc 0"
    have "2*y + 3*z + 2*u = Suc (u)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) = Suc 0"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * u + (2 * y + (3 * z + (6 * w + (2 * y + 3 * z)))) =
      2 * y' + (3 * z' + (6 * w' + (2 * y' + (3 * z' + vv))))"
    have "2*y + 3*z + 6*w + 2*y + 3*z + 2*u =
      2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + vv"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  next
    assume "2 * u + (2 * z + (5 * Suc 0 + 2 * y)) = vv"
    have "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)"
      by (tactic {* test @{context} [@{simproc nateq_cancel_numerals}] *}) fact
  }
end

subsection {* @{text natless_cancel_numerals} *}

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l1 l2 xs :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c i j k l m oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "0 < j" have "(2*length xs < 2*length xs + j)"
      by (tactic {* test @{context} [@{simproc natless_cancel_numerals}] *}) fact
  next
    assume "0 < j" have "(2*length xs < length xs * 2 + j)"
      by (tactic {* test @{context} [@{simproc natless_cancel_numerals}] *}) fact
  next
    assume "i + (j + k) < u + y"
    have "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))"
      by (tactic {* test @{context} [@{simproc natless_cancel_numerals}] *}) fact
  next
    assume "0 < Suc 0 * (m * n) + u" have "(2*n*m) < (3*(m*n)) + u"
      by (tactic {* test @{context} [@{simproc natless_cancel_numerals}] *}) fact
  }
end

subsection {* @{text natle_cancel_numerals} *}

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv w y z w' y' z' :: "nat"
  {
    assume "u + y \<le> 36 * Suc 0 + (i + (j + k))"
    have "Suc (Suc (Suc (Suc (Suc (u + y))))) \<le> ((i + j) + 41 + k)"
      by (tactic {* test @{context} [@{simproc natle_cancel_numerals}] *}) fact
  next
    assume "5 * Suc 0 + (case length (f c) of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k) = 0"
    have "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) \<le> Suc 0)"
      by (tactic {* test @{context} [@{simproc natle_cancel_numerals}] *}) fact
  next
    assume "6 + length l2 = 0" have "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) \<le> length l1"
      by (tactic {* test @{context} [@{simproc natle_cancel_numerals}] *}) fact
  next
    assume "5 + length l3 = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) \<le> length (compT P E A ST mxr e))"
      by (tactic {* test @{context} [@{simproc natle_cancel_numerals}] *}) fact
  next
    assume "5 + length (compT P E (A \<union> A' e) ST mxr c) = 0"
    have "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un A' e) ST mxr c))))))) \<le> length (compT P E A ST mxr e))"
      by (tactic {* test @{context} [@{simproc natle_cancel_numerals}] *}) fact
  }
end

subsection {* @{text natdiff_cancel_numerals} *}

notepad begin
  fix length :: "'a \<Rightarrow> nat" and l2 l3 :: "'a" and f :: "nat \<Rightarrow> 'a"
  fix c e i j k l oo u uu vv v w x y z zz w' y' z' :: "nat"
  {
    assume "i + (j + k) - 3 * Suc 0 = y" have "(i + j + 12 + k) - 15 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) - 0 = y" have "(i + j + 12 + k) - 5 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "u - Suc 0 * Suc 0 = y" have "Suc u - 2 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * Suc 0 + u - 0 = y" have "Suc (Suc (Suc u)) - 2 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "Suc 0 * Suc 0 + (i + (j + k)) - 0 = y"
    have "(i + j + 2 + k) - 1 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "i + (j + k) - Suc 0 * Suc 0 = y"
    have "(i + j + 1 + k) - 2 = y"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "2 * x + y - 2 * (u * v) = w"
    have "(2*x + (u*v) + y) - v*3*u = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "2 * x * u * v + (5 + y) - 0 = w"
    have "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "3 * (u * v) + (2 * x * u * v + y) - 0 = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "3 * u + (2 + (2 * x * u * v + y)) - 0 = w"
    have "Suc (Suc (2*x*u*v + u*4 + y)) - u = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "Suc (Suc 0 * (u * v)) - 0 = w"
    have "Suc ((u*v)*4) - v*3*u = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "2 - 0 = w" have "Suc (Suc ((u*v)*3)) - v*3*u = w"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "17 * Suc 0 + (i + (j + k)) - (u + y) = zz"
    have "(i + j + 32 + k) - (u + 15 + y) = zz"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  next
    assume "u + y - 0 = v" have "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v"
      by (tactic {* test @{context} [@{simproc natdiff_cancel_numerals}] *}) fact
  }
end

subsection {* Factor-cancellation simprocs for type @{typ nat} *}

text {* @{text nat_eq_cancel_factor}, @{text nat_less_cancel_factor},
@{text nat_le_cancel_factor}, @{text nat_divide_cancel_factor}, and
@{text nat_dvd_cancel_factor}. *}

notepad begin
  fix a b c d k x y uu :: nat
  {
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic {* test @{context} [@{simproc nat_eq_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> Suc 0 = y" have "k = k*y"
      by (tactic {* test @{context} [@{simproc nat_eq_cancel_factor}] *}) fact
  next
    assume "b = 0 \<or> a * c = Suc 0" have "a*(b*c) = b"
      by (tactic {* test @{context} [@{simproc nat_eq_cancel_factor}] *}) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d * x" have "a*(b*c) = d*b*(x*a)"
      by (tactic {* test @{context} [@{simproc nat_eq_cancel_factor}] *}) fact
  next
    assume "0 < k \<and> x < y" have "x*k < k*y"
      by (tactic {* test @{context} [@{simproc nat_less_cancel_factor}] *}) fact
  next
    assume "0 < k \<and> Suc 0 < y" have "k < k*y"
      by (tactic {* test @{context} [@{simproc nat_less_cancel_factor}] *}) fact
  next
    assume "0 < b \<and> a * c < Suc 0" have "a*(b*c) < b"
      by (tactic {* test @{context} [@{simproc nat_less_cancel_factor}] *}) fact
  next
    assume "0 < a \<and> 0 < b \<and> c < d * x" have "a*(b*c) < d*b*(x*a)"
      by (tactic {* test @{context} [@{simproc nat_less_cancel_factor}] *}) fact
  next
    assume "0 < k \<longrightarrow> x \<le> y" have "x*k \<le> k*y"
      by (tactic {* test @{context} [@{simproc nat_le_cancel_factor}] *}) fact
  next
    assume "0 < k \<longrightarrow> Suc 0 \<le> y" have "k \<le> k*y"
      by (tactic {* test @{context} [@{simproc nat_le_cancel_factor}] *}) fact
  next
    assume "0 < b \<longrightarrow> a * c \<le> Suc 0" have "a*(b*c) \<le> b"
      by (tactic {* test @{context} [@{simproc nat_le_cancel_factor}] *}) fact
  next
    assume "0 < a \<longrightarrow> 0 < b \<longrightarrow> c \<le> d * x" have "a*(b*c) \<le> d*b*(x*a)"
      by (tactic {* test @{context} [@{simproc nat_le_cancel_factor}] *}) fact
  next
    assume "(if k = 0 then 0 else x div y) = uu" have "(x*k) div (k*y) = uu"
      by (tactic {* test @{context} [@{simproc nat_div_cancel_factor}] *}) fact
  next
    assume "(if k = 0 then 0 else Suc 0 div y) = uu" have "k div (k*y) = uu"
      by (tactic {* test @{context} [@{simproc nat_div_cancel_factor}] *}) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu" have "(a*(b*c)) div (b) = uu"
      by (tactic {* test @{context} [@{simproc nat_div_cancel_factor}] *}) fact
  next
    assume "(if a = 0 then 0 else if b = 0 then 0 else c div (d * x)) = uu"
    have "(a*(b*c)) div (d*b*(x*a)) = uu"
      by (tactic {* test @{context} [@{simproc nat_div_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> x dvd y" have "(x*k) dvd (k*y)"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_factor}] *}) fact
  next
    assume "k = 0 \<or> Suc 0 dvd y" have "k dvd (k*y)"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_factor}] *}) fact
  next
    assume "b = 0 \<or> a * c dvd Suc 0" have "(a*(b*c)) dvd (b)"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_factor}] *}) fact
  next
    assume "b = 0 \<or> Suc 0 dvd a * c" have "b dvd (a*(b*c))"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_factor}] *}) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c dvd d * x" have "(a*(b*c)) dvd (d*b*(x*a))"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_factor}] *}) fact
  }
end

subsection {* Numeral-cancellation simprocs for type @{typ nat} *}

notepad begin
  fix x y z :: nat
  {
    assume "3 * x = 4 * y" have "9*x = 12 * y"
      by (tactic {* test @{context} [@{simproc nat_eq_cancel_numeral_factor}] *}) fact
  next
    assume "3 * x < 4 * y" have "9*x < 12 * y"
      by (tactic {* test @{context} [@{simproc nat_less_cancel_numeral_factor}] *}) fact
  next
    assume "3 * x \<le> 4 * y" have "9*x \<le> 12 * y"
      by (tactic {* test @{context} [@{simproc nat_le_cancel_numeral_factor}] *}) fact
  next
    assume "(3 * x) div (4 * y) = z" have "(9*x) div (12 * y) = z"
      by (tactic {* test @{context} [@{simproc nat_div_cancel_numeral_factor}] *}) fact
  next
    assume "(3 * x) dvd (4 * y)" have "(9*x) dvd (12 * y)"
      by (tactic {* test @{context} [@{simproc nat_dvd_cancel_numeral_factor}] *}) fact
  }
end

subsection {* Integer numeral div/mod simprocs *}

notepad begin
  have "(10::int) div 3 = 3"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "(10::int) mod 3 = 1"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "(10::int) div -3 = -4"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "(10::int) mod -3 = -2"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "(-10::int) div 3 = -4"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "(-10::int) mod 3 = 2"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "(-10::int) div -3 = 3"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "(-10::int) mod -3 = -1"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "(8452::int) mod 3 = 1"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "(59485::int) div 434 = 137"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "(1000006::int) mod 10 = 6"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "10000000 div 2 = (5000000::int)"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "10000001 mod 2 = (1::int)"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "10000055 div 32 = (312501::int)"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "10000055 mod 32 = (23::int)"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
  have "100094 div 144 = (695::int)"
    by (tactic {* test @{context} [@{simproc binary_int_div}] *})
  have "100094 mod 144 = (14::int)"
    by (tactic {* test @{context} [@{simproc binary_int_mod}] *})
end

end


section \<open>Utilties\<close>

theory Util
  imports
    Main
    "HOL-Library.Sublist"
    "HOL-Library.Multiset"

begin

abbreviation swap_events where
  "swap_events i j t \<equiv> take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t) @ drop (j+1) t"

lemma swap_neighbors_2:
  shows
    "i+1 < length t \<Longrightarrow> swap_events i (i+1) t = (t[i := t ! (i+1)])[i+1 := t ! i]"
proof (induct i arbitrary: t)
  case 0
  then show ?case
    by (metis One_nat_def Suc_eq_plus1 add_lessD1 append.left_neutral append_Cons cancel_comm_monoid_add_class.diff_cancel drop_update_cancel length_list_update numeral_One take_0 take_Cons_numeral upd_conv_take_nth_drop zero_less_Suc)
next
  case (Suc n)
  let ?t = "tl t"
  have "t = hd t # ?t"
    by (metis Suc.prems hd_Cons_tl list.size(3) not_less_zero)
  moreover have "swap_events n (n+1) ?t = (?t[n := ?t ! (n+1)])[n+1 := ?t ! n]"
    by (metis Suc.hyps Suc.prems Suc_eq_plus1 length_tl less_diff_conv)
  ultimately show ?case
    by (metis Suc_eq_plus1 append_Cons diff_self_eq_0 drop_Suc_Cons list_update_code(3) nth_Cons_Suc take_Suc_Cons)
qed

lemma swap_identical_length:
  assumes
    "i < j" and
    "j < length t"
  shows
    "length t = length (swap_events i j t)"
proof -
  have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
      = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
    by simp
  then have "... = j+1"
    using assms(1) assms(2) by auto
  then show ?thesis using assms(2) by auto
qed

lemma swap_identical_heads:
  assumes
    "i < j" and
    "j < length t"
  shows
    "take i t = take i (swap_events i j t)"
  using assms by auto

lemma swap_identical_tails:
  assumes
    "i < j" and
    "j < length t"
  shows
    "drop (j+1) t = drop (j+1) (swap_events i j t)"
proof -
  have "length (take i t @ [t ! j, t ! i] @ take (j - (i+1)) (drop (i+1) t))
      = length (take i t) + length [t ! j, t ! i] + length (take (j - (i+1)) (drop (i+1) t))"
    by simp
  then have "... = j+1"
    using assms(1) assms(2) by auto
  then show ?thesis
    by (metis \<open>length (take i t @ [t ! j, t ! i] @ take (j - (i + 1)) (drop (i + 1) t)) = length (take i t) + length [t ! j, t ! i] + length (take (j - (i + 1)) (drop (i + 1) t))\<close> append.assoc append_eq_conv_conj)
qed

lemma swap_neighbors:
  shows
    "i+1 < length l \<Longrightarrow> (l[i := l ! (i+1)])[i+1 := l ! i] = take i l @ [l ! (i+1), l ! i] @ drop (i+2) l"
proof (induct i arbitrary: l)
  case 0
  then show ?case
    by (metis One_nat_def add.left_neutral add_lessD1 append_Cons append_Nil drop_update_cancel length_list_update one_add_one plus_1_eq_Suc take0 take_Suc_Cons upd_conv_take_nth_drop zero_less_two)
next
  case (Suc n)
  let ?l = "tl l"
  have "(l[Suc n := l ! (Suc n + 1)])[Suc n + 1 := l ! Suc n] = hd l # (?l[n := ?l ! (n+1)])[n+1 := ?l ! n]"
    by (metis Suc.prems add.commute add_less_same_cancel2 list.collapse list.size(3) list_update_code(3) not_add_less2 nth_Cons_Suc plus_1_eq_Suc)
  have "n + 1 < length ?l" using Suc.prems by auto
  then have "(?l[n := ?l ! (n+1)])[n+1 := ?l ! n] = take n ?l @ [?l ! (n+1), ?l ! n] @ drop (n+2) ?l"
    using Suc.hyps by simp
  then show ?case
    by (cases l) auto
qed

lemma swap_events_perm:
  assumes
    "i < j" and
    "j < length t"
  shows
    "mset (swap_events i j t) = mset t"
proof -
  have swap: "swap_events i j t
      = take i t @ [t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t)) @ (drop (j+1) t)"
    by auto
  have reg: "t = take i t @ (take ((j+1) - i) (drop i t)) @ drop (j+1) t"
    by (metis add_diff_inverse_nat add_lessD1 append.assoc append_take_drop_id assms(1) less_imp_add_positive less_not_refl take_add)
  have "mset (take i t) = mset (take i t)" by simp
  moreover have "mset (drop (j+1) t) = mset (drop (j+1) t)" by simp
  moreover have "mset ([t ! j, t ! i] @ (take (j - (i+1)) (drop (i+1) t))) = mset (take ((j+1) - i) (drop i t))"
  proof -
    let ?l = "take (j - (i+1)) (drop (i+1) t)"
    have "take ((j+1) - i) (drop i t) = t ! i # ?l @ [t ! j]"
    proof -
      have f1: "Suc (j - Suc i) = j - i"
        by (meson Suc_diff_Suc assms(1))
      have f2: "i < length t"
        using assms(1) assms(2) by linarith
      have f3: "j - (i + 1) + (i + 1) = j"
        by (meson assms(1) discrete le_add_diff_inverse2)
      then have "drop (j - (i + 1)) (drop (i + 1) t) = drop j t"
        by (metis drop_drop)
      then show ?thesis
        using f3 f2 f1 by (metis (no_types) Cons_nth_drop_Suc Suc_diff_le Suc_eq_plus1 assms(1) assms(2) hd_drop_conv_nth length_drop less_diff_conv nat_less_le take_Suc_Cons take_hd_drop)
    qed
    then show ?thesis by fastforce
  qed
  ultimately show ?thesis using swap reg
    by simp (metis mset_append union_mset_add_mset_left union_mset_add_mset_right)
qed

lemma sum_eq_if_same_subterms:
  fixes
    i :: nat
  shows
    "\<forall>k. i \<le> k \<and> k < j \<longrightarrow> f k = f' k \<Longrightarrow> sum f {i..<j} = sum f' {i..<j}"
  by auto

lemma filter_neq_takeWhile:
  assumes
    "filter ((\<noteq>) a) l \<noteq> takeWhile ((\<noteq>) a) l"
  shows
    "\<exists>i j. i < j \<and> j < length l \<and> l ! i = a \<and> l ! j \<noteq> a" (is ?P)
proof (rule ccontr)
  assume "~ ?P"
  then have asm: "\<forall>i j. i < j \<and> j < length l \<longrightarrow> l ! i \<noteq> a \<or> l ! j = a" (is ?Q) by simp
  then have "filter ((\<noteq>) a) l = takeWhile ((\<noteq>) a) l"
  proof (cases "a : set l")
    case False
    then have "\<forall>i. i < length l \<longrightarrow> l ! i \<noteq> a" by auto
    then show ?thesis
      by (metis (mono_tags, lifting) False filter_True takeWhile_eq_all_conv)
  next
    case True
    then have ex_j: "\<exists>j. j < length l \<and> l ! j = a"
      by (simp add: in_set_conv_nth)
    let ?j = "Min {j. j < length l \<and> l ! j = a}"
    have fin_j: "finite {j. j < length l \<and> l ! j = a}"
      using finite_nat_set_iff_bounded by blast
    moreover have "{j. j < length l \<and> l ! j = a} \<noteq> empty" using ex_j by blast
    ultimately have "?j < length l"
      using Min_less_iff by blast
    have tail_all_a: "\<forall>j. j < length l \<and> j \<ge> ?j \<longrightarrow> l ! j = a"
    proof (rule allI, rule impI)
      fix j
      assume "j < length l \<and> j \<ge> ?j"
      moreover have "\<lbrakk> ?Q; j < length l \<and> j \<ge> ?j \<rbrakk> \<Longrightarrow> \<forall>k. k \<ge> ?j \<and> k \<le> j \<longrightarrow> l ! j = a"
      proof (induct "j - ?j")
        case 0
        then have "j = ?j" using 0 by simp
        then show ?case
          using Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j by blast
      next
        case (Suc n)
        then have "\<forall>k. k \<ge> ?j \<and> k < j \<longrightarrow> l ! j = a"
          by (metis (mono_tags, lifting) Min_in \<open>{j. j < length l \<and> l ! j = a} \<noteq> {}\<close> fin_j le_eq_less_or_eq mem_Collect_eq)
        then show ?case
          using Suc.hyps(2) by auto
      qed
      ultimately show "l ! j = a" using asm by blast
    qed
    moreover have head_all_not_a: "\<forall>i. i < ?j \<longrightarrow> l ! i \<noteq> a" using asm calculation
      by (metis (mono_tags, lifting) Min_le \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> fin_j leD less_trans mem_Collect_eq)
    ultimately have "takeWhile ((\<noteq>) a) l = take ?j l"
    proof -
      have "length (takeWhile ((\<noteq>) a) l) = ?j"
      proof -
        have "length (takeWhile ((\<noteq>) a) l) \<le> ?j" (is ?S)
        proof (rule ccontr)
          assume "\<not> ?S"
          then have "l ! ?j \<noteq> a"
            by (metis (mono_tags, lifting) not_le_imp_less nth_mem set_takeWhileD takeWhile_nth)
          then show False
            using \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> tail_all_a by blast
        qed
        moreover have "length (takeWhile ((\<noteq>) a) l) \<ge> ?j" (is ?T)
        proof (rule ccontr)
          assume "\<not> ?T"
          then have "\<exists>j. j < ?j \<and> l ! j = a"
            by (metis (mono_tags, lifting) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> calculation le_less_trans not_le_imp_less nth_length_takeWhile)
          then show False
            using head_all_not_a by blast
        qed
        ultimately show ?thesis by simp
      qed
      moreover have "length (take ?j l) = ?j"
        by (metis calculation takeWhile_eq_take)
      ultimately show ?thesis
        by (metis takeWhile_eq_take)

    qed
    moreover have "filter ((\<noteq>) a) l = take ?j l"
    proof -
      have "filter ((\<noteq>) a) l = filter ((\<noteq>) a) (take ?j l) @ filter ((\<noteq>) a) (drop ?j l)"
        by (metis append_take_drop_id filter_append)
      moreover have "filter ((\<noteq>) a) (take ?j l) = take ?j l" using head_all_not_a
        by (metis \<open>takeWhile ((\<noteq>) a) l = take (Min {j. j < length l \<and> l ! j = a}) l\<close> filter_id_conv set_takeWhileD)
      moreover have "filter ((\<noteq>) a) (drop ?j l) = []"
      proof -
        have "\<forall>j. j \<ge> ?j \<and> j < length l \<longrightarrow> l ! j = drop ?j l ! (j - ?j)"
          by simp
        then have "\<forall>j. j < length l - ?j \<longrightarrow> drop ?j l ! j = a" using tail_all_a
          by (metis (no_types, lifting) Groups.add_ac(2) \<open>Min {j. j < length l \<and> l ! j = a} < length l\<close> less_diff_conv less_imp_le_nat not_add_less2 not_le nth_drop)
        then show ?thesis
        proof -
          obtain aa :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a" where
            "\<forall>x0 x1. (\<exists>v2. v2 \<in> set x1 \<and> x0 v2) = (aa x0 x1 \<in> set x1 \<and> x0 (aa x0 x1))"
            by moura
          then have f1: "\<forall>as p. aa p as \<in> set as \<and> p (aa p as) \<or> filter p as = []"
            by (metis (full_types) filter_False)
          obtain nn :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
            f2: "\<forall>x0 x1. (\<exists>v2<length x0. x0 ! v2 = x1) = (nn x0 x1 < length x0 \<and> x0 ! nn x0 x1 = x1)"
          by moura
          { assume "drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) = a"
            then have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
              using f1 by (metis (full_types)) }
          moreover
          { assume "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length l - Min {n. n < length l \<and> l ! n = a}"
            then have "\<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
              by simp }
          ultimately have "filter ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l) = [] \<or> \<not> nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) < length (drop (Min {n. n < length l \<and> l ! n = a}) l) \<or> drop (Min {n. n < length l \<and> l ! n = a}) l ! nn (drop (Min {n. n < length l \<and> l ! n = a}) l) (aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)) \<noteq> aa ((\<noteq>) a) (drop (Min {n. n < length l \<and> l ! n = a}) l)"
            using \<open>\<forall>j<length l - Min {j. j < length l \<and> l ! j = a}. drop (Min {j. j < length l \<and> l ! j = a}) l ! j = a\<close> by blast
          then show ?thesis
            using f2 f1 by (meson in_set_conv_nth)
        qed
      qed
      ultimately show ?thesis by simp
    qed
    ultimately show ?thesis by simp
  qed
  then show False using assms by simp
qed

lemma util_exactly_one_element:
  assumes
    "m \<notin> set l" and
    "l' = l @ [m]"
  shows
    "\<exists>!j. j < length l' \<and> l' ! j = m" (is ?P)
proof -
  have "\<forall>j. j < length l' - 1 \<longrightarrow> l' ! j \<noteq> m"
    by (metis assms(1) assms(2) butlast_snoc length_butlast nth_append nth_mem)
  then have one_j: "\<forall>j. j < length l' \<and> l' ! j = m \<longrightarrow> j = (length l' - 1)"
    by (metis (no_types, opaque_lifting) diff_Suc_1 lessE)
  show ?thesis
  proof (rule ccontr)
    assume "~ ?P"
    then obtain i j where "i \<noteq> j" "i < length l'" "j < length l'"
                          "l' ! i = m" "l' ! j = m"
      using assms by auto
    then show False using one_j by blast
  qed
qed

end