section\<open>Lattice Orderd Groups\<close>

(*
    Author: Viorel Preoteasa
*)

theory Lattice_Ordered_Group
imports Modular_Distrib_Lattice
begin

text\<open>
This theory introduces lattice ordered groups \cite{birkhoff:1942}
and proves some results about them. The most important result is
that a lattice ordered group is also a distributive lattice.
\<close>

class lgroup = group_add + lattice +
assumes add_order_preserving: "a \<le> b \<Longrightarrow> u + a + v \<le> u + b + v"
begin

lemma add_order_preserving_left: "a \<le> b \<Longrightarrow> u + a \<le> u + b"
  apply (cut_tac a = a and b = b and u = u and v = 0 in add_order_preserving)
  by simp_all

lemma add_order_preserving_right: "a \<le> b \<Longrightarrow> a + v \<le> b + v"
  apply (cut_tac a = a and b = b and u = 0 and v = v in add_order_preserving)
  by simp_all

lemma minus_order: "-a \<le> -b \<Longrightarrow> b \<le> a"
  apply (cut_tac a = "-a" and b = "-b" and u = a and v = b in add_order_preserving)
  by simp_all

lemma right_move_to_left: "a + - c \<le> b \<Longrightarrow> a \<le> b + c"
  apply (drule_tac v = "c" in add_order_preserving_right)
  by (simp add: add.assoc)

lemma right_move_to_right: "a \<le> b + -c \<Longrightarrow> a + c \<le> b"
  apply (drule_tac v = "c" in add_order_preserving_right)
  by (simp add: add.assoc)

lemma [simp]: "(a \<sqinter> b) - c = (a - c) \<sqinter> (b - c)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma left_move_to_left: "-c + a \<le> b \<Longrightarrow> a \<le> c + b"
  apply (drule_tac u = "c" in add_order_preserving_left)
  by (simp add: add.assoc [THEN sym])

lemma left_move_to_right: "a \<le> - c + b \<Longrightarrow> c + a \<le> b"
  apply (drule_tac u = "c" in add_order_preserving_left)
  by (simp add: add.assoc [THEN sym])

lemma [simp]: "c + (a \<sqinter> b) = (c + a) \<sqinter> (c + b)"
  apply (rule antisym)
  apply simp
  apply safe
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule left_move_to_left)
  apply simp
  apply safe
  apply (rule left_move_to_right)
  apply simp
  apply (rule left_move_to_right)
  by simp

lemma [simp]: "- (a \<sqinter> b) = (- a) \<squnion> (- b)"
  apply (rule antisym)
  apply (rule minus_order)
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  apply simp
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  by simp

lemma [simp]: "(a \<squnion> b) + c = (a + c) \<squnion> (b + c)"
  apply (rule antisym)
  apply (rule right_move_to_right)
  apply simp
  apply safe
  apply (simp_all only: diff_conv_add_uminus)
  apply (rule right_move_to_left)
  apply simp
  apply (rule right_move_to_left)
  apply simp
  apply simp
  apply safe
  apply (rule add_order_preserving_right)
  apply simp
  apply (rule add_order_preserving_right)
  by simp

lemma [simp]: "c + (a \<squnion> b) = (c + a) \<squnion> (c + b)"
  apply (rule antisym)
  apply (rule left_move_to_right)
  apply simp
  apply safe
  apply (rule left_move_to_left)
  apply simp
  apply (rule left_move_to_left)
  apply simp
  apply simp
  apply safe
  apply (rule add_order_preserving_left)
  apply simp
  apply (rule add_order_preserving_left)
  by simp

lemma [simp]: "c - (a \<sqinter> b) = (c - a) \<squnion> (c - b)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma [simp]: "(a \<squnion> b) - c = (a - c) \<squnion>  (b - c)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma [simp]: "- (a \<squnion> b) = (- a) \<sqinter> (- b)"
  apply (rule antisym)
  apply simp
  apply safe
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  apply simp
  apply (rule minus_order)
  by simp

lemma [simp]: "c - (a \<squnion> b) = (c - a) \<sqinter> (c - b)"
  by (simp add: diff_conv_add_uminus del: add_uminus_conv_diff)

lemma add_pos: "0 \<le> a \<Longrightarrow> b \<le> b + a"
  apply (cut_tac a = 0 and b = a and u = b and v = 0 in add_order_preserving)
  by simp_all

lemma add_pos_left: "0 \<le> a \<Longrightarrow> b \<le> a + b"
  apply (rule right_move_to_left)
  by simp

lemma inf_sup: "a - (a \<sqinter> b) + b = a \<squnion> b"
  by (simp add: add.assoc sup_commute)

lemma inf_sup_2: "b = (a \<sqinter> b) - a + (a \<squnion> b)"
  apply (unfold inf_sup [THEN sym])
  proof -
    fix a b:: 'a
    have "b = (a \<sqinter> b) + (- a + a) + - (a \<sqinter> b) + b" by (simp only: right_minus left_minus add_0_right add_0_left)
    also have "\<dots> = (a \<sqinter> b) + - a + (a + - (a \<sqinter> b) + b)" by (unfold add.assoc, simp)
    also have "\<dots> = (a \<sqinter> b) - a + (a - (a \<sqinter> b) + b)" by simp
    finally show "b = (a \<sqinter> b) - a + (a - (a \<sqinter> b) + b)" .
  qed

subclass inf_sup_eq_lattice
  proof
    fix x y z:: 'a
    assume A: "x \<sqinter> z = y \<sqinter> z"
    assume B: "x \<squnion> z = y \<squnion> z"
    have "x = (z \<sqinter> x) - z + (z \<squnion> x)" by (rule inf_sup_2)
    also have "\<dots> = (z \<sqinter> y) - z + (z \<squnion> y)" by (simp add: sup_commute inf_commute A B)
    also have "\<dots> = y" by (simp only: inf_sup_2 [THEN sym])
    finally show "x = y" .
  qed
end

end


(* Author: Tobias Nipkow & Stefan Dirix *)

section \<open>Weight Balanced Tree Implementation of Sets\<close>

text \<open>This theory follows Hirai and Yamamoto but we do not prove their general
theorem. Instead we provide a short parameterized theory that, when
interpreted with valid parameters, will prove perservation of the invariant
for these parameters.\<close>

theory Weight_Balanced_Trees
imports
  "HOL-Data_Structures.Isin2"
begin

lemma neq_Leaf2_iff: "t \<noteq> Leaf \<longleftrightarrow> (\<exists>l a n r. t = Node l (a,n) r)"
by(cases t) auto

type_synonym 'a wbt = "('a * nat) tree"

fun size_wbt :: "'a wbt \<Rightarrow> nat" where
"size_wbt Leaf = 0" |
"size_wbt (Node _ (_, n) _) = n"

text \<open>Smart constructor:\<close>

fun N :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"N l a r = Node l (a, size_wbt l + size_wbt r + 1) r"

text "Basic Rotations:"

fun rot1L :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot1L A a B b C = N (N A a B) b C"

fun rot1R :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot1R A a B b C = N A a (N B b C)"

fun rot2 :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rot2 A a (Node B1 (b,_) B2) c C = N (N A a B1) b (N B2 c C)"

subsection "WB trees"

text \<open>
Parameters:
  \<^descr> \<open>\<Delta>\<close> determines when a tree needs to be rebalanced
  \<^descr> \<open>\<Gamma>\<close> determines whether it needs to be single or double rotation.

\noindent We represent rational numbers as pairs: \<open>\<Delta> = \<Delta>1/\<Delta>2\<close> and \<open>\<Gamma> = \<Gamma>1/\<Gamma>2\<close>.
\bigskip

Hirai and Yamamoto \cite{HiraiY11} proved that under the following constraints
insertion and deletion preserve the WB invariant, i.e.\
\<open>\<Delta>\<close> and \<open>\<Gamma>\<close> are \emph{valid}:\<close>

definition valid_params :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"valid_params \<Delta>1 \<Delta>2 \<Gamma>1 \<Gamma>2 = (
  \<Delta>1 * 2 < \<Delta>2 * 9  \<comment> \<open>right: \<open>\<Delta> < 4.5\<close>\<close> \<and>
  \<Gamma>1 * \<Delta>2 + \<Gamma>2 * \<Delta>2 \<le> \<Gamma>2 * \<Delta>1 \<comment> \<open>left: \<open>\<Gamma> + 1 \<le> \<Delta>\<close>\<close> \<and>
  \<Gamma>1 * \<Delta>1 \<ge> \<Gamma>2 * (\<Delta>1 + \<Delta>2)  \<comment> \<open>lower: \<open>\<Gamma> \<ge> (\<Delta> + 1) / \<Delta>\<close>\<close> \<and>
  \<comment> \<open>upper:\<close>
  (5*\<Delta>2 \<le> 2*\<Delta>1 \<and> 1*\<Delta>1 < 3*\<Delta>2 \<longrightarrow> \<Gamma>1*2 \<le> \<Gamma>2*3)
     \<comment> \<open>\<open>\<Gamma> \<le> 3/2\<close> if \<open>2.5 \<le> \<Delta> < 3\<close>\<close> \<and>
  (3*\<Delta>2 \<le> 1*\<Delta>1 \<and> 2*\<Delta>1 < 7*\<Delta>2 \<longrightarrow> \<Gamma>1*2 \<le> \<Gamma>2*4)
     \<comment> \<open>\<open>\<Gamma> \<le> 4/2\<close> if \<open>3 \<le> \<Delta> < 3.5\<close>\<close> \<and>
  (7*\<Delta>2 \<le> 2*\<Delta>1 \<and> 1*\<Delta>1 < 4*\<Delta>2 \<longrightarrow> \<Gamma>1*3 \<le> \<Gamma>2*4)
     \<comment> \<open>\<open>\<Gamma> \<le> 4/3\<close> when \<open>3.5 \<le> \<Delta> < 4\<close>\<close> \<and>
  (4*\<Delta>2 \<le> 1*\<Delta>1 \<and> 2*\<Delta>1 < 9*\<Delta>2 \<longrightarrow> \<Gamma>1*3 \<le> \<Gamma>2*5)
     \<comment> \<open>\<open>\<Gamma> \<le> 5/3\<close> when \<open>4 \<le> \<Delta> < 4.5\<close>\<close>
  )"

text \<open>We do not make use of these constraints and do not prove that they guarantee
preservation of the invariant. Instead, we provide generic proofs of invariant preservation
that work for many (all?) interpretations of locale \<open>WBT\<close> (below) with valid parameters.
Further down we demonstrate this by interpreting \<open>WBT\<close> with a selection of valid parameters.
[For some parameters, some \<open>smt\<close> proofs fail because \<open>smt\<close> on \<open>nat\<close>s fails although
on non-negative \<open>int\<close>s it succeeds, i.e.\ the goal should be provable.
This is a shortcoming of \<open>smt\<close> that is under investigation.]

Locale \<open>WBT\<close> comes with some minimal assumptions (\<open>\<Gamma>1 > \<Gamma>2\<close> and \<open>\<Delta>1 > \<Delta>2\<close>) which follow
from @{const valid_params} and from which we conclude some simple lemmas.
\<close>

locale WBT =
fixes \<Delta>1 \<Delta>2 :: nat and \<Gamma>1 \<Gamma>2 :: nat
assumes Delta_gr1: "\<Delta>1 > \<Delta>2" and Gamma_gr1: "\<Gamma>1 > \<Gamma>2"
begin

(* How to prove the assumptions from valid_params:
lemma Gamma_gr1: "\<Gamma>1 > \<Gamma>2"
proof -
  have "\<not> (\<Delta>1 + \<Delta>2) * \<Gamma>2 \<le> \<Delta>1 * \<Gamma>2" by (simp add: not0)
  thus ?thesis by (metis order.trans lower mult.commute mult_le_cancel2 not_le)
qed

lemma Delta_gr2: "\<Delta>1 > 2 * \<Delta>2"
proof -
  from Gamma_gr1 have "\<Gamma>2 * \<Delta>2 < \<Gamma>1 * \<Delta>2" by (simp add: not0)
  with left have "2 * \<Gamma>2 * \<Delta>2 < \<Gamma>2 * \<Delta>1" by linarith
  thus ?thesis by(simp)
qed
*)

subsubsection "Balance Indicators"

fun balanced1 :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> bool" where
"balanced1 t1 t2 = (\<Delta>1 * (size_wbt t1 + 1) \<ge> \<Delta>2 * (size_wbt t2 + 1))"

text \<open>The global weight-balanced tree invariant:\<close>

fun wbt :: "'a wbt \<Rightarrow> bool" where
"wbt Leaf = True"|
"wbt (Node l (_, n) r) =
  (n = size l + size r + 1 \<and> balanced1 l r \<and> balanced1 r l \<and> wbt l \<and> wbt r)"

lemma size_wbt_eq_size[simp]: "wbt t \<Longrightarrow> size_wbt t = size t"
by(induction t) auto

fun single :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> bool" where
"single t1 t2 = (\<Gamma>1 * (size_wbt t2 + 1) > \<Gamma>2 * (size_wbt t1 + 1))"

subsubsection "Code"

fun rotateL :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rotateL A a (Node B (b, _) C) =
   (if single B C then rot1L A a B b C else rot2 A a B b C)"

fun balanceL :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"balanceL l a r = (if balanced1 l r then N l a r else rotateL l a r)"

fun rotateR :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"rotateR (Node A (a, _) B) b C =
  (if single B A then rot1R A a B b C else rot2 A a B b C)"

fun balanceR :: "'a wbt \<Rightarrow> 'a \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"balanceR l a r = (if balanced1 r l then N l a r else rotateR l a r)"

fun insert :: "'a::linorder \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"insert x Leaf = Node Leaf (x, 1) Leaf" |
"insert x (Node l (a, n) r) =
   (case cmp x a of
      LT \<Rightarrow> balanceR (insert x l) a r |
      GT \<Rightarrow> balanceL l a (insert x r) |
      EQ \<Rightarrow> Node l (a, n) r )"

fun split_min :: "'a wbt \<Rightarrow> 'a * 'a wbt" where
"split_min (Node l (a, _) r) =
   (if l = Leaf then (a,r) else let (x,l') = split_min l in (x, balanceL l' a r))"

fun del_max :: "'a wbt \<Rightarrow> 'a * 'a wbt" where
"del_max (Node l (a, _) r) =
   (if r = Leaf then (a,l) else let (x,r') = del_max r in (x, balanceR l a r'))"

fun combine :: "'a wbt \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt"  where
"combine Leaf Leaf = Leaf"|
"combine Leaf r = r"|
"combine l Leaf = l"|
"combine l r =
   (if size l > size r then
      let (lMax, l') = del_max l in balanceL l' lMax r
    else
      let (rMin, r') = split_min r in balanceR l rMin r')"

fun delete :: "'a::linorder \<Rightarrow> 'a wbt \<Rightarrow> 'a wbt" where
"delete _ Leaf = Leaf" |
"delete x (Node l (a, _) r) =
  (case cmp x a of
     LT \<Rightarrow> balanceL (delete x l) a r |
     GT \<Rightarrow> balanceR l a (delete x r) |
     EQ \<Rightarrow> combine l r)"

subsection "Functional Correctness Proofs"

text \<open>A WB tree must be of a certain structure if balanced1 and single are False.\<close>

lemma not_Leaf_if_not_balanced1:
  assumes "\<not> balanced1 l r"
  shows "r \<noteq> Leaf"
proof
  assume "r = Leaf" with assms Delta_gr1 show False by simp
qed

lemma not_Leaf_if_not_single:
  assumes "\<not> single l r"
  shows "l \<noteq> Leaf"
proof
  assume "l = Leaf" with assms Gamma_gr1 show False by simp
qed

subsubsection "Inorder Properties"

lemma inorder_rotateL:
  "r \<noteq> Leaf \<Longrightarrow> inorder(rotateL l a r) = inorder l @ a # inorder r"
by (induction l a r rule: rotateL.induct) (auto simp add: inorder_rot2 not_Leaf_if_not_single)

lemma inorder_rotateR:
  "l \<noteq> Leaf \<Longrightarrow> inorder(rotateR l a r) = inorder l @ a # inorder r"
by (induction l a r rule: rotateR.induct) (auto simp add: inorder_rot2 not_Leaf_if_not_single)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
by (induction t)
   (auto simp: ins_list_simps inorder_rotateL inorder_rotateR not_Leaf_if_not_balanced1)

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by (induction t arbitrary: t' rule: split_min.induct)
   (auto simp: sorted_lems inorder_rotateL not_Leaf_if_not_balanced1
     split: prod.splits if_splits)

lemma del_maxD:
  "del_max t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> inorder t' @ [x] = inorder t"
by (induction t arbitrary: t' rule: del_max.induct)
   (auto simp: sorted_lems inorder_rotateR not_Leaf_if_not_balanced1
     split: prod.splits if_splits)

lemma inorder_combine:
  "inorder(combine l r) = inorder l @ inorder r"
by(induction l r rule: combine.induct)
  (auto simp: del_maxD split_minD inorder_rotateL inorder_rotateR not_Leaf_if_not_balanced1
    simp del: rotateL.simps rotateR.simps split: prod.splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t)
  (auto simp: del_list_simps inorder_combine inorder_rotateL inorder_rotateR
     not_Leaf_if_not_balanced1 simp del: rotateL.simps rotateR.simps)

subsection "Size Lemmas"

subsubsection "Insertion"

lemma size_rot2L[simp]:
  "B \<noteq> Leaf \<Longrightarrow> size(rot2 A a B b C) = size A + size B + size C + 2"
by(induction A a B b C rule: rot2.induct) auto

lemma size_rotateR[simp]:
  "l \<noteq> Leaf \<Longrightarrow> size(rotateR l a r) = size l + size r + 1"
by(induction l a r rule: rotateR.induct)
  (auto simp: not_Leaf_if_not_single simp del: rot2.simps)

lemma size_rotateL[simp]:
  "r \<noteq> Leaf \<Longrightarrow> size(rotateL l a r) = size l + size r + 1"
by(induction l a r rule: rotateL.induct)
  (auto simp: not_Leaf_if_not_single simp del: rot2.simps)

lemma size_length: "size t = length (inorder t)"
by (induction t rule: inorder.induct) auto

lemma size_insert: "size (insert x t) = (if isin t x then size t else Suc (size t))"
by (induction t rule: tree2_induct) (auto simp: not_Leaf_if_not_balanced1)

subsubsection "Deletion"

lemma size_delete_if_isin: "isin t x \<Longrightarrow> size t = Suc (size(delete x t))"
proof (induction t rule: tree2_induct)
  case (Node _ a _ _)
  thus ?case
  proof (cases "cmp x a")
    case LT thus ?thesis using Node.prems by (simp add: Node.IH(1) not_Leaf_if_not_balanced1)
  next
    case EQ thus ?thesis by simp (metis size_length inorder_combine length_append)
  next
    case GT thus ?thesis using Node.prems by (simp add: Node.IH(2) not_Leaf_if_not_balanced1)
  qed
qed (auto)

lemma delete_id_if_wbt_notin: "wbt t \<Longrightarrow> \<not> isin t x \<Longrightarrow> delete x t = t"
by (induction t) auto

lemma size_split_min: "t \<noteq> Leaf \<Longrightarrow> size t = Suc (size (snd (split_min t)))"
by(induction t) (auto simp: not_Leaf_if_not_balanced1 split: if_splits prod.splits)

subsection "Auxiliary Definitions"

fun balanced1_arith :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"balanced1_arith a b = (\<Delta>1 * (a + 1) \<ge> \<Delta>2 * (b + 1))"

fun balanced2_arith :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"balanced2_arith a b = (balanced1_arith a b \<and> balanced1_arith b a)"

fun singly_balanced_arith :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"singly_balanced_arith x y w = (balanced2_arith x y \<and> balanced2_arith (x+y+1) w)"

fun doubly_balanced_arith :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"doubly_balanced_arith x y z w =
  (balanced2_arith x y \<and> balanced2_arith z w \<and> balanced2_arith (x+y+1) (z+w+1))"

end

subsection "Preservation of WB tree Invariant for Concrete Parameters"

text \<open>A number of sample interpretations with valid parameters:\<close>

interpretation WBT where
  \<Delta>1 = 25 and \<Delta>2 = 10 and \<Gamma>1 = 14 and \<Gamma>2 = 10
(* \<Delta>1 = 25 and \<Delta>2 = 10 and \<Gamma>1 = 15 and \<Gamma>2 = 10*)
(* \<Delta>1 = 28 and \<Delta>2 = 10 and \<Gamma>1 = 10 and \<Gamma>2 = 7*)

(* \<Delta>1 = 3 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 4 and \<Gamma>2 = 3*)
  (* The only integer solution: *)
(* \<Delta>1 = 3 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 2 and \<Gamma>2 = "Suc 0"*)
(* \<Delta>1 = 31 and \<Delta>2 = 10 and \<Gamma>1 = 18 and \<Gamma>2 = 10*)

(* \<Delta>1 = 35 and \<Delta>2 = 10 and \<Gamma>1 = 45 and \<Gamma>2 = 35*)
(* \<Delta>1 = 35 and \<Delta>2 = 10 and \<Gamma>1 = 4 and \<Gamma>2 = 3*)
(* \<Delta>1 = 37 and \<Delta>2 = 10 and \<Gamma>1 = 13 and \<Gamma>2 = 10*)

(* \<Delta>1 = 4 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 5 and \<Gamma>2 = 4*)
(* \<Delta>1 = 4 and \<Delta>2 = "Suc 0" and \<Gamma>1 = 5 and \<Gamma>2 = 3*)
(* \<Delta>1 = 17 and \<Delta>2 = 4 and \<Gamma>1 = 5 and \<Gamma>2 = 3 *)
by (auto simp add: WBT_def)

lemma wbt_insert:
  "wbt t \<Longrightarrow> wbt (insert x t)"
proof (induction t rule: tree2_induct)
  case Leaf show ?case by simp
next
  case (Node l a _ r)
  show ?case
  proof (cases "cmp x a")
    case EQ thus ?thesis using Node.prems by auto
  next
    case [simp]: LT
    let ?l' = "insert x l"
    show ?thesis
    proof (cases "balanced1 r ?l'")
      case True thus ?thesis using Node size_insert[of x l] by auto
    next
      case [simp]: False
      hence "?l' \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
      then obtain k ll' al' rl' where [simp]: "?l' = (Node ll' (al', k) rl')"
        by(meson neq_Leaf2_iff)
      show ?thesis
      proof (cases "single rl' ll'")
        case True thus ?thesis using Node size_insert[of x l]
          by (auto split: if_splits)
      next
        case isDouble: False
        then obtain k llr' alr' rlr' where [simp]: "rl' = (Node llr' (alr', k) rlr')"
          using not_Leaf_if_not_single tree2_cases by blast
        show ?thesis using isDouble Node size_insert[of x l]
          by (auto split: if_splits)
      qed
    qed
  next
    case [simp]: GT
    let ?r' = "insert x r"
    show ?thesis
    proof (cases "balanced1 l ?r'")
      case True thus ?thesis using Node size_insert[of x r] by auto
    next
      case [simp]: False
      hence "?r' \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
      then obtain k lr' ar' rr' where [simp]: "?r' = (Node lr' (ar', k) rr')"
        by(meson neq_Leaf2_iff)
      show ?thesis
      proof (cases "single lr' rr'")
        case True thus ?thesis using Node size_insert[of x r]
          by (auto split: if_splits)
      next
        case isDouble: False
        hence "lr' \<noteq> Leaf" using not_Leaf_if_not_single by auto
        thus ?thesis
          using Node isDouble size_insert[of x r]
          by (auto simp: neq_Leaf2_iff split: if_splits)
      qed
    qed
  qed
qed

declare [[smt_nat_as_int]]

text \<open>
  Show that invariant is preserved by deletion in the left/right subtree:
\<close>

lemma wbt_balanceL:
  assumes "wbt (Node l (a, n) r)" "wbt l'" "size l = size l' + 1"
  shows "wbt (balanceL l' a' r)"
proof -
  have rl'Balanced: "balanced1 r l'" using assms by auto
  have rBalanced: "wbt r" using assms(1) by simp
  show ?thesis
  proof (cases "balanced1 l' r")
    case True thus ?thesis using assms(2) rBalanced rl'Balanced by auto
  next
    case notBalanced: False
    hence "r \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
    then obtain k lr ar rr where [simp]: "r = Node lr (ar, k) rr" by(meson neq_Leaf2_iff)
    show ?thesis
    proof (cases "single lr rr")
      case single: True
      have "singly_balanced_arith (size l') (size lr) (size rr)"
        using assms(1) notBalanced rl'Balanced rBalanced single assms
        by (simp) (smt?)
      thus ?thesis using notBalanced single assms(2) rBalanced by simp
    next
      case isDouble: False
      hence "lr \<noteq> Leaf" using not_Leaf_if_not_single by auto
      then obtain k2 llr alr rlr where [simp]: "lr = (Node llr (alr, k2) rlr)"
        by(meson neq_Leaf2_iff)
      have "doubly_balanced_arith (size l') (size llr) (size rlr) (size rr)"
        using assms(1) notBalanced rl'Balanced rBalanced isDouble assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using notBalanced isDouble assms(2) rBalanced by simp
    qed
  qed
qed

lemma wbt_balanceR:
  assumes "wbt (Node l (a, n) r)" "wbt r'" "size r = size r' + 1"
  shows "wbt (balanceR l a' r')"
proof -
  have lr'Balanced: "balanced1 l r'" using assms by auto
  have lBalanced: "wbt l" using assms(1) by simp
  show ?thesis
  proof (cases "balanced1 r' l")
    case True thus ?thesis using assms(2) lBalanced lr'Balanced by simp
  next
    case notBalanced: False
    hence "l \<noteq> Leaf" using not_Leaf_if_not_balanced1 by auto
    then obtain k ll al rl where [simp]: "l = (Node ll (al, k) rl)" by(meson neq_Leaf2_iff)
    show ?thesis
    proof (cases "single rl ll")
      case single: True
      have "singly_balanced_arith (size rl) (size r') (size ll)"
        using assms(1) notBalanced lr'Balanced lBalanced single assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using assms(2) lBalanced notBalanced single by simp
    next
      case isDouble: False
      hence "rl \<noteq> Leaf" using not_Leaf_if_not_single by auto
      then obtain k lrl arl rrl where [simp]: "rl = (Node lrl (arl, k) rrl)"
        by(meson neq_Leaf2_iff)
      have "doubly_balanced_arith (size ll) (size lrl) (size rrl) (size r')"
        using assms(1) notBalanced lr'Balanced lBalanced isDouble assms(2,3)
        apply (auto) apply((thin_tac "_ = _")+, smt)? done
      thus ?thesis using assms(2) lBalanced notBalanced isDouble by simp
    qed
  qed
qed

lemma wbt_split_min: "t \<noteq> Leaf \<Longrightarrow> wbt t \<Longrightarrow> wbt (snd (split_min t))"
proof (induction t rule: split_min.induct)
  case (1 l a m r)
  show ?case
  proof (cases l rule: tree2_cases)
    case Leaf thus ?thesis using "1.prems"(2) by simp
  next
    case (Node ll al n rl)
    let ?l' = "snd (split_min (Node ll (al, n) rl))"
    have delBalanceL: "snd (split_min (Node l (a, m) r)) = balanceL ?l' a r"
      using Node by(auto split: prod.splits)
    have "wbt ?l'" using "1"(1) "1.prems"(2) Node by auto
    moreover have "size l = size ?l' + 1"
      using Node size_split_min by (metis Suc_eq_plus1 neq_Leaf2_iff)
    ultimately have "wbt (balanceL ?l' a r)"
      by (meson "1.prems"(2) wbt_balanceL)
    thus ?thesis using delBalanceL by auto
  qed
qed (blast)

lemma wbt_del_max: "t \<noteq> Leaf \<Longrightarrow> wbt t \<Longrightarrow> wbt (snd (del_max t))"
proof (induction t rule: del_max.induct)
  case (1 l a m r)
  show ?case
  proof (cases r rule: tree2_cases)
    case Leaf thus ?thesis using "1.prems"(2) by simp
  next
    case (Node lr ar n rr)
    then obtain r' where delMaxR: "r' = snd (del_max (Node lr (ar, n) rr))"
      by simp
    hence delBalanceR: "snd (del_max (Node l (a, m) r)) = balanceR l a r'"
      using Node by(auto split: prod.splits)
    have "wbt r'" using "1"(1) "1.prems"(2) Node delMaxR by auto
    moreover have "size r = size r' + 1" using size_del_max Node delMaxR
      by (metis Suc_eq_plus1 tree.simps(3))
    ultimately have "wbt (balanceR l a r')"
      using wbt_balanceR by (metis "1.prems"(2))
    thus ?thesis using delBalanceR by auto
  qed
qed (blast)

lemma wbt_delete: "wbt t \<Longrightarrow> wbt (delete x t)"
proof (induction t rule: tree2_induct)
  case Leaf thus ?case by simp
next
  case (Node l a n r)
  show ?case
  proof (cases "isin (Node l (a, n) r) x")
    case False thus ?thesis using Node.prems delete_id_if_wbt_notin by metis
  next
    case isin: True
    thus ?thesis
    proof (cases "cmp x a")
      case LT
      let ?l' = "delete x l"
      have "size l = size ?l' + 1"
        using LT isin by (auto simp: size_delete_if_isin)
      hence "wbt (balanceL ?l' a r)"
        using Node.IH(1) Node.prems by (fastforce intro: wbt_balanceL)
      thus ?thesis by (simp add: LT)
    next
      case GT
      let ?r' = "delete x r"
      have "wbt ?r'" using Node.IH(2) Node.prems by simp
      moreover have "size r = size ?r' + 1"
        using GT Node.prems isin size_delete_if_isin by auto
      ultimately have "wbt (balanceR l a ?r')"
        by (meson Node.prems wbt_balanceR)
      thus ?thesis by (simp add: GT)
    next
      case [simp]: EQ
      hence xCombine: "delete x (Node l (a, n) r) = combine l r" by simp
      {
        assume "l = Leaf" "r = Leaf" hence ?thesis by simp
      }
      moreover
      {
        assume "l = Leaf" "r \<noteq> Leaf"
        hence ?thesis using Node.prems by (auto simp: neq_Leaf2_iff)
      }
      moreover
      {
        assume "l \<noteq> Leaf" "r = Leaf"
        hence ?thesis using Node.prems by (auto simp: neq_Leaf2_iff)
      }
      moreover
      {
        assume lrNotLeaf: "l \<noteq> Leaf" "r \<noteq> Leaf"
        then obtain kl kr ll al rl lr ar rr
          where [simp]: "l = (Node ll (al, kl) rl)" "r = (Node lr (ar, kr) rr)"
          by (meson neq_Leaf2_iff)
        have ?thesis
        proof (cases "size l > size r")
          case True
          obtain lMax l' where letMax: "del_max l = (lMax, l')"
            by (metis prod.exhaust)
          hence balanceLeft: "combine l r = balanceL l' lMax r"
            using \<open>size l > size r\<close> by (simp)
          have "wbt l'"
            using Node.prems wbt_del_max[OF lrNotLeaf(1)] letMax
            by (metis wbt.simps(2) snd_conv)
          moreover have "size l = size l' + 1"
            using size_del_max[OF lrNotLeaf(1)] letMax by (simp)
          ultimately have "wbt(balanceL l' lMax r)"
            using wbt_balanceL by (metis Node.prems)
          thus ?thesis using balanceLeft by simp
        next
          case False
          obtain rMin r' where letMin: "split_min r = (rMin, r')"
            by (metis prod.exhaust)
          hence balanceRight: "combine l r = balanceR l rMin r'"
            using \<open>\<not> size l > size r\<close> by (simp)
          have "wbt r'"
            using Node.prems wbt_split_min[OF lrNotLeaf(2)] letMin
            by (metis wbt.simps(2) snd_conv)
          moreover have "size r = size r' + 1"
            using size_split_min[OF lrNotLeaf(2)] letMin by simp
          ultimately have "wbt(balanceR l rMin r')"
            using wbt_balanceR by (metis Node.prems)
          thus ?thesis using balanceRight by simp
        qed
      }
      ultimately show ?thesis by blast
    qed
  qed
qed

subsection \<open>The final correctness proof\<close>

interpretation S: Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = wbt
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 show ?case by simp
next
  case 6 thus ?case using wbt_insert by blast
next
  case 7 thus ?case using wbt_delete by blast
qed

end


theory T20
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


(* Author: Thiemann *)
section \<open>Perron-Frobenius Theorem\<close>

subsection \<open>Auxiliary Notions\<close>

text \<open>We define notions like non-negative real-valued matrix, both
  in JNF and in HMA. These notions will be linked via HMA-connect.\<close>

theory Perron_Frobenius_Aux
imports HMA_Connect
begin

definition real_nonneg_mat :: "complex mat \<Rightarrow> bool" where
  "real_nonneg_mat A \<equiv> \<forall> a \<in> elements_mat A. a \<in> \<real> \<and> Re a \<ge> 0"

definition real_nonneg_vec :: "complex Matrix.vec \<Rightarrow> bool" where
  "real_nonneg_vec v \<equiv> \<forall> a \<in> vec_elements v. a \<in> \<real> \<and> Re a \<ge> 0"

definition real_non_neg_vec :: "complex ^ 'n \<Rightarrow> bool" where
  "real_non_neg_vec v \<equiv> (\<forall> a \<in> vec_elements_h v. a \<in> \<real> \<and> Re a \<ge> 0)"

definition real_non_neg_mat :: "complex ^ 'nr ^ 'nc \<Rightarrow> bool" where
  "real_non_neg_mat A \<equiv> (\<forall> a \<in> elements_mat_h A. a \<in> \<real> \<and> Re a \<ge> 0)"

lemma real_non_neg_matD: assumes "real_non_neg_mat A"
  shows "A $h i $h j \<in> \<real>" "Re (A $h i $h j) \<ge> 0"
  using assms unfolding real_non_neg_mat_def elements_mat_h_def by auto

definition nonneg_mat :: "'a :: linordered_idom mat \<Rightarrow> bool" where
  "nonneg_mat A \<equiv> \<forall> a \<in> elements_mat A. a \<ge> 0"

definition non_neg_mat :: "'a :: linordered_idom ^ 'nr ^ 'nc \<Rightarrow> bool" where
  "non_neg_mat A \<equiv> (\<forall> a \<in> elements_mat_h A. a \<ge> 0)"

context includes lifting_syntax
begin

lemma HMA_real_non_neg_mat [transfer_rule]:
  "((HMA_M :: complex mat \<Rightarrow> complex ^ 'nc ^ 'nr \<Rightarrow> bool) ===> (=))
  real_nonneg_mat real_non_neg_mat"
  unfolding real_nonneg_mat_def[abs_def] real_non_neg_mat_def[abs_def]
  by transfer_prover

lemma HMA_real_non_neg_vec [transfer_rule]:
  "((HMA_V :: complex Matrix.vec \<Rightarrow> complex ^ 'n \<Rightarrow> bool) ===> (=))
  real_nonneg_vec real_non_neg_vec"
  unfolding real_nonneg_vec_def[abs_def] real_non_neg_vec_def[abs_def]
  by transfer_prover

lemma HMA_non_neg_mat [transfer_rule]:
  "((HMA_M :: 'a :: linordered_idom mat \<Rightarrow> 'a ^ 'nc ^ 'nr \<Rightarrow> bool) ===> (=))
  nonneg_mat non_neg_mat"
  unfolding nonneg_mat_def[abs_def] non_neg_mat_def[abs_def]
  by transfer_prover

end

primrec matpow :: "'a::semiring_1^'n^'n \<Rightarrow> nat \<Rightarrow> 'a^'n^'n" where
  matpow_0:   "matpow A 0 = mat 1" |
  matpow_Suc: "matpow A (Suc n) = (matpow A n) ** A"

context includes lifting_syntax
begin
lemma HMA_pow_mat[transfer_rule]:
  "((HMA_M ::'a::{semiring_1} mat \<Rightarrow> 'a^'n^'n \<Rightarrow> bool) ===> (=) ===> HMA_M) pow_mat matpow"
proof -
  {
    fix A :: "'a mat" and A' :: "'a^'n^'n" and n :: nat
    assume [transfer_rule]: "HMA_M A A'"
    hence [simp]: "dim_row A = CARD('n)" unfolding HMA_M_def by simp
    have "HMA_M (pow_mat A n) (matpow A' n)"
    proof (induct n)
      case (Suc n)
      note [transfer_rule] = this
      show ?case by (simp, transfer_prover)
    qed (simp, transfer_prover)
  }
  thus ?thesis by blast
qed
end

lemma trancl_image:
  "(i,j) \<in> R\<^sup>+ \<Longrightarrow> (f i, f j) \<in> (map_prod f f ` R)\<^sup>+"
proof (induct rule: trancl_induct)
  case (step j k)
  from step(2) have "(f j, f k) \<in> map_prod f f ` R" by auto
  from step(3) this show ?case by auto
qed auto

lemma inj_trancl_image: assumes inj: "inj f"
  shows "(f i, f j) \<in> (map_prod f f ` R)\<^sup>+ = ((i,j) \<in> R\<^sup>+)" (is "?l = ?r")
proof
  assume ?r from trancl_image[OF this] show ?l .
next
  assume ?l from trancl_image[OF this, of "the_inv f"]
  show ?r unfolding image_image prod.map_comp o_def the_inv_f_f[OF inj] by auto
qed

lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma norm_smult: "norm ((a :: real) *s x) = abs a * norm x"
  unfolding norm_vec_def
  by (metis norm_scaleR norm_vec_def scalar_mult_eq_scaleR)

lemma nonneg_mat_mult:
  "nonneg_mat A \<Longrightarrow> nonneg_mat B \<Longrightarrow> A \<in> carrier_mat nr n
  \<Longrightarrow> B \<in> carrier_mat n nc \<Longrightarrow> nonneg_mat (A * B)"
  unfolding nonneg_mat_def
  by (auto simp: elements_mat_def scalar_prod_def intro!: sum_nonneg)

lemma nonneg_mat_power: assumes "A \<in> carrier_mat n n" "nonneg_mat A"
  shows "nonneg_mat (A ^\<^sub>m k)"
proof (induct k)
  case 0
  thus ?case by (auto simp: nonneg_mat_def)
next
  case (Suc k)
  from nonneg_mat_mult[OF this assms(2) _ assms(1), of n] assms(1)
  show ?case by auto
qed

lemma nonneg_matD: assumes "nonneg_mat A"
  and "i < dim_row A" and "j < dim_col A"
shows "A $$ (i,j) \<ge> 0"
  using assms unfolding nonneg_mat_def elements_mat by auto

lemma (in comm_ring_hom) similar_mat_wit_hom: assumes
  "similar_mat_wit A B C D"
shows "similar_mat_wit (mat\<^sub>h A) (mat\<^sub>h B) (mat\<^sub>h C) (mat\<^sub>h D)"
proof -
  obtain n where n: "n = dim_row A" by auto
  note * = similar_mat_witD[OF n assms]
  from * have [simp]: "dim_row C = n" by auto
  note C = *(6) note D = *(7)
  note id = mat_hom_mult[OF C D] mat_hom_mult[OF D C]
  note ** = *(1-3)[THEN arg_cong[of _ _ "mat\<^sub>h"], unfolded id]
  note mult = mult_carrier_mat[of _ n n]
  note hom_mult = mat_hom_mult[of _ n n _ n]
  show ?thesis unfolding similar_mat_wit_def Let_def unfolding **(3) using **(1,2)
    by (auto simp: n[symmetric] hom_mult simp: *(4-) mult)
qed

lemma (in comm_ring_hom) similar_mat_hom:
  "similar_mat A B \<Longrightarrow> similar_mat (mat\<^sub>h A) (mat\<^sub>h B)"
  using similar_mat_wit_hom[of A B C D for C D]
  by (smt similar_mat_def)

lemma det_dim_1: assumes A: "A \<in> carrier_mat n n"
  and n: "n = 1"
shows "Determinant.det A = A $$ (0,0)"
  by (subst laplace_expansion_column[OF A[unfolded n], of 0], insert A n,
    auto simp: cofactor_def mat_delete_def)

lemma det_dim_2: assumes A: "A \<in> carrier_mat n n"
  and n: "n = 2"
shows "Determinant.det A = A $$ (0,0) * A $$ (1,1) - A $$ (0,1) * A $$ (1,0)"
proof -
  have set: "(\<Sum>i<(2 :: nat). f i) = f 0 + f 1" for f
    by (subst sum.cong[of _ "{0,1}" f f], auto)
  show ?thesis
    apply (subst laplace_expansion_column[OF A[unfolded n], of 0], insert A n,
      auto simp: cofactor_def mat_delete_def set)
    apply (subst (1 2) det_dim_1, auto)
    done
qed

lemma jordan_nf_root_char_poly: fixes A :: "'a :: {semiring_no_zero_divisors, idom} mat"
  assumes "jordan_nf A n_as"
  and "(m, lam) \<in> set n_as"
shows "poly (char_poly A) lam = 0"
proof -
  from assms have m0: "m \<noteq> 0" unfolding jordan_nf_def by force
  from split_list[OF assms(2)] obtain as bs where nas: "n_as = as @ (m, lam) # bs" by auto
  show ?thesis using m0
    unfolding jordan_nf_char_poly[OF assms(1)] nas poly_prod_list prod_list_zero_iff by (auto simp: o_def)
qed

lemma inverse_of_nat_tendsto_zero:
  "(\<lambda>x. inverse (of_nat x :: 'a :: real_normed_div_algebra)) \<longlonglongrightarrow> 0"
  using inverse_power_tendsto_zero[of 0] by auto

lemma poly_times_exp_tendsto_zero: assumes b: "norm (b :: 'a :: real_normed_field) < 1"
  shows "(\<lambda> x. of_nat x ^ k * b ^ x) \<longlonglongrightarrow> 0"
proof (cases "b = 0")
  case False
  define nla where "nla = norm b"
  define s where "s = sqrt nla"
  from b False have nla: "0 < nla" "nla < 1" unfolding nla_def by auto
  hence s: "0 < s" "s < 1" unfolding s_def by auto
  {
    fix x
    have "s^x * s^x = sqrt (nla ^ (2 * x))"
      unfolding s_def power_add[symmetric]
      unfolding real_sqrt_power[symmetric]
      by (rule arg_cong[of _ _ "\<lambda> x. sqrt (nla ^ x)"], simp)
    also have "\<dots> = nla^x" unfolding power_mult real_sqrt_power
      using nla by simp
    finally have "nla^x = s^x * s^x" by simp
  } note nla_s = this
  show "(\<lambda>x. of_nat x ^ k * b ^ x) \<longlonglongrightarrow> 0"
  proof (rule tendsto_norm_zero_cancel, unfold norm_mult norm_power norm_of_nat nla_def[symmetric] nla_s
       mult.assoc[symmetric])
    from poly_exp_constant_bound[OF s, of 1 k] obtain p where
      p: "real x ^ k * s^x \<le> p" for x by (auto simp: ac_simps)
    have "norm (real x ^ k * s ^ x) = real x ^ k * s^x" for x using s by auto
    with p have p: "norm (real x ^ k * s ^ x) \<le> p" for x by auto
    from s have s: "norm s < 1" by auto
    show "(\<lambda>x. real x ^ k * s ^ x * s ^ x) \<longlonglongrightarrow> 0"
      by (rule lim_null_mult_left_bounded[OF _ LIMSEQ_power_zero[OF s], of _ p], insert p, auto)
  qed
next
  case True
  show ?thesis unfolding True
    by (subst tendsto_cong[of _ "\<lambda> x. 0"], rule eventually_sequentiallyI[of 1], auto)
qed

lemma (in linorder_topology) tendsto_Min: assumes I: "I \<noteq> {}" and fin: "finite I"
  shows "(\<And>i. i \<in> I \<Longrightarrow> (f i \<longlongrightarrow> a i) F) \<Longrightarrow> ((\<lambda>x. Min ((\<lambda> i. f i x) ` I)) \<longlongrightarrow>
    (Min (a ` I) :: 'a)) F"
  using fin I
proof (induct rule: finite_induct)
  case (insert i I)
  hence i: "(f i \<longlongrightarrow> a i) F" by auto
  show ?case
  proof (cases "I = {}")
    case True
    show ?thesis unfolding True using i by auto
  next
    case False
    have *: "Min (a ` insert i I) = min (a i) (Min (a ` I))" using False insert(1) by auto
    have **: "(\<lambda>x. Min ((\<lambda>i. f i x) ` insert i I)) = (\<lambda>x. min (f i x) (Min ((\<lambda>i. f i x) ` I)))"
      using False insert(1) by auto
    have IH: "((\<lambda>x. Min ((\<lambda>i. f i x) ` I)) \<longlongrightarrow> Min (a ` I)) F"
      using insert(3)[OF insert(4) False] by auto
    show ?thesis unfolding * **
      by (auto intro!: tendsto_min i IH)
  qed
qed simp

lemma tendsto_mat_mult [tendsto_intros]:
  "(f \<longlongrightarrow> a) F \<Longrightarrow> (g \<longlongrightarrow> b) F \<Longrightarrow> ((\<lambda>x. f x ** g x) \<longlongrightarrow> a ** b) F"
  for f :: "'a \<Rightarrow> 'b :: {semiring_1, real_normed_algebra} ^ 'n1 ^ 'n2"
  unfolding matrix_matrix_mult_def[abs_def] by (auto intro!: tendsto_intros)

lemma continuous_matpow: "continuous_on R (\<lambda> A :: 'a :: {semiring_1, real_normed_algebra_1} ^ 'n ^ 'n. matpow A n)"
  unfolding continuous_on_def by (auto intro!: tendsto_intros)

lemma vector_smult_distrib: "(A *v ((a :: 'a :: comm_ring_1) *s x)) = a *s ((A *v x))"
  unfolding matrix_vector_mult_def vector_scalar_mult_def
  by (simp add: ac_simps sum_distrib_left)

instance real :: ordered_semiring_strict
  by (intro_classes, auto)

lemma poly_tendsto_pinfty:  fixes p :: "real poly"
  assumes "lead_coeff p > 0" "degree p \<noteq> 0"
  shows "poly p \<longlonglongrightarrow> \<infinity>"
  unfolding Lim_PInfty
proof
  fix b
  show "\<exists>N. \<forall>n\<ge>N. ereal b \<le> ereal (poly p (real n))"
    unfolding ereal_less_eq using poly_pinfty_ge[OF assms, of b]
    by (meson of_nat_le_iff order_trans real_arch_simple)
qed

lemma div_lt_nat: "(j :: nat) < x * y \<Longrightarrow> j div x < y"
  by (simp add: less_mult_imp_div_less mult.commute)

definition diagvector :: "('n \<Rightarrow> 'a :: semiring_0) \<Rightarrow> 'a ^ 'n ^ 'n" where
  "diagvector x = (\<chi> i. \<chi> j. if i = j then x i else 0)"

lemma diagvector_mult_vector[simp]: "diagvector x *v y = (\<chi> i. x i * y $ i)"
  unfolding diagvector_def matrix_vector_mult_def vec_eq_iff vec_lambda_beta
proof (rule, goal_cases)
  case (1 i)
  show ?case by (subst sum.remove[of _ i], auto)
qed

lemma diagvector_mult_left: "diagvector x ** A = (\<chi> i j. x i * A $ i $ j)" (is "?A = ?B")
  unfolding vec_eq_iff
proof (intro allI)
  fix i j
  show "?A $h i $h j = ?B $h i $h j"
    unfolding map_vector_def diagvector_def matrix_matrix_mult_def vec_lambda_beta
    by (subst sum.remove[of _ i], auto)
qed

lemma diagvector_mult_right: "A ** diagvector x = (\<chi> i j. A $ i $ j * x j)" (is "?A = ?B")
  unfolding vec_eq_iff
proof (intro allI)
  fix i j
  show "?A $h i $h j = ?B $h i $h j"
    unfolding map_vector_def diagvector_def matrix_matrix_mult_def vec_lambda_beta
    by (subst sum.remove[of _ j], auto)
qed

lemma diagvector_mult[simp]: "diagvector x ** diagvector y = diagvector (\<lambda> i. x i * y i)"
  unfolding diagvector_mult_left unfolding diagvector_def by (auto simp: vec_eq_iff)

lemma diagvector_const[simp]: "diagvector (\<lambda> x. k) = mat k"
  unfolding diagvector_def mat_def by auto

lemma diagvector_eq_mat: "diagvector x = mat a \<longleftrightarrow> x = (\<lambda> x. a)"
  unfolding diagvector_def mat_def by (auto simp: vec_eq_iff)

lemma cmod_eq_Re: assumes "cmod x = Re x"
  shows "of_real (Re x) = x"
proof (cases "Im x = 0")
  case False
  hence "(cmod x)^2 \<noteq> (Re x)^2" unfolding norm_complex_def by simp
  from this[unfolded assms] show ?thesis by auto
qed (cases x, auto simp: norm_complex_def complex_of_real_def)

hide_fact (open) Matrix.vec_eq_iff

no_notation
  vec_index (infixl "$" 100)

lemma spectral_radius_ev:
  "\<exists> ev v. eigen_vector A v ev \<and> norm ev = spectral_radius A"
proof -
  from non_empty_spectrum[of A] finite_spectrum[of A] have
    "spectral_radius A \<in> norm ` (Collect (eigen_value A))"
    unfolding spectral_radius_ev_def by auto
  thus ?thesis unfolding eigen_value_def[abs_def] by auto
qed

lemma spectral_radius_max: assumes "eigen_value A v"
  shows "norm v \<le> spectral_radius A"
proof -
  from assms have "norm v \<in> norm ` (Collect (eigen_value A))" by auto
  from Max_ge[OF _ this, folded spectral_radius_ev_def]
    finite_spectrum[of A] show ?thesis by auto
qed

text \<open>For Perron-Frobenius it is useful to use the linear norm, and
  not the Euclidean norm.\<close>

definition norm1 :: "'a :: real_normed_field ^ 'n \<Rightarrow> real" where
  "norm1 v = (\<Sum>i\<in>UNIV. norm (v $ i))"

lemma norm1_ge_0: "norm1 v \<ge> 0" unfolding norm1_def
  by (rule sum_nonneg, auto)

lemma norm1_0[simp]: "norm1 0 = 0" unfolding norm1_def by auto

lemma norm1_nonzero: assumes "v \<noteq> 0"
  shows "norm1 v > 0"
proof -
  from \<open>v \<noteq> 0\<close> obtain i where vi: "v $ i \<noteq> 0" unfolding vec_eq_iff
    using Finite_Cartesian_Product.vec_eq_iff zero_index by force
  have "sum (\<lambda> i. norm (v $ i)) (UNIV - {i}) \<ge> 0"
    by (rule sum_nonneg, auto)
  moreover have "norm (v $ i) > 0" using vi by auto
  ultimately
  have "0 < norm (v $ i) + sum (\<lambda> i. norm (v $ i)) (UNIV - {i})" by arith
  also have "\<dots> = norm1 v" unfolding norm1_def
    by (simp add: sum.remove)
  finally show "norm1 v > 0" .
qed

lemma norm1_0_iff[simp]: "(norm1 v = 0) = (v = 0)"
  using norm1_0 norm1_nonzero by (cases "v = 0", force+)

lemma norm1_scaleR[simp]: "norm1 (r *\<^sub>R v) = abs r * norm1 v" unfolding norm1_def sum_distrib_left
  by (rule sum.cong, auto)

lemma abs_norm1[simp]: "abs (norm1 v) = norm1 v" using norm1_ge_0[of v] by arith

lemma normalize_eigen_vector: assumes "eigen_vector (A :: 'a :: real_normed_field ^ 'n ^ 'n) v ev"
  shows "eigen_vector A ((1 / norm1 v) *\<^sub>R v) ev" "norm1 ((1 / norm1 v) *\<^sub>R v) = 1"
proof -
  let ?v = "(1 / norm1 v) *\<^sub>R v"
  from assms[unfolded eigen_vector_def]
  have nz: "v \<noteq> 0" and id: "A *v v = ev *s v" by auto
  from nz have norm1: "norm1 v \<noteq> 0" by auto
  thus "norm1 ?v = 1" by simp
  from norm1 nz have nz: "?v \<noteq> 0" by auto
  have "A *v ?v = (1 / norm1 v) *\<^sub>R (A *v v)"
    by (auto simp: vec_eq_iff matrix_vector_mult_def real_vector.scale_sum_right)
  also have "A *v v = ev *s v" unfolding id ..
  also have "(1 / norm1 v) *\<^sub>R (ev *s v) = ev *s ?v"
    by (auto simp: vec_eq_iff)
  finally show "eigen_vector A ?v ev" using nz unfolding eigen_vector_def by auto
qed

lemma norm1_ge_norm: "norm1 v \<ge> norm v" unfolding norm1_def norm_vec_def
  by (rule L2_set_le_sum, auto)

text \<open>The following continuity lemmas have been proven with hints from Fabian Immler.\<close>

lemma tendsto_matrix_vector_mult[tendsto_intros]:
  "((*v) (A :: 'a :: real_normed_algebra_1 ^ 'n ^ 'k) \<longlongrightarrow> A *v v) (at v within S)"
  unfolding matrix_vector_mult_def[abs_def]
  by (auto intro!: tendsto_intros)

lemma tendsto_matrix_matrix_mult[tendsto_intros]:
  "((**) (A :: 'a :: real_normed_algebra_1 ^ 'n ^ 'k) \<longlongrightarrow> A ** B) (at B within S)"
  unfolding matrix_matrix_mult_def[abs_def]
  by (auto intro!: tendsto_intros)

lemma matrix_vect_scaleR: "(A :: 'a :: real_normed_algebra_1 ^ 'n ^ 'k) *v (a *\<^sub>R v) = a *\<^sub>R (A *v v)"
  unfolding vec_eq_iff
  by (auto simp: matrix_vector_mult_def scaleR_vec_def scaleR_sum_right
  intro!: sum.cong)

lemma (in inj_semiring_hom) map_vector_0: "(map_vector hom v = 0) = (v = 0)"
  unfolding vec_eq_iff map_vector_def by auto

lemma (in inj_semiring_hom) map_vector_inj: "(map_vector hom v = map_vector hom w) = (v = w)"
  unfolding vec_eq_iff map_vector_def by auto

lemma (in semiring_hom) matrix_vector_mult_hom:
  "(map_matrix hom A) *v (map_vector hom v) = map_vector hom (A *v v)"
  by (transfer fixing: hom, auto simp: mult_mat_vec_hom)

lemma (in semiring_hom) vector_smult_hom:
  "hom x *s (map_vector hom v) = map_vector hom (x *s v)"
  by (transfer fixing: hom, auto simp: vec_hom_smult)

lemma (in inj_comm_ring_hom) eigen_vector_hom:
  "eigen_vector (map_matrix hom A) (map_vector hom v) (hom x) = eigen_vector A v x"
  unfolding eigen_vector_def matrix_vector_mult_hom vector_smult_hom map_vector_0 map_vector_inj
  by auto

end


(* Title: Fishers_Inequality.thy
   Author: Chelsea Edmonds
*)

section \<open>Fisher's Inequality\<close>

text \<open>This theory presents the proof of Fisher's Inequality \cite{fisherExaminationDifferentPossible1940a}
 on BIBD's (i.e. uniform Fisher's) and the generalised nonuniform Fisher's Inequality \<close>
theory Fishers_Inequality imports Rank_Argument_General Linear_Bound_Argument
begin

subsection \<open> Uniform Fisher's Inequality \<close>
context ordered_bibd
begin

text \<open>Row/Column transformation steps \<close>

text\<open>Following design theory lecture notes from MATH3301 at the University of Queensland
 \cite{HerkeLectureNotes2016}, a simple transformation to produce an upper triangular matrix using elementary
row operations is to (1) Subtract the first row from each other row, and (2) add all columns to the first column\<close>

lemma transform_N_step1_vals:
  defines mdef: "M \<equiv> (N * N\<^sup>T)"
  assumes "i < dim_row M"
  assumes "j < dim_col M"
  shows "i = 0 \<Longrightarrow> j = 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>)" \<comment> \<open> top left elem \<close>
  and "i \<noteq> 0 \<Longrightarrow> j = 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>) - (int \<r>)" \<comment> \<open> first column ex. 1 \<close>
  and "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>)" \<comment> \<open> first row ex. 1 \<close>
  and "i \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>) - (int \<Lambda>)" \<comment> \<open> diagonal ex. 1 \<close>
  and "i \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> i \<noteq> j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = 0" \<comment> \<open> everything else \<close>
  using transpose_N_mult_diag v_non_zero assms
proof (simp)
  show "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>)"
    using transpose_N_mult_off_diag v_non_zero assms transpose_N_mult_dim(2) by force
next
  assume a: "j = 0" "i\<noteq>0"
  then have ail: "((-1) * M $$(0, j)) = -(int \<r>)"
    using transpose_N_mult_diag v_non_zero mdef by auto
  then have ijne: "j \<noteq> i" using a by simp
  then have aij: "M $$ (i, j) = (int \<Lambda>)" using assms(2) mdef transpose_N_mult_off_diag a v_non_zero
    by (metis transpose_N_mult_dim(1))
  then have "add_row_to_multiple (-1) [1..<dim_row M] 0 M $$ (i, j) = (-1)*(int \<r>) + (int \<Lambda>)"
    using ail add_first_row_to_multiple_index(2) assms(2) assms(3) a by (metis mult_minus1)
  then show "(add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<Lambda>) - (int \<r>)"
    by linarith
next
  assume a: "i \<noteq> 0" "j \<noteq> 0"
  have ail: "((-1) * M $$(0, j)) = -(int \<Lambda>)"
    using assms transpose_N_mult_off_diag a v_non_zero transpose_N_mult_dim(1) by auto
  then have  "i = j \<Longrightarrow> M $$ (i, j) = (int \<r>)"
    using assms transpose_N_mult_diag a v_non_zero by (metis transpose_N_mult_dim(1))
  then show "i = j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = (int \<r>) - (int \<Lambda>)"
    using ail add_first_row_to_multiple_index(2) assms a by (metis uminus_add_conv_diff)
  then have "i \<noteq> j \<Longrightarrow> M $$ (i, j) = (int \<Lambda>)" using assms transpose_N_mult_off_diag a v_non_zero
    by (metis transpose_N_mult_dim(1) transpose_N_mult_dim(2))
  then show "i \<noteq> j \<Longrightarrow> (add_row_to_multiple (-1) [1..<dim_row M] 0 M) $$ (i, j) = 0"
    using ail add_first_row_to_multiple_index(2) assms a by (metis add.commute add.right_inverse)
qed

lemma transform_N_step2_vals:
  defines mdef: "M \<equiv> (add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  assumes "i < dim_row (M)"
  assumes "j < dim_col (M)"
  shows "i = 0 \<Longrightarrow> j = 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) =
    (int \<r>) + (int \<Lambda>) * (\<v> - 1)" \<comment> \<open> top left element \<close>
  and "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j)  = (int \<Lambda>)" \<comment> \<open> top row \<close>
  and "i \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) - (int \<Lambda>)" \<comment> \<open> Diagonal \<close>
  and "i \<noteq> 0 \<Longrightarrow> i \<noteq> j \<Longrightarrow>  add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = 0" \<comment> \<open>Everything else\<close>
proof -
  show "i = 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j)  = (int \<Lambda>)"
    using add_all_cols_to_first assms transform_N_step1_vals(3) by simp
  show "i \<noteq> 0 \<Longrightarrow> i = j \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) - (int \<Lambda>)"
    using add_all_cols_to_first assms transform_N_step1_vals(4) by simp
next
  assume a: "i = 0" "j =0"
  then have size: "card {1..<dim_col M} = \<v> - 1" using assms by simp
  have val: "\<And> l . l \<in> {1..<dim_col M} \<Longrightarrow> M $$ (i, l) = (int \<Lambda>)"
    using mdef transform_N_step1_vals(3) by (simp add: a(1))
  have "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (\<Sum>l\<in>{1..<dim_col M}.  M $$(i,l)) + M$$(i,0)"
    using a assms add_all_cols_to_first by blast
  also have "... = (\<Sum>l\<in>{1..<dim_col M}.  (int \<Lambda>)) + M$$(i,0)" using val by simp
  also have "... = (\<v> - 1) * (int \<Lambda>) + M$$(i,0)" using size by (metis sum_constant)
  finally show "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (int \<r>) + (int \<Lambda>) * (\<v> - 1)"
    using transform_N_step1_vals(1) a(1) a(2) assms(1) assms(2) by simp
next
  assume a: "i \<noteq> 0"  "i \<noteq> j"
  then show "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = 0"
  proof (cases "j \<noteq> 0")
    case True
    then show ?thesis using add_all_cols_to_first assms a transform_N_step1_vals(5) by simp
  next
    case False
    then have iin: "i \<in> {1..<dim_col M}" using a(1) assms by simp
    have cond: "\<And> l . l \<in> {1..<dim_col M} \<Longrightarrow> l <dim_col (N * N\<^sup>T) \<and> l \<noteq> 0" using assms by simp
    then have val: "\<And> l . l \<in> {1..<dim_col M } - {i} \<Longrightarrow> M $$ (i, l) = 0"
      using assms(3) transform_N_step1_vals(5) a False assms(1)
      by (metis DiffE iin index_mult_mat(2) index_mult_mat(3) index_transpose_mat(3) insertI1)
    have val2: "M $$ (i, i) = (int \<r>) - (int \<Lambda>)" using mdef transform_N_step1_vals(4) a False
       assms(1) transpose_N_mult_dim(1) transpose_N_mult_dim(2)
      by (metis cond iin)
    have val3: "M$$ (i, 0) = (int \<Lambda>) - (int \<r>)"
      using assms(3) transform_N_step1_vals(2) a False assms(1) assms(2)
      by (metis add_row_to_multiple_dim(1) transpose_N_mult_dim(2) v_non_zero)
    have "add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (\<Sum>l\<in>{1..<dim_col M}.  M $$(i,l)) + M$$(i,0)"
      using assms add_all_cols_to_first False by blast
    also have "... = M $$ (i, i)  + (\<Sum>l\<in>{1..<dim_col M} - {i}.  M $$(i,l)) + M$$(i,0)"
      by (metis iin finite_atLeastLessThan sum.remove)
    finally show ?thesis using val val2 val3 by simp
  qed
qed

text \<open>Transformed matrix is upper triangular \<close>
lemma transform_upper_triangular:
  defines mdef: "M \<equiv> (add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  shows "upper_triangular (add_multiple_cols 1 0 [1..<dim_col M] M)"
  using transform_N_step2_vals(4) by (intro upper_triangularI) (simp add: assms)

text \<open>Find the determinant of the $NN^T$ matrix using transformed matrix values\<close>
lemma determinant_inc_mat_square: "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1))* (\<r> - \<Lambda>)^(\<v> - 1)"
proof -
\<comment> \<open> Show the matrix is now lower triangular, therefore the det is the product of the sum of diagonal \<close>
  have cm: "(N * N\<^sup>T) \<in> carrier_mat \<v> \<v>"
    using transpose_N_mult_dim(1) transpose_N_mult_dim(2) by blast
  define C where "C \<equiv>(add_row_to_multiple (-1) [1..<dim_row (N * N\<^sup>T)] 0 (N * N\<^sup>T))"
  have "0 \<notin> set [1..<dim_row (N * N\<^sup>T)]" by simp
  then have detbc: "det (N * N\<^sup>T) = det C"
    using C_def add_row_to_multiple_det v_non_zero by (metis cm)
  define D where "D \<equiv> add_multiple_cols 1 0 [1..<dim_col C] C"
  have d00: "D $$ (0, 0) = ((int \<r>) + (int \<Lambda>) * (\<v> - 1))" using transform_N_step2_vals(1)
    by (simp add: C_def D_def v_non_zero)
  have ine0: "\<And> i. i \<in> {1..<dim_row D} \<Longrightarrow> i \<noteq> 0" by simp
  have "\<And> i. i \<in> {1..<dim_row D} \<Longrightarrow> i < dim_row (N * N\<^sup>T)" using D_def C_def by simp
  then have diagnon0: "\<And> i. i \<in> {1..<\<v>} \<Longrightarrow> D $$ (i, i) = (int \<r>) - (int \<Lambda>)"
    using transform_N_step2_vals(3) ine0 D_def C_def by simp (* Slow *)
  have alll: "\<And> l. l \<in> set [1..<dim_col C] \<Longrightarrow> l < \<v>" using C_def by simp
  have cmc: "C \<in> carrier_mat \<v> \<v>" using cm C_def
    by (simp add: add_row_to_multiple_carrier)
  have dimgt2: "dim_row D \<ge> 2"
    using t_lt_order D_def C_def by (simp)
  then have fstterm: "0 \<in> { 0 ..< dim_row D}" by (simp add: points_list_length)
  have "0 \<notin> set [1..<dim_col C]" by simp
  then have "det (N * N\<^sup>T) = det D" using add_multiple_cols_det alll cmc D_def C_def
    by (metis detbc)
  also have "... = prod_list (diag_mat D)" using det_upper_triangular
    using transform_upper_triangular D_def C_def by fastforce
  also have "... = (\<Prod> i = 0 ..< dim_row D. D $$ (i,i))" using prod_list_diag_prod by blast
  also have "... = (\<Prod> i = 0 ..< \<v>. D $$ (i,i))"  by (simp add: D_def C_def)
  finally have "det (N * N\<^sup>T) = D $$ (0, 0) * (\<Prod> i =  1 ..< \<v>. D $$ (i,i))"
    using dimgt2 by (simp add: prod.atLeast_Suc_lessThan v_non_zero)
  then have "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1)) * ((int \<r>) - (int \<Lambda>))^(\<v> - 1)"
    using d00 diagnon0 by simp
  then have "det (N * N\<^sup>T) = (\<r> + \<Lambda> * (\<v> - 1)) * ( \<r> - \<Lambda>)^(\<v> - 1)"
    using index_lt_replication
    by (metis (no_types, lifting) less_imp_le_nat of_nat_diff of_nat_mult of_nat_power)
  then show ?thesis by blast
qed

text \<open>Fisher's Inequality using the rank argument.
Note that to use the rank argument we must first map N to a real matrix. It is useful to explicitly
include the parameters which should be used in the application of the @{thm [source] "rank_argument_det"} lemma \<close>
theorem Fishers_Inequality_BIBD: "\<v> \<le> \<b>"
proof (intro rank_argument_det[of "map_mat real_of_int N" "\<v>" "\<b>"], simp_all)
  show "N \<in> carrier_mat \<v> (length \<B>s)" using blocks_list_length N_carrier_mat by simp
  let ?B = "map_mat (real_of_int) (N * N\<^sup>T)"
  have b_split: "?B = map_mat (real_of_int) N * (map_mat (real_of_int) N)\<^sup>T"
    using semiring_hom.mat_hom_mult  of_int_hom.semiring_hom_axioms transpose_carrier_mat map_mat_transpose
    by (metis (no_types, lifting) N_carrier_mat)
  have db: "det ?B = (\<r> + \<Lambda> * (\<v> - 1))* (\<r> - \<Lambda>)^(\<v> - 1)"
    using determinant_inc_mat_square by simp
  have lhn0: "(\<r> + \<Lambda> * (\<v> - 1)) > 0"
    using r_gzero by blast
  have "(\<r> - \<Lambda>) > 0"
    using index_lt_replication zero_less_diff by blast
  then have det_not_0:  "det ?B \<noteq> 0" using lhn0 db
    by (metis gr_implies_not0 mult_is_0 of_nat_eq_0_iff power_not_zero)
  thus "det (of_int_hom.mat_hom N * (of_int_hom.mat_hom N)\<^sup>T) \<noteq> (0:: real)" using b_split by simp
qed

end

subsection \<open>Generalised Fisher's Inequality \<close>

context simp_ordered_const_intersect_design
begin

text \<open>Lemma to reason on sum coefficients \<close>
lemma sum_split_coeffs_0:
  fixes c :: "nat \<Rightarrow> real"
  assumes "\<b> \<ge> 2"
  assumes "\<m> > 0"
  assumes "j' < \<b>"
  assumes "0 = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) +
           \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)"
  shows "c j' = 0"
proof (rule ccontr)
  assume cine0: "c j' \<noteq> 0"
  have innerge: "\<And> j . j < \<b>  \<Longrightarrow> (c j)^2 * (card (\<B>s ! j) - (int \<m>))  \<ge> 0"
    using inter_num_le_block_size assms(1) by simp
  then have lhsge: "(\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) \<ge> 0"
    using sum_bounded_below[of "{0..<\<b>}" "0" "\<lambda> i. (c i)^2 * ((card (\<B>s ! i))- (int \<m>))"] by simp
  have "\<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2) \<ge> 0" by simp
  then have rhs0: "\<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2) = 0"
    using assms(2) assms(4) lhsge by linarith
  then have "(\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) = 0"
    using assms by linarith
  then have lhs0inner: "\<And> j . j < \<b>  \<Longrightarrow> (c j)^2 * (card (\<B>s ! j) - (int \<m>)) = 0"
    using innerge sum_nonneg_eq_0_iff[of "{0..<\<b>}" "\<lambda> j . (c j)^2 * (card (\<B>s ! j) - (int \<m>))"]
    by simp
  thus False proof (cases "card (\<B>s ! j') = \<m>")
    case True
    then have cj0: "\<And> j. j \<in> {0..<\<b>} - {j'} \<Longrightarrow> (c j) = 0"
      using lhs0inner const_intersect_block_size_diff assms True by auto
    then have "(\<Sum> i \<in> {0..<\<b>} . c i) \<noteq> 0"
      using sum.remove[of "{0..<\<b>}" "j'" "\<lambda> i. c i"] assms(3) cine0 cj0 by simp
    then show ?thesis using rhs0 assms by simp
  next
    case False
    then have ne: "(card (\<B>s ! j') - (int \<m>)) \<noteq> 0"
      by linarith
    then have "(c j')^2 * (card (\<B>s ! j') - (int \<m>)) \<noteq> 0" using cine0
      by auto
    then show ?thesis using lhs0inner assms(3) by auto
  qed
qed

text \<open>The general non-uniform version of fisher's inequality is also known as the "Block town problem".
In this case we are working in a constant intersect design, hence the inequality is the opposite
way around compared to the BIBD version. The theorem below is the more traditional set theoretic
approach. This proof is based off one by Jukna \cite{juknaExtremalCombinatorics2011} \<close>
theorem general_fishers_inequality:  "\<b> \<le> \<v>"
proof (cases "\<m> = 0 \<or> \<b> = 1")
  case True
  then show ?thesis using empty_inter_implies_b_lt_v v_non_zero by linarith
next
  case False
  then have mge: "\<m> > 0" by simp
  then have bge: "\<b> \<ge> 2" using b_positive False blocks_list_length by linarith
  define NR :: "real mat" where "NR \<equiv> lift_01_mat N"
  show ?thesis
  proof (intro lin_bound_argument2[of NR])
    show "distinct (cols NR)" using lift_01_distinct_cols_N NR_def by simp
    show nrcm: "NR \<in> carrier_mat \<v> \<b>" using NR_def N_carrier_mat_01_lift by simp
    have scalar_prod_real1: "\<And> i. i <\<b> \<Longrightarrow>  ((col NR i) \<bullet> (col NR i)) = card (\<B>s ! i)"
      using scalar_prod_block_size_lift_01 NR_def by auto
    have scalar_prod_real2: "\<And> i j. i <\<b> \<Longrightarrow> j <\<b> \<Longrightarrow> i \<noteq> j \<Longrightarrow> ((col NR i) \<bullet> (col NR j)) = \<m>"
      using scalar_prod_inter_num_lift_01 NR_def indexed_const_intersect by auto
    show "\<And>f. vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. f (col NR j) * (col NR j) $ i) = 0\<^sub>v \<v> \<Longrightarrow> \<forall>v\<in>set (cols NR). f v = 0"
    proof (intro ballI)
      fix f v
      assume eq0: "vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. f (col NR j) * col NR j $ i) = 0\<^sub>v \<v>"
      assume vin: "v \<in> set (cols NR)"
      define c where "c \<equiv> (\<lambda> j. f (col NR j))"
      obtain j' where v_def: "col NR j' = v" and jvlt: "j' < dim_col NR"
        using vin by (metis cols_length cols_nth index_less_size_conv nth_index)
      have dim_col: "\<And>j. j \<in> {0..< \<b>} \<Longrightarrow> dim_vec (col NR j) = \<v>" using nrcm by auto
      \<comment> \<open> Summation reasoning to obtain conclusion on coefficients \<close>
      have "0 = (vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. c j * (col NR j) $ i)) \<bullet> (vec \<v> (\<lambda>i. \<Sum>j = 0..<\<b>. c j * (col NR j) $ i))"
        using vec_prod_zero eq0 c_def by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . c j1 * c j1 * ((col NR j1) \<bullet> (col NR j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        using scalar_prod_double_sum_fn_vec[of \<b> "col NR" \<v> c] dim_col by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1) * (c j1) * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        using scalar_prod_real1 by simp
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * ((col NR j1) \<bullet> (col NR j2))))"
        by (metis power2_eq_square)
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) + (\<Sum> j1 \<in> {0..<\<b>} .
        (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2 * \<m>))" using scalar_prod_real2  by auto
      also have "... = (\<Sum> j1 \<in> {0..<\<b>} . (c j1)^2 * (card (\<B>s ! j1))) +
         \<m> * (\<Sum> j1 \<in> {0..<\<b>} . (\<Sum> j2 \<in> ({0..< \<b>} - {j1}) . c j1 * c j2))"
        using double_sum_mult_hom[of "\<m>" "\<lambda> i j . c i * c j" "\<lambda> i.{0..<\<b>} - {i}" "{0..<\<b>}"]
        by (metis (no_types, lifting) mult_of_nat_commute sum.cong)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2 - (\<Sum> j \<in> {0..<\<b>} . c j * c j))"
        using double_sum_split_square_diff by auto
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) + (-\<m>) * (\<Sum> j \<in> {0..<\<b>} . (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: algebra_simps power2_eq_square)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))) + (\<Sum> j \<in> {0..<\<b>} . (-\<m>)* (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: sum_distrib_left)
      also have "... = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * (card (\<B>s ! j))+ (-\<m>)* (c j)^2) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (metis (no_types) sum.distrib)
      finally have sum_rep: "0 = (\<Sum> j \<in> {0..<\<b>} . (c j)^2 * ((card (\<B>s ! j))- (int \<m>))) +
         \<m> * ((\<Sum> j \<in> {0..<\<b>} . c j)^2)" by (simp add: algebra_simps)
      thus "f v = 0" using sum_split_coeffs_0[of "j'" "c"] mge bge jvlt nrcm c_def v_def by simp
    qed
  qed
qed

end

text \<open>Using the dual design concept, it is easy to translate the set theoretic general definition
of Fisher's inequality to a more traditional design theoretic version on pairwise balanced designs.
Two versions of this are given using different trivial (but crucial) conditions on design properties\<close>
context ordered_pairwise_balance
begin

corollary general_nonuniform_fishers: \<comment> \<open>only valid on incomplete designs \<close>
  assumes "\<Lambda> > 0"
  assumes "\<And> bl. bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
    \<comment> \<open> i.e. not a super trivial design with only complete blocks \<close>
  shows "\<v> \<le> \<b>"
proof -
  have "mset (\<B>s*) = dual_blocks \<V> \<B>s" using dual_blocks_ordered_eq by simp
  then interpret des: simple_const_intersect_design "set [0..<(length \<B>s)]" "mset (\<B>s*)" \<Lambda>
    using assms dual_is_simp_const_inter_des by simp
  interpret odes: simp_ordered_const_intersect_design "[0..<length \<B>s]" "\<B>s*" \<Lambda>
    using distinct_upt des.wellformed by (unfold_locales) (blast)
  have "length (\<B>s*) \<le> length [0..<length \<B>s]" using odes.general_fishers_inequality
    using odes.blocks_list_length odes.points_list_length by presburger
  then have "\<v> \<le> length \<B>s"
    by (simp add: dual_blocks_len points_list_length)
  then show ?thesis by auto
qed

corollary general_nonuniform_fishers_comp:
  assumes "\<Lambda> > 0"
  assumes "count \<B> \<V> < \<Lambda>" \<comment> \<open> i.e. not a super trivial design with only complete blocks and single blocks \<close>
  shows "\<v> \<le> \<b>"
proof -
  define B where "B = (removeAll_mset \<V> \<B>)"
  have b_smaller: "size B \<le> \<b>" using B_def removeAll_size_lt by simp
  then have b_incomp: "\<And> bl. bl \<in># B \<Longrightarrow> card bl < \<v>"
    using wellformed B_def by (simp add: psubsetI psubset_card_mono)
  have index_gt: "(\<Lambda> - (count \<B> \<V>)) > 0" using assms by simp
  interpret pbd: pairwise_balance \<V> B "(\<Lambda> - (count \<B> \<V>))"
    using remove_all_complete_blocks_pbd B_def assms(2) by blast
  obtain Bs where m: "mset Bs = B"
    using ex_mset by blast
  interpret opbd: ordered_pairwise_balance \<V>s Bs "(\<Lambda> - (count \<B> \<V>))"
    by (intro pbd.ordered_pbdI) (simp_all add: m distinct)
  have "\<v> \<le> (size B)" using b_incomp opbd.general_nonuniform_fishers
    using index_gt m by blast
  then show ?thesis using b_smaller m by auto
qed

end
end


(*
  File:    Misc.thy
  Authors: Max W. Haslbeck, Manuel Eberl
*)
section \<open>Auxiliary material\<close>
theory Misc
  imports "HOL-Analysis.Analysis"
begin

text \<open>Based on @{term sorted_list_of_set} and @{term the_inv_into} we construct a bijection between
  a finite set A of type 'a::linorder and a set of natural numbers @{term "{..< card A}"}\<close>

lemma bij_betw_mono_on_the_inv_into:
  fixes A::"'a::linorder set" and B::"'b::linorder set"
  assumes b: "bij_betw f A B" and m: "mono_on A f"
  shows "mono_on B (the_inv_into A f)"
proof (rule ccontr)
  assume "\<not> mono_on B (the_inv_into A f)"
  then have "\<exists>r s. r \<in> B \<and> s \<in> B \<and> r \<le> s \<and> \<not> the_inv_into A f s \<ge> the_inv_into A f r"
    unfolding mono_on_def by blast
  then obtain r s where rs: "r \<in> B" "s \<in> B" "r \<le> s" "the_inv_into A f s < the_inv_into A f r"
    by fastforce
  have f: "f (the_inv_into A f b) = b" if "b \<in> B" for b
    using that assms f_the_inv_into_f_bij_betw by metis
  have "the_inv_into A f s \<in> A" "the_inv_into A f r \<in> A"
    using rs assms by (auto simp add: bij_betw_def the_inv_into_into)
  then have "f (the_inv_into A f s) \<le> f (the_inv_into A f r)"
   using rs by (intro mono_onD[OF m]) (auto)
  then have "r = s"
    using rs f by simp
  then show False
    using rs by auto
qed

lemma rev_removeAll_removeAll_rev: "rev (removeAll x xs) = removeAll x (rev xs)"
  by (simp add: removeAll_filter_not_eq rev_filter)

lemma sorted_list_of_set_Min_Cons:
  assumes "finite A" "A \<noteq> {}"
  shows "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
proof -
  have *: "A = insert (Min A) A"
    using assms Min_in by (auto)
  then have "sorted_list_of_set A = insort (Min A) (sorted_list_of_set (A - {Min A}))"
    using assms by (subst *, intro sorted_list_of_set_insert_remove) auto
  also have "\<dots> = Min A # sorted_list_of_set (A - {Min A})"
    using assms by (intro insort_is_Cons) (auto)
  finally show ?thesis
    by simp
qed

lemma sorted_list_of_set_filter:
  assumes "finite A"
  shows "sorted_list_of_set ({x\<in>A. P x}) = filter P (sorted_list_of_set A)"
  using assms proof (induction "sorted_list_of_set A" arbitrary: A)
  case (Cons x xs)
  have x: "x \<in> A"
    using Cons sorted_list_of_set list.set_intros(1) by metis
  have "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
    using Cons by (intro sorted_list_of_set_Min_Cons) auto
  then have 1: "x = Min A" "xs = sorted_list_of_set (A - {x})"
    using Cons by auto
  { assume Px: "P x"
    have 2: "sorted_list_of_set {x \<in> A. P x} = Min {x \<in> A. P x} # sorted_list_of_set ({x \<in> A. P x} - {Min {x \<in> A. P x}})"
      using Px Cons 1 sorted_list_of_set_eq_Nil_iff
      by (intro sorted_list_of_set_Min_Cons) fastforce+
    also have 3: "Min {x \<in> A. P x} = x"
      using Cons 1 Px x by (auto intro!: Min_eqI)
    also have 4: "{x \<in> A. P x} - {x} = {y \<in> A - {x}. P y}"
      by blast
    also have 5: "sorted_list_of_set {y \<in> A - {x}. P y} = filter P (sorted_list_of_set (A - {x}))"
      using 1 Cons by (intro Cons) (auto)
    also have "\<dots> = filter P xs"
      using 1 by simp
    also have "filter P (sorted_list_of_set A) = x # filter P xs"
      using Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
    finally have ?case
      by auto }
  moreover
  { assume Px: "\<not> P x"
    then have "{x \<in> A. P x} = {y \<in> A - {x}. P y}"
      by blast
    also have "sorted_list_of_set \<dots> = filter P (sorted_list_of_set (A - {x}))"
      using 1 Cons by (intro Cons) auto
    also have  "filter P (sorted_list_of_set (A - {x})) = filter P (sorted_list_of_set A)"
      using 1 Px by (simp flip: \<open>x # xs = sorted_list_of_set A\<close>)
    finally have ?case
      by simp }
  ultimately show ?case
    by blast
qed (use sorted_list_of_set_eq_Nil_iff in fastforce)

lemma sorted_list_of_set_Max_snoc:
  assumes "finite A" "A \<noteq> {}"
  shows "sorted_list_of_set A = sorted_list_of_set (A - {Max A}) @ [Max A]"
proof -
  have *: "A = insert (Max A) A"
    using assms Max_in by (auto)
  then have "sorted_list_of_set A = insort (Max A) (sorted_list_of_set (A - {Max A}))"
    using assms by (subst *, intro sorted_list_of_set_insert_remove) auto
  also have "\<dots> = sorted_list_of_set (A - {Max A}) @ [Max A]"
    using assms by (intro sorted_insort_is_snoc) (auto)
  finally show ?thesis
    by simp
qed

lemma sorted_list_of_set_image:
  assumes "mono_on A g" "inj_on g A"
  shows "(sorted_list_of_set (g ` A)) = map g (sorted_list_of_set A)"
proof (cases "finite A")
  case True
  then show ?thesis
    using assms proof (induction "sorted_list_of_set A" arbitrary: A)
    case Nil
    then show ?case
      using sorted_list_of_set_eq_Nil_iff by fastforce
  next
    case (Cons x xs A)
    have not_empty_A: "A \<noteq> {}"
      using Cons sorted_list_of_set_eq_Nil_iff by auto
    have *: "Min (g ` A) = g (Min A)"
    proof -
      have "g (Min A) \<le> g a" if "a \<in> A" for a
        using that Cons Min_in Min_le not_empty_A by (auto intro!: mono_onD[of _ g])
      then show ?thesis
        using Cons not_empty_A by (intro Min_eqI) auto
    qed
    have "g ` A \<noteq> {}" "finite (g ` A)"
      using Cons by auto
    then have "(sorted_list_of_set (g ` A)) =
             Min (g ` A) # sorted_list_of_set ((g ` A) - {Min (g ` A)})"
      by (auto simp add: sorted_list_of_set_Min_Cons)
    also have "(g ` A) - {Min (g ` A)} = g ` (A - {Min A})"
      using Cons Min_in not_empty_A * by (subst inj_on_image_set_diff[of _ A]) auto
    also have "sorted_list_of_set (g ` (A - {Min A})) = map g (sorted_list_of_set (A - {Min A}))"
      using not_empty_A Cons mono_on_subset[of A _ "A - {Min A}"] inj_on_subset[of _ A "A - {Min A}"]
      by (intro Cons) (auto simp add: sorted_list_of_set_Min_Cons)
    finally show ?case
      using Cons not_empty_A * by (auto simp add: sorted_list_of_set_Min_Cons)
  qed
next
  case False
  then show ?thesis
    using assms by (simp add: finite_image_iff)
qed

lemma sorted_list_of_set_length: "length (sorted_list_of_set A) = card A"
  using distinct_card sorted_list_of_set[of A] by (cases "finite A") fastforce+

lemma sorted_list_of_set_bij_betw:
  assumes "finite A"
  shows "bij_betw (\<lambda>n. sorted_list_of_set A ! n) {..<card A} A"
  by (rule bij_betw_nth) (fastforce simp add: assms sorted_list_of_set_length)+

lemma nth_mono_on:
  assumes "sorted xs" "distinct xs" "set xs = A"
  shows "mono_on {..<card A} (\<lambda>n. xs ! n)"
  using assms by (intro mono_onI sorted_nth_mono) (auto simp add: distinct_card)

lemma sorted_list_of_set_mono_on:
  "finite A \<Longrightarrow> mono_on {..<card A} (\<lambda>n. sorted_list_of_set A ! n)"
  by (rule nth_mono_on) (auto)

definition bij_mono_map_set_to_nat :: "'a::linorder set \<Rightarrow> 'a \<Rightarrow> nat" where
  "bij_mono_map_set_to_nat A =
    (\<lambda>x. if x \<in> A then the_inv_into {..<card A} ((!) (sorted_list_of_set A)) x
                  else card A)"

lemma bij_mono_map_set_to_nat:
  assumes "finite A"
  shows "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
        "mono_on A (bij_mono_map_set_to_nat A)"
        "(bij_mono_map_set_to_nat A) ` A = {..<card A}"
proof -
  let ?f = "bij_mono_map_set_to_nat A"
  have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}"
    using assms sorted_list_of_set_bij_betw  bij_betw_the_inv_into by blast
  moreover have "bij_betw (the_inv_into {..<card A} ((!) (sorted_list_of_set A))) A {..<card A}
                     = bij_betw ?f A {..<card A}"
    unfolding bij_mono_map_set_to_nat_def by (rule bij_betw_cong) simp
  ultimately show *: "bij_betw (bij_mono_map_set_to_nat A) A {..<card A}"
    by blast
  have "mono_on A (the_inv_into {..<card A} ((!) (sorted_list_of_set A)))"
    using assms sorted_list_of_set_bij_betw
      sorted_list_of_set_mono_on by (intro bij_betw_mono_on_the_inv_into) auto
  then show "mono_on A (bij_mono_map_set_to_nat A)"
    unfolding bij_mono_map_set_to_nat_def using mono_onD by (intro mono_onI) (auto)
  show "?f ` A = {..<card A}"
      using assms bij_betw_imp_surj_on * by blast
qed

end


(*<*)
(*
   Title:  Theory JoinSplitTime.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
 header {* Changing time granularity of the streams  *}

theory JoinSplitTime
imports stream arith_hints
begin

subsection  {* Join time units *}

primrec
  join_ti ::"'a istream \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
join_ti_0:
 "join_ti s x 0 = s x" |
join_ti_Suc:
 "join_ti s x (Suc i) = (join_ti s x i) @ (s (x + (Suc i)))"

primrec
  fin_join_ti ::"'a fstream \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
fin_join_ti_0:
 "fin_join_ti s x 0 = nth s x" |
fin_join_ti_Suc:
 "fin_join_ti s x (Suc i) = (fin_join_ti s x i) @ (nth s (x + (Suc i)))"

definition
  join_time ::"'a istream \<Rightarrow> nat \<Rightarrow> 'a istream"
where
 "join_time s n t \<equiv>
  (case n of
        0  \<Rightarrow> []
  |(Suc i) \<Rightarrow>  join_ti s (n*t) i)"

lemma join_ti_hint1:
  assumes "join_ti s x (Suc i) = []"
  shows   "join_ti s x i = []"
using assms by auto

lemma join_ti_hint2:
  assumes "join_ti s x (Suc i) = []"
  shows   "s (x + (Suc i)) = []"
using assms by auto

lemma join_ti_hint3:
  assumes "join_ti s x (Suc i) = []"
  shows   "s (x + i) = []"
using assms by (induct i, auto)

lemma join_ti_empty_join:
  assumes "i \<le> n"
         and "join_ti s x n = []"
  shows      "s (x+i) = []"
using assms
proof (induct n)
  case 0 then show ?case by auto
next
  case (Suc n) then show ?case
  by (metis join_ti_hint1 join_ti_hint2 le_SucE)
qed

lemma join_ti_empty_ti:
  assumes "\<forall> i \<le> n. s (x+i) = []"
  shows    "join_ti s x n = []"
using assms by (induct n, auto)

lemma join_ti_1nempty:
  assumes "\<forall> i. 0 < i \<and> i < Suc n \<longrightarrow> s (x+i) = []"
  shows    "join_ti s x n = s x"
using assms by (induct n, auto)

lemma join_time1t: "\<forall> t. join_time s (1::nat) t = s t"
by (simp add: join_time_def)

lemma join_time1: "join_time s 1 = s"
by (simp add: fun_eq_iff join_time_def)

lemma join_time_empty1:
  assumes h1:"i < n"
         and h2:"join_time s n t = []"
  shows      "s (n*t + i) = []"
proof (cases n)
  assume "n = 0"
  from assms and this show ?thesis by (simp add: join_time_def)
next
  fix x
  assume a2:"n = Suc x"
  from assms and a2 have sg1:"join_ti s (t + x * t) x = []"
    by (simp add: join_time_def)
  from a2 and h1 have "i \<le> x" by simp
  from this and sg1 and a2 show ?thesis by (simp add: join_ti_empty_join)
qed

lemma fin_join_ti_hint1:
  assumes "fin_join_ti s x (Suc i) = []"
  shows   "fin_join_ti s x i = []"
using assms by auto

lemma fin_join_ti_hint2:
  assumes "fin_join_ti s x (Suc i) = []"
  shows    "nth s (x + (Suc i)) = []"
using assms by auto

lemma fin_join_ti_hint3:
  assumes "fin_join_ti s x (Suc i) = []"
  shows    "nth s (x + i) = []"
using assms by (induct i, auto)

lemma fin_join_ti_empty_join:
  assumes "i \<le> n"
         and "fin_join_ti s x n = []"
  shows      "nth s (x+i) = []"
using assms
proof (induct n)
  case 0 then show ?case by auto
next
  case (Suc n) then show ?case
  proof (cases "i = Suc n")
    assume "i = Suc n"
    from Suc and this show ?thesis by simp
  next
    assume "i \<noteq> Suc n"
    from Suc and this show ?thesis by simp
  qed
qed

lemma fin_join_ti_empty_ti:
  assumes "\<forall> i \<le> n. nth s (x+i) = []"
  shows    "fin_join_ti s x n = []"
using assms by (induct n, auto)

lemma fin_join_ti_1nempty:
  assumes "\<forall> i. 0 < i \<and> i < Suc n \<longrightarrow> nth s (x+i) = []"
  shows    "fin_join_ti s x n = nth s x"
using assms  by (induct n, auto)

subsection {* Split time units *}

definition
  split_time ::"'a istream \<Rightarrow> nat \<Rightarrow> 'a istream"
where
 "split_time s n t \<equiv>
  ( if (t mod n = 0)
    then s (t div n)
    else [])"

lemma split_time1t: "\<forall> t. split_time s 1 t = s t"
by (simp add: split_time_def)

lemma split_time1: "split_time s 1 = s"
by (simp add: fun_eq_iff split_time_def)

lemma split_time_mod:
  assumes "t mod n \<noteq> 0"
  shows    "split_time s n t = []"
using assms by (simp add: split_time_def)

lemma split_time_nempty:
  assumes "0 < n"
  shows    "split_time s n (n * t) = s t"
using assms by (simp add: split_time_def)

lemma split_time_nempty_Suc:
  assumes "0 < n"
  shows   "split_time s (Suc n) ((Suc n) * t) = split_time s n (n * t)"
proof -
  have "0 < Suc n" by simp
  then have sg1:"split_time s (Suc n) ((Suc n) * t) =  s t"
    by (rule split_time_nempty)
  from assms have sg2:"split_time s n (n * t) = s t"
    by (rule split_time_nempty)
  from sg1 and sg2 show ?thesis by simp
qed

lemma split_time_empty:
  assumes "i < n" and h2:"0 < i"
  shows    "split_time s n (n * t + i) = []"
proof -
  from assms have "0 < (n * t + i) mod n" by (simp add: arith_mod_nzero)
  from assms and this show ?thesis by (simp add: split_time_def)
qed

lemma split_time_empty_Suc:
  assumes h1:"i < n"
         and h2:"0 < i"
  shows "split_time s (Suc n) ((Suc n)* t + i)  = split_time s n (n * t + i)"
proof -
  from h1 have "i < Suc n" by simp
  from this and h2 have sg2:"split_time s (Suc n) (Suc n * t + i) = []"
    by (rule split_time_empty)
  from assms have sg3:"split_time s n (n * t + i) = []"
    by (rule split_time_empty)
  from sg3 and sg2 show ?thesis by simp
qed

lemma split_time_hint1:
  assumes "n = Suc m"
  shows   "split_time s (Suc n) (i + n * i + n) = []"
proof -
  have sg1:"i + n * i + n = (Suc n) * i + n" by simp
  have sg2:"n < Suc n" by simp
  from assms have sg3:"0 < n" by simp
  from sg2 and sg3 have sg4:"split_time s (Suc n) (Suc n * i + n) = []"
     by (rule split_time_empty)
  from sg1 and sg4  show ?thesis by auto
qed

subsection {* Duality of the split and the join operators *}

lemma join_split_i:
  assumes "0 < n"
  shows   "join_time (split_time s n) n i = s i"
proof (cases n)
  assume "n = 0"
  from this and assms show ?thesis by simp
next
  fix k
  assume a2:"n = Suc k"
  have sg0:"0 < Suc k" by simp
  then have sg1:"(split_time s (Suc k)) (Suc k * i) = s i"
    by (rule split_time_nempty)
  have sg2:"i + k * i = (Suc k) * i" by simp
  have sg3:"\<forall> j. 0 < j \<and> j < Suc k \<longrightarrow> split_time s (Suc k) (Suc k * i + j) = []"
    by (clarify, rule split_time_empty, auto)
  from sg3 have sg4:"join_ti (split_time s (Suc k)) ((Suc k) * i) k =
                     (split_time s (Suc k)) (Suc k * i)"
    by (rule join_ti_1nempty)
  from a2 and sg4 and sg1 show ?thesis by (simp add: join_time_def)
qed

lemma join_split:
  assumes "0 < n"
  shows "join_time (split_time s n) n = s"
using assms  by (simp add: fun_eq_iff join_split_i)

end