(*  Author:     Florian Haftmann, TU Muenchen *)

section \<open>A combinator to build partial equivalence relations from a predicate and an equivalence relation\<close>

theory Combine_PER
  imports Main
begin

unbundle lattice_syntax

definition combine_per :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "combine_per P R = (\<lambda>x y. P x \<and> P y) \<sqinter> R"

lemma combine_per_simp [simp]:
  "combine_per P R x y \<longleftrightarrow> P x \<and> P y \<and> x \<approx> y" for R (infixl "\<approx>" 50)
  by (simp add: combine_per_def)

lemma combine_per_top [simp]: "combine_per \<top> R = R"
  by (simp add: fun_eq_iff)

lemma combine_per_eq [simp]: "combine_per P HOL.eq = HOL.eq \<sqinter> (\<lambda>x y. P x)"
  by (auto simp add: fun_eq_iff)

lemma symp_combine_per: "symp R \<Longrightarrow> symp (combine_per P R)"
  by (auto simp add: symp_def sym_def combine_per_def)

lemma transp_combine_per: "transp R \<Longrightarrow> transp (combine_per P R)"
  by (auto simp add: transp_def trans_def combine_per_def)

lemma combine_perI: "P x \<Longrightarrow> P y \<Longrightarrow> x \<approx> y \<Longrightarrow> combine_per P R x y" for R (infixl "\<approx>" 50)
  by (simp add: combine_per_def)

lemma symp_combine_per_symp: "symp R \<Longrightarrow> symp (combine_per P R)"
  by (auto intro!: sympI elim: sympE)

lemma transp_combine_per_transp: "transp R \<Longrightarrow> transp (combine_per P R)"
  by (auto intro!: transpI elim: transpE)

lemma equivp_combine_per_part_equivp [intro?]:
  fixes R (infixl "\<approx>" 50)
  assumes "\<exists>x. P x" and "equivp R"
  shows "part_equivp (combine_per P R)"
proof -
  from \<open>\<exists>x. P x\<close> obtain x where "P x" ..
  moreover from \<open>equivp R\<close> have "x \<approx> x"
    by (rule equivp_reflp)
  ultimately have "\<exists>x. P x \<and> x \<approx> x"
    by blast
  with \<open>equivp R\<close> show ?thesis
    by (auto intro!: part_equivpI symp_combine_per_symp transp_combine_per_transp
      elim: equivpE)
qed

end


section \<open>Resultants and Multivariate Polynomials\<close>

subsection \<open>Connecting Univariate and Multivariate Polynomials\<close>

text \<open>We define a conversion of multivariate polynomials into univariate polynomials
  w.r.t.\ a fixed variable $x$ and multivariate polynomials as coefficients.\<close>

theory Poly_Connection
  imports
    Polynomials.MPoly_Type_Univariate
    Jordan_Normal_Form.Missing_Misc
    Polynomial_Interpolation.Ring_Hom_Poly
    Hermite_Lindemann.More_Multivariate_Polynomial_HLW
    Polynomials.MPoly_Type_Class
begin

lemma mpoly_is_unitE:
  fixes p :: "'a :: {comm_semiring_1, semiring_no_zero_divisors} mpoly"
  assumes "p dvd 1"
  obtains c where "p = Const c" "c dvd 1"
proof -
  obtain r where r: "p * r = 1"
    using assms by auto
  from r have [simp]: "p \<noteq> 0" "r \<noteq> 0"
    by auto
  have "0 = lead_monom (1 :: 'a mpoly)"
    by simp
  also have "1 = p * r"
    using r by simp
  also have "lead_monom (p * r) = lead_monom p + lead_monom r"
    by (intro lead_monom_mult) auto
  finally have "lead_monom p = 0"
    by simp
  hence "vars p = {}"
    by (simp add: lead_monom_eq_0_iff)
  hence *: "p = Const (lead_coeff p)"
    by (auto simp: vars_empty_iff)

  have "1 = lead_coeff (1 :: 'a mpoly)"
    by simp
  also have "1 = p * r"
    using r by simp
  also have "lead_coeff (p * r) = lead_coeff p * lead_coeff r"
    by (intro lead_coeff_mult) auto
  finally have "lead_coeff p dvd 1"
    using dvdI by blast
  with * show ?thesis using that
    by blast
qed

lemma Const_eq_Const_iff [simp]:
  "Const c = Const c' \<longleftrightarrow> c = c'"
  by (metis lead_coeff_Const)

lemma is_unit_ConstI [intro]: "c dvd 1 \<Longrightarrow> Const c dvd 1"
  by (metis dvd_def mpoly_Const_1 mpoly_Const_mult)

lemma is_unit_Const_iff:
  fixes c :: "'a :: {comm_semiring_1, semiring_no_zero_divisors}"
  shows "Const c dvd 1 \<longleftrightarrow> c dvd 1"
proof
  assume "Const c dvd 1"
  thus "c dvd 1"
    by (auto elim!: mpoly_is_unitE)
qed auto

lemma vars_emptyE: "vars p = {} \<Longrightarrow> (\<And>c. p = Const c \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp: vars_empty_iff)

lemma degree_geI:
  assumes "MPoly_Type.coeff p m \<noteq> 0"
  shows   "MPoly_Type.degree p i \<ge> Poly_Mapping.lookup m i"
proof -
  have "lookup m i \<le> Max (insert 0 ((\<lambda>m. lookup m i) ` keys (mapping_of p)))"
  proof (rule Max.coboundedI)
    show "lookup m i \<in> insert 0 ((\<lambda>m. lookup m i) ` keys (mapping_of p))"
      using assms by (auto simp: coeff_keys)
  qed auto
  thus ?thesis unfolding MPoly_Type.degree_def by auto
qed

lemma monom_of_degree_exists:
  assumes "p \<noteq> 0"
  obtains m where "MPoly_Type.coeff p m \<noteq> 0" "Poly_Mapping.lookup m i = MPoly_Type.degree p i"
proof (cases "MPoly_Type.degree p i = 0")
  case False
  have "MPoly_Type.degree p i = Max (insert 0 ((\<lambda>m. lookup m i) ` keys (mapping_of p)))"
    by (simp add: MPoly_Type.degree_def)
  also have "\<dots> \<in> insert 0 ((\<lambda>m. lookup m i) ` keys (mapping_of p))"
    by (rule Max_in) auto
  finally show ?thesis
    using False that by (auto simp: coeff_keys)
next
  case [simp]: True
  from assms obtain m where m: "MPoly_Type.coeff p m \<noteq> 0"
    using coeff_all_0 by blast
  show ?thesis using degree_geI[of p m i] m
    by (intro that[of m]) auto
qed

lemma degree_leI:
  assumes "\<And>m. Poly_Mapping.lookup m i > n \<Longrightarrow> MPoly_Type.coeff p m = 0"
  shows   "MPoly_Type.degree p i \<le> n"
proof (cases "p = 0")
  case False
  obtain m where m: "MPoly_Type.coeff p m \<noteq> 0" "Poly_Mapping.lookup m i = MPoly_Type.degree p i"
    using monom_of_degree_exists False by blast
  with assms show ?thesis
    by force
qed auto

lemma coeff_gt_degree_eq_0:
  assumes "Poly_Mapping.lookup m i > MPoly_Type.degree p i"
  shows   "MPoly_Type.coeff p m = 0"
  using assms degree_geI leD by blast

lemma vars_altdef: "vars p = (\<Union>m\<in>{m. MPoly_Type.coeff p m \<noteq> 0}. keys m)"
  unfolding vars_def
  by (intro arg_cong[where f = "\<Union>"] image_cong refl) (simp flip: coeff_keys)

lemma degree_pos_iff: "MPoly_Type.degree p x > 0 \<longleftrightarrow> x \<in> vars p"
proof
  assume "MPoly_Type.degree p x > 0"
  hence "p \<noteq> 0" by auto
  then obtain m where m: "lookup m x = MPoly_Type.degree p x" "MPoly_Type.coeff p m \<noteq> 0"
    using monom_of_degree_exists[of p x] by metis
  from m and \<open>MPoly_Type.degree p x > 0\<close> have "x \<in> keys m"
    by (simp add: in_keys_iff)
  with m show "x \<in> vars p"
    by (auto simp: vars_altdef)
next
  assume "x \<in> vars p"
  then obtain m where m: "x \<in> keys m" "MPoly_Type.coeff p m \<noteq> 0"
    by (auto simp: vars_altdef)
  have "0 < lookup m x"
    using m by (auto simp: in_keys_iff)
  also from m have "\<dots> \<le> MPoly_Type.degree p x"
    by (intro degree_geI) auto
  finally show "MPoly_Type.degree p x > 0" .
qed

lemma degree_eq_0_iff: "MPoly_Type.degree p x = 0 \<longleftrightarrow> x \<notin> vars p"
  using degree_pos_iff[of p x] by auto

lemma MPoly_Type_monom_zero[simp]: "MPoly_Type.monom m 0 = 0"
  by (simp add: More_MPoly_Type.coeff_monom coeff_all_0)

lemma vars_monom_keys': "vars (MPoly_Type.monom m c) = (if c = 0 then {} else keys m)"
  by (cases "c = 0") (auto simp: vars_monom_keys)

lemma Const_eq_0_iff [simp]: "Const c = 0 \<longleftrightarrow> c = 0"
  by (metis lead_coeff_Const mpoly_Const_0)

lemma monom_remove_key: "MPoly_Type.monom m (a :: 'a :: semiring_1) =
  MPoly_Type.monom (remove_key x m) a * MPoly_Type.monom (Poly_Mapping.single x (lookup m x)) 1"
  unfolding MPoly_Type.mult_monom
  by (rule arg_cong2[of _ _ _ _ MPoly_Type.monom], auto simp: remove_key_sum)

lemma MPoly_Type_monom_0_iff[simp]: "MPoly_Type.monom m x = 0 \<longleftrightarrow> x = 0"
  by (metis (full_types) MPoly_Type_monom_zero More_MPoly_Type.coeff_monom when_def)

lemma vars_signof[simp]: "vars (signof x) = {}"
  by (simp add: sign_def)

lemma prod_mset_Const: "prod_mset (image_mset Const A) = Const (prod_mset A)"
  by (induction A) (auto simp: mpoly_Const_mult)

lemma Const_eq_product_iff:
  fixes c :: "'a :: idom"
  assumes "c \<noteq> 0"
  shows   "Const c = a * b \<longleftrightarrow> (\<exists>a' b'. a = Const a' \<and> b = Const b' \<and> c = a' * b')"
proof
  assume *: "Const c = a * b"
  have "lead_monom (a * b) = 0"
    by (auto simp flip: *)
  hence "lead_monom a = 0 \<and> lead_monom b = 0"
    by (subst (asm) lead_monom_mult) (use assms * in auto)
  hence "vars a = {}" "vars b = {}"
    by (auto simp: lead_monom_eq_0_iff)
  then obtain a' b' where "a = Const a'" "b = Const b'"
    by (auto simp: vars_empty_iff)
  with * show "(\<exists>a' b'. a = Const a' \<and> b = Const b' \<and> c = a' * b')"
    by (auto simp flip: mpoly_Const_mult)
qed (auto simp: mpoly_Const_mult)

lemma irreducible_Const_iff [simp]:
  "irreducible (Const (c :: 'a :: idom)) \<longleftrightarrow> irreducible c"
proof
  assume *: "irreducible (Const c)"
  show "irreducible c"
  proof (rule irreducibleI)
    fix a b assume "c = a * b"
    hence "Const c = Const a * Const b"
      by (simp add: mpoly_Const_mult)
    with * have "Const a dvd 1 \<or> Const b dvd 1"
      by blast
    thus "a dvd 1 \<or> b dvd 1"
      by (meson is_unit_Const_iff)
  qed (use * in \<open>auto simp: irreducible_def\<close>)
next
  assume *: "irreducible c"
  have [simp]: "c \<noteq> 0"
    using * by auto
  show "irreducible (Const c)"
  proof (rule irreducibleI)
    fix a b assume "Const c = a * b"
    then obtain a' b' where [simp]: "a = Const a'" "b = Const b'" and "c = a' * b'"
      by (auto simp: Const_eq_product_iff)
    hence "a' dvd 1 \<or> b' dvd 1"
      using * by blast
    thus "a dvd 1 \<or> b dvd 1"
      by auto
  qed (use * in \<open>auto simp: irreducible_def is_unit_Const_iff\<close>)
qed

lemma Const_dvd_Const_iff [simp]: "Const a dvd Const b \<longleftrightarrow> a dvd b"
proof
  assume "a dvd b"
  then obtain c where "b = a * c"
    by auto
  hence "Const b = Const a * Const c"
    by (auto simp: mpoly_Const_mult)
  thus "Const a dvd Const b"
    by simp
next
  assume "Const a dvd Const b"
  then obtain p where p: "Const b = Const a * p"
    by auto
  have "MPoly_Type.coeff (Const b) 0 = MPoly_Type.coeff (Const a * p) 0"
    using p by simp
  also have "\<dots> = MPoly_Type.coeff (Const a) 0 * MPoly_Type.coeff p 0"
    using mpoly_coeff_times_0 by blast
  finally show "a dvd b"
    by (simp add: mpoly_coeff_Const)
qed

text \<open>The lemmas above should be moved into the right theories. The part below is on the new
connection between multivariate polynomials and univariate polynomials.\<close>

text \<open>The imported theories only allow a conversion from one-variable mpoly's to poly and vice-versa.
  However, we require a conversion from arbitrary mpoly's into poly's with mpolys as coefficients.\<close>

(* converts a multi-variate polynomial into a univariate polynomial with multivariate coefficients *)
definition mpoly_to_mpoly_poly :: "nat \<Rightarrow> 'a :: comm_ring_1 mpoly \<Rightarrow> 'a mpoly poly" where
  "mpoly_to_mpoly_poly x p = (\<Sum>m .
        Polynomial.monom (MPoly_Type.monom (remove_key x m) (MPoly_Type.coeff p m)) (lookup m x))"

lemma mpoly_to_mpoly_poly_add [simp]:
  "mpoly_to_mpoly_poly x (p + q) = mpoly_to_mpoly_poly x p + mpoly_to_mpoly_poly x q"
  unfolding mpoly_to_mpoly_poly_def  More_MPoly_Type.coeff_add[symmetric]  MPoly_Type.monom_add add_monom[symmetric]
  by (rule Sum_any.distrib) auto

lemma mpoly_to_mpoly_poly_monom: "mpoly_to_mpoly_poly x (MPoly_Type.monom m a) = Polynomial.monom (MPoly_Type.monom (remove_key x m) a) (lookup m x)"
proof -
  have "mpoly_to_mpoly_poly x (MPoly_Type.monom m a) =
    (\<Sum> m'. Polynomial.monom (MPoly_Type.monom (remove_key x m') a) (lookup m' x) when m' = m)"
    unfolding mpoly_to_mpoly_poly_def
    by (intro Sum_any.cong, auto simp: when_def More_MPoly_Type.coeff_monom)
  also have "\<dots> = Polynomial.monom (MPoly_Type.monom (remove_key x m) a) (lookup m x)"
    unfolding Sum_any_when_equal ..
  finally show ?thesis .
qed

lemma remove_key_transfer [transfer_rule]:
  "rel_fun (=) (rel_fun (pcr_poly_mapping (=) (=)) (pcr_poly_mapping (=) (=)))
     (\<lambda>k0 f k. f k when k \<noteq> k0) remove_key"
  unfolding pcr_poly_mapping_def cr_poly_mapping_def OO_def
  by (auto simp: rel_fun_def remove_key_lookup)

lemma remove_key_0 [simp]: "remove_key x 0 = 0"
  by transfer auto

lemma remove_key_single' [simp]:
  "x \<noteq> y \<Longrightarrow> remove_key x (Poly_Mapping.single y n) = Poly_Mapping.single y n"
  by transfer (auto simp: when_def fun_eq_iff)

lemma poly_coeff_Sum_any:
  assumes "finite {x. f x \<noteq> 0}"
  shows   "poly.coeff (Sum_any f) n = Sum_any (\<lambda>x. poly.coeff (f x) n)"
proof -
  have "Sum_any f = (\<Sum>x | f x \<noteq> 0. f x)"
    by (rule Sum_any.expand_set)
  also have "poly.coeff \<dots> n = (\<Sum>x | f x \<noteq> 0. poly.coeff (f x) n)"
    by (simp add: Polynomial.coeff_sum)
  also have "\<dots> = Sum_any (\<lambda>x. poly.coeff (f x) n)"
    by (rule Sum_any.expand_superset [symmetric]) (use assms in auto)
  finally show ?thesis .
qed

lemma coeff_coeff_mpoly_to_mpoly_poly:
  "MPoly_Type.coeff (poly.coeff (mpoly_to_mpoly_poly x p) n) m =
     (MPoly_Type.coeff p (m + Poly_Mapping.single x n) when lookup m x = 0)"
proof -
  have "MPoly_Type.coeff (poly.coeff (mpoly_to_mpoly_poly x p) n) m =
          MPoly_Type.coeff (\<Sum>a. MPoly_Type.monom (remove_key x a) (MPoly_Type.coeff p a) when lookup a x = n) m"
    unfolding mpoly_to_mpoly_poly_def by (subst poly_coeff_Sum_any) (auto simp: when_def)
  also have "\<dots> = (\<Sum>xa. MPoly_Type.coeff (MPoly_Type.monom (remove_key x xa) (MPoly_Type.coeff p xa)) m when lookup xa x = n)"
    by (subst coeff_Sum_any, force) (auto simp: when_def intro!: Sum_any.cong)
  also have "\<dots> = (\<Sum>a. MPoly_Type.coeff p a when lookup a x = n \<and> m = remove_key x a)"
    by (intro Sum_any.cong) (simp add: More_MPoly_Type.coeff_monom when_def)
  also have "(\<lambda>a. lookup a x = n \<and> m = remove_key x a) =
             (\<lambda>a. lookup m x = 0 \<and> a = m + Poly_Mapping.single x n)"
    by (rule ext, transfer) (auto simp: fun_eq_iff when_def)
  also have "(\<Sum>a. MPoly_Type.coeff p a when \<dots> a) =
             (\<Sum>a. MPoly_Type.coeff p a when lookup m x = 0 when a = m + Poly_Mapping.single x n)"
    by (intro Sum_any.cong) (auto simp: when_def)
  also have "\<dots> = (MPoly_Type.coeff p (m + Poly_Mapping.single x n) when lookup m x = 0)"
    by (rule Sum_any_when_equal)
  finally show ?thesis .
qed

lemma mpoly_to_mpoly_poly_Const [simp]:
  "mpoly_to_mpoly_poly x (Const c) = [:Const c:]"
proof -
  have "mpoly_to_mpoly_poly x (Const c) =
          (\<Sum>m. Polynomial.monom (MPoly_Type.monom (remove_key x m)
                  (MPoly_Type.coeff (Const c) m)) (lookup m x) when m = 0)"
    unfolding mpoly_to_mpoly_poly_def
    by (intro Sum_any.cong) (auto simp: when_def mpoly_coeff_Const)
  also have "\<dots> = [:Const c:]"
    by (subst Sum_any_when_equal)
       (auto simp: mpoly_coeff_Const monom_altdef simp flip: Const_conv_monom)
  finally show ?thesis .
qed

lemma mpoly_to_mpoly_poly_Var:
  "mpoly_to_mpoly_poly x (Var y) = (if x = y then [:0, 1:] else [:Var y:])"
proof -
  have "mpoly_to_mpoly_poly x (Var y) =
          (\<Sum>a. Polynomial.monom (MPoly_Type.monom (remove_key x a) 1) (lookup a x)
             when a = Poly_Mapping.single y 1)"
    unfolding mpoly_to_mpoly_poly_def by (intro Sum_any.cong) (auto simp: when_def coeff_Var)
  also have "\<dots> = (if x = y then [:0, 1:] else [:Var y:])"
    by (auto simp: Polynomial.monom_altdef lookup_single Var_altdef)
  finally show ?thesis .
qed

lemma mpoly_to_mpoly_poly_Var_this [simp]:
  "mpoly_to_mpoly_poly x (Var x) = [:0, 1:]"
  "x \<noteq> y \<Longrightarrow> mpoly_to_mpoly_poly x (Var y) = [:Var y:]"
  by (simp_all add: mpoly_to_mpoly_poly_Var)

lemma mpoly_to_mpoly_poly_uminus [simp]:
  "mpoly_to_mpoly_poly x (-p) = -mpoly_to_mpoly_poly x p"
  unfolding mpoly_to_mpoly_poly_def
  by (auto simp: monom_uminus Sum_any_uminus simp flip: minus_monom)

lemma mpoly_to_mpoly_poly_diff [simp]:
  "mpoly_to_mpoly_poly x (p - q) = mpoly_to_mpoly_poly x p - mpoly_to_mpoly_poly x q"
  by (subst diff_conv_add_uminus, subst mpoly_to_mpoly_poly_add) auto

lemma mpoly_to_mpoly_poly_0 [simp]:
  "mpoly_to_mpoly_poly x 0 = 0"
  unfolding mpoly_Const_0 [symmetric] mpoly_to_mpoly_poly_Const by simp

lemma mpoly_to_mpoly_poly_1 [simp]:
  "mpoly_to_mpoly_poly x 1 = 1"
  unfolding mpoly_Const_1 [symmetric] mpoly_to_mpoly_poly_Const by simp

lemma mpoly_to_mpoly_poly_of_nat [simp]:
  "mpoly_to_mpoly_poly x (of_nat n) = of_nat n"
  unfolding of_nat_mpoly_eq mpoly_to_mpoly_poly_Const of_nat_poly ..

lemma mpoly_to_mpoly_poly_of_int [simp]:
  "mpoly_to_mpoly_poly x (of_int n) = of_int n"
  unfolding of_nat_mpoly_eq mpoly_to_mpoly_poly_Const of_nat_poly by (cases n) auto

lemma mpoly_to_mpoly_poly_numeral [simp]:
  "mpoly_to_mpoly_poly x (numeral n) = numeral n"
  using mpoly_to_mpoly_poly_of_nat[of x "numeral n"] by (simp del: mpoly_to_mpoly_poly_of_nat)

lemma coeff_monom_mult':
  "MPoly_Type.coeff (MPoly_Type.monom m a * q) m' =
   (a * MPoly_Type.coeff q (m' - m) when lookup m' \<ge> lookup m)"
proof (cases "lookup m' \<ge> lookup m")
  case True
  have "a * MPoly_Type.coeff q (m' - m) = MPoly_Type.coeff (MPoly_Type.monom m a * q) (m + (m' - m))"
    by (rule More_MPoly_Type.coeff_monom_mult [symmetric])
  also have "m + (m' - m) = m'"
    using True by transfer (auto simp: le_fun_def)
  finally show ?thesis
    using True by (simp add: when_def)
next
  case False
  have "MPoly_Type.coeff (MPoly_Type.monom m a * q) m' =
          (\<Sum>m1. a * (\<Sum>m2. MPoly_Type.coeff q m2 when m' = m1 + m2) when m1 = m)"
    unfolding coeff_mpoly_times prod_fun_def
    by (intro Sum_any.cong) (auto simp: More_MPoly_Type.coeff_monom when_def)
  also have "\<dots> = a * (\<Sum>m2. MPoly_Type.coeff q m2 when m' = m + m2)"
    by (subst Sum_any_when_equal) auto
  also have "(\<lambda>m2. m' = m + m2) = (\<lambda>m2. False)"
    by (rule ext) (use False in \<open>transfer, auto simp: le_fun_def\<close>)
  finally show ?thesis
    using False by simp
qed

lemma mpoly_to_mpoly_poly_mult_monom:
  "mpoly_to_mpoly_poly x (MPoly_Type.monom m a * q) =
     Polynomial.monom (MPoly_Type.monom (remove_key x m) a) (lookup m x) * mpoly_to_mpoly_poly x q"
  (is "?lhs = ?rhs")
proof (rule poly_eqI, rule mpoly_eqI)
  fix n :: nat and mon :: "nat \<Rightarrow>\<^sub>0 nat"
  have "MPoly_Type.coeff (poly.coeff ?lhs n) mon =
          (a * MPoly_Type.coeff q (mon + Poly_Mapping.single x n - m)
          when lookup m \<le> lookup (mon + Poly_Mapping.single x n) \<and> lookup mon x = 0)"
    by (simp add: coeff_coeff_mpoly_to_mpoly_poly coeff_monom_mult' when_def)
  have "MPoly_Type.coeff (poly.coeff ?rhs n) mon =
          (a * MPoly_Type.coeff q (mon - remove_key x m + Poly_Mapping.single x (n - lookup m x))
          when lookup (remove_key x m) \<le> lookup mon \<and> lookup m x \<le> n \<and> lookup mon x = 0)"
    by (simp add: coeff_coeff_mpoly_to_mpoly_poly coeff_monom_mult' lookup_minus_fun
                  remove_key_lookup Missing_Polynomial.coeff_monom_mult when_def)
  also have "lookup (remove_key x m) \<le> lookup mon \<and> lookup m x \<le> n \<and> lookup mon x = 0 \<longleftrightarrow>
             lookup m \<le> lookup (mon + Poly_Mapping.single x n) \<and> lookup mon x = 0" (is "_ = ?P")
    by transfer (auto simp: when_def le_fun_def)
  also have "mon - remove_key x m + Poly_Mapping.single x (n - lookup m x) = mon + Poly_Mapping.single x n - m" if ?P
    using that by transfer (auto simp: fun_eq_iff when_def)
  hence "(a * MPoly_Type.coeff q (mon - remove_key x m + Poly_Mapping.single x (n - lookup m x)) when ?P) =
         (a * MPoly_Type.coeff q \<dots> when ?P)"
    by (intro when_cong) auto
  also have "\<dots> = MPoly_Type.coeff (poly.coeff ?lhs n) mon"
    by (simp add: coeff_coeff_mpoly_to_mpoly_poly coeff_monom_mult' when_def)
  finally show "MPoly_Type.coeff (poly.coeff ?lhs n) mon = MPoly_Type.coeff (poly.coeff ?rhs n) mon" ..
qed

lemma mpoly_to_mpoly_poly_mult [simp]:
  "mpoly_to_mpoly_poly x (p * q) = mpoly_to_mpoly_poly x p * mpoly_to_mpoly_poly x q"
  by (induction p arbitrary: q rule: mpoly_induct)
     (simp_all add: mpoly_to_mpoly_poly_monom mpoly_to_mpoly_poly_mult_monom ring_distribs)

lemma coeff_mpoly_to_mpoly_poly:
  "Polynomial.coeff (mpoly_to_mpoly_poly x p) n =
     Sum_any (\<lambda>m. MPoly_Type.monom (remove_key x m) (MPoly_Type.coeff p m) when Poly_Mapping.lookup m x = n)"
  unfolding mpoly_to_mpoly_poly_def by (subst poly_coeff_Sum_any) (auto simp: when_def)

lemma mpoly_coeff_to_mpoly_poly_coeff:
  "MPoly_Type.coeff p m = MPoly_Type.coeff (poly.coeff (mpoly_to_mpoly_poly x p) (lookup m x)) (remove_key x m)"
proof -
  have "MPoly_Type.coeff (poly.coeff (mpoly_to_mpoly_poly x p) (lookup m x)) (remove_key x m) =
        (\<Sum>xa. MPoly_Type.coeff (MPoly_Type.monom (remove_key x xa) (MPoly_Type.coeff p xa) when
             lookup xa x = lookup m x) (remove_key x m))"
    by (subst coeff_mpoly_to_mpoly_poly, subst coeff_Sum_any) auto
  also have "\<dots> = (\<Sum>xa. MPoly_Type.coeff (MPoly_Type.monom (remove_key x xa) (MPoly_Type.coeff p xa)) (remove_key x m)
                    when lookup xa x = lookup m x)"
    by (intro Sum_any.cong) (auto simp: when_def)
  also have "\<dots> = (\<Sum>xa. MPoly_Type.coeff p xa when remove_key x m = remove_key x xa \<and> lookup xa x = lookup m x)"
    by (intro Sum_any.cong) (auto simp: More_MPoly_Type.coeff_monom when_def)
  also have "(\<lambda>xa. remove_key x m = remove_key x xa \<and> lookup xa x = lookup m x) = (\<lambda>xa. xa = m)"
    using remove_key_sum by metis
  also have "(\<Sum>xa. MPoly_Type.coeff p xa when xa = m) = MPoly_Type.coeff p m"
    by simp
  finally show ?thesis ..
qed

lemma degree_mpoly_to_mpoly_poly [simp]:
  "Polynomial.degree (mpoly_to_mpoly_poly x p) = MPoly_Type.degree p x"
proof (rule antisym)
  show "Polynomial.degree (mpoly_to_mpoly_poly x p) \<le> MPoly_Type.degree p x"
  proof (intro Polynomial.degree_le allI impI)
    fix i assume i: "i > MPoly_Type.degree p x"
    have "poly.coeff (mpoly_to_mpoly_poly x p) i =
            (\<Sum>m. 0 when lookup m x = i)"
      unfolding coeff_mpoly_to_mpoly_poly using i
      by (intro Sum_any.cong when_cong refl) (auto simp: coeff_gt_degree_eq_0)
    also have "\<dots> = 0"
      by simp
    finally show "poly.coeff (mpoly_to_mpoly_poly x p) i = 0" .
  qed
next
  show "Polynomial.degree (mpoly_to_mpoly_poly x p) \<ge> MPoly_Type.degree p x"
  proof (cases "p = 0")
    case False
    then obtain m where m: "MPoly_Type.coeff p m \<noteq> 0" "lookup m x = MPoly_Type.degree p x"
      using monom_of_degree_exists by blast
    show "Polynomial.degree (mpoly_to_mpoly_poly x p) \<ge> MPoly_Type.degree p x"
    proof (rule Polynomial.le_degree)
      have "0 \<noteq> MPoly_Type.coeff p m"
        using m by auto
      also have "MPoly_Type.coeff p m = MPoly_Type.coeff (poly.coeff (mpoly_to_mpoly_poly x p) (lookup m x)) (remove_key x m)"
        by (rule mpoly_coeff_to_mpoly_poly_coeff)
      finally show "poly.coeff (mpoly_to_mpoly_poly x p) (MPoly_Type.degree p x) \<noteq> 0"
        using m by auto
    qed
  qed auto
qed

text \<open>The upcoming lemma is similar to @{thm reduce_nested_mpoly_extract_var}.\<close>
lemma poly_mpoly_to_mpoly_poly:
  "poly (mpoly_to_mpoly_poly x p) (Var x) = p"
proof (induct p rule: mpoly_induct)
  case (monom m a)
  show ?case unfolding mpoly_to_mpoly_poly_monom poly_monom
    by (transfer, simp add: Var\<^sub>0_power mult_single remove_key_sum)
next
  case (sum p1 p2 m a)
  then show ?case by (simp add: mpoly_to_mpoly_poly_add)
qed

lemma mpoly_to_mpoly_poly_eq_iff [simp]:
  "mpoly_to_mpoly_poly x p = mpoly_to_mpoly_poly x q \<longleftrightarrow> p = q"
proof
  assume "mpoly_to_mpoly_poly x p = mpoly_to_mpoly_poly x q"
  hence "poly (mpoly_to_mpoly_poly x p) (Var x) =
         poly (mpoly_to_mpoly_poly x q) (Var x)"
    by simp
  thus "p = q"
    by (auto simp: poly_mpoly_to_mpoly_poly)
qed auto

text \<open>Evaluation, i.e., insertion of concrete values is identical\<close>
lemma insertion_mpoly_to_mpoly_poly: assumes "\<And> y. y \<noteq> x \<Longrightarrow> \<beta> y = \<alpha> y"
  shows "poly (map_poly (insertion \<beta>) (mpoly_to_mpoly_poly x p)) (\<alpha> x) = insertion \<alpha> p"
proof (induct p rule: mpoly_induct)
  case (monom m a)
  let ?rkm = "remove_key x m"
  have to_alpha: "insertion \<beta> (MPoly_Type.monom ?rkm a) = insertion \<alpha> (MPoly_Type.monom ?rkm a)"
    by (rule insertion_irrelevant_vars, rule assms, insert vars_monom_subset[of ?rkm a], auto simp: remove_key_keys[symmetric])
  have main: "insertion \<alpha> (MPoly_Type.monom ?rkm a) * \<alpha> x ^ lookup m x = insertion \<alpha> (MPoly_Type.monom m a)"
    unfolding monom_remove_key[of m a x] insertion_mult
    by (metis insertion_single mult.left_neutral)
  show ?case using main to_alpha
    by (simp add: mpoly_to_mpoly_poly_monom map_poly_monom poly_monom)
next
  case (sum p1 p2 m a)
  then show ?case by (simp add: mpoly_to_mpoly_poly_add insertion_add map_poly_add)
qed

lemma mpoly_to_mpoly_poly_dvd_iff [simp]:
  "mpoly_to_mpoly_poly x p dvd mpoly_to_mpoly_poly x q \<longleftrightarrow> p dvd q"
proof
  assume "mpoly_to_mpoly_poly x p dvd mpoly_to_mpoly_poly x q"
  hence "poly (mpoly_to_mpoly_poly x p) (Var x) dvd poly (mpoly_to_mpoly_poly x q) (Var x)"
    by (intro poly_hom.hom_dvd)
  thus "p dvd q"
    by (simp add: poly_mpoly_to_mpoly_poly)
qed auto

lemma vars_coeff_mpoly_to_mpoly_poly: "vars (poly.coeff (mpoly_to_mpoly_poly x p) i) \<subseteq> vars p - {x}"
  unfolding mpoly_to_mpoly_poly_def Sum_any.expand_set Polynomial.coeff_sum More_MPoly_Type.coeff_monom
  apply (rule order.trans[OF vars_setsum], force)
  apply (rule UN_least, simp)
  apply (intro impI order.trans[OF vars_monom_subset])
  by (simp add: remove_key_keys[symmetric] Diff_mono SUP_upper2 coeff_keys vars_def)

locale transfer_mpoly_to_mpoly_poly =
  fixes x :: nat
begin

definition R :: "'a :: comm_ring_1 mpoly poly \<Rightarrow> 'a mpoly \<Rightarrow> bool" where
  "R p p' \<longleftrightarrow> p = mpoly_to_mpoly_poly x p'"

context
  includes lifting_syntax
begin

lemma transfer_0 [transfer_rule]: "R 0 0"
  and transfer_1 [transfer_rule]: "R 1 1"
  and transfer_Const [transfer_rule]: "R [:Const c:] (Const c)"
  and transfer_uminus [transfer_rule]: "(R ===> R) uminus uminus"
  and transfer_of_nat [transfer_rule]: "((=) ===> R) of_nat of_nat"
  and transfer_of_int [transfer_rule]: "((=) ===> R) of_nat of_nat"
  and transfer_numeral [transfer_rule]: "((=) ===> R) of_nat of_nat"
  and transfer_add [transfer_rule]: "(R ===> R ===> R) (+) (+)"
  and transfer_diff [transfer_rule]: "(R ===> R ===> R) (+) (+)"
  and transfer_mult [transfer_rule]: "(R ===> R ===> R) (*) (*)"
  and transfer_dvd [transfer_rule]: "(R ===> R ===> (=)) (dvd) (dvd)"
  and transfer_monom [transfer_rule]:
        "((=) ===> (=) ===> R)
          (\<lambda>m a. Polynomial.monom (MPoly_Type.monom (remove_key x m) a) (lookup m x))
          MPoly_Type.monom"
  and transfer_coeff [transfer_rule]:
        "(R ===> (=) ===> (=))
           (\<lambda>p m. MPoly_Type.coeff (poly.coeff p (lookup m x)) (remove_key x m))
           MPoly_Type.coeff"
  and transfer_degree [transfer_rule]:
        "(R ===> (=)) Polynomial.degree (\<lambda>p. MPoly_Type.degree p x)"
  unfolding R_def
  by (auto simp: rel_fun_def mpoly_to_mpoly_poly_monom
           simp flip: mpoly_coeff_to_mpoly_poly_coeff)

lemma transfer_vars [transfer_rule]:
  assumes [transfer_rule]: "R p p'"
  shows   "(\<Union>i. vars (poly.coeff p i)) \<union> (if Polynomial.degree p = 0 then {} else {x}) = vars p'"
    (is "?A \<union> ?B = _")
proof (intro equalityI)
  have "vars p' = vars (poly p (Var x))"
    using assms by (simp add: R_def poly_mpoly_to_mpoly_poly)
  also have "poly p (Var x) = (\<Sum>i\<le>Polynomial.degree p. poly.coeff p i * Var x ^ i)"
    unfolding poly_altdef ..
  also have "vars \<dots> \<subseteq> (\<Union>i. vars (poly.coeff p i) \<union> (if Polynomial.degree p = 0 then {} else {x}))"
  proof (intro order.trans[OF vars_sum] UN_mono order.trans[OF vars_mult] Un_mono)
    fix i :: nat
    assume i: "i \<in> {..Polynomial.degree p}"
    show "vars (Var x ^ i) \<subseteq> (if Polynomial.degree p = 0 then {} else {x})"
    proof (cases "Polynomial.degree p = 0")
      case False
      thus ?thesis
        by (intro order.trans[OF vars_power]) (auto simp: vars_Var)
    qed (use i in auto)
  qed auto
  finally show "vars p' \<subseteq> ?A \<union> ?B" by blast
next
  have "?A \<subseteq> vars p'"
    using assms vars_coeff_mpoly_to_mpoly_poly by (auto simp: R_def)
  moreover have "?B \<subseteq> vars p'"
    using assms by (auto simp: R_def degree_pos_iff)
  ultimately show "?A \<union> ?B \<subseteq> vars p'"
    by blast
qed

lemma right_total [transfer_rule]: "right_total R"
  unfolding right_total_def
proof safe
  fix p' :: "'a mpoly"
  show "\<exists>p. R p p'"
    by (rule exI[of _ "mpoly_to_mpoly_poly x p'"]) (auto simp: R_def)
qed

lemma bi_unique [transfer_rule]: "bi_unique R"
  unfolding bi_unique_def by (auto simp: R_def)

end

end

lemma mpoly_degree_mult_eq:
  fixes p q :: "'a :: idom mpoly"
  assumes "p \<noteq> 0" "q \<noteq> 0"
  shows   "MPoly_Type.degree (p * q) x = MPoly_Type.degree p x + MPoly_Type.degree q x"
proof -
  interpret transfer_mpoly_to_mpoly_poly x .
  define deg :: "'a mpoly \<Rightarrow> nat" where "deg = (\<lambda>p. MPoly_Type.degree p x)"
  have [transfer_rule]: "rel_fun R (=) Polynomial.degree deg"
    using transfer_degree unfolding deg_def .

  have "deg (p * q) = deg p + deg q"
    using assms unfolding deg_def [symmetric]
    by transfer (simp add: degree_mult_eq)
  thus ?thesis
    by (simp add: deg_def)
qed

text \<open>Converts a multi-variate polynomial into a univariate polynomial via inserting values for all but one variable\<close>
definition partial_insertion :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a :: comm_ring_1 mpoly \<Rightarrow> 'a poly" where
  "partial_insertion \<alpha> x p = map_poly (insertion \<alpha>) (mpoly_to_mpoly_poly x p)"

lemma comm_ring_hom_insertion: "comm_ring_hom (insertion \<alpha>)"
  by (unfold_locales, auto simp: insertion_add insertion_mult)

lemma partial_insertion_add: "partial_insertion \<alpha> x (p + q) = partial_insertion \<alpha> x p + partial_insertion \<alpha> x q"
proof -
  interpret i: comm_ring_hom "insertion \<alpha>" by (rule comm_ring_hom_insertion)
  show ?thesis unfolding partial_insertion_def mpoly_to_mpoly_poly_add hom_distribs ..
qed

lemma partial_insertion_monom: "partial_insertion \<alpha> x (MPoly_Type.monom m a) = Polynomial.monom (insertion \<alpha> (MPoly_Type.monom (remove_key x m) a)) (lookup m x)"
  unfolding partial_insertion_def mpoly_to_mpoly_poly_monom
  by (subst map_poly_monom, auto)

text \<open>Partial insertion + insertion of last value is identical to (full) insertion\<close>
lemma insertion_partial_insertion: assumes "\<And> y. y \<noteq> x \<Longrightarrow> \<beta> y = \<alpha> y"
  shows "poly (partial_insertion \<beta> x p) (\<alpha> x) = insertion \<alpha> p"
proof (induct p rule: mpoly_induct)
  case (monom m a)
  let ?rkm = "remove_key x m"
  have to_alpha: "insertion \<beta> (MPoly_Type.monom ?rkm a) = insertion \<alpha> (MPoly_Type.monom ?rkm a)"
    by (rule insertion_irrelevant_vars, rule assms, insert vars_monom_subset[of ?rkm a], auto simp: remove_key_keys[symmetric])
  have main: "insertion \<alpha> (MPoly_Type.monom ?rkm a) * \<alpha> x ^ lookup m x = insertion \<alpha> (MPoly_Type.monom m a)"
    unfolding monom_remove_key[of m a x] insertion_mult
    by (metis insertion_single mult.left_neutral)
  show ?case using main to_alpha by (simp add: partial_insertion_monom poly_monom)
next
  case (sum p1 p2 m a)
  then show ?case by (simp add: partial_insertion_add insertion_add map_poly_add)
qed

lemma insertion_coeff_mpoly_to_mpoly_poly[simp]:
  "insertion \<alpha> (coeff (mpoly_to_mpoly_poly x p) k) = coeff (partial_insertion \<alpha> x p) k"
  unfolding partial_insertion_def
  by (subst coeff_map_poly, auto)

lemma degree_map_poly_Const: "degree (map_poly (Const :: 'a :: semiring_0 \<Rightarrow> _) f) = degree f"
  by (rule degree_map_poly, auto)

lemma degree_partial_insertion_le_mpoly: "degree (partial_insertion \<alpha> x p) \<le> degree (mpoly_to_mpoly_poly x p)"
  unfolding partial_insertion_def by (rule degree_map_poly_le)

end


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

section \<open>Testing of arithmetic simprocs\<close>

theory Simproc_Tests
imports MainRLT
begin

text \<open>
  This theory tests the various simprocs defined in \<^file>\<open>~~/src/HOL/Nat.thy\<close> and
  \<^file>\<open>~~/src/HOL/Numeral_Simprocs.thy\<close>. Many of the tests are derived from commented-out code
  originally found in \<^file>\<open>~~/src/HOL/Tools/numeral_simprocs.ML\<close>.
\<close>

subsection \<open>ML bindings\<close>

ML \<open>
  fun test ctxt ps =
    CHANGED (asm_simp_tac (put_simpset HOL_basic_ss ctxt addsimprocs ps) 1)
\<close>

subsection \<open>Cancellation simprocs from \<open>Nat.thy\<close>\<close>

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

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

subsection \<open>Abelian group cancellation simprocs\<close>

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 \<open>test \<^context> [\<^simproc>\<open>group_cancel_diff\<close>]\<close>) fact
  next
    assume "a + 0 = b + 0" have "a + c = b + c"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>group_cancel_eq\<close>]\<close>) fact
  }
end
(* TODO: more tests for Groups.group_cancel_{add,diff,eq,less,le} *)

subsection \<open>\<open>int_combine_numerals\<close>\<close>

(* 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 \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "10 + (2 * l + oo) = uu"
    have "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-3 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "7 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-4 * (u * v) + (2 * x + y) = w"
    have "(2*x - (u*v) + y) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "2 * x * u * v + y = w"
    have "(2*x*u*v + (u*v)*4 + y) - v*u*4 = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-3 * (u * v) + (- (x * u * v) + - y) = w"
    have "u*v - (x*u*v + (u*v)*4 + y) = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "a + - c = d"
    have "a + -(b+c) + b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-2 * b + (a + - c) = d"
    have "a + -(b+c) - b = d"
      apply (simp only: minus_add_distrib)
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-7 + (i + (j + (k + (- u + - y)))) = z"
    have "(i + j + -2 + k) - (u + 5 + y) = z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "-27 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - 15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "27 + (i + (j + k)) = y"
    have "(i + j + 12 + k) - -15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  next
    assume "3 + (i + (j + k)) = y"
    have "(i + j + -12 + k) - -15 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>inteq_cancel_numerals\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 + (j + (i + k)) = y"
    have "(i + j*2 + 12 + k) = j + 5 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>int_combine_numerals\<close>, \<^simproc>\<open>inteq_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>intless_cancel_numerals\<close>\<close>

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

subsection \<open>\<open>ring_eq_cancel_numeral_factor\<close>\<close>

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

subsection \<open>\<open>int_div_cancel_numeral_factors\<close>\<close>

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

subsection \<open>\<open>ring_less_cancel_numeral_factor\<close>\<close>

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

subsection \<open>\<open>ring_le_cancel_numeral_factor\<close>\<close>

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

subsection \<open>\<open>divide_cancel_numeral_factor\<close>\<close>

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

subsection \<open>\<open>ring_eq_cancel_factor\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a*c = 1" have "a*(b*c) = b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d*x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> x = y" have "x*k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> 1 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>ring_eq_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>int_div_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::unique_euclidean_semiring"
  {
    assume "(if k = 0 then 0 else x div y) = uu"
    have "(x*k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 div y) = uu"
    have "(k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) div b = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>int_div_cancel_factor\<close>]\<close>) fact
  }
end

lemma shows "a*(b*c)/(y*z) = d*(b::'a::linordered_field)*(x*a)/z"
oops \<comment> \<open>FIXME: need simproc to cover this case\<close>

subsection \<open>\<open>divide_cancel_factor\<close>\<close>

notepad begin
  fix a b c d k uu x y :: "'a::field"
  {
    assume "(if k = 0 then 0 else x / y) = uu"
    have "(x*k) / (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else 1 / y) = uu"
    have "(k) / (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu"
    have "(a*(b*c)) / b = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>divide_cancel_factor\<close>]\<close>) fact
  }
end

lemma
  fixes a b c d x y z :: "'a::linordered_field"
  shows "a*(b*c)/(y*z) = d*(b)*(x*a)/z"
oops \<comment> \<open>FIXME: need simproc to cover this case\<close>

subsection \<open>\<open>linordered_ring_less_cancel_factor\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> x*z < z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < y*z"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x < y" have "0 < z \<Longrightarrow> z*x < z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]\<close>) 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 \<open>CHANGED (asm_simp_tac (put_simpset HOL_basic_ss \<^context>
        addsimprocs [\<^simproc>\<open>linordered_ring_less_cancel_factor\<close>]
        addsimps [@{thm z_pos}]) 1)\<close>) fact
  }
end

subsection \<open>\<open>linordered_ring_le_cancel_factor\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>linordered_ring_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < z \<Longrightarrow> x \<le> y" have "0 < z \<Longrightarrow> z*x \<le> z*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>linordered_ring_le_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>\<open>field_combine_numerals\<close>\<close>

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

lemma
  fixes x :: "'a::{linordered_field}"
  shows "2/3 * x + x / 3 = uu"
apply (tactic \<open>test \<^context> [\<^simproc>\<open>field_combine_numerals\<close>]\<close>)?
oops \<comment> \<open>FIXME: test fails\<close>

subsection \<open>\<open>nat_combine_numerals\<close>\<close>

notepad begin
  fix i j k m n u :: nat
  {
    assume "4*k = u" have "k + 3*k = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    (* FIXME "Suc (i + 3) \<equiv> i + 4" *)
    assume "4 * Suc 0 + i = u" have "Suc (i + 3) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    assume "2 * j + 4 * k = u" have "k + j + 3*k + j = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  next
    assume "5 * (m * n) = u" have "(2*n*m) + (3*(m*n)) = u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_combine_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>nateq_cancel_numerals\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u = Suc 0" have "2*u = Suc (u)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) = 3 * Suc 0 + (u + y)"
    have "(i + j + 12 + k) = u + 15 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = u + 5 + y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "11 * Suc 0 + (i + (j + k)) = u + y"
    have "(i + j + 12 + k) = Suc (u + y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * u + (2 * y + 3 * z) = Suc 0"
    have "2*y + 3*z + 2*u = Suc (u)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nateq_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natless_cancel_numerals\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "0 < j" have "(2*length xs < length xs * 2 + j)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) < u + y"
    have "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  next
    assume "0 < Suc 0 * (m * n) + u" have "(2*n*m) < (3*(m*n)) + u"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natless_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natle_cancel_numerals\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  next
    assume "6 + length l2 = 0" have "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) \<le> length l1"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natle_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>\<open>natdiff_cancel_numerals\<close>\<close>

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 \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "7 * Suc 0 + (i + (j + k)) - 0 = y" have "(i + j + 12 + k) - 5 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "u - Suc 0 * Suc 0 = y" have "Suc u - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + u - 0 = y" have "Suc (Suc (Suc u)) - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc 0 * Suc 0 + (i + (j + k)) - 0 = y"
    have "(i + j + 2 + k) - 1 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "i + (j + k) - Suc 0 * Suc 0 = y"
    have "(i + j + 1 + k) - 2 = y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 * x + y - 2 * (u * v) = w"
    have "(2*x + (u*v) + y) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "Suc (Suc 0 * (u * v)) - 0 = w"
    have "Suc ((u*v)*4) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "2 - 0 = w" have "Suc (Suc ((u*v)*3)) - v*3*u = w"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "17 * Suc 0 + (i + (j + k)) - (u + y) = zz"
    have "(i + j + 32 + k) - (u + 15 + y) = zz"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  next
    assume "u + y - 0 = v" have "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>natdiff_cancel_numerals\<close>]\<close>) fact
  }
end

subsection \<open>Factor-cancellation simprocs for type \<^typ>\<open>nat\<close>\<close>

text \<open>\<open>nat_eq_cancel_factor\<close>, \<open>nat_less_cancel_factor\<close>,
\<open>nat_le_cancel_factor\<close>, \<open>nat_divide_cancel_factor\<close>, and
\<open>nat_dvd_cancel_factor\<close>.\<close>

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 \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 = y" have "k = k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a * c = Suc 0" have "a*(b*c) = b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c = d * x" have "a*(b*c) = d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_eq_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<and> x < y" have "x*k < k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<and> Suc 0 < y" have "k < k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < b \<and> a * c < Suc 0" have "a*(b*c) < b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < a \<and> 0 < b \<and> c < d * x" have "a*(b*c) < d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_less_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<longrightarrow> x \<le> y" have "x*k \<le> k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < k \<longrightarrow> Suc 0 \<le> y" have "k \<le> k*y"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < b \<longrightarrow> a * c \<le> Suc 0" have "a*(b*c) \<le> b"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "0 < a \<longrightarrow> 0 < b \<longrightarrow> c \<le> d * x" have "a*(b*c) \<le> d*b*(x*a)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_le_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else x div y) = uu" have "(x*k) div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if k = 0 then 0 else Suc 0 div y) = uu" have "k div (k*y) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "(if b = 0 then 0 else a * c) = uu" have "(a*(b*c)) div (b) = uu"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) 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 \<open>test \<^context> [\<^simproc>\<open>nat_div_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> x dvd y" have "(x*k) dvd (k*y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "k = 0 \<or> Suc 0 dvd y" have "k dvd (k*y)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> a * c dvd Suc 0" have "(a*(b*c)) dvd (b)"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "b = 0 \<or> Suc 0 dvd a * c" have "b dvd (a*(b*c))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  next
    assume "a = 0 \<or> b = 0 \<or> c dvd d * x" have "(a*(b*c)) dvd (d*b*(x*a))"
      by (tactic \<open>test \<^context> [\<^simproc>\<open>nat_dvd_cancel_factor\<close>]\<close>) fact
  }
end

subsection \<open>Numeral-cancellation simprocs for type \<^typ>\<open>nat\<close>\<close>

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

subsection \<open>Integer numeral div/mod simprocs\<close>

notepad begin
  have "(10::int) div 3 = 3"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) mod 3 = 1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) div -3 = -4"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(10::int) mod -3 = -2"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) div 3 = -4"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) mod 3 = 2"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) div -3 = 3"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(-10::int) mod -3 = -1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(8452::int) mod 3 = 1"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(59485::int) div 434 = 137"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "(1000006::int) mod 10 = 6"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000000 div 2 = (5000000::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000001 mod 2 = (1::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000055 div 32 = (312501::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "10000055 mod 32 = (23::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "100094 div 144 = (695::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
  have "100094 mod 144 = (14::int)"
    by (tactic \<open>test \<^context> [\<^simproc>\<open>numeral_divmod\<close>]\<close>)
end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Noninterference_Base_Alternatives
imports Noninterference_Base "../../lib/Eisbach_Methods"
begin

text {*
  This theory explores a bunch of alternative definitions for the @{term sources}
  and @{term ipurge} functions that are the basis of our noninterference formulation
  and shows that they all turn out to yield equivalent noninterference properties.
*}
context noninterference_system begin

(* the following definition turns out to yield an information flow property equivalent
   to the above one -- see below *)
primrec
 xources :: "'e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set" where
 xources_Nil: "xources [] s u = {u}"|
 xources_Cons: "xources (a#as) s u = (\<Inter>{xources as s' u| s'. (s,s') \<in> Step a}) \<union>
      {w. w = dom a s \<and> (\<forall> s'. (s,s') \<in> Step a \<longrightarrow> (\<exists> v. dom a s \<leadsto> v \<and> v \<in> xources as s' u))}"

lemma in_xources_ConsD:
  "x \<in> (xources (a # as) s u) \<Longrightarrow>
   (\<forall> s'. (s,s') \<in> Step a \<longrightarrow> x \<in> xources as s' u) \<or>
   (x = dom a s \<and> (\<forall> s'. (s,s') \<in> Step a \<longrightarrow> (\<exists> v. dom a s \<leadsto> v \<and> v \<in> xources as s' u)))"
  by auto

lemma in_xources_ConsI1:
  "\<lbrakk>\<forall> s'. (s,s') \<in> Step a \<longrightarrow> x \<in> xources as s' u\<rbrakk> \<Longrightarrow> x \<in> xources (a#as) s u"
  by auto

lemma in_xources_ConsI2:
  "\<lbrakk>x = dom a s; \<forall> s'. (s,s') \<in> Step a \<longrightarrow> (\<exists> v. dom a s \<leadsto> v \<and> v \<in> xources as s' u)\<rbrakk> \<Longrightarrow>
  x \<in> xources (a#as) s u"
  by auto

declare xources_Nil [simp del]
declare xources_Cons [simp del]

lemma xources_subset_xources_Cons:
  "\<Inter>{xources as s' u|s'. (s,s') \<in> Step a} \<subseteq> xources (a#as) s u"
  by(fastforce simp: xources_Cons)

primrec gen_purgx :: "('e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set) \<Rightarrow> 'd \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list"
where
  Nil : "gen_purgx sf u []     ss = []" |
  Cons: "gen_purgx sf u (a#as) ss =
            (if (\<forall>s\<in>ss. dom a s \<in> sf (a#as) s u) then
               a#gen_purgx sf u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
             else
               gen_purgx sf u as ss)"

definition
  xpurge :: "'d \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list" where
 "xpurge \<equiv> gen_purge xources"

definition
  ipurgx :: "'d \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list" where
 "ipurgx \<equiv> gen_purgx sources"

definition
  xpurgx :: "'d \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list" where
 "xpurgx \<equiv> gen_purgx xources"

lemma xpurge_Nil:
  "xpurge u [] ss = []"
  by(auto simp: xpurge_def)

lemma ipurgx_Nil:
  "ipurgx u [] ss = []"
  by(auto simp: ipurgx_def)

lemma xpurgx_Nil:
  "xpurgx u [] ss = []"
  by(auto simp: xpurgx_def)

lemma xpurge_Cons:
  "xpurge u (a#as) ss =
     (if (\<exists>s\<in>ss. dom a s \<in> xources (a#as) s u) then
         a#xpurge u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
      else
         xpurge u as ss)"
  by (auto simp: xpurge_def)

lemma ipurgx_Cons:
  "ipurgx u (a#as) ss =
     (if (\<forall>s\<in>ss. dom a s \<in> sources (a#as) s u) then
         a#ipurgx u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
      else
         ipurgx u as ss)"
  by (auto simp: ipurgx_def)

lemma xpurgx_Cons:
  "xpurgx u (a#as) ss =
     (if (\<forall>s\<in>ss. dom a s \<in> xources (a#as) s u) then
         a#xpurgx u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
      else
         xpurgx u as ss)"
  by (auto simp: xpurgx_def)

definition xNonleakage_gen :: "bool" where
  "xNonleakage_gen \<equiv> \<forall>as s u t. reachable s \<and> reachable t \<longrightarrow>
     s \<sim>schedDomain\<sim> t \<longrightarrow>
       s \<approx>(xources as s u)\<approx> t \<longrightarrow> uwr_equiv s as t as u"

end

context unwinding_system begin
lemma xources_sources:
  "confidentiality_u \<Longrightarrow> reachable s \<longrightarrow> (xources as s u = sources as s u)"
  apply(induct as arbitrary: s)
   apply(simp add: xources_Nil sources_Nil)
  apply(simp add: sources_Cons xources_Cons)
  apply(rule impI)
  apply(rule un_eq)
   apply(rule sym)
   apply(simp only: Union_eq, simp only: UNION_eq[symmetric])
   apply(simp only: Inter_eq, simp only: INTER_eq[symmetric])
   apply(rule Un_eq_Int)
     apply (clarsimp simp: Step_def)
     apply(erule reachable_enabled)
    apply (clarsimp simp: Step_def)
    apply(erule reachable_enabled)
   apply clarsimp
   apply(drule_tac x=s'a in meta_spec, clarsimp simp: reachable_Step)
   apply(rule sources_eq)
      apply assumption
     apply(fastforce intro: sched_equiv_preserved uwr_refl)
    apply(fastforce intro: reachable_Step)
   apply(fastforce intro: reachable_Step)
  apply(rule Collect_cong)
  apply(rule conj_cong, rule refl)
  apply safe
   apply(cut_tac s=s and a=a in enabled_Step)
    apply assumption
   apply clarsimp
   apply(drule_tac x=s' in spec)
   apply clarsimp
   apply(rule_tac x=v in exI)
   apply clarsimp
   apply(rule_tac x=s' in exI)
   apply(drule_tac x=s' in meta_spec)
   apply(fastforce intro: reachable_Step)
  apply(rule_tac x=v in exI, clarsimp)
  apply(drule_tac x=s' in meta_spec)
  apply(clarsimp simp: reachable_Step)
  apply(rule subst[OF sources_eq])
      apply assumption
     prefer 4
     apply assumption
    apply(fastforce intro: sched_equiv_preserved uwr_refl)
  by(auto intro: reachable_Step)

lemma xpurge_ipurge':
  "confidentiality_u \<Longrightarrow> (\<forall> s\<in>ss. reachable s) \<longrightarrow> xpurge u as ss = ipurge u as ss"
  apply(induct as arbitrary: ss)
   apply(simp add: xpurge_Nil ipurge_Nil)
  apply(clarsimp simp: ipurge_Cons xpurge_Cons xources_sources[rule_format] intro: reachable_Step | safe)+
  apply(drule_tac x="\<Union>s\<in>ss. {s'. (s,s') \<in> Step a}" in meta_spec)
  apply(fastforce intro: reachable_Step)
  done

lemma ipurgx_xpurge':
  "confidentiality_u \<Longrightarrow> (\<forall> s\<in>ss. reachable s) \<and> (\<exists>s. s \<in> ss) \<and> (\<forall> s s'. s\<in>ss \<and> s'\<in>ss \<longrightarrow> s\<sim>schedDomain\<sim>s') \<longrightarrow> ipurgx u as ss = xpurge u as ss"
  apply(induct as arbitrary: ss)
   apply(simp add: ipurgx_Nil xpurge_Nil)
  apply(clarsimp simp: xpurge_Cons ipurgx_Cons | safe)+
    apply(drule_tac x="\<Union>s\<in>ss. {s'. (s,s') \<in> Step a}" in meta_spec)
    apply(erule impE)
     apply(rule conjI)
      apply(fastforce intro: reachable_Step)
     apply(rule conjI)
      apply(drule bspec, assumption, frule_tac a=a in enabled_Step)
      apply blast
     apply clarsimp
     apply(match conclusion in \<open>s' \<sim>schedDomain\<sim> t'\<close> for s' t' \<Rightarrow>
             \<open>match premises in \<open>(s,s') \<in> Step a\<close> and \<open>(t,t') \<in> Step a\<close> for a s t \<Rightarrow>
                \<open>rule sched_equiv_preserved[of s t]\<close>\<close>)
          apply assumption
         apply blast
        apply blast
       apply blast
      apply assumption
     apply assumption
    apply assumption
   apply(simp add: xources_sources)
  apply(simp add: xources_sources)
  apply(erule notE)
  apply(frule_tac s=s and t=sa in sources_eq, simp+)
  apply(erule ssubst)
  apply(subst schedIncludesCurrentDom)
   prefer 2
   apply assumption
  apply blast
  done

lemma ipurgx_xpurgx':
  "confidentiality_u \<Longrightarrow> (\<forall> s\<in>ss. reachable s)  \<longrightarrow> ipurgx u as ss = xpurgx u as ss"
  apply(induct as arbitrary: ss)
   apply(simp add: ipurgx_Nil xpurgx_Nil)
  apply(clarsimp simp: xpurgx_Cons ipurgx_Cons | safe)+
    apply(drule_tac x="\<Union>s\<in>ss. {s'. (s,s') \<in> Step a}" in meta_spec)
    apply(fastforce intro: reachable_Step)
   apply(simp add: xources_sources)
  apply(simp add: xources_sources)
  done

lemma xpurge_ipurge:
  "confidentiality_u \<Longrightarrow> reachable s \<Longrightarrow> xpurge u as {s} = ipurge u as {s}"
  apply(subst xpurge_ipurge', auto)
  done

lemma ipurgx_ipurge:
  "confidentiality_u \<Longrightarrow> reachable s \<Longrightarrow> ipurgx u as {s} = ipurge u as {s}"
  apply(subst ipurgx_xpurge', (simp add: uwr_refl)+)
  apply(subst xpurge_ipurge', auto)
  done

lemma xpurgx_ipurge:
  "confidentiality_u \<Longrightarrow> reachable s \<Longrightarrow> xpurgx u as {s} = ipurge u as {s}"
  apply(subst ipurgx_xpurgx'[rule_format, THEN sym], simp+)
  apply(subst ipurgx_xpurge', (simp add: uwr_refl)+)
  apply(subst xpurge_ipurge', auto)
  done

(* we have four different purge functions, and two different sources functions.
   So we should be able to make 8 different definitions of security. All of which
   are equivalent. One of those definitions is of course the one above. *)
definition
  xNoninfluence_strong_uwr_xources_ipurge :: "bool" where
 "xNoninfluence_strong_uwr_xources_ipurge \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(xources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_sources_xpurge :: "bool" where
 "xNoninfluence_strong_uwr_sources_xpurge \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         xpurge u as {s} = xpurge u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_xources_xpurge :: "bool" where
 "xNoninfluence_strong_uwr_xources_xpurge \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(xources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         xpurge u as {s} = xpurge u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_sources_ipurgx :: "bool" where
 "xNoninfluence_strong_uwr_sources_ipurgx \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurgx u as {s} = ipurgx u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_xources_ipurgx :: "bool" where
 "xNoninfluence_strong_uwr_xources_ipurgx \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(xources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurgx u as {s} = ipurgx u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_sources_xpurgx :: "bool" where
 "xNoninfluence_strong_uwr_sources_xpurgx \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         xpurgx u as {s} = xpurgx u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition
  xNoninfluence_strong_uwr_xources_xpurgx :: "bool" where
 "xNoninfluence_strong_uwr_xources_xpurgx \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(xources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         xpurgx u as {s} = xpurgx u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

(* The following perhaps feels more natural, but we show is equivalent. 'pg' here is for Pete Gammie who pushed me to prove this. *)
definition
  Noninfluence_strong_uwr_pg :: "bool" where
 "Noninfluence_strong_uwr_pg \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {t} \<longrightarrow>
         uwr_equiv s as t bs u"

lemma xNoninfluence_strong_uwr_xources_ipurge_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_xources_ipurge = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurge_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: xources_sources)
  done

lemma xNoninfluence_strong_uwr_sources_xpurge_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_sources_xpurge = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurge_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: xpurge_ipurge)
  done

lemma xNoninfluence_strong_uwr_xources_xpurge_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_xources_xpurge = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurge_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: xources_sources xpurge_ipurge)
  done

lemma xNoninfluence_strong_uwr_sources_ipurgx_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_sources_ipurgx = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_ipurgx_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: ipurgx_ipurge)
  done

lemma xNoninfluence_strong_uwr_xources_ipurgx_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_xources_ipurgx = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurgx_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
apply(simp add: xources_sources ipurgx_ipurge)
  done

lemma xNoninfluence_strong_uwr_sources_xpurgx_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_sources_xpurgx = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurgx_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: xpurgx_ipurge)
  done

lemma xNoninfluence_strong_uwr_xources_xpurgx_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  xNoninfluence_strong_uwr_xources_xpurgx = Noninfluence_strong_uwr"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurgx_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: xpurgx_ipurge xources_sources)
  done

lemma Noninfluence_strong_uwr_pg_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  Noninfluence_strong_uwr_pg = Noninfluence_strong_uwr"
  apply(clarsimp simp: Noninfluence_strong_uwr_pg_def Noninfluence_strong_uwr_def)
  apply(frule (1) confidentiality_u_weak)
  apply(simp add: ipurge_eq)
  done

lemma xources_Step:
  "\<lbrakk>reachable s; (dom a s, u) \<notin> policy\<rbrakk> \<Longrightarrow>
  xources [a] s u = {u}"
  apply(auto simp: xources_Cons xources_Nil enabled_Step dest: enabled_Step)
  done

lemma xources_Step_2:
  "\<lbrakk>reachable s; (dom a s, u) \<in> policy\<rbrakk> \<Longrightarrow>
  xources [a] s u = {dom a s,u}"
  apply(auto simp: xources_Cons xources_Nil enabled_Step dest: enabled_Step)
  done

lemma xNoninfluence_strong_uwr_xources_ipurge_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_xources_ipurge \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurge_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: xources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_sources_xpurge_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_sources_xpurge \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurge_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_xources_xpurge_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_xources_xpurge \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurge_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: xources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_sources_ipurgx_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_sources_ipurgx \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_ipurgx_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_xources_ipurgx_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_xources_ipurgx \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurgx_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: xources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_sources_xpurgx_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_sources_xpurgx \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurgx_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma xNoninfluence_strong_uwr_xources_xpurgx_confidentiality_u_weak:
  "xNoninfluence_strong_uwr_xources_xpurgx \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurgx_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: xources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma ipurge_single_eq:
  "\<lbrakk>reachable s; reachable t; s \<sim>schedDomain\<sim> t\<rbrakk> \<Longrightarrow>
   ipurge u [a] {s} = ipurge u [a] {t}"
  apply(frule_tac e=a in schedIncludesCurrentDom)
  apply(simp add: ipurge_Cons ipurge_Nil sources_Cons sources_Nil)
  apply (auto dest: enabled_Step)
  done

lemma Noninfluence_strong_uwr_pg_confidentiality_u_weak:
  "Noninfluence_strong_uwr_pg \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: Noninfluence_strong_uwr_pg_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def ipurge_single_eq)
  done

end

context complete_unwinding_system begin

lemma Nonleakage_gen_xNonleakage_gen:
  "confidentiality_u \<Longrightarrow> Nonleakage_gen = xNonleakage_gen"
  apply(simp add: Nonleakage_gen_def xNonleakage_gen_def)
  apply(fastforce simp: xources_sources)
  done

lemma xNonleakage_gen:
  "confidentiality_u \<Longrightarrow> xNonleakage_gen"
  apply(simp add: Nonleakage_gen_xNonleakage_gen[symmetric])
  apply(erule Nonleakage_gen)
  done

lemma xNonleakage_gen_confidentiality_u:
  "xNonleakage_gen \<Longrightarrow> confidentiality_u"
  apply(clarsimp simp: xNonleakage_gen_def confidentiality_u_def)
  apply(drule_tac x="[a]" in spec, drule_tac x=s in spec)
  apply(drule_tac x=u in spec, drule_tac x=t in spec)
  apply(case_tac "dom a s \<leadsto> u")
   apply(simp add: xources_Step_2 uwr_equiv_def sameFor_dom_def Step_def)
  apply(simp add: xources_Step uwr_equiv_def sameFor_dom_def Step_def)
  done

lemma xNoninfluence_strong_uwr_xources_ipurge_integrity_u: "xNoninfluence_strong_uwr_xources_ipurge \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurge_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurge_Cons ipurge_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_sources_xpurge_integrity_u: "xNoninfluence_strong_uwr_sources_xpurge \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurge_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: xources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def xpurge_Cons xpurge_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_xources_xpurge_integrity_u: "xNoninfluence_strong_uwr_xources_xpurge \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurge_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: xources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def xpurge_Cons xpurge_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_sources_ipurgx_integrity_u: "xNoninfluence_strong_uwr_sources_ipurgx \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_ipurgx_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurgx_Cons ipurgx_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_xources_ipurgx_integrity_u: "xNoninfluence_strong_uwr_xources_ipurgx \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_ipurgx_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurgx_Cons ipurgx_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_sources_xpurgx_integrity_u: "xNoninfluence_strong_uwr_sources_xpurgx \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_sources_xpurgx_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: xources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def xpurgx_Cons xpurgx_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma xNoninfluence_strong_uwr_xources_xpurgx_integrity_u: "xNoninfluence_strong_uwr_xources_xpurgx \<Longrightarrow> integrity_u"
  apply(clarsimp simp: xNoninfluence_strong_uwr_xources_xpurgx_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: xources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def xpurgx_Cons xpurgx_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

lemma Noninfluence_strong_uwr_pg_integrity_u: "Noninfluence_strong_uwr_pg \<Longrightarrow> integrity_u"
  apply(clarsimp simp: Noninfluence_strong_uwr_pg_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurge_Cons ipurge_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

(* The choice as to which sources/ipurge definition to adopt doesn't matter.
   For this reason we adopt the one that is simpler to prove the sufficiency of the
   unwinding conditions for, while having both the sources and ipurge being of the
   same "kind". *)
lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_xources_ipurge:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_xources_ipurge"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_xources_ipurge_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_xources_ipurge_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_xources_ipurge_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_sources_xpurge:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_sources_xpurge"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_sources_xpurge_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_sources_xpurge_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_sources_xpurge_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_xources_xpurge:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_xources_xpurge"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_xources_xpurge_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_xources_xpurge_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_xources_xpurge_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_sources_ipurgx:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_sources_ipurgx"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_sources_ipurgx_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_sources_ipurgx_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_sources_ipurgx_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_xources_ipurgx:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_xources_ipurgx"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_xources_ipurgx_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_xources_ipurgx_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_xources_ipurgx_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_sources_xpurgx:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_sources_xpurgx"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_sources_xpurgx_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_sources_xpurgx_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_sources_xpurgx_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_xNoninfluence_strong_uwr_xources_xpurgx:
  "Noninfluence_strong_uwr = xNoninfluence_strong_uwr_xources_xpurgx"
  apply(rule iffI)
   apply(subst xNoninfluence_strong_uwr_xources_xpurgx_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule xNoninfluence_strong_uwr_xources_xpurgx_confidentiality_u_weak)
  apply(erule xNoninfluence_strong_uwr_xources_xpurgx_integrity_u)
  done

lemma Noninfluence_strong_uwr_equiv_Noninfluence_strong_uwr_pg:
  "Noninfluence_strong_uwr = Noninfluence_strong_uwr_pg"
  apply(rule iffI)
   apply(subst Noninfluence_strong_uwr_pg_Noninfluence_strong_uwr)
     apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_integrity_u)
   apply assumption
  apply(rule Noninfluence_strong_uwr)
   apply(erule Noninfluence_strong_uwr_pg_confidentiality_u_weak)
  apply(erule Noninfluence_strong_uwr_pg_integrity_u)
  done

end

end