subsection "Splay Tree Analysis (Optimal)"

theory Splay_Tree_Analysis_Optimal
imports
  Splay_Tree_Analysis_Base
  Amortized_Framework
  "HOL-Library.Sum_of_Squares"
begin

text\<open>This analysis follows Schoenmakers~\cite{Schoenmakers-IPL93}.\<close>

subsubsection "Analysis of splay"

locale Splay_Analysis =
fixes \<alpha> :: real and \<beta> :: real
assumes a1[arith]: "\<alpha> > 1"
assumes A1: "\<lbrakk>1 \<le> x; 1 \<le> y; 1 \<le> z\<rbrakk> \<Longrightarrow>
 (x+y) * (y+z) powr \<beta> \<le> (x+y) powr \<beta> * (x+y+z)"
assumes A2: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> lr; 1 \<le> r\<rbrakk> \<Longrightarrow>
   \<alpha> * (l'+r') * (lr+r) powr \<beta> * (lr+r'+r) powr \<beta>
    \<le> (l'+r') powr \<beta> * (l'+lr+r') powr \<beta> * (l'+lr+r'+r)"
assumes A3: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> ll; 1 \<le> r\<rbrakk> \<Longrightarrow>
  \<alpha> * (l'+r') * (l'+ll) powr \<beta> * (r'+r) powr \<beta>
  \<le> (l'+r') powr \<beta> * (l'+ll+r') powr \<beta> * (l'+ll+r'+r)"
begin

lemma nl2: "\<lbrakk> ll \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  log \<alpha> (ll + lr) + \<beta> * log \<alpha> (lr + r)
  \<le> \<beta> * log \<alpha> (ll + lr) + log \<alpha> (ll + lr + r)"
apply(rule powr_le_cancel_iff[THEN iffD1, OF a1])
apply(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric] A1)
done

definition \<phi> :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> real" where
"\<phi> t1 t2 = \<beta> * log \<alpha> (size1 t1 + size1 t2)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + \<phi> l r"

definition A :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> real" where
"A a t = t_splay a t + \<Phi>(splay a t) - \<Phi> t"

lemma A_simps[simp]: "A a (Node l a r) = 1"
 "a<b \<Longrightarrow> A a (Node (Node ll a lr) b r) = \<phi> lr r - \<phi> lr ll + 1"
 "b<a \<Longrightarrow> A a (Node l b (Node rl a rr)) = \<phi> rl l - \<phi> rr rl + 1"
by(auto simp add: A_def \<phi>_def algebra_simps)

lemma A_ub: "\<lbrakk> bst t; Node la a ra : subtrees t \<rbrakk>
  \<Longrightarrow> A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
proof(induction a t rule: splay.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 4 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 5 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 7 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 10 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 12 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case 13 hence False by(fastforce dest: in_set_tree_if) thus ?case ..
next
  case (3 b a lb rb ra)
  have "b \<notin> set_tree ra" using "3.prems"(1) by auto
  thus ?case using "3.prems"(1,2) nl2[of "size1 lb" "size1 rb" "size1 ra"]
    by (auto simp: \<phi>_def log_divide algebra_simps)
next
  case (9 a b la lb rb)
  have "b \<notin> set_tree la" using "9.prems"(1) by auto
  thus ?case using "9.prems"(1,2) nl2[of "size1 rb" "size1 lb" "size1 la"]
    by (auto simp add: \<phi>_def log_divide algebra_simps)
next
  case (6 x b a lb rb ra)
  hence 0: "x \<notin> set_tree rb \<and> x \<notin> set_tree ra" using "6.prems"(1) by auto
  hence 1: "x \<in> set_tree lb" using "6.prems" \<open>x<b\<close> by (auto)
  then obtain lu u ru where sp: "splay x lb = Node lu u ru"
    using "6.prems"(1,2) by(cases "splay x lb") auto
  have "b < a" using "6.prems"(1,2) by (auto)
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?rb = "real(size1 rb)"  let ?r = "real(size1 ra)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?rb + ?r) + \<beta> * log \<alpha> (?rb + ?ru + ?r) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?rb + ?ru) + log \<alpha> (?lu + ?rb + ?ru + ?r)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
    show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?lu ?ru ?rb ?r]
      by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 6 0 1 sp
    by(auto simp: A_def \<phi>_def size_if_splay algebra_simps log_divide)
next
  case (8 b x a rb lb ra)
  hence 0: "x \<notin> set_tree lb \<and> x \<notin> set_tree ra" using "8.prems"(1) by(auto)
  hence 1: "x \<in> set_tree rb" using "8.prems" \<open>b<x\<close> \<open>x<a\<close> by (auto)
  then obtain lu u ru where sp: "splay x rb = Node lu u ru"
    using "8.prems"(1,2) by(cases "splay x rb") auto
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?lb = "real(size1 lb)" let ?r = "real(size1 ra)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb) + \<beta> * log \<alpha> (?ru + ?r) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb + ?ru) + log \<alpha> (?lu + ?lb + ?ru + ?r)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
     show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?lu ?ru ?lb ?r]
       by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 8 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
next
  case (11 a x b lb la rb)
  hence 0: "x \<notin> set_tree rb \<and> x \<notin> set_tree la" using "11.prems"(1) by (auto)
  hence 1: "x \<in> set_tree lb" using "11.prems" \<open>a<x\<close> \<open>x<b\<close> by (auto)
  then obtain lu u ru where sp: "splay x lb = Node lu u ru"
    using "11.prems"(1,2) by(cases "splay x lb") auto
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  let ?l = "real(size1 la)"  let ?rb = "real(size1 rb)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?l) + \<beta> * log \<alpha> (?ru + ?rb) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?ru + ?rb) + log \<alpha> (?lu + ?l + ?ru + ?rb)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
    show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?ru ?lu ?rb ?l]
      by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
        (simp add: algebra_simps)
  qed
  thus ?case using 11 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
next
  case (14 a x b rb la lb)
  hence 0: "x \<notin> set_tree lb \<and> x \<notin> set_tree la" using "14.prems"(1) by(auto)
  hence 1: "x \<in> set_tree rb" using "14.prems" \<open>a<x\<close> \<open>b<x\<close> by (auto)
  then obtain lu u ru where sp: "splay x rb = Node lu u ru"
    using "14.prems"(1,2) by(cases "splay x rb") auto
  let ?la = "real(size1 la)"  let ?lb = "real(size1 lb)"
  let ?lu = "real (size1 lu)" let ?ru = "real (size1 ru)"
  have "1 + log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?la + ?lb) + \<beta> * log \<alpha> (?lu + ?la + ?lb) \<le>
        \<beta> * log \<alpha> (?lu + ?ru) + \<beta> * log \<alpha> (?lu + ?lb + ?ru) + log \<alpha> (?lu + ?lb + ?ru + ?la)" (is "?L\<le>?R")
  proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
     show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?ru ?lu ?lb ?la]
       by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
  qed
  thus ?case using 14 0 1 sp
    by(auto simp add: A_def size_if_splay \<phi>_def log_divide algebra_simps)
qed

lemma A_ub2: assumes "bst t" "a : set_tree t"
shows "A a t \<le> log \<alpha> ((size1 t)/2) + 1"
proof -
  from assms(2) obtain la ra where N: "Node la a ra : subtrees t"
    by (metis set_treeE)
  have "A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
    by(rule A_ub[OF assms(1) N])
  also have "\<dots> \<le> log \<alpha> ((size1 t)/2) + 1" by(simp add: field_simps)
  finally show ?thesis by simp
qed

lemma A_ub3: assumes "bst t" shows "A a t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: A_def)
next
  assume "t \<noteq> Leaf"
  from ex_in_set_tree[OF this assms] obtain a' where
    a': "a' \<in> set_tree t"  "splay a' t = splay a t"  "t_splay a' t = t_splay a t"
    by blast
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using A_ub2[OF assms a'(1)] by(simp add: A_def a' log_divide)
qed

definition Am :: "'a::linorder tree \<Rightarrow> real" where
"Am t = t_splay_max t + \<Phi>(splay_max t) - \<Phi> t"

lemma Am_simp3': "\<lbrakk> c<b; bst rr; rr \<noteq> Leaf\<rbrakk> \<Longrightarrow>
  Am (Node l c (Node rl b rr)) =
  (case splay_max rr of Node rrl _ rrr \<Rightarrow>
   Am rr + \<phi> rrl (Node l c rl) + \<phi> l rl - \<phi> rl rr - \<phi> rrl rrr + 1)"
by(auto simp: Am_def \<phi>_def size_if_splay_max algebra_simps neq_Leaf_iff split: tree.split)

lemma Am_ub: "\<lbrakk> bst t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow> Am t \<le> log \<alpha> ((size1 t)/2) + 1"
proof(induction t rule: splay_max.induct)
  case 1 thus ?case by (simp)
next
  case 2 thus ?case by (simp add: Am_def)
next
  case (3 l b rl c rr)
  show ?case
  proof cases
    assume "rr = Leaf"
    thus ?thesis
      using nl2[of 1 "size1 rl" "size1 l"] log_le_cancel_iff[of \<alpha> 2 "2 + real(size rl)"]
      by(auto simp: Am_def \<phi>_def log_divide field_simps
           simp del: log_le_cancel_iff)
  next
    assume "rr \<noteq> Leaf"
    then obtain l' u r' where sp: "splay_max rr = Node l' u r'"
      using splay_max_Leaf_iff tree.exhaust by blast
    hence 1: "size rr = size l' + size r' + 1"
      using size_splay_max[of rr] by(simp)
    let ?l = "real (size1 l)" let ?rl = "real (size1 rl)"
    let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
    have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l + ?rl) + \<beta> * log \<alpha> (?l' + ?l + ?rl) \<le>
      \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?rl + ?r') + log \<alpha> (?l' + ?rl + ?r' + ?l)" (is "?L\<le>?R")
    proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
      show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?r' ?l' ?rl ?l]
        by(simp add: powr_add add.commute add.left_commute mult.commute[of \<beta>] powr_powr[symmetric])
    qed
    thus ?case using 3 sp 1 \<open>rr \<noteq> Leaf\<close>
      by(auto simp add: Am_simp3' \<phi>_def log_divide algebra_simps)
  qed
qed

lemma Am_ub3: assumes "bst t" shows "Am t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: Am_def)
next
  assume "t \<noteq> Leaf"
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using Am_ub[OF assms \<open>t \<noteq> Leaf\<close>] by(simp add: Am_def log_divide)
qed

end

subsubsection "Optimal Interpretation"

lemma mult_root_eq_root:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> root n x * y = root n (x * (y ^ n))"
by(simp add: real_root_mult real_root_pos2)

lemma mult_root_eq_root2:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> y * root n x = root n ((y ^ n) * x)"
by(simp add: real_root_mult real_root_pos2)

lemma powr_inverse_numeral:
  "0 < x \<Longrightarrow> x powr (1 / numeral n) = root (numeral n) x"
by (simp add: root_powr_inverse)

lemmas root_simps = mult_root_eq_root mult_root_eq_root2 powr_inverse_numeral

lemma nl31: "\<lbrakk> (l'::real) \<ge> 1; r' \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  4 * (l' + r') * (lr + r) \<le> (l' + lr + r' + r)^2"
by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + lr + ~1*r']^2))))")

lemma nl32: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (lr + r) * (lr + r' + r) \<le> (l' + lr + r' + r)^3"
proof -
  have 1: "lr + r' + r \<le> l' + lr + r' + r" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> lr + r' + r" using assms by arith
  from mult_mono[OF nl31[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc)
qed

lemma nl3: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (lr + r) * (lr + r' + r)
       \<le> (l' + lr + r') * (l' + lr + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + lr + r'" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl32[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma nl41: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^2"
using assms by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + ~1*ll + r']^2))))")

lemma nl42: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^3"
proof -
  have 1: "l' + r' \<le> l' + ll + r' + r" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl41[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc del: distrib_right_numeral)
qed

lemma nl4: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (l' + ll) * (r' + r)
    \<le> (l' + ll + r') * (l' + ll + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + ll + r'" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl42[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma cancel: "x>(0::real) \<Longrightarrow> c * x ^ 2 * y * z \<le> u * v \<Longrightarrow> c * x ^ 3 * y * z \<le> x * u * v"
by(simp add: power2_eq_square power3_eq_cube)

interpretation S34: Splay_Analysis "root 3 4" "1/3"
proof (standard, goal_cases)
  case 2 thus ?case
    by(simp add: root_simps)
      (auto simp: numeral_eq_Suc split_mult_pos_le intro!: mult_mono)
next
  case 3 thus ?case by(simp add: root_simps cancel nl3)
next
  case 4 thus ?case by(simp add: root_simps cancel nl4)
qed simp

lemma log4_log2: "log 4 x = log 2 x / 2"
proof -
  have "log 4 x = log (2^2) x" by simp
  also have "\<dots> = log 2 x / 2" by(simp only: log_base_pow)
  finally show ?thesis .
qed

declare log_base_root[simp]

lemma A34_ub: assumes "bst t"
shows "S34.A a t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.A a t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.A_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size t + 1) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

lemma Am34_ub: assumes "bst t"
shows "S34.Am t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.Am t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.Am_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size1 t) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

subsubsection "Overall analysis"

fun U where
"U Empty [] = 1" |
"U (Splay _) [t] = (3/2) * log 2 (size1 t) + 1" |
"U (Insert _) [t] = 2 * log 2 (size1 t) + 3/2" |
"U (Delete _) [t] = 3 * log 2 (size1 t) + 2"

interpretation Amortized
where arity = arity and exec = exec and inv = bst
and cost = cost and \<Phi> = S34.\<Phi> and U = U
proof (standard, goal_cases)
  case (1 ss f) show ?case
  proof (cases f)
    case Empty thus ?thesis using 1 by auto
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with Splay bst_splay[OF \<open>bst t\<close>, of a] show ?thesis
      by (auto split: tree.split)
  next
    case (Insert a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with bst_splay[OF \<open>bst t\<close>, of a] Insert show ?thesis
      by (auto simp: splay_bstL[OF \<open>bst t\<close>] splay_bstR[OF \<open>bst t\<close>] split: tree.split)
  next
    case (Delete a)
    then obtain t where "ss = [t]" "bst t" using 1 by auto
    with 1 Delete show ?thesis by(simp add: bst_delete)
  qed
next
  case (2 t) show ?case by(induction t)(simp_all add: S34.\<phi>_def)
next
  case (3 ss f)
  show ?case (is "?l \<le> ?r")
  proof(cases f)
    case Empty thus ?thesis using 3(2) by(simp add: S34.A_def)
  next
    case (Splay a)
    then obtain t where "ss = [t]" "bst t" using 3 by auto
    thus ?thesis using S34.A_ub3[OF \<open>bst t\<close>] Splay
      by(simp add: S34.A_def log4_log2)
  next
    case [simp]: (Insert a)
    obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    show ?thesis
    proof cases
      assume "t = Leaf" thus ?thesis by(simp add: S34.\<phi>_def log4_log2)
    next
      assume "t \<noteq> Leaf"
      then obtain l e r where [simp]: "splay a t = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(t_splay a t)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> t"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      have opt: "?t + S34.\<Phi> (splay a t) - ?Ps  \<le> 3/2 * log 2 (real (size1 t)) + 1"
        using S34.A_ub3[OF \<open>bst t\<close>, simplified S34.A_def, of a]
        by (simp add: log4_log2)
      from less_linear[of e a]
      show ?thesis
      proof (elim disjE)
        assume "e=a"
        have nneg: "log 2 (1 + real (size t)) \<ge> 0" by simp
        thus ?thesis using \<open>t \<noteq> Leaf\<close> opt \<open>e=a\<close>
          apply(simp add: field_simps) using nneg by arith
      next
        let ?L = "log 2 (real(size1 l) + 1)"
        assume "e<a" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?L / 2 + ?LR / 2"
          using \<open>t \<noteq> Leaf\<close> \<open>e<a\<close> by(simp add: S34.\<phi>_def log4_log2)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a t,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?L/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a t,symmetric] by simp
      next
        let ?R = "log 2 (2 + real(size r))"
        assume "a<e" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?R / 2 + ?LR / 2"
          using  \<open>t \<noteq> Leaf\<close> \<open>a<e\<close> by(simp add: S34.\<phi>_def log4_log2)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a t,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?R/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a t,symmetric] by simp
      qed
    qed
  next
    case [simp]: (Delete a)
    obtain t where [simp]: "ss = [t]" and "bst t" using 3 by auto
    show ?thesis
    proof (cases t)
      case Leaf thus ?thesis
        by(simp add: Splay_Tree.delete_def t_delete_def S34.\<phi>_def log4_log2)
    next
      case [simp]: (Node ls x rs)
      then obtain l e r where sp[simp]: "splay a (Node ls x rs) = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(t_splay a t)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> t"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      let ?lslr = "log 2 (real (size ls) + (real (size rs) + 2))"
      have "?lslr \<ge> 0" by simp
      have opt: "?t + S34.\<Phi> (splay a t) - ?Ps  \<le> 3/2 * log 2 (real (size1 t)) + 1"
        using S34.A_ub3[OF \<open>bst t\<close>, simplified S34.A_def, of a]
        by (simp add: log4_log2 field_simps)
      show ?thesis
      proof (cases "e=a")
        case False thus ?thesis using opt
          apply(simp add: Splay_Tree.delete_def t_delete_def field_simps)
          using \<open>?lslr \<ge> 0\<close> by arith
      next
        case [simp]: True
        show ?thesis
        proof (cases l)
          case Leaf
          have "S34.\<phi> Leaf r \<ge> 0" by(simp add: S34.\<phi>_def)
          thus ?thesis using Leaf opt
            apply(simp add: Splay_Tree.delete_def t_delete_def field_simps)
            using \<open>?lslr \<ge> 0\<close> by arith
        next
          case (Node ll y lr)
          then obtain l' y' r' where [simp]:
            "splay_max (Node ll y lr) = Node l' y' r'"
            using splay_max_Leaf_iff tree.exhaust by blast
          have "bst l" using bst_splay[OF \<open>bst t\<close>, of a] by simp
          have "S34.\<Phi> r' \<ge> 0" apply (induction r') by (auto simp add: S34.\<phi>_def)
          have optm: "real(t_splay_max l) + S34.\<Phi> (splay_max l) - S34.\<Phi> l
            \<le> 3/2 * log 2 (real (size1 l)) + 1"
            using S34.Am_ub3[OF \<open>bst l\<close>, simplified S34.Am_def]
            by (simp add: log4_log2 field_simps Node)
          have 1: "log 4 (2+(real(size l')+real(size r))) \<le>
            log 4 (2+(real(size l)+real(size r)))"
            using size_splay_max[of l] Node by simp
          have 2: "log 4 (2 + (real (size l') + real (size r'))) \<ge> 0" by simp
          have 3: "S34.\<phi> l' r \<le> S34.\<phi> l' r' + S34.\<phi> l r"
            apply(simp add: S34.\<phi>_def) using 1 2 by arith
          have 4: "log 2 (real(size ll) + (real(size lr) + 2)) \<le> ?lslr"
            using size_if_splay[OF sp] Node by simp
          show ?thesis using add_mono[OF opt optm] Node 3
            apply(simp add: Splay_Tree.delete_def t_delete_def field_simps)
            using 4 \<open>S34.\<Phi> r' \<ge> 0\<close> by arith
        qed
      qed
    qed
  qed
qed

end


theory SINVAR_BLPtrusted
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Basic Bell LaPadula with trusted entities *}

type_synonym security_level = nat

record node_config =
    security_level::security_level
    trusted::bool

definition default_node_properties :: "node_config"
  where  "default_node_properties \<equiv> \<lparr> security_level = 0, trusted = False \<rparr>"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow>  bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (if trusted (nP e2) then True else security_level (nP e1) \<le> security_level (nP e2) ))"

text{*A simplified version of the Bell LaPadula model was presented in @{file "SINVAR_BLPbasic.thy"}.
In this theory, we extend this template with a notion of trust by adding a Boolean flag @{const trusted} to the host attributes.
This is a refinement to represent real-world scenarios more accurately and analogously happened to the
original Bell LaPadula model (see publication ``Looking Back at the Bell-La Padula Model''
A trusted host can receive information of any security level and may declassify it,
i.e. distribute the information with its own security level.
For example, a @{term "trusted (sc::node_config) = True"} host is allowed to receive any information
and with the @{term "0::security_level"} level, it is allowed to reveal it to anyone.
*}

definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto split: prod.split prod.split_asm)[6]
   apply(simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops split: prod.split prod.split_asm)[1]
   apply (metis prod.inject)
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma "a \<noteq> b \<Longrightarrow> ((\<exists> x. y x)) \<Longrightarrow> ((\<forall> x. \<not> y x) \<Longrightarrow> a = b )" by simp

lemma BLP_def_unique: "otherbot \<noteq> default_node_properties \<Longrightarrow>
    \<exists>G p i f. wf_graph G \<and> \<not> sinvar G p \<and> f \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G p) \<and>
       sinvar (delete_edges G f) p \<and>
         i \<in> snd ` f \<and> sinvar G (p(i := otherbot)) "
  apply(simp add:default_node_properties_def)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(rule_tac x="\<lparr> nodes={vertex_1, vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := \<lparr>security_level = 1, trusted = False \<rparr>, vertex_2 := \<lparr>security_level = 0, trusted = False \<rparr>)" in exI, simp add:default_node_properties_def)
  apply(rule_tac x="vertex_2" in exI, simp)
  apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
  apply(case_tac otherbot)
  apply simp
  apply(erule disjE)
   apply force
  apply fast
  done

subsubsection {*ENF*}
  definition BLP_P where "BLP_P \<equiv> (\<lambda>n1 n2.(if trusted n2 then True else security_level n1 \<le> security_level n2 ))"
  lemma zero_default_candidate: "\<forall>nP e1 e2. \<not> BLP_P (nP e1) (nP e2) \<longrightarrow> \<not> BLP_P (nP e1) default_node_properties"
    apply(rule allI)+
    apply(case_tac "nP e1")
    apply(case_tac "nP e2")
    apply(rename_tac privacy2 trusted2 more2)
    apply (simp add: BLP_P_def default_node_properties_def)
    done
  lemma privacylevel_refl: "BLP_P e e"
    by(simp_all add: BLP_P_def)
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    unfolding BLP_P_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar BLP_P"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp add: privacylevel_refl)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> BLP_P (nP e1) (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation BLPtrusted: SecurityInvariant_IFS
  where default_node_properties = default_node_properties
  and sinvar = sinvar
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply unfold_locales
      apply(rule ballI)
      apply (rule_tac f=f in SecurityInvariant_withOffendingFlows.ENF_snds_refl_instance[OF BLP_ENF_refl zero_default_candidate])
       apply(simp)
      apply(simp)
     apply(erule default_uniqueness_by_counterexample_IFS)
     apply(fact BLP_def_unique)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPtrusted: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_type (open) node_config
hide_const (open) sinvar_mono

hide_const (open) BLP_P
hide_fact BLP_def_unique zero_default_candidate  privacylevel_refl BLP_ENF BLP_ENF_refl

hide_const (open) sinvar receiver_violation default_node_properties

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_55
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = Z"
| "t2 (S z2) (Z) = S z2"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((drop n (x xs ys)) = (x (drop n xs) (drop (t2 n (len xs)) ys)))"
  find_proof DInd
  (*TODO: investigate why.*)
  apply (induct n xs rule: TIP_prop_55.drop.induct)
    apply auto
  done

end


(* Title: Left-Sided Elements in Quantales
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Left-Sided Elements in Quantales\<close>

theory Quantale_Left_Sided
  imports Quantic_Nuclei_Conuclei
begin

context quantale
begin

subsection \<open>Basic Definitions\<close>

text \<open>Left-sided elements are well investigated in quantale theory. They could be defined in weaker settings, for instance,
ord with a top element.\<close>

definition "lsd x = (\<top> \<cdot> x \<le> x)"

definition "rsd x = (x \<cdot> \<top> \<le> x)"

definition "twosd x = (lsd x \<and> rsd x)"

definition "slsd x = (\<top> \<cdot> x = x)"

definition "srsd x = (x \<cdot> \<top> = x)"

definition "stwsd x = (slsd x \<and> srsd x)"

lemma lsided_fres: "(lsd x) = (\<top> \<le> x \<leftarrow> x)"
  by (simp add: fres_galois lsd_def)

lemma lsided_fres_eq: "(lsd x) = (x \<leftarrow> x = \<top>)"
  using fres_galois top_le lsd_def by force

lemma lsided_slsided: "lsd x \<Longrightarrow> x \<cdot> x = x \<Longrightarrow> slsd x"
  using fres_sol lsided_fres_eq slsd_def by force

lemma lsided_prop: "lsd x \<Longrightarrow> y \<cdot> x \<le> x"
  by (simp add: fres_galois lsided_fres_eq)

lemma rsided_fres: "(rsd x) = (x \<le> x \<leftarrow> \<top>)"
  by (simp add: fres_galois rsd_def)

lemma rsided_bres: "(rsd x) = (\<top> \<le> x \<rightarrow> x)"
  by (simp add: bres_galois rsd_def)

lemma rsided_bres_eq: "(rsd x) = (x \<rightarrow> x = \<top>)"
  using top_le rsided_bres by blast

lemma rsided_srsided: "rsd x \<Longrightarrow> x \<cdot> x = x \<Longrightarrow> srsd x"
  using bres_sol rsided_bres_eq srsd_def by auto

lemma rsided_prop: "rsd x \<Longrightarrow> x \<cdot> y \<le> x"
  by (simp add: bres_galois rsided_bres_eq)

lemma lsided_top: "lsd \<top>"
  by (simp add: lsd_def)

lemma lsided_bot: "lsd \<bottom>"
  by (simp add: lsd_def)

lemma rsided_top: "rsd \<top>"
  by (simp add: rsd_def)

lemma rsided_bot: "rsd \<bottom>"
  by (simp add: rsd_def)

end

text \<open>Right-sided elements are henceforth not considered. Their properties arise by opposition
duality, which is not formalised.\<close>

text \<open>The following functions have left-sided elements as fixpoints.\<close>

definition lsl:: "'a::quantale \<Rightarrow> 'a" ("\<nu>") where
  "\<nu> x = \<top> \<cdot> x"

definition lsu :: "'a::quantale \<Rightarrow> 'a" ("\<nu>\<^sup>\<natural>") where
  "\<nu>\<^sup>\<natural> x = \<top> \<rightarrow> x"

text \<open>These functions are adjoints.\<close>

lemma ls_galois: "\<nu> \<stileturn> \<nu>\<^sup>\<natural>"
  by (simp add: adj_def bres_galois lsl_def lsu_def)

text \<open>Due to this, the following properties hold.\<close>

lemma lsl_iso: "mono \<nu>"
  using adj_iso1 ls_galois by blast

lemma lsl_iso_var: "x \<le> y \<Longrightarrow> \<nu> x \<le> \<nu> y"
  by (simp add: lsl_iso monoD)

lemma lsu_iso: "mono \<nu>\<^sup>\<natural>"
  using adj_iso2 ls_galois by blast

lemma lsu_iso_var: "x \<le> y \<Longrightarrow> \<nu>\<^sup>\<natural> x \<le> \<nu>\<^sup>\<natural> y"
  by (simp add: lsu_iso monoD)

lemma lsl_bot [simp]: "\<nu> \<bottom> = \<bottom>"
  by (simp add: lsl_def)

lemma lsu_top [simp]: "\<nu>\<^sup>\<natural> \<top> = \<top>"
  by (simp add: lsu_def bres_galois_imp top_le)

lemma lsu_Inf_pres: "Inf_pres \<nu>\<^sup>\<natural>"
  unfolding fun_eq_iff by (metis ls_galois radj_Inf_pres)

lemma lsl_Sup_pres: "Sup_pres (\<nu>::'a::quantale \<Rightarrow> 'a)"
  by (simp add: fun_eq_iff, metis SUP_cong Sup_distl lsl_def)

lemma lsu_Inf_closed: "Inf_closed_set (range \<nu>\<^sup>\<natural>)"
  by (simp add: Inf_pres_Inf_closed lsu_Inf_pres)

lemma lsl_Sup_closed: "Sup_closed_set (range (\<nu>::'a::quantale \<Rightarrow> 'a))"
  by (simp add: Sup_pres_Sup_closed lsl_Sup_pres)

lemma lsl_lsu_canc1: "\<nu> \<circ> \<nu>\<^sup>\<natural> \<le> id"
  by (simp add: adj_cancel1 ls_galois)

lemma lsl_lsu_canc2: "id \<le> \<nu>\<^sup>\<natural> \<circ> \<nu>"
  by (simp add: adj_cancel2 ls_galois)

lemma clop_lsu_lsl: "clop (\<nu>\<^sup>\<natural> \<circ> \<nu>)"
  by (simp add: clop_adj ls_galois)

lemma coclop_lsl_lsu: "coclop (\<nu> \<circ> \<nu>\<^sup>\<natural>)"
  by (simp add: coclop_adj ls_galois)

lemma dang1: "\<nu> (\<nu> x \<sqinter> y) \<le> \<nu> x"
  unfolding lsl_def by (metis bres_galois bres_interchange bres_top_top inf.coboundedI1)

lemma lsl_trans: "\<nu> \<circ> \<nu> \<le> \<nu>"
  unfolding lsl_def fun_eq_iff comp_def
  by (metis (no_types, lifting) bres_galois bres_interchange bres_top_top le_funI)

lemma lsl_lsu_prop: "\<nu> \<circ> \<nu>\<^sup>\<natural> \<le> \<nu>\<^sup>\<natural>"
  unfolding le_fun_def comp_def
  by (metis adj_def dang1 dual_order.trans le_iff_inf ls_galois order_refl top_greatest)

lemma lsu_lsl_prop: "\<nu> \<le> \<nu>\<^sup>\<natural> \<circ> \<nu>"
  unfolding le_fun_def comp_def by (metis adj_def comp_def le_fun_def ls_galois lsl_trans)

context unital_quantale
begin

text \<open>Left-sidedness and strict left-sidedness now coincide.\<close>

lemma lsided_eq: "lsd = slsd"
  unfolding fun_eq_iff by (simp add: eq_iff le_top lsd_def slsd_def)

lemma lsided_eq_var1:  "(x \<le> \<top> \<rightarrow> x) = (x = \<top> \<rightarrow> x)"
  using bres_galois dual_order.trans eq_iff le_top by blast

lemma lsided_eq_var2: "lsd x = (x = \<top> \<rightarrow> x)"
  using bres_galois lsided_eq lsided_eq_var1 lsd_def by simp

end

lemma lsided_def3: "(\<nu> (x::'a::unital_quantale) = x) = (\<nu>\<^sup>\<natural> x = x)"
  unfolding lsl_def lsu_def by (metis lsided_eq lsided_eq_var2 slsd_def)

lemma Fix_lsl_lsu: "Fix (\<nu>::'a::unital_quantale \<Rightarrow> 'a) = Fix \<nu>\<^sup>\<natural>"
  unfolding Fix_def by (simp add: lsided_def3)

lemma Fix_lsl_left_slsided: "Fix \<nu> = {(x::'a::unital_quantale). lsd x}"
  unfolding Fix_def lsl_def lsd_def using eq_iff le_top by blast

lemma Fix_lsl_iff [simp]: "(x \<in> Fix \<nu>) = (\<nu> x = x)"
  by (simp add: Fix_def)

lemma lsl_lsu_prop_eq [simp]: "(\<nu>::'a::unital_quantale \<Rightarrow> 'a) \<circ> \<nu>\<^sup>\<natural> = \<nu>\<^sup>\<natural>"
  by (smt antisym clop_extensive_var clop_lsu_lsl comp_apply le_fun_def lsided_eq_var1 lsl_lsu_prop lsu_def lsu_lsl_prop)

lemma lsu_lsl_prop_eq [simp]: "\<nu>\<^sup>\<natural> \<circ> \<nu> = (\<nu>::'a::unital_quantale \<Rightarrow> 'a)"
  by (metis adj_cancel_eq1 ls_galois lsl_lsu_prop_eq)

subsection \<open>Connection with Closure and Coclosure Operators, Nuclei and Conuclei\<close>

text \<open>lsl is therefore a closure operator, lsu a cocolosure operator.\<close>

lemma lsl_clop: "clop (\<nu>::'a::unital_quantale \<Rightarrow> 'a)"
  by (metis clop_lsu_lsl lsu_lsl_prop_eq)

lemma lsu_coclop: "coclop (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a)"
  by (metis coclop_lsl_lsu lsl_lsu_prop_eq)

lemma lsl_range_fix: "range (\<nu>::'a::unital_quantale \<Rightarrow> 'a) = Fix \<nu>"
  by (simp add: clop_closure_set lsl_clop)

lemma lsu_range_fix: "range (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a) = Fix \<nu>\<^sup>\<natural>"
  by (simp add: coclop_coclosure_set lsu_coclop)

lemma range_lsl_iff [simp]: "((x::'a::unital_quantale) \<in> range \<nu>) = (\<nu> x = x)"
  by (simp add: lsl_range_fix)

lemma range_lsu_iff [simp]: "((x::'a::unital_quantale) \<in> range \<nu>\<^sup>\<natural>) = (\<nu>\<^sup>\<natural> x = x)"
  by (simp add: lsu_range_fix)

text \<open>lsl and lsu are therefore both Sup and Inf closed.\<close>

lemma lsu_Sup_closed: "Sup_closed_set (Fix (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a))"
  by (metis Fix_lsl_lsu lsl_Sup_closed lsl_range_fix)

lemma lsl_Inf_closed: "Inf_closed_set (Fix (\<nu>::'a::unital_quantale \<Rightarrow> 'a))"
  by (metis Fix_lsl_lsu lsu_Inf_closed lsu_range_fix)

text \<open>lsl is even a quantic conucleus.\<close>

lemma lsu_lax: "\<nu>\<^sup>\<natural> (x::'a::unital_quantale) \<cdot> \<nu>\<^sup>\<natural> y \<le> \<nu>\<^sup>\<natural> (x \<cdot> y)"
  unfolding lsu_def by (meson bres_canc1 bres_galois bres_interchange le_top order_trans)

lemma lsu_one: "\<nu>\<^sup>\<natural> 1 \<le> (1::'a::unital_quantale)"
  unfolding lsu_def using bres_canc1 dual_order.trans le_top by blast

lemma lsl_one: "1 \<le> \<nu> (1::'a::unital_quantale)"
  unfolding lsl_def by simp

lemma lsu_conuc: "conucleus (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a)"
  by (simp add: lsu_coclop conucleus_def lsu_lax)

text \<open>It is therefore closed under composition.\<close>

lemma lsu_comp_closed_var [simp]: "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<cdot> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> x \<cdot> \<nu>\<^sup>\<natural> (y::'a::unital_quantale)"
  by (simp add: conuc_comp_closed lsu_conuc)

lemma lsu_comp_closed: "comp_closed_set (Fix (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a))"
  by (simp add: conuc_Sup_qclosed lsu_conuc)

text \<open>lsl is not a quantic nucleus unless composition is commutative.\<close>

lemma "\<nu> x \<cdot> \<nu> y \<le> \<nu> (x \<cdot> (y::'a::unital_quantale))" (*nitpick*)
  oops

text \<open>Yet it is closed under composition (because the set of fixpoints are the same).\<close>

lemma lsl_comp_closed: "comp_closed_set (Fix (\<nu>::'a::unital_quantale \<Rightarrow> 'a))"
  by (simp add: Fix_lsl_lsu lsu_comp_closed)

lemma lsl_comp_closed_var [simp]: "\<nu> (\<nu> x \<cdot> \<nu> (y::'a::unital_quantale)) = \<nu> x \<cdot> \<nu> y"
  by (metis Fix_lsl_iff lsl_def lsl_range_fix mult.assoc rangeI)

text \<open>The following simple properties go beyond nuclei and conuclei.\<close>

lemma lsl_lsu_ran: "range \<nu>\<^sup>\<natural> = range (\<nu>::'a::unital_quantale \<Rightarrow> 'a)"
  by (simp add: Fix_lsl_lsu lsl_range_fix lsu_range_fix)

lemma lsl_top [simp]: "\<nu> \<top> = (\<top>::'a::unital_quantale)"
  by (simp add: clop_top lsl_clop)

lemma lsu_bot [simp]: "\<nu>\<^sup>\<natural> \<bottom> = (\<bottom>::'a::unital_quantale)"
  using lsided_def3 lsl_bot by blast

lemma lsu_inj_on: "inj_on \<nu>\<^sup>\<natural> (Fix (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a))"
  by (metis coclop_coclosure inj_onI lsu_coclop lsu_range_fix)

lemma lsl_inj_on: "inj_on \<nu> (Fix (\<nu>::'a::unital_quantale \<Rightarrow> 'a))"
  by (metis clop_closure inj_onI lsl_clop lsl_range_fix)

text \<open>Additional preservation properties of lsl and lsu are useful in proofs.\<close>

lemma lsl_Inf_closed_var [simp]: "\<nu> (\<Sqinter>x \<in> X. \<nu> x) = (\<Sqinter>x \<in> X.  \<nu> (x::'a::unital_quantale))"
  by (metis (no_types, hide_lams) INF_image lsided_def3 lsu_Inf_pres lsu_lsl_prop_eq o_apply)

lemma lsl_Sup_closed_var [simp]: "\<nu> (\<Squnion>x \<in> X. \<nu> x) = (\<Squnion>x \<in> X. \<nu> (x::'a::unital_quantale))"
  unfolding lsl_def by (metis Sup_distl mult.assoc top_times_top)

lemma lsu_Inf_closed_var [simp]: "\<nu>\<^sup>\<natural> (\<Sqinter>x \<in> X. \<nu>\<^sup>\<natural> x) = (\<Sqinter>x \<in> X. \<nu>\<^sup>\<natural> (x::'a::unital_quantale))"
  by (metis INF_image lsided_def3 lsl_Inf_closed_var lsl_lsu_prop_eq)

lemma lsu_Sup_closed_var [simp]: "\<nu>\<^sup>\<natural> (\<Squnion>x \<in> X. \<nu>\<^sup>\<natural> x) = (\<Squnion>x \<in> X. \<nu>\<^sup>\<natural> (x::'a::unital_quantale))"
  by (metis SUP_image lsided_def3 lsl_Sup_closed_var lsl_lsu_prop_eq)

lemma lsl_inf_closed_var [simp]: "\<nu> (\<nu> x \<sqinter> \<nu> y) = \<nu> (x::'a::unital_quantale) \<sqinter> \<nu> y"
  by (smt antisym clop_extensive_var dang1 inf_sup_aci(1) le_inf_iff lsl_clop)

lemma lsl_sup_closed_var [simp]: "\<nu> (\<nu> x \<squnion> \<nu> y) = \<nu> (x::'a::unital_quantale) \<squnion> \<nu> y"
  by (meson Sup_sup_closed lsl_Sup_closed range_eqI range_lsl_iff sup_closed_set_def)

lemma lsu_inf_closed_var [simp]: "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<sqinter> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> (x::'a::unital_quantale) \<sqinter> \<nu>\<^sup>\<natural> y"
  by (metis (no_types, lifting) lsided_def3 lsl_inf_closed_var lsl_lsu_prop_eq o_apply)

lemma lsu_sup_closed_var [simp]: "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<squnion> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> (x::'a::unital_quantale) \<squnion> \<nu>\<^sup>\<natural> y"
  by (metis (no_types, lifting) lsided_def3 lsl_lsu_prop_eq lsl_sup_closed_var o_def)

lemma lsu_fres_closed [simp]: "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<leftarrow> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> x \<leftarrow> \<nu>\<^sup>\<natural> (y::'a::unital_quantale)"
  unfolding lsu_def by (simp add: bres_curry fres_bres)

lemma lsl_fres_closed [simp]: "\<nu> (\<nu> x \<leftarrow> \<nu> y) = \<nu> x \<leftarrow> \<nu> (y::'a::unital_quantale)"
  unfolding lsl_def by (metis fres_interchange lsd_def lsided_eq mult.assoc slsd_def top_times_top)

lemma lsl_almost_lax: "x \<cdot> \<nu> y \<le> \<nu> (y::'a::unital_quantale)"
  by (metis inf_top.right_neutral lsided_eq lsided_prop lsl_def lsl_inf_closed_var mult.right_neutral slsd_def)

text \<open>Finally, here are two counterexamples.\<close>

lemma "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<rightarrow> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> x \<rightarrow> \<nu>\<^sup>\<natural> (y::'a::unital_quantale)" (*nitpick*)
  oops

lemma "\<nu> (\<nu> x \<rightarrow> \<nu> y) = \<nu> x \<rightarrow> \<nu> (y::'a::unital_quantale)" (*nitpick*)
  oops

context ab_quantale
begin

lemma lsided_times_top: "lsd (\<top> \<cdot> x)"
  by (metis lsd_def mult_isor top_greatest mult_assoc)

lemma lsided_le2: "lsd x \<Longrightarrow> x \<cdot> y \<le> x \<sqinter> (y \<cdot> \<top>)"
  using lsided_prop psrpq.mult_isol mult_commute by auto

lemma lsided_le3: "lsd x \<Longrightarrow> (x \<sqinter> y) \<cdot> z \<le> x"
  by (metis inf_le1 lsided_prop mult_isol order_trans mult_commute)

lemma lsided_le4: "lsd x \<Longrightarrow> (x \<sqinter> y) \<cdot> z \<le> x \<sqinter> (y \<cdot> z)"
  by (simp add: mult_isor lsided_le3)

lemma lsided_times_le_inf: "lsd x \<Longrightarrow> lsd y \<Longrightarrow> x \<cdot> y \<le> x \<sqinter> y"
  using lsided_prop lsided_le2 by force

end

text \<open>Now lsl is a quantic nucleus.\<close>

lemma lsl_lax: "\<nu> x \<cdot> \<nu> y \<le> \<nu> (x \<cdot> (y::'aa::ab_unital_quantale))"
  by (metis (no_types, hide_lams) lsl_almost_lax lsl_def mult.commute mult.left_commute)

lemma lsl_nuc: "nucleus (\<nu>::'a::ab_unital_quantale \<Rightarrow> 'a)"
  by (simp add: lsl_clop nucleus_def lsl_lax)

text \<open>The following properties go beyond nuclei.\<close>

lemma lsl_comp_pres: "\<nu> (x \<cdot> y) = \<nu> x \<cdot> \<nu> (y::'a::ab_unital_quantale)"
  by (metis (no_types, lifting) lsl_comp_closed_var lsl_nuc nuc_prop1 nuc_prop2)

lemma lsl_bres_closed [simp]: "\<nu> (\<nu> x \<rightarrow> \<nu> y) = \<nu> x \<rightarrow> \<nu> (y::'a::ab_unital_quantale)"
  by (simp add: lsl_nuc nuc_bres_closed)

lemma lsu_bres_pres [simp]: "\<nu>\<^sup>\<natural> (\<nu>\<^sup>\<natural> x \<rightarrow> \<nu>\<^sup>\<natural> y) = \<nu>\<^sup>\<natural> x \<rightarrow> \<nu>\<^sup>\<natural> (y::'a::ab_unital_quantale)"
  by (simp add: bres_fres_eq)

lemma lsl_prelocalic_var: "\<nu> x \<cdot> y \<le> \<nu> x \<sqinter> \<nu> (y::'a::ab_unital_quantale)"
  by (metis inf_top.right_neutral lsided_le4 lsided_times_top lsl_def)

lemma dang3: "(\<nu> x \<sqinter> y) \<cdot> z \<le> \<nu> x \<sqinter> (y \<cdot> (z::'a::ab_unital_quantale))"
  by (metis lsided_le4 lsided_times_top lsl_def)

lemma lsl_prelocalic: "\<nu> x \<cdot> \<nu> y \<le> \<nu> x \<sqinter> \<nu> (y::'a::ab_unital_quantale)"
  by (metis lsided_times_le_inf lsided_times_top lsl_def)

lemma lsl_local: "x \<cdot> \<nu> y \<le> \<nu> (x \<cdot> (y::'a::ab_unital_quantale))"
  by (simp add: lsl_def mult.left_commute)

text \<open>Relative pseudocomplementation can be defined on the subquantale induced by lsu.\<close>

definition "rpc x y = \<nu>\<^sup>\<natural> (-x \<squnion> (y::'a::bool_unital_quantale))"

lemma lsl_rpc [simp]: "\<nu> (rpc x y) = rpc x y"
  by (metis lsl_lsu_prop_eq o_apply rpc_def)

lemma lsu_rpc [simp]: "\<nu>\<^sup>\<natural> (rpc x y) = rpc x y"
  using lsided_def3 lsl_rpc by blast

lemma lsl_rpc_galois: "(x \<sqinter> \<nu> z \<le> y) = (z \<le> rpc x (y::'a::bool_unital_quantale))"
  unfolding rpc_def by (metis adj_def inf_commute ls_galois shunt1)

lemma lsl_rpc_galois_var: "x \<sqinter> \<nu> z \<le> y \<longleftrightarrow> \<nu> z \<le> rpc x y"
  by (metis adj_def ls_galois lsl_rpc_galois lsu_rpc)

lemma rpc_expl_aux: "\<Squnion>{z. x \<sqinter> \<nu> z \<le> y} = \<Squnion>{z. x \<sqinter> z \<le> y \<and> \<nu> z = (z::'a::bool_unital_quantale)}"
proof (rule antisym)
  show "\<Squnion>{z. x \<sqinter> \<nu> z \<le> y} \<le> \<Squnion>{z. x \<sqinter> z \<le> y \<and> \<nu> z = z}"
    apply (rule Sup_mono, safe)
    by (smt lsided_eq lsided_prop lsl_def lsl_lsu_prop_eq lsl_rpc_galois mem_Collect_eq o_apply rpc_def slsd_def)
  show " \<Squnion>{z. x \<sqinter> z \<le> y \<and> \<nu> z = z} \<le> \<Squnion>{z. x \<sqinter> \<nu> z \<le> y}"
     by (simp add: Collect_mono_iff Sup_subset_mono)
 qed

lemma rpc_expl: "rpc x y = \<Squnion>{z. x \<sqinter> z \<le> y \<and> \<nu> z = (z::'a::bool_unital_quantale)}"
proof-
  have "rpc x y = \<Squnion>{z. z \<le> rpc x y}"
    using Sup_atMost atMost_def by metis
  also have "... = \<Squnion>{z. x \<sqinter> \<nu> z \<le> y}"
    using lsl_rpc_galois by metis
  finally show ?thesis
    by (simp add: rpc_expl_aux)
qed

subsection \<open>Non-Preservation and Lack of Closure\<close>

context bool_ab_unital_quantale
begin

text \<open>A few counterexamples deal in particular with lack of closure with respect to boolean complementation.\<close>

lemma "\<nu>\<^sup>\<natural> (x \<cdot> y) = \<nu>\<^sup>\<natural> x \<cdot> \<nu>\<^sup>\<natural> y" (*nitpick    *)
  oops

lemma "\<nu> 1 = 1" (*nitpick*)
  oops

lemma "\<nu>\<^sup>\<natural> x = \<nu> x" (*nitpick*)
  oops

lemma "\<nu>\<^sup>\<natural> (\<Squnion> P) = \<Squnion>{\<nu>\<^sup>\<natural> p |p. p \<in> P}" (*nitpick*)
  oops

lemma "rpc (\<nu>\<^sup>\<natural> x) (\<nu>\<^sup>\<natural> y) = -(\<nu>\<^sup>\<natural> x) \<squnion> (\<nu>\<^sup>\<natural> y)" (*nitpick*)
  oops

lemma "rpc (\<nu> x) (\<nu> y) = -(\<nu> x) \<squnion> (\<nu> y)" (*nitpick*)
  oops

lemma "\<nu> (-(\<nu>\<^sup>\<natural> x) \<squnion> (\<nu>\<^sup>\<natural> y)) = -(\<nu>\<^sup>\<natural> x) \<squnion> (\<nu>\<^sup>\<natural> y)" (*nitpick*)
  oops

lemma "\<nu> (-(\<nu> x) \<squnion> (\<nu> y)) = -(\<nu> x) \<squnion> (\<nu> y)" (*nitpick*)
  oops

lemma  "\<nu> x \<cdot> \<nu> y = \<nu> x \<sqinter> \<nu> y" (*nitpick this rules out localic nuclei.*)
  oops

lemma "\<nu> (- (\<nu> x)) = - (\<nu> x)"  (*nitpick*)
  oops

lemma "\<nu>\<^sup>\<natural> (- (\<nu>\<^sup>\<natural> x)) = - (\<nu>\<^sup>\<natural> x)"  (*nitpick*)
  oops

lemma "\<nu> (- (\<nu> x) \<squnion> (\<nu> y)) = - (\<nu> x) \<squnion> (\<nu> y)"  (*nitpick*)
  oops

lemma "\<nu>\<^sup>\<natural> (- (\<nu>\<^sup>\<natural> x) \<squnion> (\<nu>\<^sup>\<natural> y)) = - (\<nu>\<^sup>\<natural> x) \<squnion> (\<nu>\<^sup>\<natural> y)"  (*nitpick*)
  oops

end

subsection \<open>Properties of Quotient Algebras and Subalgebras\<close>

text \<open>Finally I replay Rosenthal's quotient and subalgebra proofs for nuclei and conuclei in the concrete setting of left-sided elements. Ideally
it should be sufficient to show that lsl is a (quantale with) nucleus and then pick up the quotient algebra proof from the nucleus section. But there is no
way of achieving this, apart from creating a type class for quantales with the lsl operation. This seems bizarre, since lsl is just a definition.
On the other hand, an approach in which interpretations are used instead of instantiations might do the job.\<close>

text \<open>The first proof shows that lsu, as a conucleus, yields a subalgebra.\<close>

typedef (overloaded) 'a lsu_set = "Fix (\<nu>\<^sup>\<natural>::'a::unital_quantale \<Rightarrow> 'a)"
  using Fix_lsu_iff lsu_bot by blast

setup_lifting type_definition_lsu_set

instantiation lsu_set :: (unital_quantale) quantale
begin

lift_definition times_lsu_set :: "'a lsu_set \<Rightarrow> 'a lsu_set \<Rightarrow> 'a lsu_set" is times
  using comp_closed_set_def lsu_comp_closed by blast

lift_definition Inf_lsu_set :: "'a lsu_set set \<Rightarrow> 'a lsu_set" is Inf
  by (metis Fix_lsl_lsu Inf_closed_set_def lsl_Inf_closed subset_eq)

lift_definition  Sup_lsu_set :: "'a lsu_set set \<Rightarrow> 'a lsu_set" is Sup
  using Sup_closed_set_def lsu_Sup_closed subsetI by blast

lift_definition  bot_lsu_set ::  "'a lsu_set" is "\<bottom>"
  by simp

lift_definition sup_lsu_set :: "'a lsu_set \<Rightarrow> 'a lsu_set \<Rightarrow> 'a lsu_set" is sup
  by (metis Fix_lsu_iff lsu_sup_closed_var)

lift_definition top_lsu_set ::  "'a lsu_set" is "\<top>"
  by simp

lift_definition inf_lsu_set :: "'a lsu_set \<Rightarrow> 'a lsu_set \<Rightarrow> 'a lsu_set" is inf
  by (metis Fix_lsu_iff lsu_inf_closed_var)

lift_definition less_eq_lsu_set :: "'a lsu_set \<Rightarrow> 'a lsu_set \<Rightarrow> bool" is less_eq .

lift_definition  less_lsu_set :: "'a lsu_set \<Rightarrow> 'a lsu_set \<Rightarrow> bool" is less .

instance
  by (intro_classes; transfer, simp_all add: mult.assoc Inf_lower Inf_greatest Sup_upper Sup_least less_le_not_le Sup_distr Sup_distl)

end

text \<open>This proof checks simply closure conditions, as one would expect for establishing a subalgebra.\<close>

instance lsu_set :: (bool_ab_unital_quantale) distrib_ab_quantale
  apply (intro_classes; transfer)
   apply (simp add: mult.commute)
  using sup_inf_distrib1 by blast

typedef (overloaded) 'a lsl_set = "range (\<nu>::'a:: unital_quantale \<Rightarrow> 'a)"
  by blast

setup_lifting type_definition_lsl_set

text \<open>The final statement shows that lsu, as a nucleus, yields a quotient algebra.\<close>

instantiation lsl_set :: (ab_unital_quantale) ab_unital_quantale
begin

lift_definition one_lsl_set :: "'a::ab_unital_quantale lsl_set" is "\<nu> 1"
  by blast

lift_definition Inf_lsl_set :: "'a lsl_set set \<Rightarrow> 'a lsl_set" is "\<lambda>X. \<nu> (\<Sqinter>X)"
  by blast

lift_definition Sup_lsl_set :: "'a lsl_set set \<Rightarrow> 'a lsl_set" is "\<lambda>X. \<nu> (\<Squnion>X)"
  by blast

lift_definition bot_lsl_set :: "'a lsl_set" is "\<nu> \<bottom>"
  by blast

lift_definition sup_lsl_set :: "'a lsl_set \<Rightarrow> 'a lsl_set \<Rightarrow> 'a lsl_set" is "\<lambda>x y. \<nu> x \<squnion> \<nu> y"
  by auto (metis lsl_sup_closed_var)

lift_definition   top_lsl_set :: "'a lsl_set" is "\<nu> \<top>"
  by blast

lift_definition  inf_lsl_set :: "'a lsl_set \<Rightarrow> 'a lsl_set \<Rightarrow> 'a lsl_set" is "\<lambda>x y. \<nu> x \<sqinter> \<nu> y"
  by (meson lsl_inf_closed_var range_lsl_iff)

lift_definition less_eq_lsl_set :: "'a lsl_set \<Rightarrow> 'a lsl_set \<Rightarrow> bool" is "\<lambda>x y . \<nu> x \<le> \<nu> y" .

lift_definition less_lsl_set :: "'a lsl_set \<Rightarrow> 'a lsl_set \<Rightarrow> bool" is "\<lambda>x y. \<nu> x \<le> \<nu> y \<and> x \<noteq> y" .

lift_definition   times_lsl_set :: "'a lsl_set \<Rightarrow> 'a lsl_set \<Rightarrow> 'a lsl_set" is "\<lambda> x y. \<nu> (x \<cdot> y)"
  by blast

instance
  apply (standard; transfer)
                      apply (simp add: lsl_local_eq mult.commute mult.left_commute)
                      apply (simp add: mult.commute)
                     apply auto[1]
                    apply fastforce+
                  apply auto[1]
                 apply fastforce+
           apply (metis Inf_lower lsl_iso_var range_lsl_iff)
          apply (metis Inf_greatest lsl_iso_var range_lsl_iff)
         apply (metis Sup_upper lsl_iso_var range_lsl_iff)
        apply (metis Sup_least lsl_iso_var range_lsl_iff)
       apply fastforce+
     apply (smt Sup_distl image_cong lsl_local_eq mult.commute)
    apply (smt Sup_distl image_cong lsl_local_eq mult.commute)
   apply (simp add: lsl_def cong del: image_cong_simp)
  apply (simp add: lsl_local_eq)
  done

end

text \<open>This proof checks preservation properties instead of closure ones.\<close>

end


(*  Title:      HOL/ex/LocaleTest2.thy
    Author:     Clemens Ballarin
    Copyright (c) 2007 by Clemens Ballarin

More regression tests for locales.
Definitions are less natural in FOL, since there is no selection operator.
Hence we do them here in HOL, not in the main test suite for locales,
which is FOL/ex/LocaleTest.thy
*)

section \<open>Test of Locale Interpretation\<close>

theory LocaleTest2
imports Main
begin

section \<open>Interpretation of Defined Concepts\<close>

text \<open>Naming convention for global objects: prefixes D and d\<close>

subsection \<open>Lattices\<close>

text \<open>Much of the lattice proofs are from HOL/Lattice.\<close>

subsubsection \<open>Definitions\<close>

locale dpo =
  fixes le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and antisym [intro]: "[| x \<sqsubseteq> y; y \<sqsubseteq> x |] ==> x = y"
    and trans [trans]: "[| x \<sqsubseteq> y; y \<sqsubseteq> z |] ==> x \<sqsubseteq> z"

begin

theorem circular:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> z; z \<sqsubseteq> x |] ==> x = y & y = z"
  by (blast intro: trans)

definition
  less :: "['a, 'a] => bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y & x ~= y)"

theorem abs_test:
  "op \<sqsubset> = (%x y. x \<sqsubset> y)"
  by simp

definition
  is_inf :: "['a, 'a, 'a] => bool"
  where "is_inf x y i = (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

definition
  is_sup :: "['a, 'a, 'a] => bool"
  where "is_sup x y s = (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

end

locale dlat = dpo +
  assumes ex_inf: "EX inf. dpo.is_inf le x y inf"
    and ex_sup: "EX sup. dpo.is_sup le x y sup"

begin

definition
  meet :: "['a, 'a] => 'a" (infixl "\<sqinter>" 70)
  where "x \<sqinter> y = (THE inf. is_inf x y inf)"

definition
  join :: "['a, 'a] => 'a" (infixl "\<squnion>" 65)
  where "x \<squnion> y = (THE sup. is_sup x y sup)"

lemma is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
  "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
  by (unfold is_inf_def) blast

theorem is_inf_uniq: "is_inf x y i \<Longrightarrow> is_inf x y i' \<Longrightarrow> i = i'"
proof -
  assume inf: "is_inf x y i"
  assume inf': "is_inf x y i'"
  show ?thesis
  proof (rule antisym)
    from inf' show "i \<sqsubseteq> i'"
    proof (rule is_inf_greatest)
      from inf show "i \<sqsubseteq> x" ..
      from inf show "i \<sqsubseteq> y" ..
    qed
    from inf show "i' \<sqsubseteq> i"
    proof (rule is_inf_greatest)
      from inf' show "i' \<sqsubseteq> x" ..
      from inf' show "i' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

lemma meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
proof (unfold meet_def)
  assume "is_inf x y i"
  then show "(THE i. is_inf x y i) = i"
    by (rule the_equality) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meetI [intro?]:
    "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
  by (rule meet_equality, rule is_infI) blast+

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain i where "is_inf x y i" ..
  then show "is_inf x y (THE i. is_inf x y i)"
    by (rule theI) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meet_left [intro?]:
  "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_right [intro?]:
  "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_le [intro?]:
  "[| z \<sqsubseteq> x; z \<sqsubseteq> y |] ==> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

theorem is_sup_uniq: "is_sup x y s \<Longrightarrow> is_sup x y s' \<Longrightarrow> s = s'"
proof -
  assume sup: "is_sup x y s"
  assume sup': "is_sup x y s'"
  show ?thesis
  proof (rule antisym)
    from sup show "s \<sqsubseteq> s'"
    proof (rule is_sup_least)
      from sup' show "x \<sqsubseteq> s'" ..
      from sup' show "y \<sqsubseteq> s'" ..
    qed
    from sup' show "s' \<sqsubseteq> s"
    proof (rule is_sup_least)
      from sup show "x \<sqsubseteq> s" ..
      from sup show "y \<sqsubseteq> s" ..
    qed
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

lemma join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
proof (unfold join_def)
  assume "is_sup x y s"
  then show "(THE s. is_sup x y s) = s"
    by (rule the_equality) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
  by (rule join_equality, rule is_supI) blast+

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain s where "is_sup x y s" ..
  then show "is_sup x y (THE s. is_sup x y s)"
    by (rule theI) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma join_left [intro?]:
  "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_right [intro?]:
  "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_le [intro?]:
  "[| x \<sqsubseteq> z; y \<sqsubseteq> z |] ==> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof (rule meetI)
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof (rule meetI)
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof (rule meetI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof (rule joinI)
  show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof
    show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "y \<sqsubseteq> y \<squnion> z" ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
  qed
  show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof -
    have "z \<sqsubseteq> y \<squnion> z"  ..
    also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    finally show ?thesis .
  qed
  fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
  show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
  proof
    show "x \<sqsubseteq> w"
    proof -
      have "x \<sqsubseteq> x \<squnion> y" ..
      also have "\<dots> \<sqsubseteq> w" by fact
      finally show ?thesis .
    qed
    show "y \<squnion> z \<sqsubseteq> w"
    proof
      show "y \<sqsubseteq> w"
      proof -
        have "y \<sqsubseteq> x \<squnion> y" ..
        also have "... \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "z \<sqsubseteq> w" by fact
    qed
  qed
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof (rule joinI)
  show "x \<sqsubseteq> y \<squnion> x" ..
  show "y \<sqsubseteq> y \<squnion> x" ..
  fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
  then show "y \<squnion> x \<sqsubseteq> z" ..
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof (rule joinI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqinter> y \<sqsubseteq> x" ..
  fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
  show "x \<sqsubseteq> z" by fact
qed

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof (rule meetI)
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
  by (drule meet_related) (simp add: meet_commute)

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof (rule joinI)
  assume "x \<sqsubseteq> y"
  show "y \<sqsubseteq> y" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  show "y \<sqsubseteq> z" by fact
qed

theorem join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  by (drule join_related) (simp add: join_commute)

text \<open>Additional theorems\<close>

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
  using meet_commute meet_connection by simp

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  using join_commute join_connection by simp

text \<open>Naming according to Jacobson I, p.\ 459.\<close>

lemmas L1 = join_commute meet_commute
lemmas L2 = join_assoc meet_assoc
(*lemmas L3 = join_idem meet_idem*)
lemmas L4 = join_meet_absorb meet_join_absorb

end

locale ddlat = dlat +
  assumes meet_distr:
    "dlat.meet le x (dlat.join le y z) =
    dlat.join le (dlat.meet le x y) (dlat.meet le x z)"

begin

lemma join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  txt \<open>Jacobson I, p.\ 462\<close>
proof -
  have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
  also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
  also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
  also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
  also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
  finally show ?thesis .
qed

end

locale dlo = dpo +
  assumes total: "x \<sqsubseteq> y | y \<sqsubseteq> x"

begin

lemma less_total: "x \<sqsubset> y | x = y | y \<sqsubset> x"
  using total
  by (unfold less_def) blast

end

sublocale dlo < dlat
proof
  fix x y
  from total have "is_inf x y (if x \<sqsubseteq> y then x else y)" by (auto simp: is_inf_def)
  then show "EX inf. is_inf x y inf" by blast
next
  fix x y
  from total have "is_sup x y (if x \<sqsubseteq> y then y else x)" by (auto simp: is_sup_def)
  then show "EX sup. is_sup x y sup" by blast
qed

sublocale dlo < ddlat
proof
  fix x y z
  show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
    txt \<open>Jacobson I, p.\ 462\<close>
  proof -
    { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
      from c have "?l = y \<squnion> z"
        by (metis c (*join_commute*) join_connection2 join_related2 (*meet_commute*) meet_connection meet_related2 total)
      also from c have "... = ?r" by (metis (*c*) (*join_commute*) meet_related2)
      finally have "?l = ?r" . }
    moreover
    { assume c: "x \<sqsubseteq> y | x \<sqsubseteq> z"
      from c have "?l = x"
        by (metis (*antisym*) (*c*) (*circular*) (*join_assoc*)(* join_commute *) join_connection2 (*join_left*) join_related2 meet_connection(* meet_related2*) total trans)
      also from c have "... = ?r"
        by (metis join_commute join_related2 meet_connection meet_related2 total)
      finally have "?l = ?r" . }
    moreover note total
    ultimately show ?thesis by blast
  qed
qed

subsubsection \<open>Total order \<open><=\<close> on @{typ int}\<close>

interpretation int: dpo "op <= :: [int, int] => bool"
  rewrites "(dpo.less (op <=) (x::int) y) = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo (op <= :: [int, int] => bool)"
    proof qed auto
  then interpret int: dpo "op <= :: [int, int] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "(dpo.less (op <=) (x::int) y) = (x < y)"
    by (unfold int.less_def) auto
qed

thm int.circular
lemma "\<lbrakk> (x::int) \<le> y; y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> x = y \<and> y = z"
  apply (rule int.circular) apply assumption apply assumption apply assumption done
thm int.abs_test
lemma "(op < :: [int, int] => bool) = op <"
  apply (rule int.abs_test) done

interpretation int: dlat "op <= :: [int, int] => bool"
  rewrites meet_eq: "dlat.meet (op <=) (x::int) y = min x y"
    and join_eq: "dlat.join (op <=) (x::int) y = max x y"
proof -
  show "dlat (op <= :: [int, int] => bool)"
    apply unfold_locales
    apply (unfold int.is_inf_def int.is_sup_def)
    apply arith+
    done
  then interpret int: dlat "op <= :: [int, int] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (op <=) (x::int) y = min x y"
    apply (unfold int.meet_def)
    apply (rule the_equality)
    apply (unfold int.is_inf_def)
    by auto
  show "dlat.join (op <=) (x::int) y = max x y"
    apply (unfold int.join_def)
    apply (rule the_equality)
    apply (unfold int.is_sup_def)
    by auto
qed

interpretation int: dlo "op <= :: [int, int] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm int.less_def text \<open>from dpo\<close>
thm int.meet_left text \<open>from dlat\<close>
thm int.meet_distr text \<open>from ddlat\<close>
thm int.less_total text \<open>from dlo\<close>

subsubsection \<open>Total order \<open><=\<close> on @{typ nat}\<close>

interpretation nat: dpo "op <= :: [nat, nat] => bool"
  rewrites "dpo.less (op <=) (x::nat) y = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo (op <= :: [nat, nat] => bool)"
    proof qed auto
  then interpret nat: dpo "op <= :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (op <=) (x::nat) y = (x < y)"
    apply (unfold nat.less_def)
    apply auto
    done
qed

interpretation nat: dlat "op <= :: [nat, nat] => bool"
  rewrites "dlat.meet (op <=) (x::nat) y = min x y"
    and "dlat.join (op <=) (x::nat) y = max x y"
proof -
  show "dlat (op <= :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat.is_inf_def nat.is_sup_def)
    apply arith+
    done
  then interpret nat: dlat "op <= :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (op <=) (x::nat) y = min x y"
    apply (unfold nat.meet_def)
    apply (rule the_equality)
    apply (unfold nat.is_inf_def)
    by auto
  show "dlat.join (op <=) (x::nat) y = max x y"
    apply (unfold nat.join_def)
    apply (rule the_equality)
    apply (unfold nat.is_sup_def)
    by auto
qed

interpretation nat: dlo "op <= :: [nat, nat] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat.less_def text \<open>from dpo\<close>
thm nat.meet_left text \<open>from dlat\<close>
thm nat.meet_distr text \<open>from ddlat\<close>
thm nat.less_total text \<open>from ldo\<close>

subsubsection \<open>Lattice \<open>dvd\<close> on @{typ nat}\<close>

interpretation nat_dvd: dpo "op dvd :: [nat, nat] => bool"
  rewrites "dpo.less (op dvd) (x::nat) y = (x dvd y & x ~= y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo (op dvd :: [nat, nat] => bool)"
    proof qed (auto simp: dvd_def)
  then interpret nat_dvd: dpo "op dvd :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (op dvd) (x::nat) y = (x dvd y & x ~= y)"
    apply (unfold nat_dvd.less_def)
    apply auto
    done
qed

interpretation nat_dvd: dlat "op dvd :: [nat, nat] => bool"
  rewrites "dlat.meet (op dvd) (x::nat) y = gcd x y"
    and "dlat.join (op dvd) (x::nat) y = lcm x y"
proof -
  show "dlat (op dvd :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat_dvd.is_inf_def nat_dvd.is_sup_def)
    apply (rule_tac x = "gcd x y" in exI)
    apply auto [1]
    apply (rule_tac x = "lcm x y" in exI)
    apply (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
    done
  then interpret nat_dvd: dlat "op dvd :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (op dvd) (x::nat) y = gcd x y"
    apply (unfold nat_dvd.meet_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_inf_def)
    by auto
  show "dlat.join (op dvd) (x::nat) y = lcm x y"
    apply (unfold nat_dvd.join_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_sup_def)
    by (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
qed

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat_dvd.less_def text \<open>from dpo\<close>
lemma "((x::nat) dvd y & x ~= y) = (x dvd y & x ~= y)"
  apply (rule nat_dvd.less_def) done
thm nat_dvd.meet_left text \<open>from dlat\<close>
lemma "gcd x y dvd (x::nat)"
  apply (rule nat_dvd.meet_left) done

subsection \<open>Group example with defined operations \<open>inv\<close> and \<open>unit\<close>\<close>

subsubsection \<open>Locale declarations and lemmas\<close>

locale Dsemi =
  fixes prod (infixl "**" 65)
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"

locale Dmonoid = Dsemi +
  fixes one
  assumes l_one [simp]: "one ** x = x"
    and r_one [simp]: "x ** one = x"

begin

definition
  inv where "inv x = (THE y. x ** y = one & y ** x = one)"
definition
  unit where "unit x = (EX y. x ** y = one  & y ** x = one)"

lemma inv_unique:
  assumes eq: "y ** x = one" "x ** y' = one"
  shows "y = y'"
proof -
  from eq have "y = y ** (x ** y')" by (simp add: r_one)
  also have "... = (y ** x) ** y'" by (simp add: assoc)
  also from eq have "... = y'" by (simp add: l_one)
  finally show ?thesis .
qed

lemma unit_one [intro, simp]:
  "unit one"
  by (unfold unit_def) auto

lemma unit_l_inv_ex:
  "unit x ==> \<exists>y. y ** x = one"
  by (unfold unit_def) auto

lemma unit_r_inv_ex:
  "unit x ==> \<exists>y. x ** y = one"
  by (unfold unit_def) auto

lemma unit_l_inv:
  "unit x ==> inv x ** x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_r_inv:
  "unit x ==> x ** inv x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_inv_unit [intro, simp]:
  "unit x ==> unit (inv x)"
proof -
  assume x: "unit x"
  show "unit (inv x)"
    by (auto simp add: unit_def
      intro: unit_l_inv unit_r_inv x)
qed

lemma unit_l_cancel [simp]:
  "unit x ==> (x ** y = x ** z) = (y = z)"
proof
  assume eq: "x ** y = x ** z"
    and G: "unit x"
  then have "(inv x ** x) ** y = (inv x ** x) ** z"
    by (simp add: assoc)
  with G show "y = z" by (simp add: unit_l_inv)
next
  assume eq: "y = z"
    and G: "unit x"
  then show "x ** y = x ** z" by simp
qed

lemma unit_inv_inv [simp]:
  "unit x ==> inv (inv x) = x"
proof -
  assume x: "unit x"
  then have "inv x ** inv (inv x) = inv x ** x"
    by (simp add: unit_l_inv unit_r_inv)
  with x show ?thesis by simp
qed

lemma inv_inj_on_unit:
  "inj_on inv {x. unit x}"
proof (rule inj_onI, simp)
  fix x y
  assume G: "unit x"  "unit y" and eq: "inv x = inv y"
  then have "inv (inv x) = inv (inv y)" by simp
  with G show "x = y" by simp
qed

lemma unit_inv_comm:
  assumes inv: "x ** y = one"
    and G: "unit x"  "unit y"
  shows "y ** x = one"
proof -
  from G have "x ** y ** x = x ** one" by (auto simp add: inv)
  with G show ?thesis by (simp del: r_one add: assoc)
qed

end

locale Dgrp = Dmonoid +
  assumes unit [intro, simp]: "Dmonoid.unit (op **) one x"

begin

lemma l_inv_ex [simp]:
  "\<exists>y. y ** x = one"
  using unit_l_inv_ex by simp

lemma r_inv_ex [simp]:
  "\<exists>y. x ** y = one"
  using unit_r_inv_ex by simp

lemma l_inv [simp]:
  "inv x ** x = one"
  using unit_l_inv by simp

lemma l_cancel [simp]:
  "(x ** y = x ** z) = (y = z)"
  using unit_l_inv by simp

lemma r_inv [simp]:
  "x ** inv x = one"
proof -
  have "inv x ** (x ** inv x) = inv x ** one"
    by (simp add: assoc [symmetric] l_inv)
  then show ?thesis by (simp del: r_one)
qed

lemma r_cancel [simp]:
  "(y ** x = z ** x) = (y = z)"
proof
  assume eq: "y ** x = z ** x"
  then have "y ** (x ** inv x) = z ** (x ** inv x)"
    by (simp add: assoc [symmetric] del: r_inv)
  then show "y = z" by simp
qed simp

lemma inv_one [simp]:
  "inv one = one"
proof -
  have "inv one = one ** (inv one)" by (simp del: r_inv)
  moreover have "... = one" by simp
  finally show ?thesis .
qed

lemma inv_inv [simp]:
  "inv (inv x) = x"
  using unit_inv_inv by simp

lemma inv_inj:
  "inj_on inv UNIV"
  using inv_inj_on_unit by simp

lemma inv_mult_group:
  "inv (x ** y) = inv y ** inv x"
proof -
  have "inv (x ** y) ** (x ** y) = (inv y ** inv x) ** (x ** y)"
    by (simp add: assoc l_inv) (simp add: assoc [symmetric])
  then show ?thesis by (simp del: l_inv)
qed

lemma inv_comm:
  "x ** y = one ==> y ** x = one"
  by (rule unit_inv_comm) auto

lemma inv_equality:
     "y ** x = one ==> inv x = y"
  apply (simp add: inv_def)
  apply (rule the_equality)
   apply (simp add: inv_comm [of y x])
  apply (rule r_cancel [THEN iffD1], auto)
  done

end

locale Dhom = prod: Dgrp prod one + sum: Dgrp sum zero
    for prod (infixl "**" 65) and one and sum (infixl "+++" 60) and zero +
  fixes hom
  assumes hom_mult [simp]: "hom (x ** y) = hom x +++ hom y"

begin

lemma hom_one [simp]:
  "hom one = zero"
proof -
  have "hom one +++ zero = hom one +++ hom one"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: sum.r_one)
qed

end

subsubsection \<open>Interpretation of Functions\<close>

interpretation Dfun: Dmonoid "op o" "id :: 'a => 'a"
  rewrites "Dmonoid.unit (op o) id f = bij (f::'a => 'a)"
(*    and "Dmonoid.inv (op o) id" = "inv :: ('a => 'a) => ('a => 'a)" *)
proof -
  show "Dmonoid op o (id :: 'a => 'a)" proof qed (simp_all add: o_assoc)
  note Dmonoid = this
(*
  from this interpret Dmonoid "op o" "id :: 'a => 'a" .
*)
  show "Dmonoid.unit (op o) (id :: 'a => 'a) f = bij f"
    apply (unfold Dmonoid.unit_def [OF Dmonoid])
    apply rule apply clarify
  proof -
    fix f g
    assume id1: "f o g = id" and id2: "g o f = id"
    show "bij f"
    proof (rule bijI)
      show "inj f"
      proof (rule inj_onI)
        fix x y
        assume "f x = f y"
        then have "(g o f) x = (g o f) y" by simp
        with id2 show "x = y" by simp
      qed
    next
      show "surj f"
      proof (rule surjI)
        fix x
        from id1 have "(f o g) x = x" by simp
        then show "f (g x) = x" by simp
      qed
    qed
  next
    fix f
    assume bij: "bij f"
    then
    have inv: "f o Hilbert_Choice.inv f = id & Hilbert_Choice.inv f o f = id"
      by (simp add: bij_def surj_iff inj_iff)
    show "EX g. f o g = id & g o f = id" by rule (rule inv)
  qed
qed

thm Dmonoid.unit_def Dfun.unit_def

thm Dmonoid.inv_inj_on_unit Dfun.inv_inj_on_unit

lemma unit_id:
  "(f :: unit => unit) = id"
  by rule simp

interpretation Dfun: Dgrp "op o" "id :: unit => unit"
  rewrites "Dmonoid.inv (op o) id f = inv (f :: unit => unit)"
proof -
  have "Dmonoid op o (id :: 'a => 'a)" ..
  note Dmonoid = this

  show "Dgrp (op o) (id :: unit => unit)"
apply unfold_locales
apply (unfold Dmonoid.unit_def [OF Dmonoid])
apply (insert unit_id)
apply simp
done
  show "Dmonoid.inv (op o) id f = inv (f :: unit => unit)"
apply (unfold Dmonoid.inv_def [OF Dmonoid])
apply (insert unit_id)
apply simp
apply (rule the_equality)
apply rule
apply rule
apply simp
done
qed

thm Dfun.unit_l_inv Dfun.l_inv

thm Dfun.inv_equality
thm Dfun.inv_equality

end


(*  Title:      HOL/Algebra/IntRing.thy
    Author:     Stephan Hohe, TU Muenchen
    Author:     Clemens Ballarin
*)

theory IntRing
imports QuotRing Lattice Int "~~/src/HOL/Number_Theory/Primes"
begin

section {* The Ring of Integers *}

subsection {* Some properties of @{typ int} *}

lemma dvds_eq_abseq:
  fixes k :: int
  shows "l dvd k \<and> k dvd l \<longleftrightarrow> abs l = abs k"
apply rule
 apply (simp add: zdvd_antisym_abs)
apply (simp add: dvd_if_abs_eq)
done

subsection {* @{text "\<Z>"}: The Set of Integers as Algebraic Structure *}

abbreviation int_ring :: "int ring" ("\<Z>")
  where "int_ring \<equiv> \<lparr>carrier = UNIV, mult = op *, one = 1, zero = 0, add = op +\<rparr>"

lemma int_Zcarr [intro!, simp]: "k \<in> carrier \<Z>"
  by simp

lemma int_is_cring: "cring \<Z>"
apply (rule cringI)
  apply (rule abelian_groupI, simp_all)
  defer 1
  apply (rule comm_monoidI, simp_all)
 apply (rule distrib_right)
apply (fast intro: left_minus)
done

(*
lemma int_is_domain:
  "domain \<Z>"
apply (intro domain.intro domain_axioms.intro)
  apply (rule int_is_cring)
 apply (unfold int_ring_def, simp+)
done
*)

subsection {* Interpretations *}

text {* Since definitions of derived operations are global, their
  interpretation needs to be done as early as possible --- that is,
  with as few assumptions as possible. *}

interpretation int: monoid \<Z>
  where "carrier \<Z> = UNIV"
    and "mult \<Z> x y = x * y"
    and "one \<Z> = 1"
    and "pow \<Z> x n = x^n"
proof -
  -- "Specification"
  show "monoid \<Z>" by default auto
  then interpret int: monoid \<Z> .

  -- "Carrier"
  show "carrier \<Z> = UNIV" by simp

  -- "Operations"
  { fix x y show "mult \<Z> x y = x * y" by simp }
  show "one \<Z> = 1" by simp
  show "pow \<Z> x n = x^n" by (induct n) simp_all
qed

interpretation int: comm_monoid \<Z>
  where "finprod \<Z> f A = (if finite A then setprod f A else undefined)"
proof -
  -- "Specification"
  show "comm_monoid \<Z>" by default auto
  then interpret int: comm_monoid \<Z> .

  -- "Operations"
  { fix x y have "mult \<Z> x y = x * y" by simp }
  note mult = this
  have one: "one \<Z> = 1" by simp
  show "finprod \<Z> f A = (if finite A then setprod f A else undefined)"
  proof (cases "finite A")
    case True
    then show ?thesis
    proof induct
      case empty
      show ?case by (simp add: one)
    next
      case insert
      then show ?case by (simp add: Pi_def mult)
    qed
  next
    case False
    then show ?thesis by (simp add: finprod_def)
  qed
qed

interpretation int: abelian_monoid \<Z>
  where int_carrier_eq: "carrier \<Z> = UNIV"
    and int_zero_eq: "zero \<Z> = 0"
    and int_add_eq: "add \<Z> x y = x + y"
    and int_finsum_eq: "finsum \<Z> f A = (if finite A then setsum f A else undefined)"
proof -
  -- "Specification"
  show "abelian_monoid \<Z>" by default auto
  then interpret int: abelian_monoid \<Z> .

  -- "Carrier"
  show "carrier \<Z> = UNIV" by simp

  -- "Operations"
  { fix x y show "add \<Z> x y = x + y" by simp }
  note add = this
  show zero: "zero \<Z> = 0"
    by simp
  show "finsum \<Z> f A = (if finite A then setsum f A else undefined)"
  proof (cases "finite A")
    case True
    then show ?thesis
    proof induct
      case empty
      show ?case by (simp add: zero)
    next
      case insert
      then show ?case by (simp add: Pi_def add)
    qed
  next
    case False
    then show ?thesis by (simp add: finsum_def finprod_def)
  qed
qed

interpretation int: abelian_group \<Z>
  (* The equations from the interpretation of abelian_monoid need to be repeated.
     Since the morphisms through which the abelian structures are interpreted are
     not the identity, the equations of these interpretations are not inherited. *)
  (* FIXME *)
  where "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = (if finite A then setsum f A else undefined)"
    and int_a_inv_eq: "a_inv \<Z> x = - x"
    and int_a_minus_eq: "a_minus \<Z> x y = x - y"
proof -
  -- "Specification"
  show "abelian_group \<Z>"
  proof (rule abelian_groupI)
    fix x
    assume "x \<in> carrier \<Z>"
    then show "\<exists>y \<in> carrier \<Z>. y \<oplus>\<^bsub>\<Z>\<^esub> x = \<zero>\<^bsub>\<Z>\<^esub>"
      by simp arith
  qed auto
  then interpret int: abelian_group \<Z> .
  -- "Operations"
  { fix x y have "add \<Z> x y = x + y" by simp }
  note add = this
  have zero: "zero \<Z> = 0" by simp
  {
    fix x
    have "add \<Z> (- x) x = zero \<Z>"
      by (simp add: add zero)
    then show "a_inv \<Z> x = - x"
      by (simp add: int.minus_equality)
  }
  note a_inv = this
  show "a_minus \<Z> x y = x - y"
    by (simp add: int.minus_eq add a_inv)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq)+

interpretation int: "domain" \<Z>
  where "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = (if finite A then setsum f A else undefined)"
    and "a_inv \<Z> x = - x"
    and "a_minus \<Z> x y = x - y"
proof -
  show "domain \<Z>"
    by unfold_locales (auto simp: distrib_right distrib_left)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq int_a_inv_eq int_a_minus_eq)+

text {* Removal of occurrences of @{term UNIV} in interpretation result
  --- experimental. *}

lemma UNIV:
  "x \<in> UNIV \<longleftrightarrow> True"
  "A \<subseteq> UNIV \<longleftrightarrow> True"
  "(\<forall>x \<in> UNIV. P x) \<longleftrightarrow> (\<forall>x. P x)"
  "(EX x : UNIV. P x) \<longleftrightarrow> (EX x. P x)"
  "(True \<longrightarrow> Q) \<longleftrightarrow> Q"
  "(True \<Longrightarrow> PROP R) \<equiv> PROP R"
  by simp_all

interpretation int (* FIXME [unfolded UNIV] *) :
  partial_order "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  where "carrier \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> = UNIV"
    and "le \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x \<le> y)"
    and "lless \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x < y)"
proof -
  show "partial_order \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
    by default simp_all
  show "carrier \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> = UNIV"
    by simp
  show "le \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x \<le> y)"
    by simp
  show "lless \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = (x < y)"
    by (simp add: lless_def) auto
qed

interpretation int (* FIXME [unfolded UNIV] *) :
  lattice "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  where "join \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = max x y"
    and "meet \<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr> x y = min x y"
proof -
  let ?Z = "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  show "lattice ?Z"
    apply unfold_locales
    apply (simp add: least_def Upper_def)
    apply arith
    apply (simp add: greatest_def Lower_def)
    apply arith
    done
  then interpret int: lattice "?Z" .
  show "join ?Z x y = max x y"
    apply (rule int.joinI)
    apply (simp_all add: least_def Upper_def)
    apply arith
    done
  show "meet ?Z x y = min x y"
    apply (rule int.meetI)
    apply (simp_all add: greatest_def Lower_def)
    apply arith
    done
qed

interpretation int (* [unfolded UNIV] *) :
  total_order "\<lparr>carrier = UNIV::int set, eq = op =, le = op \<le>\<rparr>"
  by default clarsimp

subsection {* Generated Ideals of @{text "\<Z>"} *}

lemma int_Idl: "Idl\<^bsub>\<Z>\<^esub> {a} = {x * a | x. True}"
  apply (subst int.cgenideal_eq_genideal[symmetric]) apply simp
  apply (simp add: cgenideal_def)
  done

lemma multiples_principalideal: "principalideal {x * a | x. True } \<Z>"
  by (metis UNIV_I int.cgenideal_eq_genideal int.cgenideal_is_principalideal int_Idl)

lemma prime_primeideal:
  assumes prime: "prime p"
  shows "primeideal (Idl\<^bsub>\<Z>\<^esub> {p}) \<Z>"
apply (rule primeidealI)
   apply (rule int.genideal_ideal, simp)
  apply (rule int_is_cring)
 apply (simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def)
 apply clarsimp defer 1
 apply (simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def)
 apply (elim exE)
proof -
  fix a b x
  assume "a * b = x * int p"
  then have "p dvd a * b" by simp
  then have "p dvd a \<or> p dvd b"
    by (metis prime prime_dvd_mult_eq_int)
  then show "(\<exists>x. a = x * int p) \<or> (\<exists>x. b = x * int p)"
    by (metis dvd_def mult.commute)
next
  assume "UNIV = {uu. EX x. uu = x * int p}"
  then obtain x where "1 = x * int p" by best
  then have "\<bar>int p * x\<bar> = 1" by (simp add: mult.commute)
  then show False
    by (metis abs_of_nat int_1 of_nat_eq_iff abs_zmult_eq_1 one_not_prime_nat prime)
qed

subsection {* Ideals and Divisibility *}

lemma int_Idl_subset_ideal: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} = (k \<in> Idl\<^bsub>\<Z>\<^esub> {l})"
  by (rule int.Idl_subset_ideal') simp_all

lemma Idl_subset_eq_dvd: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> l dvd k"
  apply (subst int_Idl_subset_ideal, subst int_Idl, simp)
  apply (rule, clarify)
  apply (simp add: dvd_def)
  apply (simp add: dvd_def ac_simps)
  done

lemma dvds_eq_Idl: "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
proof -
  have a: "l dvd k \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l})"
    by (rule Idl_subset_eq_dvd[symmetric])
  have b: "k dvd l \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k})"
    by (rule Idl_subset_eq_dvd[symmetric])

  have "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k}"
    by (subst a, subst b, simp)
  also have "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k} \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
    by blast
  finally show ?thesis .
qed

lemma Idl_eq_abs: "Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> abs l = abs k"
  apply (subst dvds_eq_abseq[symmetric])
  apply (rule dvds_eq_Idl[symmetric])
  done

subsection {* Ideals and the Modulus *}

definition ZMod :: "int \<Rightarrow> int \<Rightarrow> int set"
  where "ZMod k r = (Idl\<^bsub>\<Z>\<^esub> {k}) +>\<^bsub>\<Z>\<^esub> r"

lemmas ZMod_defs =
  ZMod_def genideal_def

lemma rcos_zfact:
  assumes kIl: "k \<in> ZMod l r"
  shows "\<exists>x. k = x * l + r"
proof -
  from kIl[unfolded ZMod_def] have "\<exists>xl\<in>Idl\<^bsub>\<Z>\<^esub> {l}. k = xl + r"
    by (simp add: a_r_coset_defs)
  then obtain xl where xl: "xl \<in> Idl\<^bsub>\<Z>\<^esub> {l}" and k: "k = xl + r"
    by auto
  from xl obtain x where "xl = x * l"
    by (auto simp: int_Idl)
  with k have "k = x * l + r"
    by simp
  then show "\<exists>x. k = x * l + r" ..
qed

lemma ZMod_imp_zmod:
  assumes zmods: "ZMod m a = ZMod m b"
  shows "a mod m = b mod m"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  from zmods have "b \<in> ZMod m a"
    unfolding ZMod_def by (simp add: a_repr_independenceD)
  then have "\<exists>x. b = x * m + a"
    by (rule rcos_zfact)
  then obtain x where "b = x * m + a"
    by fast
  then have "b mod m = (x * m + a) mod m"
    by simp
  also have "\<dots> = ((x * m) mod m) + (a mod m)"
    by (simp add: mod_add_eq)
  also have "\<dots> = a mod m"
    by simp
  finally have "b mod m = a mod m" .
  then show "a mod m = b mod m" ..
qed

lemma ZMod_mod: "ZMod m a = ZMod m (a mod m)"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  show ?thesis
    unfolding ZMod_def
    apply (rule a_repr_independence'[symmetric])
    apply (simp add: int_Idl a_r_coset_defs)
  proof -
    have "a = m * (a div m) + (a mod m)"
      by (simp add: zmod_zdiv_equality)
    then have "a = (a div m) * m + (a mod m)"
      by simp
    then show "\<exists>h. (\<exists>x. h = x * m) \<and> a = h + a mod m"
      by fast
  qed simp
qed

lemma zmod_imp_ZMod:
  assumes modeq: "a mod m = b mod m"
  shows "ZMod m a = ZMod m b"
proof -
  have "ZMod m a = ZMod m (a mod m)"
    by (rule ZMod_mod)
  also have "\<dots> = ZMod m (b mod m)"
    by (simp add: modeq[symmetric])
  also have "\<dots> = ZMod m b"
    by (rule ZMod_mod[symmetric])
  finally show ?thesis .
qed

corollary ZMod_eq_mod: "ZMod m a = ZMod m b \<longleftrightarrow> a mod m = b mod m"
  apply (rule iffI)
  apply (erule ZMod_imp_zmod)
  apply (erule zmod_imp_ZMod)
  done

subsection {* Factorization *}

definition ZFact :: "int \<Rightarrow> int set ring"
  where "ZFact k = \<Z> Quot (Idl\<^bsub>\<Z>\<^esub> {k})"

lemmas ZFact_defs = ZFact_def FactRing_def

lemma ZFact_is_cring: "cring (ZFact k)"
  apply (unfold ZFact_def)
  apply (rule ideal.quotient_is_cring)
   apply (intro ring.genideal_ideal)
    apply (simp add: cring.axioms[OF int_is_cring] ring.intro)
   apply simp
  apply (rule int_is_cring)
  done

lemma ZFact_zero: "carrier (ZFact 0) = (\<Union>a. {{a}})"
  apply (insert int.genideal_zero)
  apply (simp add: ZFact_defs A_RCOSETS_defs r_coset_def)
  done

lemma ZFact_one: "carrier (ZFact 1) = {UNIV}"
  apply (simp only: ZFact_defs A_RCOSETS_defs r_coset_def ring_record_simps)
  apply (subst int.genideal_one)
  apply (rule, rule, clarsimp)
   apply (rule, rule, clarsimp)
   apply (rule, clarsimp, arith)
  apply (rule, clarsimp)
  apply (rule exI[of _ "0"], clarsimp)
  done

lemma ZFact_prime_is_domain:
  assumes pprime: "prime p"
  shows "domain (ZFact p)"
  apply (unfold ZFact_def)
  apply (rule primeideal.quotient_is_domain)
  apply (rule prime_primeideal[OF pprime])
  done

end