(* Title:      (More) Relation Algebra
   Author:     Walter Guttmann, Peter Hoefner
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
               Peter Hoefner <peter at hoefner-online.de>
*)

section \<open>(More) Relation Algebra\<close>

text \<open>
This theory presents fundamental properties of relation algebras, which are not present in the AFP entry on relation algebras but could be integrated there \<^cite>\<open>"ArmstrongFosterStruthWeber2014"\<close>.
Many theorems concern vectors and points.
\<close>

theory More_Relation_Algebra

imports Relation_Algebra.Relation_Algebra_RTC Relation_Algebra.Relation_Algebra_Functions

begin

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

context relation_algebra
begin

notation
  converse ("(_\<^sup>T)" [102] 101)

abbreviation bijective
  where "bijective x \<equiv> is_inj x \<and> is_sur x"

abbreviation reflexive
  where "reflexive R \<equiv> 1' \<le> R"

abbreviation symmetric
  where "symmetric R \<equiv> R = R\<^sup>T"

abbreviation transitive
  where "transitive R \<equiv> R;R \<le> R"

text \<open>General theorems\<close>

lemma x_leq_triple_x:
  "x \<le> x;x\<^sup>T;x"
proof -
  have "x = x;1' \<cdot> 1"
    by simp
  also have "... \<le> (x \<cdot> 1;1'\<^sup>T);(1' \<cdot> x\<^sup>T;1)"
    by (rule dedekind)
  also have "... = x;(x\<^sup>T;1 \<cdot> 1')"
    by (simp add: inf.commute)
  also have "... \<le> x;(x\<^sup>T \<cdot> 1';1\<^sup>T);(1 \<cdot> (x\<^sup>T)\<^sup>T;1')"
    by (metis comp_assoc dedekind mult_isol)
  also have "... \<le> x;x\<^sup>T;x"
    by simp
  finally show ?thesis .
qed

lemma inj_triple:
  assumes "is_inj x"
    shows "x = x;x\<^sup>T;x"
by (metis assms order.eq_iff inf_absorb2 is_inj_def mult_1_left mult_subdistr x_leq_triple_x)

lemma p_fun_triple:
  assumes "is_p_fun x"
    shows "x = x;x\<^sup>T;x"
by (metis assms comp_assoc order.eq_iff is_p_fun_def mult_isol mult_oner x_leq_triple_x)

lemma loop_backward_forward:
  "x\<^sup>T \<le> -(1') + x"
by (metis conv_e conv_times inf.cobounded2 test_dom test_domain test_eq_conv galois_2 inf.commute
           sup.commute)

lemma inj_sur_semi_swap:
  assumes "is_sur z"
      and "is_inj x"
    shows "z \<le> y;x \<Longrightarrow> x \<le> y\<^sup>T;z"
proof -
  assume "z \<le> y;x"
  hence "z;x\<^sup>T \<le> y;(x;x\<^sup>T)"
    by (metis mult_isor mult_assoc)
  hence "z;x\<^sup>T \<le> y"
    using \<open>is_inj x\<close> unfolding is_inj_def
    by (metis mult_isol order.trans mult_1_right)
  hence "(z\<^sup>T;z);x\<^sup>T \<le> z\<^sup>T;y"
    by (metis mult_isol mult_assoc)
  hence "x\<^sup>T \<le> z\<^sup>T;y"
    using \<open>is_sur z\<close> unfolding is_sur_def
    by (metis mult_isor order.trans mult_1_left)
  thus ?thesis
    using conv_iso by fastforce
qed

lemma inj_sur_semi_swap_short:
  assumes "is_sur z"
      and "is_inj x"
    shows "z \<le> y\<^sup>T;x \<Longrightarrow> x \<le> y;z"
proof -
  assume as: "z \<le> y\<^sup>T;x"
  hence "z;x\<^sup>T \<le> y\<^sup>T"
    using \<open>z \<le> y\<^sup>T;x\<close> \<open>is_inj x\<close> unfolding is_inj_def
    by (metis assms(2) conv_invol inf.orderI inf_absorb1 inj_p_fun ss_422iii)
  hence "x\<^sup>T \<le> z\<^sup>T;y\<^sup>T"
    using \<open>is_sur z\<close> unfolding is_sur_def
    by (metis as assms inj_sur_semi_swap conv_contrav conv_invol conv_iso)
  thus "x \<le> y;z"
    using conv_iso by fastforce
qed

lemma bij_swap:
  assumes "bijective z"
      and "bijective x"
    shows "z \<le> y\<^sup>T;x \<longleftrightarrow> x \<le> y;z"
by (metis assms inj_sur_semi_swap conv_invol)

text \<open>The following result is \<^cite>\<open>\<open>Proposition 4.2.2(iv)\<close> in "SchmidtStroehlein1993"\<close>.\<close>

text \<open>The following results are variants of \<^cite>\<open>\<open>Proposition 4.2.3\<close> in "SchmidtStroehlein1993"\<close>.\<close>

lemma ss423conv:
  assumes "bijective x"
    shows "x ; y \<le> z \<longleftrightarrow> y \<le> x\<^sup>T ; z"
by (metis assms conv_contrav conv_iso inj_p_fun is_map_def ss423 sur_total)

lemma ss423bij:
  assumes "bijective x"
    shows "y ; x\<^sup>T \<le> z \<longleftrightarrow> y \<le> z ; x"
by (simp add: assms is_map_def p_fun_inj ss423 total_sur)

lemma inj_distr:
  assumes "is_inj z"
    shows "(x\<cdot>y);z = (x;z)\<cdot>(y;z)"
apply (rule order.antisym)
 using mult_subdistr_var apply blast
using assms conv_iso inj_p_fun p_fun_distl by fastforce

lemma test_converse:
  "x \<cdot> 1' = x\<^sup>T \<cdot> 1'"
by (metis conv_e conv_times inf_le2 is_test_def test_eq_conv)

lemma injective_down_closed:
  assumes "is_inj x"
      and "y \<le> x"
    shows "is_inj y"
by (meson assms conv_iso dual_order.trans is_inj_def mult_isol_var)

lemma injective_sup:
  assumes "is_inj t"
      and "e;t\<^sup>T \<le> 1'"
      and "is_inj e"
    shows "is_inj (t + e)"
proof -
  have 1: "t;e\<^sup>T \<le> 1'"
    using assms(2) conv_contrav conv_e conv_invol conv_iso by fastforce
  have "(t + e);(t + e)\<^sup>T = t;t\<^sup>T + t;e\<^sup>T + e;t\<^sup>T + e;e\<^sup>T"
    by (metis conv_add distrib_left distrib_right' sup_assoc)
  also have "... \<le> 1'"
    using 1 assms by (simp add: is_inj_def le_supI)
  finally show ?thesis
    unfolding is_inj_def .
qed

text \<open>Some (more) results about vectors\<close>

lemma vector_meet_comp:
  assumes "is_vector v"
      and "is_vector w"
    shows "v;w\<^sup>T = v\<cdot>w\<^sup>T"
by (metis assms conv_contrav conv_one inf_top_right is_vector_def vector_1)

lemma vector_meet_comp':
  assumes "is_vector v"
    shows "v;v\<^sup>T = v\<cdot>v\<^sup>T"
using assms vector_meet_comp by blast

lemma vector_meet_comp_x:
  "x;1;x\<^sup>T = x;1\<cdot>1;x\<^sup>T"
by (metis comp_assoc inf_top.right_neutral is_vector_def one_idem_mult vector_1)

lemma vector_meet_comp_x':
  "x;1;x = x;1\<cdot>1;x"
by (metis inf_commute inf_top.right_neutral ra_1)

lemma vector_prop1:
  assumes "is_vector v"
    shows "-v\<^sup>T;v = 0"
by (metis assms compl_inf_bot inf_top.right_neutral one_compl one_idem_mult vector_2)

text \<open>The following results and a number of others in this theory are from \<^cite>\<open>"Guttmann2017a"\<close>.\<close>

lemma ee:
  assumes "is_vector v"
      and "e \<le> v;-v\<^sup>T"
    shows "e;e = 0"
proof -
  have "e;v \<le> 0"
    by (metis assms annir mult_isor vector_prop1 comp_assoc)
  thus ?thesis
    by (metis assms(2) annil order.antisym bot_least comp_assoc mult_isol)
qed

lemma et:
  assumes "is_vector v"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
    shows "e;t = 0"
      and "e;t\<^sup>T = 0"
proof -
  have "e;t \<le> v;-v\<^sup>T;v;v\<^sup>T"
    by (metis assms(2-3) mult_isol_var comp_assoc)
  thus "e;t = 0"
    by (simp add: assms(1) comp_assoc le_bot vector_prop1)
next
  have "t\<^sup>T \<le> v;v\<^sup>T"
    using assms(3) conv_iso by fastforce
  hence "e;t\<^sup>T \<le> v;-v\<^sup>T;v;v\<^sup>T"
    by (metis assms(2) mult_isol_var comp_assoc)
  thus "e;t\<^sup>T = 0"
    by (simp add: assms(1) comp_assoc le_bot vector_prop1)
qed

text \<open>Some (more) results about points\<close>

definition point
  where "point x \<equiv> is_vector x \<and> bijective x"

lemma point_swap:
  assumes "point p"
      and "point q"
    shows "p \<le> x;q \<longleftrightarrow> q \<le> x\<^sup>T;p"
by (metis assms conv_invol inj_sur_semi_swap point_def)

text \<open>Some (more) results about singletons\<close>

abbreviation singleton
  where "singleton x \<equiv> bijective (x;1) \<and> bijective (x\<^sup>T;1)"

lemma singleton_injective:
  assumes "singleton x"
    shows "is_inj x"
using assms injective_down_closed maddux_20 by blast

lemma injective_inv:
  assumes "is_vector v"
      and "singleton e"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
      and "is_inj t"
    shows "is_inj (t + e)"
by (metis assms singleton_injective injective_sup bot_least et(2))

lemma singleton_is_point:
  assumes "singleton p"
    shows "point (p;1)"
by (simp add: assms comp_assoc is_vector_def point_def)

lemma singleton_transp:
  assumes "singleton p"
    shows "singleton (p\<^sup>T)"
by (simp add: assms)

lemma point_to_singleton:
  assumes "singleton p"
    shows "singleton (1'\<cdot>p;p\<^sup>T)"
using assms dom_def_aux_var dom_one is_vector_def point_def by fastforce

lemma singleton_singletonT:
  assumes "singleton p"
    shows "p;p\<^sup>T \<le> 1'"
using assms singleton_injective is_inj_def by blast

text \<open>Minimality\<close>

abbreviation minimum
  where "minimum x v \<equiv> v \<cdot> -(x\<^sup>T;v)"

text \<open>Regressively finite\<close>

abbreviation regressively_finite
  where "regressively_finite x \<equiv> \<forall>v . is_vector v \<and> v \<le> x\<^sup>T;v \<longrightarrow> v = 0"

lemma regressively_finite_minimum:
  "regressively_finite R \<Longrightarrow> is_vector v \<Longrightarrow> v \<noteq> 0 \<Longrightarrow> minimum R v \<noteq> 0"
using galois_aux2 by blast

lemma regressively_finite_irreflexive:
  assumes "regressively_finite x"
    shows "x \<le> -1'"
proof -
  have 1: "is_vector ((x\<^sup>T \<cdot> 1');1)"
    by (simp add: is_vector_def mult_assoc)
  have "(x\<^sup>T \<cdot> 1');1 = (x\<^sup>T \<cdot> 1');(x\<^sup>T \<cdot> 1');1"
    by (simp add: is_test_def test_comp_eq_mult)
  with 1 have "(x\<^sup>T \<cdot> 1');1 = 0"
    by (metis assms comp_assoc mult_subdistr)
  thus ?thesis
    by (metis conv_e conv_invol conv_times conv_zero galois_aux ss_p18)
qed

end (* relation_algebra *)

subsection \<open>Relation algebras satisfying the Tarski rule\<close>

class relation_algebra_tarski = relation_algebra +
  assumes tarski: "x \<noteq> 0 \<longleftrightarrow> 1;x;1 = 1"
begin

text \<open>Some (more) results about points\<close>

lemma point_equations:
  assumes "is_point p"
  shows "p;1=p"
    and "1;p=1"
    and "p\<^sup>T;1=1"
    and "1;p\<^sup>T=p\<^sup>T"
   apply (metis assms is_point_def is_vector_def)
  using assms is_point_def is_vector_def tarski vector_comp apply fastforce
 apply (metis assms conv_contrav conv_one conv_zero is_point_def is_vector_def tarski)
by (metis assms conv_contrav conv_one is_point_def is_vector_def)

text \<open>The following result is \<^cite>\<open>\<open>Proposition 2.4.5(i)\<close> in "SchmidtStroehlein1993"\<close>.\<close>

lemma point_singleton:
  assumes "is_point p"
      and "is_vector v"
      and "v \<noteq> 0"
      and "v \<le> p"
    shows "v = p"
proof -
  have "1;v = 1"
    using assms(2,3) comp_assoc is_vector_def tarski by fastforce
  hence "p = 1;v \<cdot> p"
    by simp
  also have "... \<le> (1 \<cdot> p;v\<^sup>T);(v \<cdot> 1\<^sup>T;p)"
    using dedekind by blast
  also have "... \<le> p;v\<^sup>T;v"
    by (simp add: mult_subdistl)
  also have "... \<le> p;p\<^sup>T;v"
    using assms(4) conv_iso mult_double_iso by blast
  also have "... \<le> v"
    by (metis assms(1) is_inj_def is_point_def mult_isor mult_onel)
  finally show ?thesis
    using assms(4) by simp
qed

lemma point_not_equal_aux:
  assumes "is_point p"
      and "is_point q"
    shows "p\<noteq>q \<longleftrightarrow> p \<cdot> -q \<noteq> 0"
proof
  show "p \<noteq> q \<Longrightarrow> p \<cdot> - q \<noteq> 0"
  proof (rule contrapos_nn)
    assume "p \<cdot> -q = 0"
    thus "p = q"
     using assms galois_aux2 is_point_def point_singleton by fastforce
  qed
next
  show "p \<cdot> - q \<noteq> 0 \<Longrightarrow> p \<noteq> q"
    using inf_compl_bot by blast
qed

text \<open>The following result is part of \<^cite>\<open>\<open>Proposition 2.4.5(ii)\<close> in "SchmidtStroehlein1993"\<close>.\<close>

lemma point_not_equal:
  assumes "is_point p"
      and "is_point q"
    shows "p\<noteq>q \<longleftrightarrow> p\<le>-q"
      and "p\<le>-q \<longleftrightarrow> p;q\<^sup>T \<le> -1'"
      and "p;q\<^sup>T \<le> -1' \<longleftrightarrow> p\<^sup>T;q \<le> 0"
proof -
  have "p \<noteq> q \<Longrightarrow> p \<le> - q"
    by (metis assms point_not_equal_aux is_point_def vector_compl vector_mult point_singleton
              inf.orderI inf.cobounded1)
  thus "p\<noteq>q \<longleftrightarrow> p\<le>-q"
    by (metis assms(1) galois_aux inf.orderE is_point_def order.refl)
next
  show "(p \<le> - q) = (p ; q\<^sup>T \<le> - 1')"
    by (simp add: conv_galois_2)
next
  show "(p ; q\<^sup>T \<le> - 1') = (p\<^sup>T ; q \<le> 0)"
    by (metis assms(2) compl_bot_eq conv_galois_2 galois_aux maddux_141 mult_1_right
              point_equations(4))
qed

lemma point_is_point:
  "point x \<longleftrightarrow> is_point x"
apply (rule iffI)
 apply (simp add: is_point_def point_def surj_one tarski)
using is_point_def is_vector_def mult_assoc point_def sur_def_var1 tarski by fastforce

lemma point_in_vector_or_complement:
  assumes "point p"
      and "is_vector v"
    shows "p \<le> v \<or> p \<le> -v"
proof (cases "p \<le> -v")
  assume "p \<le> -v"
  thus ?thesis
    by simp
next
  assume "\<not>(p \<le> -v)"
  hence "p\<cdot>v \<noteq> 0"
    by (simp add: galois_aux)
  hence "1;(p\<cdot>v) = 1"
    using assms comp_assoc is_vector_def point_def tarski vector_mult by fastforce
  hence "p \<le> p;(p\<cdot>v)\<^sup>T;(p\<cdot>v)"
    by (metis inf_top.left_neutral modular_2_var)
  also have "... \<le> p;p\<^sup>T;v"
    by (simp add: mult_isol_var)
  also have "... \<le> v"
    using assms(1) comp_assoc point_def ss423conv by fastforce
  finally show ?thesis ..
qed

lemma point_in_vector_or_complement_iff:
  assumes "point p"
      and "is_vector v"
    shows "p \<le> v \<longleftrightarrow> \<not>(p \<le> -v)"
by (metis assms annir compl_top_eq galois_aux inf.orderE one_compl point_def ss423conv tarski
          top_greatest point_in_vector_or_complement)

lemma different_points_consequences:
  assumes "point p"
      and "point q"
      and "p\<noteq>q"
    shows "p\<^sup>T;-q=1"
      and "-q\<^sup>T;p=1"
      and "-(p\<^sup>T;-q)=0"
      and "-(-q\<^sup>T;p)=0"
proof -
  have "p \<le> -q"
    by (metis assms compl_le_swap1 inf.absorb1 inf.absorb2 point_def point_in_vector_or_complement)
  thus 1: "p\<^sup>T;-q=1"
    using assms(1) by (metis is_vector_def point_def ss423conv top_le)
  thus 2: "-q\<^sup>T;p=1"
    using conv_compl conv_one by force
  from 1 show "-(p\<^sup>T;-q)=0"
    by simp
  from 2 show "-(-q\<^sup>T;p)=0"
    by simp
qed

text \<open>Some (more) results about singletons\<close>

lemma singleton_pq:
  assumes "point p"
      and "point q"
    shows "singleton (p;q\<^sup>T)"
using assms comp_assoc point_def point_equations(1,3) point_is_point by fastforce

lemma singleton_equal_aux:
  assumes "singleton p"
      and "singleton q"
      and "q\<le>p"
    shows "p \<le> q;1"
proof -
  have pLp: "p;1;p\<^sup>T \<le>1'"
    by (simp add: assms(1) maddux_21 ss423conv)

  have "p = 1;(q\<^sup>T;q;1) \<cdot> p"
    using tarski
    by (metis assms(2) annir singleton_injective inf.commute inf_top.right_neutral inj_triple
              mult_assoc surj_one)
  also have "... \<le> (1 \<cdot> p;(q\<^sup>T;q;1)\<^sup>T);(q\<^sup>T;q;1 \<cdot> 1;p)"
    using dedekind by (metis conv_one)
  also have "... \<le> p;1;q\<^sup>T;q;q\<^sup>T;q;1"
    by (simp add: comp_assoc mult_isol)
  also have "... \<le> p;1;p\<^sup>T;q;q\<^sup>T;q;1"
    using assms(3) by (metis comp_assoc conv_iso mult_double_iso)
  also have "... \<le> 1';q;q\<^sup>T;q;1"
    using pLp using mult_isor by blast
  also have "... \<le> q;1"
    using assms(2) singleton_singletonT by (simp add: comp_assoc mult_isol)
  finally show ?thesis .
qed

lemma singleton_equal:
 assumes "singleton p"
     and "singleton q"
     and "q\<le>p"
   shows "q=p"
proof -
  have p1: "p \<le> q;1"
    using assms by (rule singleton_equal_aux)
  have "p\<^sup>T \<le> q\<^sup>T;1"
    using assms singleton_equal_aux singleton_transp conv_iso by fastforce
  hence p2: "p \<le> 1;q"
    using conv_iso by force

  have "p \<le> q;1 \<cdot> 1;q"
    using p1 p2 inf.boundedI by blast
  also have "... \<le> (q \<cdot> 1;q;1);(1 \<cdot> q\<^sup>T;1;q)"
    using dedekind by (metis comp_assoc conv_one)
  also have "... \<le> q;q\<^sup>T;1;q"
    by (simp add: mult_isor comp_assoc)
  also have "... \<le> q;1'"
    by (metis assms(2) conv_contrav conv_invol conv_one is_inj_def mult_assoc mult_isol
              one_idem_mult)
  also have "... \<le> q"
    by simp
  finally have "p \<le> q" .
  thus "q=p"
  using assms(3) by simp
qed

lemma singleton_nonsplit:
  assumes "singleton p"
      and "x\<le>p"
    shows "x=0 \<or> x=p"
proof (cases "x=0")
  assume "x=0"
  thus ?thesis ..
next
  assume 1: "x\<noteq>0"
  have "singleton x"
  proof (safe)
    show "is_inj (x;1)"
      using assms injective_down_closed mult_isor by blast
    show "is_inj (x\<^sup>T;1)"
      using assms conv_iso injective_down_closed mult_isol_var by blast
    show "is_sur (x;1)"
      using 1 comp_assoc sur_def_var1 tarski by fastforce
    thus "is_sur (x\<^sup>T;1)"
      by (metis conv_contrav conv_one mult.semigroup_axioms sur_def_var1 semigroup.assoc)
  qed
  thus ?thesis
    using assms singleton_equal by blast
qed

lemma singleton_nonzero:
  assumes "singleton p"
    shows "p\<noteq>0"
proof
  assume "p = 0"
  hence "point 0"
    using assms singleton_is_point by fastforce
  thus False
    by (simp add: is_point_def point_is_point)
qed

lemma singleton_sum:
  assumes "singleton p"
    shows "p \<le> x+y \<longleftrightarrow> (p\<le>x \<or> p\<le>y)"
proof
  show "p \<le> x + y \<Longrightarrow> p \<le> x \<or> p \<le> y"
  proof -
    assume as: "p \<le> x + y"
    show "p \<le> x \<or> p \<le> y"
    proof (cases "p\<le>x")
      assume "p\<le>x"
      thus ?thesis ..
    next
      assume a:"\<not>(p\<le>x)"
      hence "p\<cdot>x \<noteq> p"
        using a inf.orderI by fastforce
      hence "p \<le> -x"
        using assms singleton_nonsplit galois_aux inf_le1 by blast
      hence "p\<le>y"
        using as by (metis galois_1 inf.orderE)
      thus ?thesis
        by simp
    qed
  qed
next
  show "p \<le> x \<or> p \<le> y \<Longrightarrow> p \<le> x + y"
    using sup.coboundedI1 sup.coboundedI2 by blast
qed

lemma singleton_iff:
 "singleton x \<longleftrightarrow> x \<noteq> 0 \<and> x\<^sup>T;1;x + x;1;x\<^sup>T \<le> 1'"
by (smt comp_assoc conv_contrav conv_invol conv_one is_inj_def le_sup_iff one_idem_mult
        sur_def_var1 tarski)

lemma singleton_not_atom_in_relation_algebra_tarski:
 assumes "p\<noteq>0"
     and "\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p"
   shows "singleton p"
nitpick [expect=genuine] oops

end (* relation_algebra_tarski *)

subsection \<open>Relation algebras satisfying the point axiom\<close>

class relation_algebra_point = relation_algebra +
  assumes point_axiom: "x \<noteq> 0 \<longrightarrow> (\<exists>y z . point y \<and> point z \<and> y;z\<^sup>T \<le> x)"
begin

text \<open>Some (more) results about points\<close>

lemma point_exists:
  "\<exists>x . point x"
by (metis (full_types) order.eq_iff is_inj_def is_sur_def is_vector_def point_axiom point_def)

lemma point_below_vector:
  assumes "is_vector v"
      and "v \<noteq> 0"
    shows "\<exists>x . point x \<and> x \<le> v"
proof -
  from assms(2) obtain y and z where 1: "point y \<and> point z \<and> y;z\<^sup>T \<le> v"
    using point_axiom by blast
  have "z\<^sup>T;1 = (1;z)\<^sup>T"
    using conv_contrav conv_one by simp
  hence "y;(1;z)\<^sup>T \<le> v"
    using 1 by (metis assms(1) comp_assoc is_vector_def mult_isor)
  thus ?thesis
    using 1 by (metis conv_one is_vector_def point_def sur_def_var1)
qed

end (* relation_algebra_point *)

class relation_algebra_tarski_point = relation_algebra_tarski + relation_algebra_point
begin

lemma atom_is_singleton:
  assumes "p\<noteq>0"
      and "\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p"
    shows "singleton p"
by (metis assms singleton_nonzero singleton_pq point_axiom)

lemma singleton_iff_atom:
  "singleton p \<longleftrightarrow> p\<noteq>0 \<and> (\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p)"
using singleton_nonsplit singleton_nonzero atom_is_singleton by blast

lemma maddux_tarski:
  assumes "x\<noteq>0"
  shows "\<exists>y . y\<noteq>0 \<and> y\<le>x \<and> is_p_fun y"
proof -
  obtain p q where 1: "point p \<and> point q \<and> p;q\<^sup>T \<le> x"
    using assms point_axiom by blast
  hence 2: "p;q\<^sup>T\<noteq>0"
    by (simp add: singleton_nonzero singleton_pq)
  have "is_p_fun (p;q\<^sup>T)"
    using 1 by (meson singleton_singletonT singleton_pq singleton_transp is_inj_def p_fun_inj)
  thus ?thesis
    using 1 2 by force
qed

text \<open>Intermediate Point Theorem \<^cite>\<open>\<open>Proposition 2.4.8\<close> in "SchmidtStroehlein1993"\<close>\<close>

lemma intermediate_point_theorem:
  assumes "point p"
      and "point r"
    shows "p \<le> x;y;r \<longleftrightarrow> (\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r)"
proof
  assume 1: "p \<le> x;y;r"
  let ?v = "x\<^sup>T;p \<cdot> y;r"
  have 2: "is_vector ?v"
    using assms comp_assoc is_vector_def point_def vector_mult by fastforce
  have "?v \<noteq> 0"
    using 1 by (metis assms(1) inf.absorb2 is_point_def maddux_141 point_is_point mult.assoc)
  hence "\<exists>q . point q \<and> q \<le> ?v"
    using 2 point_below_vector by blast
  thus "\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r"
    using assms(1) point_swap by auto
next
  assume "\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r"
  thus "p \<le> x;y;r"
    using comp_assoc mult_isol order_trans by fastforce
qed

end (* relation_algebra_tarski_point *)

(*
The following shows that rtc can be defined with only 2 axioms.
This should eventually go into AFP/Relation_Algebra_RTC.relation_algebra_rtc.
There the class definition should be replaced with:

class relation_algebra_rtc = relation_algebra + star_op +
  assumes rtc_unfoldl: "1' + x ; x\<^sup>\<star> \<le> x\<^sup>\<star>"
      and rtc_inductl: "z + x ; y \<le> y \<longrightarrow> x\<^sup>\<star> ; z \<le> y"

and the following lemmas:
*)

context relation_algebra
begin

lemma unfoldl_inductl_implies_unfoldr:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "1' + rtc(x);x \<le> rtc x"
by (metis assms le_sup_iff mult_oner order.trans subdistl_eq sup_absorb2 sup_ge1)

lemma star_transpose_swap:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "rtc(x\<^sup>T) = (rtc x)\<^sup>T"
apply(simp only: order.eq_iff; rule conjI)
  apply (metis assms conv_add conv_contrav conv_e conv_iso mult_1_right
             unfoldl_inductl_implies_unfoldr )
by (metis assms conv_add conv_contrav conv_e conv_invol conv_iso mult_1_right
          unfoldl_inductl_implies_unfoldr)

lemma unfoldl_inductl_implies_inductr:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "x+z;y \<le> z \<Longrightarrow> x;rtc(y) \<le> z"
by (metis assms conv_add conv_contrav conv_iso star_transpose_swap)

end (* relation_algebra *)

context relation_algebra_rtc
begin

abbreviation tc ("(_\<^sup>+)" [101] 100) where "tc x \<equiv> x;x\<^sup>\<star>"

abbreviation is_acyclic
  where "is_acyclic x \<equiv> x\<^sup>+ \<le> -1'"

text \<open>General theorems\<close>

lemma star_denest_10:
  assumes "x;y=0"
    shows "(x+y)\<^sup>\<star> = y;y\<^sup>\<star>;x\<^sup>\<star>+x\<^sup>\<star>"
using assms bubble_sort sup.commute by auto

text \<open>The following two lemmas are from \<^cite>\<open>"Guttmann2018b"\<close>.\<close>

lemma cancel_separate:
  assumes "x ; y \<le> 1'"
  shows "x\<^sup>\<star> ; y\<^sup>\<star> \<le> x\<^sup>\<star> + y\<^sup>\<star>"
proof -
  have "x ; y\<^sup>\<star> = x + x ; y ; y\<^sup>\<star>"
    by (metis comp_assoc conway.dagger_unfoldl_distr distrib_left mult_oner)
  also have "... \<le> x + y\<^sup>\<star>"
    by (metis assms join_isol star_invol star_plus_one star_subdist_var_2 sup.absorb2 sup.assoc)
  also have "... \<le> x\<^sup>\<star> + y\<^sup>\<star>"
    using join_iso by fastforce
  finally have "x ; (x\<^sup>\<star> + y\<^sup>\<star>) \<le> x\<^sup>\<star> + y\<^sup>\<star>"
    by (simp add: distrib_left le_supI1)
  thus ?thesis
    by (simp add: rtc_inductl)
qed

lemma cancel_separate_inj_converse:
  assumes "is_inj x"
    shows "x\<^sup>\<star> ; x\<^sup>T\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
 apply (rule order.antisym)
  using assms cancel_separate is_inj_def apply blast
by (metis conway.dagger_unfoldl_distr le_supI mult_1_right mult_isol sup.cobounded1)

lemma cancel_separate_p_fun_converse:
  assumes "is_p_fun x"
    shows "x\<^sup>T\<^sup>\<star> ; x\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
using sup_commute assms cancel_separate_inj_converse p_fun_inj by fastforce

lemma cancel_separate_converse_idempotent:
  assumes "is_inj x"
      and "is_p_fun x"
    shows "(x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>);(x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>) = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (metis assms cancel_separate cancel_separate_p_fun_converse church_rosser_equiv is_inj_def
          star_denest_var_6)

lemma triple_star:
  assumes "is_inj x"
      and "is_p_fun x"
    shows "x\<^sup>\<star>;x\<^sup>T\<^sup>\<star>;x\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (simp add: assms cancel_separate_inj_converse cancel_separate_p_fun_converse)

lemma inj_xxts:
  assumes "is_inj x"
    shows "x;x\<^sup>T\<^sup>\<star> \<le> x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (metis assms cancel_separate_inj_converse distrib_right less_eq_def star_ext)

lemma plus_top:
  "x\<^sup>+;1 = x;1"
by (metis comp_assoc conway.dagger_unfoldr_distr sup_top_left)

lemma top_plus:
  "1;x\<^sup>+ = 1;x"
by (metis comp_assoc conway.dagger_unfoldr_distr star_denest_var_2 star_ext star_slide_var
           sup_top_left top_unique)

lemma plus_conv:
  "(x\<^sup>+)\<^sup>T = x\<^sup>T\<^sup>+"
by (simp add: star_conv star_slide_var)

lemma inj_implies_step_forwards_backwards:
  assumes "is_inj x"
    shows "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> x\<^sup>T;1"
proof -
  have "(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);(x\<cdot>(x\<^sup>\<star>)\<^sup>T);1"
    by (metis conv_contrav conv_e dedekind mult_1_right mult_isor star_slide_var)
  also have "... \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    by (simp add: comp_assoc mult_isol)
  finally have 1: "(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1" .

  have "x;(x\<^sup>\<star>\<cdot>x\<^sup>T);1 \<le> (x\<^sup>+\<cdot>x;x\<^sup>T);1"
    by (metis inf_idem meet_interchange mult_isor)
  also have "... \<le> (x\<^sup>+\<cdot>1');1"
    using assms is_inj_def meet_isor mult_isor by fastforce
  finally have "x;(x\<^sup>\<star>\<cdot>x\<^sup>T);1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    using 1 by fastforce
  hence "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    using 1 by (simp add: comp_assoc rtc_inductl)
  thus "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> x\<^sup>T;1"
    using inf.cobounded2 mult_isor order_trans by blast
qed

text \<open>Acyclic relations\<close>

text \<open>The following result is from \<^cite>\<open>"Guttmann2017c"\<close>.\<close>

lemma acyclic_inv:
  assumes "is_acyclic t"
      and "is_vector v"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
    shows "is_acyclic (t + e)"
proof -
  have "t\<^sup>+;e \<le> t\<^sup>+;v;-v\<^sup>T"
    by (simp add: assms(3) mult_assoc mult_isol)
  also have "... \<le> v;v\<^sup>T;t\<^sup>\<star>;v;-v\<^sup>T"
    by (simp add: assms(4) mult_isor)
  also have "... \<le> v;-v\<^sup>T"
    by (metis assms(2) mult_double_iso top_greatest is_vector_def mult_assoc)
  also have "... \<le> -1'"
    by (simp add: conv_galois_1)
  finally have 1: "t\<^sup>+;e \<le> -1'" .
  have "e \<le> v;-v\<^sup>T"
    using assms(3) by simp
  also have "... \<le> -1'"
    by (simp add: conv_galois_1)
  finally have 2: "t\<^sup>+;e + e \<le> -1'"
    using 1 by simp
  have 3: "e;t\<^sup>\<star> = e"
    by (metis assms(2-4) et(1) independence2)
  have 4: "e\<^sup>\<star> = 1' + e"
    using assms(2-3) ee boffa_var bot_least by blast
  have "(t + e)\<^sup>+ = (t + e);t\<^sup>\<star>;(e;t\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: comp_assoc)
  also have "... = (t + e);t\<^sup>\<star>;(1' + e)"
    using 3 4 by simp
  also have "... = t\<^sup>+;(1' + e) + e;t\<^sup>\<star>;(1' + e)"
    by simp
  also have "... = t\<^sup>+;(1' + e) + e;(1' + e)"
    using 3 by simp
  also have "... = t\<^sup>+;(1' + e) + e"
    using 4 assms(2-3) ee independence2 by fastforce
  also have "... = t\<^sup>+ + t\<^sup>+;e + e"
    by (simp add: distrib_left)
  also have "... \<le> -1'"
    using assms(1) 2 by simp
  finally show ?thesis .
qed

lemma acyclic_single_step:
  assumes "is_acyclic x"
    shows "x \<le> -1'"
by (metis assms dual_order.trans mult_isol mult_oner star_ref)

lemma acyclic_reachable_points:
  assumes "is_point p"
      and "is_point q"
      and "p \<le> x;q"
      and "is_acyclic x"
    shows "p\<noteq>q"
proof
  assume "p=q"
  hence "p \<le> x;q \<cdot> q"
    by (simp add: assms(3) order.eq_iff inf.absorb2)
  also have "... = (x \<cdot> 1');q"
    using assms(2) inj_distr is_point_def by simp
  also have "... \<le> (-1' \<cdot> 1');q"
    using acyclic_single_step assms(4) by (metis abel_semigroup.commute inf.abel_semigroup_axioms
          meet_isor mult_isor)
 also have "... = 0"
  by simp
 finally have "p \<le> 0" .
 thus False
  using assms(1) bot_unique is_point_def by blast
qed

lemma acyclic_trans:
 assumes "is_acyclic x"
   shows "x \<le> -(x\<^sup>T\<^sup>+)"
proof -
 have "\<exists>c\<ge>x. c \<le> - (x\<^sup>+)\<^sup>T"
  by (metis assms compl_mono conv_galois_2 conv_iso double_compl mult_onel star_1l)
 thus ?thesis
  by (metis dual_order.trans plus_conv)
qed

lemma acyclic_trans':
 assumes "is_acyclic x"
   shows "x\<^sup>\<star> \<le> -(x\<^sup>T\<^sup>+)"
proof -
 have "x\<^sup>\<star> \<le> - (- (- (x\<^sup>T ; - (- 1'))) ; (x\<^sup>\<star>)\<^sup>T)"
  by (metis assms conv_galois_1 conv_galois_2 order_trans star_trans)
 then show ?thesis
  by (simp add: star_conv)
qed

text \<open>Regressively finite\<close>

lemma regressively_finite_acyclic:
  assumes "regressively_finite x"
    shows "is_acyclic x"
proof -
  have 1: "is_vector ((x\<^sup>+ \<cdot> 1');1)"
    by (simp add: is_vector_def mult_assoc)
  have "(x\<^sup>+ \<cdot> 1');1 = (x\<^sup>T\<^sup>+ \<cdot> 1');1"
    by (metis plus_conv test_converse)
  also have "... \<le> x\<^sup>T;(1';x\<^sup>T\<^sup>\<star> \<cdot> x);1"
    by (metis conv_invol modular_1_var mult_isor mult_oner mult_onel)
  also have "... \<le> x\<^sup>T;(1' \<cdot> x\<^sup>+);x\<^sup>T\<^sup>\<star>;1"
    by (metis comp_assoc conv_invol modular_2_var mult_isol mult_isor star_conv)
  also have "... = x\<^sup>T;(x\<^sup>+ \<cdot> 1');1"
    by (metis comp_assoc conway.dagger_unfoldr_distr inf.commute sup.cobounded1 top_le)
  finally have "(x\<^sup>+ \<cdot> 1');1 = 0"
    using 1 assms by (simp add: comp_assoc)
  thus ?thesis
    by (simp add: galois_aux ss_p18)
qed

notation power (infixr "\<up>" 80)

lemma power_suc_below_plus:
  "x \<up> Suc n \<le> x\<^sup>+"
  apply (induct n)
 using mult_isol star_ref apply fastforce
by (simp add: mult_isol_var order_trans)

end (* relation_algebra_rtc *)

class relation_algebra_rtc_tarski = relation_algebra_rtc + relation_algebra_tarski
begin

lemma point_loop_not_acyclic:
  assumes "is_point p"
      and "p \<le> x \<up> Suc n ; p"
    shows "\<not> is_acyclic x"
proof -
  have "p \<le> x\<^sup>+ ; p"
    by (meson assms dual_order.trans point_def point_is_point ss423bij power_suc_below_plus)
  hence "p ; p\<^sup>T \<le> x\<^sup>+"
    using assms(1) point_def point_is_point ss423bij by blast
  thus ?thesis
    using assms(1) order.trans point_not_equal(1) point_not_equal(2) by blast
qed

end

class relation_algebra_rtc_point = relation_algebra_rtc + relation_algebra_point

class relation_algebra_rtc_tarski_point = relation_algebra_rtc_tarski + relation_algebra_rtc_point +
                                          relation_algebra_tarski_point

text \<open>
Finite graphs: the axiom says the algebra has finitely many elements.
This means the relations have a finite base set.
\<close>

class relation_algebra_rtc_tarski_point_finite = relation_algebra_rtc_tarski_point + finite
begin

text \<open>For a finite acyclic relation, the powers eventually vanish.\<close>

lemma acyclic_power_vanishes:
  assumes "is_acyclic x"
    shows "\<exists>n . x \<up> Suc n = 0"
proof -
  let ?n = "card { p . is_point p }"
  let ?p = "x \<up> ?n"
  have "?p = 0"
  proof (rule ccontr)
    assume "?p \<noteq> 0"
    from this obtain p q where 1: "point p \<and> point q \<and> p;q\<^sup>T \<le> ?p"
      using point_axiom by blast
    hence 2: "p \<le> ?p;q"
      using point_def ss423bij by blast
    have "\<forall>n\<le>?n . (\<exists>f. \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x\<up>(?n-i) ; f i \<and> f i \<le> x\<up>(i-j) ; f j))"
    proof
      fix n
      show "n\<le>?n \<longrightarrow> (\<exists>f. \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x\<up>(?n-i) ; f i \<and> f i \<le> x\<up>(i-j) ; f j))"
      proof (induct n)
        case 0
        thus ?case
          using 1 2 point_is_point by fastforce
      next
        case (Suc n)
        fix n
        assume 3: "n\<le>?n \<longrightarrow> (\<exists>f . \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j))"
        show "Suc n\<le>?n \<longrightarrow> (\<exists>f . \<forall>i\<le>Suc n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j))"
        proof
          assume 4: "Suc n\<le>?n"
          from this obtain f where 5: "\<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
            using 3 by auto
          have "p \<le> x \<up> (?n-n) ; f n"
            using 5 by blast
          also have "... = x \<up> (?n-n-one_class.one) ; x ; f n"
            using 4 by (metis (no_types) Suc_diff_le diff_Suc_1 diff_Suc_Suc power_Suc2)
          finally obtain r where 6: "point r \<and> p \<le> x \<up> (?n-Suc n) ; r \<and> r \<le> x ; f n"
            using 1 5 intermediate_point_theorem point_is_point by fastforce
          let ?g = "\<lambda>m . if m = Suc n then r else f m"
          have "\<forall>i\<le>Suc n . is_point (?g i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; ?g i \<and> ?g i \<le> x \<up> (i-j) ; ?g j)"
          proof
            fix i
            show "i\<le>Suc n \<longrightarrow> is_point (?g i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; ?g i \<and> ?g i \<le> x \<up> (i-j) ; ?g j)"
            proof (cases "i\<le>n")
              case True
              thus ?thesis
                using 5 by simp
            next
              case False
              have "is_point (?g (Suc n)) \<and> (\<forall>j\<le>Suc n . p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j)"
              proof
                show "is_point (?g (Suc n))"
                  using 6 point_is_point by fastforce
              next
                show "\<forall>j\<le>Suc n . p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                proof
                  fix j
                  show "j\<le>Suc n \<longrightarrow> p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                  proof
                    assume 7: "j\<le>Suc n"
                    show "p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                    proof
                      show "p \<le> x \<up> (?n-Suc n) ; ?g (Suc n)"
                        using 6 by simp
                    next
                      show "?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                      proof (cases "j = Suc n")
                        case True
                        thus ?thesis
                          by simp
                      next
                        case False
                        hence "f n \<le> x \<up> (n-j) ; f j"
                          using 5 7 by fastforce
                        hence "x ; f n \<le> x \<up> (Suc n-j) ; f j"
                          using 7 False Suc_diff_le comp_assoc mult_isol by fastforce
                        thus ?thesis
                          using 6 False by fastforce
                      qed
                    qed
                  qed
                qed
              qed
              thus ?thesis
                by (simp add: False le_Suc_eq)
            qed
          qed
          thus "\<exists>f . \<forall>i\<le>Suc n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
            by auto
        qed
      qed
    qed
    from this obtain f where 8: "\<forall>i\<le>?n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
      by fastforce
    let ?A = "{ k . k\<le>?n }"
    have "f ` ?A \<subseteq> { p . is_point p }"
      using 8 by blast
    hence "card (f ` ?A) \<le> ?n"
      by (simp add: card_mono)
    hence "\<not> inj_on f ?A"
      by (simp add: pigeonhole)
    from this obtain i j where 9: "i \<le> ?n \<and> j \<le> ?n \<and> i \<noteq> j \<and> f i = f j"
      by (metis (no_types, lifting) inj_on_def mem_Collect_eq)
    show False
      apply (cases "i < j")
     using 8 9 apply (metis Suc_diff_le Suc_leI assms diff_Suc_Suc order_less_imp_le
                            point_loop_not_acyclic)
    using 8 9 by (metis assms neqE point_loop_not_acyclic Suc_diff_le Suc_leI assms diff_Suc_Suc
                        order_less_imp_le)
    qed
    thus ?thesis
      by (metis annir power.simps(2))
qed

text \<open>Hence finite acyclic relations are regressively finite.\<close>

lemma acyclic_regressively_finite:
  assumes "is_acyclic x"
    shows "regressively_finite x"
proof
  have "is_acyclic (x\<^sup>T)"
    using assms acyclic_trans' compl_le_swap1 order_trans star_ref by blast
  from this obtain n where 1: "x\<^sup>T \<up> Suc n = 0"
    using acyclic_power_vanishes by fastforce
  fix v
  show "is_vector v \<and> v \<le> x\<^sup>T;v \<longrightarrow> v = 0"
  proof
    assume 2: "is_vector v \<and> v \<le> x\<^sup>T;v"
    have "v \<le> x\<^sup>T \<up> Suc n ; v"
    proof (induct n)
      case 0
      thus ?case
        using 2 by simp
    next
      case (Suc n)
      hence "x\<^sup>T ; v \<le> x\<^sup>T \<up> Suc (Suc n) ; v"
        by (simp add: comp_assoc mult_isol)
      thus ?case
        using 2 dual_order.trans by blast
    qed
    thus "v = 0"
      using 1 by (simp add: le_bot)
  qed
 qed

lemma acyclic_is_regressively_finite:
  "is_acyclic x \<longleftrightarrow> regressively_finite x"
using acyclic_regressively_finite regressively_finite_acyclic by blast

end (* end relation_algebra_rtc_tarski_point_finite *)

end


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

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

theory Parity
  imports Euclidean_Rings
begin

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

class semiring_parity = comm_semiring_1 + semiring_modulo +
  assumes even_iff_mod_2_eq_zero: "2 dvd a \<longleftrightarrow> a mod 2 = 0"
    and odd_iff_mod_2_eq_one: "\<not> 2 dvd a \<longleftrightarrow> a mod 2 = 1"
    and odd_one [simp]: "\<not> 2 dvd 1"
begin

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

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

end

class ring_parity = ring + semiring_parity
begin

subclass comm_ring_1 ..

end

instance nat :: semiring_parity
  by standard (simp_all add: dvd_eq_mod_eq_0)

instance int :: ring_parity
  by standard (auto simp add: dvd_eq_mod_eq_0)

context semiring_parity
begin

lemma parity_cases [case_names even odd]:
  assumes "even a \<Longrightarrow> a mod 2 = 0 \<Longrightarrow> P"
  assumes "odd a \<Longrightarrow> a mod 2 = 1 \<Longrightarrow> P"
  shows P
  using assms by (cases "even a")
    (simp_all add: even_iff_mod_2_eq_zero [symmetric] odd_iff_mod_2_eq_one [symmetric])

lemma odd_of_bool_self [simp]:
  \<open>odd (of_bool p) \<longleftrightarrow> p\<close>
  by (cases p) simp_all

lemma not_mod_2_eq_0_eq_1 [simp]:
  "a mod 2 \<noteq> 0 \<longleftrightarrow> a mod 2 = 1"
  by (cases a rule: parity_cases) simp_all

lemma not_mod_2_eq_1_eq_0 [simp]:
  "a mod 2 \<noteq> 1 \<longleftrightarrow> a mod 2 = 0"
  by (cases a rule: parity_cases) simp_all

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

lemma oddE [elim?]:
  assumes "odd a"
  obtains b where "a = 2 * b + 1"
proof -
  have "a = 2 * (a div 2) + a mod 2"
    by (simp add: mult_div_mod_eq)
  with assms have "a = 2 * (a div 2) + 1"
    by (simp add: odd_iff_mod_2_eq_one)
  then show ?thesis ..
qed

lemma mod_2_eq_odd:
  "a mod 2 = of_bool (odd a)"
  by (auto elim: oddE simp add: even_iff_mod_2_eq_zero)

lemma of_bool_odd_eq_mod_2:
  "of_bool (odd a) = a mod 2"
  by (simp add: mod_2_eq_odd)

lemma even_mod_2_iff [simp]:
  \<open>even (a mod 2) \<longleftrightarrow> even a\<close>
  by (simp add: mod_2_eq_odd)

lemma mod2_eq_if:
  "a mod 2 = (if even a then 0 else 1)"
  by (simp add: mod_2_eq_odd)

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

lemma odd_even_add:
  "even (a + b)" if "odd a" and "odd b"
proof -
  from that obtain c d where "a = 2 * c + 1" and "b = 2 * d + 1"
    by (blast elim: oddE)
  then have "a + b = 2 * c + 2 * d + (1 + 1)"
    by (simp only: ac_simps)
  also have "\<dots> = 2 * (c + d + 1)"
    by (simp add: algebra_simps)
  finally show ?thesis ..
qed

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

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

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

lemma even_mult_iff [simp]:
  "even (a * b) \<longleftrightarrow> even a \<or> even b" (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?Q
  then show ?P
    by auto
next
  assume ?P
  show ?Q
  proof (rule ccontr)
    assume "\<not> (even a \<or> even b)"
    then have "odd a" and "odd b"
      by auto
    then obtain r s where "a = 2 * r + 1" and "b = 2 * s + 1"
      by (blast elim: oddE)
    then have "a * b = (2 * r + 1) * (2 * s + 1)"
      by simp
    also have "\<dots> = 2 * (2 * r * s + r + s) + 1"
      by (simp add: algebra_simps)
    finally have "odd (a * b)"
      by simp
    with \<open>?P\<close> show False
      by auto
  qed
qed

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

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

lemma odd_numeral_BitM [simp]:
  \<open>odd (numeral (Num.BitM w))\<close>
  by (cases w) simp_all

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

lemma even_prod_iff:
  \<open>even (prod f A) \<longleftrightarrow> (\<exists>a\<in>A. even (f a))\<close> if \<open>finite A\<close>
  using that by (induction A) simp_all

lemma mask_eq_sum_exp:
  \<open>2 ^ n - 1 = (\<Sum>m\<in>{q. q < n}. 2 ^ m)\<close>
proof -
  have *: \<open>{q. q < Suc m} = insert m {q. q < m}\<close> for m
    by auto
  have \<open>2 ^ n = (\<Sum>m\<in>{q. q < n}. 2 ^ m) + 1\<close>
    by (induction n) (simp_all add: ac_simps mult_2 *)
  then have \<open>2 ^ n - 1 = (\<Sum>m\<in>{q. q < n}. 2 ^ m) + 1 - 1\<close>
    by simp
  then show ?thesis
    by simp
qed

lemma (in -) mask_eq_sum_exp_nat:
  \<open>2 ^ n - Suc 0 = (\<Sum>m\<in>{q. q < n}. 2 ^ m)\<close>
  using mask_eq_sum_exp [where ?'a = nat] by simp

end

context ring_parity
begin

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

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

end

subsection \<open>Instance for \<^typ>\<open>nat\<close>\<close>

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

lemma even_Suc [simp]: "even (Suc n) \<longleftrightarrow> odd n"
  using even_plus_one_iff [of n] by simp

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

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

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

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

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

lemma even_Suc_div_two [simp]:
  "even n \<Longrightarrow> Suc n div 2 = n div 2"
  by auto

lemma odd_Suc_div_two [simp]:
  "odd n \<Longrightarrow> Suc n div 2 = Suc (n div 2)"
  by (auto elim: oddE)

lemma odd_two_times_div_two_nat [simp]:
  assumes "odd n"
  shows "2 * (n div 2) = n - (1 :: nat)"
proof -
  from assms have "2 * (n div 2) + 1 = n"
    by (auto elim: oddE)
  then have "Suc (2 * (n div 2)) - 1 = n - 1"
    by simp
  then show ?thesis
    by simp
qed

lemma not_mod2_eq_Suc_0_eq_0 [simp]:
  "n mod 2 \<noteq> Suc 0 \<longleftrightarrow> n mod 2 = 0"
  using not_mod_2_eq_1_eq_0 [of n] by simp

lemma odd_card_imp_not_empty:
  \<open>A \<noteq> {}\<close> if \<open>odd (card A)\<close>
  using that by auto

lemma nat_induct2 [case_names 0 1 step]:
  assumes "P 0" "P 1" and step: "\<And>n::nat. P n \<Longrightarrow> P (n + 2)"
  shows "P n"
proof (induct n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n < Suc (Suc 0)")
    case True
    then show ?thesis
      using assms by (auto simp: less_Suc_eq)
  next
    case False
    then obtain k where k: "n = Suc (Suc k)"
      by (force simp: not_less nat_le_iff_add)
    then have "k<n"
      by simp
    with less assms have "P (k+2)"
      by blast
    then show ?thesis
      by (simp add: k)
  qed
qed

context semiring_parity
begin

lemma even_sum_iff:
  \<open>even (sum f A) \<longleftrightarrow> even (card {a\<in>A. odd (f a)})\<close> if \<open>finite A\<close>
using that proof (induction A)
  case empty
  then show ?case
    by simp
next
  case (insert a A)
  moreover have \<open>{b \<in> insert a A. odd (f b)} = (if odd (f a) then {a} else {}) \<union> {b \<in> A. odd (f b)}\<close>
    by auto
  ultimately show ?case
    by simp
qed

lemma even_mask_iff [simp]:
  \<open>even (2 ^ n - 1) \<longleftrightarrow> n = 0\<close>
proof (cases \<open>n = 0\<close>)
  case True
  then show ?thesis
    by simp
next
  case False
  then have \<open>{a. a = 0 \<and> a < n} = {0}\<close>
    by auto
  then show ?thesis
    by (auto simp add: mask_eq_sum_exp even_sum_iff)
qed

lemma even_of_nat_iff [simp]:
  "even (of_nat n) \<longleftrightarrow> even n"
  by (induction n) simp_all

end

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

context ring_1
begin

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

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

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

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

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

lemma neg_one_power_add_eq_neg_one_power_diff: "k \<le> n \<Longrightarrow> (- 1) ^ (n + k) = (- 1) ^ (n - k)"
  by (cases "even (n + k)") auto

lemma minus_one_power_iff: "(- 1) ^ n = (if even n then 1 else - 1)"
  by (induct n) auto

end

context linordered_idom
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end

subsection \<open>Instance for \<^typ>\<open>int\<close>\<close>

lemma even_diff_iff:
  "even (k - l) \<longleftrightarrow> even (k + l)" for k l :: int
  by (fact even_diff)

lemma even_abs_add_iff:
  "even (\<bar>k\<bar> + l) \<longleftrightarrow> even (k + l)" for k l :: int
  by simp

lemma even_add_abs_iff:
  "even (k + \<bar>l\<bar>) \<longleftrightarrow> even (k + l)" for k l :: int
  by simp

lemma even_nat_iff: "0 \<le> k \<Longrightarrow> even (nat k) \<longleftrightarrow> even k"
  by (simp add: even_of_nat_iff [of "nat k", where ?'a = int, symmetric])

context
  assumes "SORT_CONSTRAINT('a::division_ring)"
begin

lemma power_int_minus_left:
  "power_int (-a :: 'a) n = (if even n then power_int a n else -power_int a n)"
  by (auto simp: power_int_def minus_one_power_iff even_nat_iff)

lemma power_int_minus_left_even [simp]: "even n \<Longrightarrow> power_int (-a :: 'a) n = power_int a n"
  by (simp add: power_int_minus_left)

lemma power_int_minus_left_odd [simp]: "odd n \<Longrightarrow> power_int (-a :: 'a) n = -power_int a n"
  by (simp add: power_int_minus_left)

lemma power_int_minus_left_distrib:
  "NO_MATCH (-1) x \<Longrightarrow> power_int (-a :: 'a) n = power_int (-1) n * power_int a n"
  by (simp add: power_int_minus_left)

lemma power_int_minus_one_minus: "power_int (-1 :: 'a) (-n) = power_int (-1) n"
  by (simp add: power_int_minus_left)

lemma power_int_minus_one_diff_commute: "power_int (-1 :: 'a) (a - b) = power_int (-1) (b - a)"
  by (subst power_int_minus_one_minus [symmetric]) auto

lemma power_int_minus_one_mult_self [simp]:
  "power_int (-1 :: 'a) m * power_int (-1) m = 1"
  by (simp add: power_int_minus_left)

lemma power_int_minus_one_mult_self' [simp]:
  "power_int (-1 :: 'a) m * (power_int (-1) m * b) = b"
  by (simp add: power_int_minus_left)

end

subsection \<open>Special case: euclidean rings containing the natural numbers\<close>

class unique_euclidean_semiring_with_nat = semidom + semiring_char_0 + unique_euclidean_semiring +
  assumes of_nat_div: "of_nat (m div n) = of_nat m div of_nat n"
    and division_segment_of_nat [simp]: "division_segment (of_nat n) = 1"
    and division_segment_euclidean_size [simp]: "division_segment a * of_nat (euclidean_size a) = a"
begin

lemma division_segment_eq_iff:
  "a = b" if "division_segment a = division_segment b"
    and "euclidean_size a = euclidean_size b"
  using that division_segment_euclidean_size [of a] by simp

lemma euclidean_size_of_nat [simp]:
  "euclidean_size (of_nat n) = n"
proof -
  have "division_segment (of_nat n) * of_nat (euclidean_size (of_nat n)) = of_nat n"
    by (fact division_segment_euclidean_size)
  then show ?thesis by simp
qed

lemma of_nat_euclidean_size:
  "of_nat (euclidean_size a) = a div division_segment a"
proof -
  have "of_nat (euclidean_size a) = division_segment a * of_nat (euclidean_size a) div division_segment a"
    by (subst nonzero_mult_div_cancel_left) simp_all
  also have "\<dots> = a div division_segment a"
    by simp
  finally show ?thesis .
qed

lemma division_segment_1 [simp]:
  "division_segment 1 = 1"
  using division_segment_of_nat [of 1] by simp

lemma division_segment_numeral [simp]:
  "division_segment (numeral k) = 1"
  using division_segment_of_nat [of "numeral k"] by simp

lemma euclidean_size_1 [simp]:
  "euclidean_size 1 = 1"
  using euclidean_size_of_nat [of 1] by simp

lemma euclidean_size_numeral [simp]:
  "euclidean_size (numeral k) = numeral k"
  using euclidean_size_of_nat [of "numeral k"] by simp

lemma of_nat_dvd_iff:
  "of_nat m dvd of_nat n \<longleftrightarrow> m dvd n" (is "?P \<longleftrightarrow> ?Q")
proof (cases "m = 0")
  case True
  then show ?thesis
    by simp
next
  case False
  show ?thesis
  proof
    assume ?Q
    then show ?P
      by auto
  next
    assume ?P
    with False have "of_nat n = of_nat n div of_nat m * of_nat m"
      by simp
    then have "of_nat n = of_nat (n div m * m)"
      by (simp add: of_nat_div)
    then have "n = n div m * m"
      by (simp only: of_nat_eq_iff)
    then have "n = m * (n div m)"
      by (simp add: ac_simps)
    then show ?Q ..
  qed
qed

lemma of_nat_mod:
  "of_nat (m mod n) = of_nat m mod of_nat n"
proof -
  have "of_nat m div of_nat n * of_nat n + of_nat m mod of_nat n = of_nat m"
    by (simp add: div_mult_mod_eq)
  also have "of_nat m = of_nat (m div n * n + m mod n)"
    by simp
  finally show ?thesis
    by (simp only: of_nat_div of_nat_mult of_nat_add) simp
qed

lemma one_div_two_eq_zero [simp]:
  "1 div 2 = 0"
proof -
  from of_nat_div [symmetric] have "of_nat 1 div of_nat 2 = of_nat 0"
    by (simp only:) simp
  then show ?thesis
    by simp
qed

lemma one_mod_two_eq_one [simp]:
  "1 mod 2 = 1"
proof -
  from of_nat_mod [symmetric] have "of_nat 1 mod of_nat 2 = of_nat 1"
    by (simp only:) simp
  then show ?thesis
    by simp
qed

lemma one_mod_2_pow_eq [simp]:
  "1 mod (2 ^ n) = of_bool (n > 0)"
proof -
  have "1 mod (2 ^ n) = of_nat (1 mod (2 ^ n))"
    using of_nat_mod [of 1 "2 ^ n"] by simp
  also have "\<dots> = of_bool (n > 0)"
    by simp
  finally show ?thesis .
qed

lemma one_div_2_pow_eq [simp]:
  "1 div (2 ^ n) = of_bool (n = 0)"
  using div_mult_mod_eq [of 1 "2 ^ n"] by auto

lemma div_mult2_eq':
  \<open>a div (of_nat m * of_nat n) = a div of_nat m div of_nat n\<close>
proof (cases \<open>m = 0 \<or> n = 0\<close>)
  case True
  then show ?thesis
    by auto
next
  case False
  then have \<open>m > 0\<close> \<open>n > 0\<close>
    by simp_all
  show ?thesis
  proof (cases \<open>of_nat m * of_nat n dvd a\<close>)
    case True
    then obtain b where \<open>a = (of_nat m * of_nat n) * b\<close> ..
    then have \<open>a = of_nat m * (of_nat n * b)\<close>
      by (simp add: ac_simps)
    then show ?thesis
      by simp
  next
    case False
    define q where \<open>q = a div (of_nat m * of_nat n)\<close>
    define r where \<open>r = a mod (of_nat m * of_nat n)\<close>
    from \<open>m > 0\<close> \<open>n > 0\<close> \<open>\<not> of_nat m * of_nat n dvd a\<close> r_def have "division_segment r = 1"
      using division_segment_of_nat [of "m * n"] by (simp add: division_segment_mod)
    with division_segment_euclidean_size [of r]
    have "of_nat (euclidean_size r) = r"
      by simp
    have "a mod (of_nat m * of_nat n) div (of_nat m * of_nat n) = 0"
      by simp
    with \<open>m > 0\<close> \<open>n > 0\<close> r_def have "r div (of_nat m * of_nat n) = 0"
      by simp
    with \<open>of_nat (euclidean_size r) = r\<close>
    have "of_nat (euclidean_size r) div (of_nat m * of_nat n) = 0"
      by simp
    then have "of_nat (euclidean_size r div (m * n)) = 0"
      by (simp add: of_nat_div)
    then have "of_nat (euclidean_size r div m div n) = 0"
      by (simp add: div_mult2_eq)
    with \<open>of_nat (euclidean_size r) = r\<close> have "r div of_nat m div of_nat n = 0"
      by (simp add: of_nat_div)
    with \<open>m > 0\<close> \<open>n > 0\<close> q_def
    have "q = (r div of_nat m + q * of_nat n * of_nat m div of_nat m) div of_nat n"
      by simp
    moreover have \<open>a = q * (of_nat m * of_nat n) + r\<close>
      by (simp add: q_def r_def div_mult_mod_eq)
    ultimately show \<open>a div (of_nat m * of_nat n) = a div of_nat m div of_nat n\<close>
      using q_def [symmetric] div_plus_div_distrib_dvd_right [of \<open>of_nat m\<close> \<open>q * (of_nat m * of_nat n)\<close> r]
      by (simp add: ac_simps)
  qed
qed

lemma mod_mult2_eq':
  "a mod (of_nat m * of_nat n) = of_nat m * (a div of_nat m mod of_nat n) + a mod of_nat m"
proof -
  have "a div (of_nat m * of_nat n) * (of_nat m * of_nat n) + a mod (of_nat m * of_nat n) = a div of_nat m div of_nat n * of_nat n * of_nat m + (a div of_nat m mod of_nat n * of_nat m + a mod of_nat m)"
    by (simp add: combine_common_factor div_mult_mod_eq)
  moreover have "a div of_nat m div of_nat n * of_nat n * of_nat m = of_nat n * of_nat m * (a div of_nat m div of_nat n)"
    by (simp add: ac_simps)
  ultimately show ?thesis
    by (simp add: div_mult2_eq' mult_commute)
qed

lemma div_mult2_numeral_eq:
  "a div numeral k div numeral l = a div numeral (k * l)" (is "?A = ?B")
proof -
  have "?A = a div of_nat (numeral k) div of_nat (numeral l)"
    by simp
  also have "\<dots> = a div (of_nat (numeral k) * of_nat (numeral l))"
    by (fact div_mult2_eq' [symmetric])
  also have "\<dots> = ?B"
    by simp
  finally show ?thesis .
qed

lemma numeral_Bit0_div_2:
  "numeral (num.Bit0 n) div 2 = numeral n"
proof -
  have "numeral (num.Bit0 n) = numeral n + numeral n"
    by (simp only: numeral.simps)
  also have "\<dots> = numeral n * 2"
    by (simp add: mult_2_right)
  finally have "numeral (num.Bit0 n) div 2 = numeral n * 2 div 2"
    by simp
  also have "\<dots> = numeral n"
    by (rule nonzero_mult_div_cancel_right) simp
  finally show ?thesis .
qed

lemma numeral_Bit1_div_2:
  "numeral (num.Bit1 n) div 2 = numeral n"
proof -
  have "numeral (num.Bit1 n) = numeral n + numeral n + 1"
    by (simp only: numeral.simps)
  also have "\<dots> = numeral n * 2 + 1"
    by (simp add: mult_2_right)
  finally have "numeral (num.Bit1 n) div 2 = (numeral n * 2 + 1) div 2"
    by simp
  also have "\<dots> = numeral n * 2 div 2 + 1 div 2"
    using dvd_triv_right by (rule div_plus_div_distrib_dvd_left)
  also have "\<dots> = numeral n * 2 div 2"
    by simp
  also have "\<dots> = numeral n"
    by (rule nonzero_mult_div_cancel_right) simp
  finally show ?thesis .
qed

lemma exp_mod_exp:
  \<open>2 ^ m mod 2 ^ n = of_bool (m < n) * 2 ^ m\<close>
proof -
  have \<open>(2::nat) ^ m mod 2 ^ n = of_bool (m < n) * 2 ^ m\<close> (is \<open>?lhs = ?rhs\<close>)
    by (auto simp add: not_less monoid_mult_class.power_add dest!: le_Suc_ex)
  then have \<open>of_nat ?lhs = of_nat ?rhs\<close>
    by simp
  then show ?thesis
    by (simp add: of_nat_mod)
qed

lemma mask_mod_exp:
  \<open>(2 ^ n - 1) mod 2 ^ m = 2 ^ min m n - 1\<close>
proof -
  have \<open>(2 ^ n - 1) mod 2 ^ m = 2 ^ min m n - (1::nat)\<close> (is \<open>?lhs = ?rhs\<close>)
  proof (cases \<open>n \<le> m\<close>)
    case True
    then show ?thesis
      by (simp add: Suc_le_lessD)
  next
    case False
    then have \<open>m < n\<close>
      by simp
    then obtain q where n: \<open>n = Suc q + m\<close>
      by (auto dest: less_imp_Suc_add)
    then have \<open>min m n = m\<close>
      by simp
    moreover have \<open>(2::nat) ^ m \<le> 2 * 2 ^ q * 2 ^ m\<close>
      using mult_le_mono1 [of 1 \<open>2 * 2 ^ q\<close> \<open>2 ^ m\<close>] by simp
    with n have \<open>2 ^ n - 1 = (2 ^ Suc q - 1) * 2 ^ m + (2 ^ m - (1::nat))\<close>
      by (simp add: monoid_mult_class.power_add algebra_simps)
    ultimately show ?thesis
      by (simp only: euclidean_semiring_cancel_class.mod_mult_self3) simp
  qed
  then have \<open>of_nat ?lhs = of_nat ?rhs\<close>
    by simp
  then show ?thesis
    by (simp add: of_nat_mod of_nat_diff)
qed

lemma of_bool_half_eq_0 [simp]:
  \<open>of_bool b div 2 = 0\<close>
  by simp

end

class unique_euclidean_ring_with_nat = ring + unique_euclidean_semiring_with_nat

instance nat :: unique_euclidean_semiring_with_nat
  by standard (simp_all add: dvd_eq_mod_eq_0)

instance int :: unique_euclidean_ring_with_nat
  by standard (auto simp add: divide_int_def division_segment_int_def elim: contrapos_np)

context unique_euclidean_semiring_with_nat
begin

subclass semiring_parity
proof
  show "2 dvd a \<longleftrightarrow> a mod 2 = 0" for a
    by (fact dvd_eq_mod_eq_0)
  show "\<not> 2 dvd a \<longleftrightarrow> a mod 2 = 1" for a
  proof
    assume "a mod 2 = 1"
    then show "\<not> 2 dvd a"
      by auto
  next
    assume "\<not> 2 dvd a"
    have eucl: "euclidean_size (a mod 2) = 1"
    proof (rule order_antisym)
      show "euclidean_size (a mod 2) \<le> 1"
        using mod_size_less [of 2 a] by simp
      show "1 \<le> euclidean_size (a mod 2)"
        using \<open>\<not> 2 dvd a\<close> by (simp add: Suc_le_eq dvd_eq_mod_eq_0)
    qed
    from \<open>\<not> 2 dvd a\<close> have "\<not> of_nat 2 dvd division_segment a * of_nat (euclidean_size a)"
      by simp
    then have "\<not> of_nat 2 dvd of_nat (euclidean_size a)"
      by (auto simp only: dvd_mult_unit_iff' is_unit_division_segment)
    then have "\<not> 2 dvd euclidean_size a"
      using of_nat_dvd_iff [of 2] by simp
    then have "euclidean_size a mod 2 = 1"
      by (simp add: semidom_modulo_class.dvd_eq_mod_eq_0)
    then have "of_nat (euclidean_size a mod 2) = of_nat 1"
      by simp
    then have "of_nat (euclidean_size a) mod 2 = 1"
      by (simp add: of_nat_mod)
    from \<open>\<not> 2 dvd a\<close> eucl
    show "a mod 2 = 1"
      by (auto intro: division_segment_eq_iff simp add: division_segment_mod)
  qed
  show "\<not> is_unit 2"
  proof (rule notI)
    assume "is_unit 2"
    then have "of_nat 2 dvd of_nat 1"
      by simp
    then have "is_unit (2::nat)"
      by (simp only: of_nat_dvd_iff)
    then show False
      by simp
  qed
qed

lemma even_succ_div_two [simp]:
  "even a \<Longrightarrow> (a + 1) div 2 = a div 2"
  by (cases "a = 0") (auto elim!: evenE dest: mult_not_zero)

lemma odd_succ_div_two [simp]:
  "odd a \<Longrightarrow> (a + 1) div 2 = a div 2 + 1"
  by (auto elim!: oddE simp add: add.assoc)

lemma even_two_times_div_two:
  "even a \<Longrightarrow> 2 * (a div 2) = a"
  by (fact dvd_mult_div_cancel)

lemma odd_two_times_div_two_succ [simp]:
  "odd a \<Longrightarrow> 2 * (a div 2) + 1 = a"
  using mult_div_mod_eq [of 2 a]
  by (simp add: even_iff_mod_2_eq_zero)

lemma coprime_left_2_iff_odd [simp]:
  "coprime 2 a \<longleftrightarrow> odd a"
proof
  assume "odd a"
  show "coprime 2 a"
  proof (rule coprimeI)
    fix b
    assume "b dvd 2" "b dvd a"
    then have "b dvd a mod 2"
      by (auto intro: dvd_mod)
    with \<open>odd a\<close> show "is_unit b"
      by (simp add: mod_2_eq_odd)
  qed
next
  assume "coprime 2 a"
  show "odd a"
  proof (rule notI)
    assume "even a"
    then obtain b where "a = 2 * b" ..
    with \<open>coprime 2 a\<close> have "coprime 2 (2 * b)"
      by simp
    moreover have "\<not> coprime 2 (2 * b)"
      by (rule not_coprimeI [of 2]) simp_all
    ultimately show False
      by blast
  qed
qed

lemma coprime_right_2_iff_odd [simp]:
  "coprime a 2 \<longleftrightarrow> odd a"
  using coprime_left_2_iff_odd [of a] by (simp add: ac_simps)

end

context unique_euclidean_ring_with_nat
begin

subclass ring_parity ..

lemma minus_1_mod_2_eq [simp]:
  "- 1 mod 2 = 1"
  by (simp add: mod_2_eq_odd)

lemma minus_1_div_2_eq [simp]:
  "- 1 div 2 = - 1"
proof -
  from div_mult_mod_eq [of "- 1" 2]
  have "- 1 div 2 * 2 = - 1 * 2"
    using add_implies_diff by fastforce
  then show ?thesis
    using mult_right_cancel [of 2 "- 1 div 2" "- 1"] by simp
qed

end

context unique_euclidean_semiring_with_nat
begin

lemma even_mask_div_iff':
  \<open>even ((2 ^ m - 1) div 2 ^ n) \<longleftrightarrow> m \<le> n\<close>
proof -
  have \<open>even ((2 ^ m - 1) div 2 ^ n) \<longleftrightarrow> even (of_nat ((2 ^ m - Suc 0) div 2 ^ n))\<close>
    by (simp only: of_nat_div) (simp add: of_nat_diff)
  also have \<open>\<dots> \<longleftrightarrow> even ((2 ^ m - Suc 0) div 2 ^ n)\<close>
    by simp
  also have \<open>\<dots> \<longleftrightarrow> m \<le> n\<close>
  proof (cases \<open>m \<le> n\<close>)
    case True
    then show ?thesis
      by (simp add: Suc_le_lessD)
  next
    case False
    then obtain r where r: \<open>m = n + Suc r\<close>
      using less_imp_Suc_add by fastforce
    from r have \<open>{q. q < m} \<inter> {q. 2 ^ n dvd (2::nat) ^ q} = {q. n \<le> q \<and> q < m}\<close>
      by (auto simp add: dvd_power_iff_le)
    moreover from r have \<open>{q. q < m} \<inter> {q. \<not> 2 ^ n dvd (2::nat) ^ q} = {q. q < n}\<close>
      by (auto simp add: dvd_power_iff_le)
    moreover from False have \<open>{q. n \<le> q \<and> q < m \<and> q \<le> n} = {n}\<close>
      by auto
    then have \<open>odd ((\<Sum>a\<in>{q. n \<le> q \<and> q < m}. 2 ^ a div (2::nat) ^ n) + sum ((^) 2) {q. q < n} div 2 ^ n)\<close>
      by (simp_all add: euclidean_semiring_cancel_class.power_diff_power_eq semiring_parity_class.even_sum_iff not_less mask_eq_sum_exp_nat [symmetric])
    ultimately have \<open>odd (sum ((^) (2::nat)) {q. q < m} div 2 ^ n)\<close>
      by (subst euclidean_semiring_cancel_class.sum_div_partition) simp_all
    with False show ?thesis
      by (simp add: mask_eq_sum_exp_nat)
  qed
  finally show ?thesis .
qed

end

subsection \<open>Generic symbolic computations\<close>

text \<open>
  The following type class contains everything necessary to formulate
  a division algorithm in ring structures with numerals, restricted
  to its positive segments.
\<close>

class unique_euclidean_semiring_with_nat_division = unique_euclidean_semiring_with_nat +
  fixes divmod :: \<open>num \<Rightarrow> num \<Rightarrow> 'a \<times> 'a\<close>
    and divmod_step :: \<open>'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<times> 'a\<close> \<comment> \<open>
      These are conceptually definitions but force generated code
      to be monomorphic wrt. particular instances of this class which
      yields a significant speedup.\<close>
  assumes divmod_def: \<open>divmod m n = (numeral m div numeral n, numeral m mod numeral n)\<close>
    and divmod_step_def [simp]: \<open>divmod_step l (q, r) =
      (if euclidean_size l \<le> euclidean_size r then (2 * q + 1, r - l)
       else (2 * q, r))\<close> \<comment> \<open>
         This is a formulation of one step (referring to one digit position)
         in school-method division: compare the dividend at the current
         digit position with the remainder from previous division steps
         and evaluate accordingly.\<close>
begin

lemma fst_divmod:
  \<open>fst (divmod m n) = numeral m div numeral n\<close>
  by (simp add: divmod_def)

lemma snd_divmod:
  \<open>snd (divmod m n) = numeral m mod numeral n\<close>
  by (simp add: divmod_def)

text \<open>
  Following a formulation of school-method division.
  If the divisor is smaller than the dividend, terminate.
  If not, shift the dividend to the right until termination
  occurs and then reiterate single division steps in the
  opposite direction.
\<close>

lemma divmod_divmod_step:
  \<open>divmod m n = (if m < n then (0, numeral m)
    else divmod_step (numeral n) (divmod m (Num.Bit0 n)))\<close>
proof (cases \<open>m < n\<close>)
  case True
  then show ?thesis
    by (simp add: prod_eq_iff fst_divmod snd_divmod flip: of_nat_numeral of_nat_div of_nat_mod)
next
  case False
  define r s t where \<open>r = (numeral m :: nat)\<close> \<open>s = (numeral n :: nat)\<close> \<open>t = 2 * s\<close>
  then have *: \<open>numeral m = of_nat r\<close> \<open>numeral n = of_nat s\<close> \<open>numeral (num.Bit0 n) = of_nat t\<close>
    and \<open>\<not> s \<le> r mod s\<close>
    by (simp_all add: not_le)
  have t: \<open>2 * (r div t) = r div s - r div s mod 2\<close>
    \<open>r mod t = s * (r div s mod 2) + r mod s\<close>
    by (simp add: Rings.minus_mod_eq_mult_div Groups.mult.commute [of 2] Euclidean_Rings.div_mult2_eq \<open>t = 2 * s\<close>)
      (use mod_mult2_eq [of r s 2] in \<open>simp add: ac_simps \<open>t = 2 * s\<close>\<close>)
  have rs: \<open>r div s mod 2 = 0 \<or> r div s mod 2 = Suc 0\<close>
    by auto
  from \<open>\<not> s \<le> r mod s\<close> have \<open>s \<le> r mod t \<Longrightarrow>
     r div s = Suc (2 * (r div t)) \<and>
     r mod s = r mod t - s\<close>
    using rs
    by (auto simp add: t)
  moreover have \<open>r mod t < s \<Longrightarrow>
     r div s = 2 * (r div t) \<and>
     r mod s = r mod t\<close>
    using rs
    by (auto simp add: t)
  ultimately show ?thesis
    by (simp add: divmod_def prod_eq_iff split_def Let_def
        not_less mod_eq_0_iff_dvd Rings.mod_eq_0_iff_dvd False not_le *)
    (simp add: flip: of_nat_numeral of_nat_mult add.commute [of 1] of_nat_div of_nat_mod of_nat_Suc of_nat_diff)
qed

text \<open>The division rewrite proper -- first, trivial results involving \<open>1\<close>\<close>

lemma divmod_trivial [simp]:
  "divmod m Num.One = (numeral m, 0)"
  "divmod num.One (num.Bit0 n) = (0, Numeral1)"
  "divmod num.One (num.Bit1 n) = (0, Numeral1)"
  using divmod_divmod_step [of "Num.One"] by (simp_all add: divmod_def)

text \<open>Division by an even number is a right-shift\<close>

lemma divmod_cancel [simp]:
  \<open>divmod (Num.Bit0 m) (Num.Bit0 n) = (case divmod m n of (q, r) \<Rightarrow> (q, 2 * r))\<close> (is ?P)
  \<open>divmod (Num.Bit1 m) (Num.Bit0 n) = (case divmod m n of (q, r) \<Rightarrow> (q, 2 * r + 1))\<close> (is ?Q)
proof -
  define r s where \<open>r = (numeral m :: nat)\<close> \<open>s = (numeral n :: nat)\<close>
  then have *: \<open>numeral m = of_nat r\<close> \<open>numeral n = of_nat s\<close>
    \<open>numeral (num.Bit0 m) = of_nat (2 * r)\<close> \<open>numeral (num.Bit0 n) = of_nat (2 * s)\<close>
    \<open>numeral (num.Bit1 m) = of_nat (Suc (2 * r))\<close>
    by simp_all
  have **: \<open>Suc (2 * r) div 2 = r\<close>
    by simp
  show ?P and ?Q
    by (simp_all add: divmod_def *)
      (simp_all flip: of_nat_numeral of_nat_div of_nat_mod of_nat_mult add.commute [of 1] of_nat_Suc
       add: Euclidean_Rings.mod_mult_mult1 div_mult2_eq [of _ 2] mod_mult2_eq [of _ 2] **)
qed

text \<open>The really hard work\<close>

lemma divmod_steps [simp]:
  "divmod (num.Bit0 m) (num.Bit1 n) =
      (if m \<le> n then (0, numeral (num.Bit0 m))
       else divmod_step (numeral (num.Bit1 n))
             (divmod (num.Bit0 m)
               (num.Bit0 (num.Bit1 n))))"
  "divmod (num.Bit1 m) (num.Bit1 n) =
      (if m < n then (0, numeral (num.Bit1 m))
       else divmod_step (numeral (num.Bit1 n))
             (divmod (num.Bit1 m)
               (num.Bit0 (num.Bit1 n))))"
  by (simp_all add: divmod_divmod_step)

lemmas divmod_algorithm_code = divmod_trivial divmod_cancel divmod_steps

text \<open>Special case: divisibility\<close>

definition divides_aux :: "'a \<times> 'a \<Rightarrow> bool"
where
  "divides_aux qr \<longleftrightarrow> snd qr = 0"

lemma divides_aux_eq [simp]:
  "divides_aux (q, r) \<longleftrightarrow> r = 0"
  by (simp add: divides_aux_def)

lemma dvd_numeral_simp [simp]:
  "numeral m dvd numeral n \<longleftrightarrow> divides_aux (divmod n m)"
  by (simp add: divmod_def mod_eq_0_iff_dvd)

text \<open>Generic computation of quotient and remainder\<close>

lemma numeral_div_numeral [simp]:
  "numeral k div numeral l = fst (divmod k l)"
  by (simp add: fst_divmod)

lemma numeral_mod_numeral [simp]:
  "numeral k mod numeral l = snd (divmod k l)"
  by (simp add: snd_divmod)

lemma one_div_numeral [simp]:
  "1 div numeral n = fst (divmod num.One n)"
  by (simp add: fst_divmod)

lemma one_mod_numeral [simp]:
  "1 mod numeral n = snd (divmod num.One n)"
  by (simp add: snd_divmod)

end

instantiation nat :: unique_euclidean_semiring_with_nat_division
begin

definition divmod_nat :: "num \<Rightarrow> num \<Rightarrow> nat \<times> nat"
where
  divmod'_nat_def: "divmod_nat m n = (numeral m div numeral n, numeral m mod numeral n)"

definition divmod_step_nat :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat"
where
  "divmod_step_nat l qr = (let (q, r) = qr
    in if r \<ge> l then (2 * q + 1, r - l)
    else (2 * q, r))"

instance
  by standard (simp_all add: divmod'_nat_def divmod_step_nat_def)

end

declare divmod_algorithm_code [where ?'a = nat, code]

lemma Suc_0_div_numeral [simp]:
  \<open>Suc 0 div numeral Num.One = 1\<close>
  \<open>Suc 0 div numeral (Num.Bit0 n) = 0\<close>
  \<open>Suc 0 div numeral (Num.Bit1 n) = 0\<close>
  by simp_all

lemma Suc_0_mod_numeral [simp]:
  \<open>Suc 0 mod numeral Num.One = 0\<close>
  \<open>Suc 0 mod numeral (Num.Bit0 n) = 1\<close>
  \<open>Suc 0 mod numeral (Num.Bit1 n) = 1\<close>
  by simp_all

instantiation int :: unique_euclidean_semiring_with_nat_division
begin

definition divmod_int :: "num \<Rightarrow> num \<Rightarrow> int \<times> int"
where
  "divmod_int m n = (numeral m div numeral n, numeral m mod numeral n)"

definition divmod_step_int :: "int \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int"
where
  "divmod_step_int l qr = (let (q, r) = qr
    in if \<bar>l\<bar> \<le> \<bar>r\<bar> then (2 * q + 1, r - l)
    else (2 * q, r))"

instance
  by standard (auto simp add: divmod_int_def divmod_step_int_def)

end

declare divmod_algorithm_code [where ?'a = int, code]

context
begin

qualified definition adjust_div :: "int \<times> int \<Rightarrow> int"
where
  "adjust_div qr = (let (q, r) = qr in q + of_bool (r \<noteq> 0))"

qualified lemma adjust_div_eq [simp, code]:
  "adjust_div (q, r) = q + of_bool (r \<noteq> 0)"
  by (simp add: adjust_div_def)

qualified definition adjust_mod :: "num \<Rightarrow> int \<Rightarrow> int"
where
  [simp]: "adjust_mod l r = (if r = 0 then 0 else numeral l - r)"

lemma minus_numeral_div_numeral [simp]:
  "- numeral m div numeral n = - (adjust_div (divmod m n) :: int)"
proof -
  have "int (fst (divmod m n)) = fst (divmod m n)"
    by (simp only: fst_divmod divide_int_def) auto
  then show ?thesis
    by (auto simp add: split_def Let_def adjust_div_def divides_aux_def divide_int_def)
qed

lemma minus_numeral_mod_numeral [simp]:
  "- numeral m mod numeral n = adjust_mod n (snd (divmod m n) :: int)"
proof (cases "snd (divmod m n) = (0::int)")
  case True
  then show ?thesis
    by (simp add: mod_eq_0_iff_dvd divides_aux_def)
next
  case False
  then have "int (snd (divmod m n)) = snd (divmod m n)" if "snd (divmod m n) \<noteq> (0::int)"
    by (simp only: snd_divmod modulo_int_def) auto
  then show ?thesis
    by (simp add: divides_aux_def adjust_div_def)
      (simp add: divides_aux_def modulo_int_def)
qed

lemma numeral_div_minus_numeral [simp]:
  "numeral m div - numeral n = - (adjust_div (divmod m n) :: int)"
proof -
  have "int (fst (divmod m n)) = fst (divmod m n)"
    by (simp only: fst_divmod divide_int_def) auto
  then show ?thesis
    by (auto simp add: split_def Let_def adjust_div_def divides_aux_def divide_int_def)
qed

lemma numeral_mod_minus_numeral [simp]:
  "numeral m mod - numeral n = - adjust_mod n (snd (divmod m n) :: int)"
proof (cases "snd (divmod m n) = (0::int)")
  case True
  then show ?thesis
    by (simp add: mod_eq_0_iff_dvd divides_aux_def)
next
  case False
  then have "int (snd (divmod m n)) = snd (divmod m n)" if "snd (divmod m n) \<noteq> (0::int)"
    by (simp only: snd_divmod modulo_int_def) auto
  then show ?thesis
    by (simp add: divides_aux_def adjust_div_def)
      (simp add: divides_aux_def modulo_int_def)
qed

lemma minus_one_div_numeral [simp]:
  "- 1 div numeral n = - (adjust_div (divmod Num.One n) :: int)"
  using minus_numeral_div_numeral [of Num.One n] by simp

lemma minus_one_mod_numeral [simp]:
  "- 1 mod numeral n = adjust_mod n (snd (divmod Num.One n) :: int)"
  using minus_numeral_mod_numeral [of Num.One n] by simp

lemma one_div_minus_numeral [simp]:
  "1 div - numeral n = - (adjust_div (divmod Num.One n) :: int)"
  using numeral_div_minus_numeral [of Num.One n] by simp

lemma one_mod_minus_numeral [simp]:
  "1 mod - numeral n = - adjust_mod n (snd (divmod Num.One n) :: int)"
  using numeral_mod_minus_numeral [of Num.One n] by simp

end

lemma divmod_BitM_2_eq [simp]:
  \<open>divmod (Num.BitM m) (Num.Bit0 Num.One) = (numeral m - 1, (1 :: int))\<close>
  by (cases m) simp_all

subsubsection \<open>Computation by simplification\<close>

lemma euclidean_size_nat_less_eq_iff:
  \<open>euclidean_size m \<le> euclidean_size n \<longleftrightarrow> m \<le> n\<close> for m n :: nat
  by simp

lemma euclidean_size_int_less_eq_iff:
  \<open>euclidean_size k \<le> euclidean_size l \<longleftrightarrow> \<bar>k\<bar> \<le> \<bar>l\<bar>\<close> for k l :: int
  by auto

simproc_setup numeral_divmod
  ("0 div 0 :: 'a :: unique_euclidean_semiring_with_nat_division" | "0 mod 0 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "0 div 1 :: 'a :: unique_euclidean_semiring_with_nat_division" | "0 mod 1 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "0 div - 1 :: int" | "0 mod - 1 :: int" |
   "0 div numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" | "0 mod numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "0 div - numeral b :: int" | "0 mod - numeral b :: int" |
   "1 div 0 :: 'a :: unique_euclidean_semiring_with_nat_division" | "1 mod 0 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "1 div 1 :: 'a :: unique_euclidean_semiring_with_nat_division" | "1 mod 1 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "1 div - 1 :: int" | "1 mod - 1 :: int" |
   "1 div numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" | "1 mod numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "1 div - numeral b :: int" |"1 mod - numeral b :: int" |
   "- 1 div 0 :: int" | "- 1 mod 0 :: int" | "- 1 div 1 :: int" | "- 1 mod 1 :: int" |
   "- 1 div - 1 :: int" | "- 1 mod - 1 :: int" | "- 1 div numeral b :: int" | "- 1 mod numeral b :: int" |
   "- 1 div - numeral b :: int" | "- 1 mod - numeral b :: int" |
   "numeral a div 0 :: 'a :: unique_euclidean_semiring_with_nat_division" | "numeral a mod 0 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "numeral a div 1 :: 'a :: unique_euclidean_semiring_with_nat_division" | "numeral a mod 1 :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "numeral a div - 1 :: int" | "numeral a mod - 1 :: int" |
   "numeral a div numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" | "numeral a mod numeral b :: 'a :: unique_euclidean_semiring_with_nat_division" |
   "numeral a div - numeral b :: int" | "numeral a mod - numeral b :: int" |
   "- numeral a div 0 :: int" | "- numeral a mod 0 :: int" |
   "- numeral a div 1 :: int" | "- numeral a mod 1 :: int" |
   "- numeral a div - 1 :: int" | "- numeral a mod - 1 :: int" |
   "- numeral a div numeral b :: int" | "- numeral a mod numeral b :: int" |
   "- numeral a div - numeral b :: int" | "- numeral a mod - numeral b :: int") = \<open>
  let
    val if_cong = the (Code.get_case_cong \<^theory> \<^const_name>\<open>If\<close>);
    fun successful_rewrite ctxt ct =
      let
        val thm = Simplifier.rewrite ctxt ct
      in if Thm.is_reflexive thm then NONE else SOME thm end;
  in fn phi =>
    let
      val simps = Morphism.fact phi (@{thms div_0 mod_0 div_by_0 mod_by_0 div_by_1 mod_by_1
        one_div_numeral one_mod_numeral minus_one_div_numeral minus_one_mod_numeral
        one_div_minus_numeral one_mod_minus_numeral
        numeral_div_numeral numeral_mod_numeral minus_numeral_div_numeral minus_numeral_mod_numeral
        numeral_div_minus_numeral numeral_mod_minus_numeral
        div_minus_minus mod_minus_minus Parity.adjust_div_eq of_bool_eq one_neq_zero
        numeral_neq_zero neg_equal_0_iff_equal arith_simps arith_special divmod_trivial
        divmod_cancel divmod_steps divmod_step_def fst_conv snd_conv numeral_One
        case_prod_beta rel_simps Parity.adjust_mod_def div_minus1_right mod_minus1_right
        minus_minus numeral_times_numeral mult_zero_right mult_1_right
        euclidean_size_nat_less_eq_iff euclidean_size_int_less_eq_iff diff_nat_numeral nat_numeral}
        @ [@{lemma "0 = 0 \<longleftrightarrow> True" by simp}]);
      fun prepare_simpset ctxt = HOL_ss |> Simplifier.simpset_map ctxt
        (Simplifier.add_cong if_cong #> fold Simplifier.add_simp simps)
    in fn ctxt => successful_rewrite (Simplifier.put_simpset (prepare_simpset ctxt) ctxt) end
  end
\<close> \<comment> \<open>
  There is space for improvement here: the calculation itself
  could be carried out outside the logic, and a generic simproc
  (simplifier setup) for generic calculation would be helpful.
\<close>

subsection \<open>Computing congruences modulo \<open>2 ^ q\<close>\<close>

context unique_euclidean_semiring_with_nat_division
begin

lemma cong_exp_iff_simps:
  "numeral n mod numeral Num.One = 0
    \<longleftrightarrow> True"
  "numeral (Num.Bit0 n) mod numeral (Num.Bit0 q) = 0
    \<longleftrightarrow> numeral n mod numeral q = 0"
  "numeral (Num.Bit1 n) mod numeral (Num.Bit0 q) = 0
    \<longleftrightarrow> False"
  "numeral m mod numeral Num.One = (numeral n mod numeral Num.One)
    \<longleftrightarrow> True"
  "numeral Num.One mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
    \<longleftrightarrow> True"
  "numeral Num.One mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> False"
  "numeral Num.One mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> (numeral n mod numeral q) = 0"
  "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
    \<longleftrightarrow> False"
  "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> numeral m mod numeral q = (numeral n mod numeral q)"
  "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> False"
  "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
    \<longleftrightarrow> (numeral m mod numeral q) = 0"
  "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> False"
  "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
    \<longleftrightarrow> numeral m mod numeral q = (numeral n mod numeral q)"
  by (auto simp add: case_prod_beta dest: arg_cong [of _ _ even])

end

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

lemmas even_of_nat = even_of_nat_iff

end