(* 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 Order_Statistic_Tree
  imports
  Deriving.Comparator
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Sorting"
begin

abbreviation sorted :: "'a::linorder list \<Rightarrow> bool" where
"sorted \<equiv> sorted_wrt (\<le>)"

text \<open>Equivalent lemmas for <= instead of <.\<close>

lemma insort_list_sorted: "sorted (xs @ [a]) \<Longrightarrow>
  Sorting.insort x (xs @ a # ys) =
  (if x < a then Sorting.insort x xs @ (a#ys) else xs @ Sorting.insort x (a#ys))"
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by (induction xs) auto
qed

corollary insort_list_sorted1: "sorted (xs @ [a]) \<Longrightarrow> a \<le> x \<Longrightarrow>
  Sorting.insort x (xs @ a # ys) = xs @ Sorting.insort x (a#ys)"
by(auto simp add: insort_list_sorted)

corollary insort_list_sorted2: "sorted (xs @ [a]) \<Longrightarrow> x < a \<Longrightarrow>
  Sorting.insort x (xs @ a # ys) = Sorting.insort x xs @ (a#ys)"
  by(auto simp: insort_list_sorted)

lemmas insort_list_simps = sorted_lems insort_list_sorted1 insort_list_sorted2

lemma insort_leq:
  assumes "\<forall>k \<in> set xs. x \<ge> k"
  and "sorted xs"
  shows "Sorting.insort x xs = xs @ [x]"
  using assms
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by (induction xs) auto
qed

lemma del_list_sorted: "sorted (xs @ a # ys) \<Longrightarrow>
  del_list x (xs @ a # ys) = (if x < a then del_list x xs @ a # ys else xs @ del_list x (a # ys))"
proof(induction xs)
  case Nil
  then show ?case by (auto intro!: del_list_idem)
next
  case (Cons a xs)
  then show ?case apply(auto) by(induction xs) auto
qed

text \<open>Wbt:\<close>

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 = (25 * (size_wbt t1 + 1) \<ge> 10 * (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 = (14 * (size_wbt t2 + 1) > 10 * (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> balanceR (insert x l) a 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)"

fun select :: "'a wbt \<Rightarrow> nat \<Rightarrow> 'a" where
  "select (Node l (a, _) r) n =
    (let s = size_wbt l in
    (case cmp s n of
      GT \<Rightarrow> select l n |
      EQ \<Rightarrow> a |
      LT \<Rightarrow> select r (n - s - 1)))" |
  "select \<langle>\<rangle> n = [] ! n"

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) = Sorting.insort x (inorder t)"
  by (induction t) (auto simp: insort_list_simps insort_leq sorted_wrt_append le_less 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_sorted sorted_wrt_append 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) = 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 [simp]: EQ
    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]: 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

lemma valid_select_wbt:
  assumes "wbt t"
  shows "select t n = (inorder t) ! n"
  using assms
proof(induction t arbitrary:n)
  case Leaf
  then show ?case  by auto
next
  case (Node t1 x2 t2)
  then obtain a s where "x2 = (a, s)" using old.prod.exhaust by blast
  then show ?case using Node by(auto split:if_splits simp:nth_append)
qed

inductive valid_wbt_mset :: "'a::linorder wbt \<Rightarrow> 'a multiset \<Rightarrow> bool"  where
  "valid_wbt_mset Leaf {#}" |
  "valid_wbt_mset (insert a t) (s + {#a#})" if "valid_wbt_mset t s" for t s |
  "valid_wbt_mset (delete a t) (s - {#a#})" if "valid_wbt_mset t s" for t s

lemma valid_wbt_mset_bulk_insert:
  assumes "valid_wbt_mset t s"
  shows "valid_wbt_mset (((insert a) ^^ n) t) (s + replicate_mset n a)"
  using assms valid_wbt_mset.intros(2) by(induction n) (auto)

lemma valid_wbt_mset_bulk_remove:
  assumes "valid_wbt_mset t s"
  shows "valid_wbt_mset (((delete a) ^^ n) t) (s - replicate_mset n a)"
  using assms valid_wbt_mset.intros(3) by(induction n) (fastforce)+

lemma inorder_insert_split:
  shows "\<exists>xs ys. inorder (insert a t) = xs @ a # ys \<and> inorder t = xs @ ys"
proof(induction t)
  case Leaf
  then show ?case by(auto)
next
  case (Node t1 x2 t2)
  then obtain a' n where [simp]: "x2 = (a', n)" by (meson surj_pair)
  obtain xs1 ys1 where t1_split: "inorder (insert a t1) = xs1 @ a # ys1 \<and> inorder t1 = xs1 @ ys1" using Node by blast
  obtain xs2 ys2 where t2_split: "inorder (insert a t2) = xs2 @ a # ys2 \<and> inorder t2 = xs2 @ ys2" using Node by blast
  then show ?case
  proof(cases "cmp a a'")
    case LT
    then have *: "insert a \<langle>t1, x2, t2\<rangle> = balanceR (insert a t1) a' t2" by(auto)
    then show ?thesis
    proof (cases "balanced1 t2 (insert a t1)")
      case True
      then show ?thesis using * t1_split by simp blast
    next
      case False
      have "insert a t1 \<noteq> \<langle>\<rangle>" using False not_Leaf_if_not_balanced1 by blast
      then show ?thesis using * inorder_rotateR[of "insert a t1" a' t2] t1_split by(auto)
    qed
  next
    case EQ
    then have *: "insert a \<langle>t1, x2, t2\<rangle> = balanceR (insert a t1) a' t2" by(auto)
    then show ?thesis
    proof (cases "balanced1 t2 (insert a t1)")
      case True
      then show ?thesis using * t1_split by simp blast
    next
      case False
      have "insert a t1 \<noteq> \<langle>\<rangle>" using False not_Leaf_if_not_balanced1 by blast
      then show ?thesis using * inorder_rotateR[of "insert a t1" a' t2] t1_split by(auto)
    qed
  next
    case GT
    then have *: "insert a \<langle>t1, x2, t2\<rangle> = balanceL t1 a' (insert a t2)" by(auto)
    then show ?thesis
    proof (cases "balanced1 t1 (insert a t2)")
      case True
      then show ?thesis using * t2_split by(simp) (metis Cons_eq_appendI append.assoc)
    next
      case False
      have "insert a t2 \<noteq> \<langle>\<rangle>" using False not_Leaf_if_not_balanced1 by blast
      then show ?thesis using * inorder_rotateL[of "insert a t2" t1 a'] t2_split by auto (metis Cons_eq_appendI append.assoc)
    qed
  qed
qed

lemma sorted_insort_rev:
  assumes "sorted (inorder (insert a t))"
  shows "sorted (inorder t)"
proof -
  obtain xs ys where "inorder (insert a t) = xs @ a # ys \<and> inorder t = xs @ ys" using inorder_insert_split by blast
  then show ?thesis using assms by (simp add: sorted_wrt_append)
qed

lemma bulk_insert_insort:
  assumes "sorted (inorder (((insert a) ^^ n) t))"
  shows "inorder (((insert a) ^^ n) t) = (insort a ^^ n) (inorder t)"
  using assms
proof(induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have "sorted (inorder ((insert a ^^ n) t))" using sorted_insort_rev Suc(2) by auto
  then have "inorder (insert a ((insert a ^^ n) t)) = insort a ((Sorting.insort a ^^ n) (Tree2.inorder t))"
    using Suc.IH inorder_insert by fastforce
  then show ?case using inorder_insert by(auto)
qed

lemma sorted_wrt_sorted_insort:
  assumes "sorted xs"
  shows "sorted (insort a (xs))"
  using Sorting.sorted_insort[of a xs] assms by simp

lemma sorted_wrt_sorted_delete:
  assumes "sorted xs"
  shows "sorted (del_list a (xs))"
  using assms
proof(induction xs rule: del_list.induct)
  case (1 x)
  then show ?case by auto
next
  case (2 x a xs)
  have "(\<forall>x\<in>set (del_list x xs). a \<le> x)" using "2.prems" by (induction xs) auto
  then show ?case using 2 by auto
qed

lemma insort_eq: "Sorting.insort a xs = linorder_class.insort a xs"
  by(induction xs) auto

lemma insort_eq2: "Sorting.insort a = linorder_class.insort a"
  using insort_eq by auto

lemma valid_wbt_mset_sorted:
  assumes "valid_wbt_mset t m"
  shows "sorted(inorder t)"
  using assms
proof(induction rule: valid_wbt_mset.induct)
  case 1
  then show ?case by auto
next
  case (2 t s a)
  then show ?case using sorted_wrt_sorted_insort by (simp add: inorder_insert)
next
  case (3 t s a)
  then show ?case using sorted_wrt_sorted_delete by (simp add: inorder_delete)
qed

lemma valid_wbt_mset_valid_wbt:
  assumes "valid_wbt_mset t m"
  shows "wbt t"
  using assms wbt_insert wbt_delete
  by(induction rule: valid_wbt_mset.induct) auto

lemma insort_del_comm:
  assumes "x \<noteq> a"
  and "sorted xs"
  shows "linorder_class.insort x (del_list a xs) =
    del_list a (linorder_class.insort x xs)"
  using assms
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case by(induction xs) (auto)
qed

lemma insort_del_inverse:
  shows "del_list a (linorder_class.insort a xs) = xs"
  by(induction xs) (auto)

lemma del_list_multiset:
  "sorted_list_of_multiset (s - {#a#}) = del_list a (sorted_list_of_multiset s)"
proof(induction s)
  case empty
  then show ?case by auto
next
  case (add x s)
  then show ?case
  proof(cases "x = a")
    case True
    then show ?thesis using insort_del_inverse[of a] by(auto)
  next
    case False
    have "sorted(sorted_list_of_multiset s)"
    proof(induction s)
      case empty then show ?case by auto
    next
      case (add x s)
      then show ?case using sorted_insort by (auto simp:insort_eq[symmetric])
    qed
    then show ?thesis using add insort_del_comm False by(auto)
  qed
qed

lemma inorder_mset_eq:
  assumes "valid_wbt_mset t m"
  shows "inorder t = sorted_list_of_multiset m"
  using assms
proof(induction rule: valid_wbt_mset.induct)
case 1
  then show ?case by auto
next
  case (2 t s a)
  have "sorted (inorder t)" using valid_wbt_mset_sorted 2(1) by auto
  then show ?case using inorder_insert[of t a] 2 insort_eq by simp
next
  case (3 t s a)
  have "sorted (inorder t)" using valid_wbt_mset_sorted 3(1) by auto
  then show ?case using inorder_delete[of t a] 3 del_list_multiset[of s] by simp
qed

lemma valid_wbt_mset_size_eq:
  assumes "valid_wbt_mset t s"
  shows "size t = size s"
proof -
  have "length (sorted_list_of_multiset s) = size s" by (metis mset_sorted_list_of_multiset size_mset)
  then show ?thesis using size_length[of t] inorder_mset_eq[of t s] by (simp add: assms)
qed

lemma valid_wbt_empty_mset_leaf:
  assumes "valid_wbt_mset t {#}"
  shows "t = Leaf"
  using valid_wbt_mset_size_eq assms by fastforce

lemma inorder_bulk_insert_remove:
  assumes "valid_wbt_mset t (s + replicate_mset n a)"
  shows "inorder t = inorder (((insert a) ^^ n) (((delete a) ^^ n) t))"
proof -
  have valid_del: "valid_wbt_mset ((delete a ^^ n) t) s"
    using valid_wbt_mset_bulk_remove[OF assms, of n a] by auto
  have *: "valid_wbt_mset (((insert a) ^^ n) ((delete a ^^ n) t)) (s + replicate_mset n a)"
    using valid_wbt_mset_bulk_insert[OF valid_del, of n a] by auto
  show ?thesis
    using inorder_mset_eq[OF *] inorder_mset_eq[OF assms] by(auto)
qed

lemma valid_select_mset_list:
  assumes "valid_wbt_mset t m"
  and "n \<ge> 0" and "n < size t"
  shows "select t n = (sorted_list_of_multiset m) ! n"
  using inorder_mset_eq[of t m] assms valid_select_wbt[of t n] valid_wbt_mset_valid_wbt[of t m] by simp

typedef (overloaded) 'a wf_wbt = "{x::'a::linorder wbt. sorted (inorder x) \<and> wbt x}"
  by(auto intro!: exI[of _ Leaf])

setup_lifting type_definition_wf_wbt

lift_definition tree_insert:: "'a::linorder \<Rightarrow> 'a wf_wbt \<Rightarrow> 'a wf_wbt" is insert
  using wbt_insert by (simp add: inorder_insert sorted_wrt_sorted_insort) blast

lift_definition tree_remove:: "'a::linorder \<Rightarrow> 'a wf_wbt \<Rightarrow> 'a wf_wbt" is delete
  using wbt_delete by auto (simp add: inorder_delete sorted_wrt_sorted_delete)

lift_definition tree_inorder:: "'a::linorder wf_wbt \<Rightarrow> 'a list" is inorder
  .

lift_definition tree_empty :: "'a::linorder wf_wbt" is Leaf
  by auto

lift_definition empty_tree:: "'a::linorder wf_wbt" is Leaf by auto
lift_definition tree_select:: "'a::linorder wf_wbt \<Rightarrow> nat \<Rightarrow> 'a" is select .
lift_definition tree_size:: "'a::linorder wf_wbt \<Rightarrow> nat" is size_wbt .

end


theory Term3
imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" "Abs" "Perm" "Fv" "Rsp" "../Attic/Prove"
begin

atom_decl name

section {*** lets with many assignments ***}

datatype rtrm3 =
  rVr3 "name"
| rAp3 "rtrm3" "rtrm3"
| rLm3 "name" "rtrm3" --"bind (name) in (trm3)"
| rLt3 "rassigns" "rtrm3" --"bind (bv3 assigns) in (trm3)"
and rassigns =
  rANil
| rACons "name" "rtrm3" "rassigns"

(* to be given by the user *)
primrec
  bv3
where
  "bv3 rANil = {}"
| "bv3 (rACons x t as) = {atom x} \<union> (bv3 as)"

setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Term3.rtrm3") 2 *}

local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Term3.rtrm3")
  [[[[]], [[], []], [[(NONE, 0)], [(NONE, 0)]], [[], [(SOME @{term bv3}, 0)]]],
   [[], [[], [], []]]] *}
print_theorems

notation
  alpha_rtrm3 ("_ \<approx>3 _" [100, 100] 100) and
  alpha_rassigns ("_ \<approx>3a _" [100, 100] 100)
thm alpha_rtrm3_alpha_rassigns.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha3_inj}, []), (build_alpha_inj @{thms alpha_rtrm3_alpha_rassigns.intros} @{thms rtrm3.distinct rtrm3.inject rassigns.distinct rassigns.inject} @{thms alpha_rtrm3.cases alpha_rassigns.cases} ctxt)) ctxt)) *}
thm alpha3_inj

lemma alpha3_eqvt:
  "t \<approx>3 s \<Longrightarrow> (pi \<bullet> t) \<approx>3 (pi \<bullet> s)"
  "a \<approx>3a b \<Longrightarrow> (pi \<bullet> a) \<approx>3a (pi \<bullet> b)"
sorry

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha3_equivp}, []),
  (build_equivps [@{term alpha_rtrm3}, @{term alpha_rassigns}] @{thm rtrm3_rassigns.induct} @{thm alpha_rtrm3_alpha_rassigns.induct} @{thms rtrm3.inject rassigns.inject} @{thms alpha3_inj} @{thms rtrm3.distinct rassigns.distinct} @{thms alpha_rtrm3.cases alpha_rassigns.cases} @{thms alpha3_eqvt} ctxt)) ctxt)) *}
thm alpha3_equivp

quotient_type
  trm3 = rtrm3 / alpha_rtrm3
and
  assigns = rassigns / alpha_rassigns
  by (rule alpha3_equivp(1)) (rule alpha3_equivp(2))

end


theory ReversePathFiltering
imports Routing_Table Simple_Firewall.Simple_Packet
begin

text\<open>RFC3704 style RPF\<close>

text\<open>\begin{quote}The procedure is that the
   source address is looked up in the Forwarding Information Base (FIB)
   - and if the packet is received on the interface which would be used
   to forward the traffic to the source of the packet, it passes the
   check.\end{quote}\<close>
(* There's an iptables rpf in ./net/ipv4/netfilter/ipt_rpfilter.c:35
   More interesting is ./net/ipv4/fib_frontend.c:323 though
*)
definition "rpf_strict rtbl p \<equiv> output_iface (routing_table_semantics rtbl (p_src p)) = p_iiface p"

text\<open>\begin{quote}
   Feasible Path Reverse Path Forwarding (Feasible RPF) is an extension
   of Strict RPF.  The source address is still looked up in the FIB (or
   an equivalent, RPF-specific table) but instead of just inserting one
   best route there, the alternative paths (if any) have been added as
   well, and are valid for consideration.
\end{quote}\<close>
definition "rpf_feasible rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_oiface rr = p_iiface p"
definition "rpf_loose rtbl p \<equiv> \<exists>rr \<in> set rtbl. prefix_match_semantics (routing_match rr) (p_src p)"
definition "rpf_loose_ign_default rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_match rr \<noteq> PrefixMatch 0 0"
text\<open>Note that this clearly exposes a weakness of our models: The FIB we modelled really only considers the routing table. We have not taken care to avoid un-routable address spaces. As such, @{const rpf_loose} is not very useful:\<close>
lemma "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> \<forall>p. rpf_loose rtbl p"
  by(induction rtbl) (auto simp add: valid_prefixes_alt_def zero_prefix_match_all rpf_loose_def[abs_def])

text\<open>One might ask: What (nonstandard) formulations of reverse path filtering are possible? This is an example that fits into the hierarchy, between feasible and strict RPF:\<close>
definition "rpf_semifeasible    rtbl p \<equiv> \<exists>rr \<in> set rtbl.
  prefix_match_semantics (routing_match rr) (p_src p) \<and> routing_oiface rr = p_iiface p (* rule applies and routes to right interface *)
\<and> (\<forall>ra \<in> set rtbl. routing_prefix ra > routing_prefix rr \<longrightarrow>  \<not>prefix_match_semantics (routing_match ra) (p_src p)) (* no rules more specific than this one apply *)
"
text\<open>Unlinke feasible RPF, this only considers alternate routes if these routes have the same prefix length as the best route.\<close>
text\<open>The insight we are not going to prove here is: There is an infinite number of levels in this hierarchy.
(For example we might only allow alternate routes whose metric difference it at max @{term n}. However, there are more interesting formulations of RPF that we did not discuss.)\<close>

lemma "prefix_match_semantics (PrefixMatch 0 0) any" by (simp add: valid_prefix_00 zero_prefix_match_all)

text\<open>The hierarchy unfolds:\<close>
lemma
  assumes "valid_prefixes rtbl" "is_longest_prefix_routing rtbl" "has_default_route rtbl" "unambiguous_routing rtbl"
  shows "rpf_strict rtbl p \<Longrightarrow> rpf_semifeasible rtbl p"
unfolding rpf_semifeasible_def rpf_strict_def
(* meh, the thing is subtly different enough from existential_routing that we can't use that directly *)
proof goal_cases
  case 1
  then obtain act where *: "routing_table_semantics rtbl (p_src p) = act" by blast
  with existential_routing[OF assms]
  have ex: "(\<exists>rr\<in>set rtbl.
        prefix_match_semantics (routing_match rr) (p_src p) \<and>
        output_iface (routing_action rr) = output_iface act \<and> (\<forall>ra\<in>set rtbl. routing_rule_sort_key ra < routing_rule_sort_key rr \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) (p_src p)))" by auto
  from * 1 have act: "p_iiface p = output_iface act" by simp
  have **: "routing_prefix rr < routing_prefix ra \<Longrightarrow> routing_rule_sort_key ra < routing_rule_sort_key rr" for rr ra by(auto simp add: act routing_rule_sort_key_def linord_helper_less int_of_nat_def)
  from ex show ?case using ** by (simp add: act) blast
qed

lemma "rpf_semifeasible rtbl p \<Longrightarrow> rpf_feasible rtbl p"
unfolding rpf_semifeasible_def rpf_feasible_def by blast
lemma "rpf_feasible rtbl p \<Longrightarrow> rpf_loose rtbl p"
unfolding rpf_loose_def rpf_feasible_def by blast
lemma "rpf_loose_ign_default rtbl p \<Longrightarrow> rpf_loose rtbl p"
unfolding rpf_loose_def rpf_loose_ign_default_def by blast
text\<open>Unfortunately, nothing stronger can be said about @{const rpf_loose_ign_default}:\<close>
context begin
private definition "all_valid rtbl \<equiv> valid_prefixes rtbl \<and> is_longest_prefix_routing rtbl \<and> has_default_route rtbl \<and> unambiguous_routing rtbl"

lemma "\<exists>rtbl :: 'a :: len prefix_routing. all_valid rtbl \<and> (\<forall>p. \<not>rpf_loose_ign_default rtbl p) \<and> (\<exists>p :: 'a simple_packet. rpf_strict rtbl p)" (is "\<exists>x. ?t1 x")
text\<open>Read: There are routing tables where @{const rpf_loose_ign_default} is strongly stricter than @{const rpf_strict}.\<close>
proof text\<open>The catch here is that the routing table only containing the default rule will forbid all packets with @{term rpf_loose_ign_default}.\<close>
  have "rpf_strict [
    \<lparr>routing_match = PrefixMatch 0 0, metric = 418, routing_action = \<lparr>output_iface = ''e'', next_hop = Some 1\<rparr>\<rparr>]
    \<lparr> p_iiface = ''e'', p_oiface = '''', p_src = 0, p_dst = 0 :: 'a word, p_proto = TCP, p_sport = 0, p_dport = 0, p_tcp_flags = {}, p_payload = '''' \<rparr>"
  unfolding rpf_strict_def by(simp add: valid_prefix_00 zero_prefix_match_all)
  thus "?t1 [\<lparr>routing_match = PrefixMatch 0 0, metric = 418, routing_action = \<lparr>output_iface = ''e'', next_hop = Some 1\<rparr>\<rparr>]"
  unfolding rpf_loose_ign_default_def unfolding all_valid_def by (auto simp add: valid_prefixes_alt_def valid_prefix_00 is_longest_prefix_routing_def unambiguous_routing_code)
qed

lemma
  shows "\<exists>rtbl :: 32 prefix_routing. all_valid rtbl \<and> (\<forall>p. rpf_loose rtbl p \<longleftrightarrow> rpf_loose_ign_default rtbl p)" (is "\<exists>x. _ \<and> (\<forall>p. ?t2 x p)")
  text\<open>Read: There are routing tables where @{const rpf_loose_ign_default} is just as weak as @{const rpf_loose}. (Even though they contain a default route, mind you!)\<close>
  text\<open>And yes, this could be shown for a more general type, but I suspect that would be a lot more annoying.\<close>
proof (intro exI allI conjI) text\<open>The catch here is that the functionality of the default route can entirely be taken over by other routes.\<close>
    let ?c = "[\<lparr>routing_match = PrefixMatch 0 1, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>,
        \<lparr>routing_match = PrefixMatch 2147483648 1, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>,
        \<lparr>routing_match = PrefixMatch 0 0, metric = 0, routing_action = \<lparr>output_iface = ''e'', next_hop = None\<rparr>\<rparr>] :: 32 prefix_routing"
    show "all_valid ?c" by eval (* I'd like to make this part of the lemma, but\<dots> Isabelle bug? *)
    have l: "~~ mask 31 && p = 0 \<Longrightarrow> prefix_match_semantics (PrefixMatch 0 1) p" for p :: "32 word" unfolding prefix_match_semantics_def pfxm_prefix_def pfxm_mask_def by simp
    have m: "~~(mask 31 :: 32 word) = 0x80000000" by eval
    have s: "(1 << 31) && p \<noteq> 0 \<Longrightarrow> (1 << 31) && p = 1 << 31" for p :: "32 word"
      unfolding word_bw_comms word_and_1_shiftl by(simp split: if_splits)
    have u: "~~ mask 31 && p \<noteq> 0 \<Longrightarrow> prefix_match_semantics (PrefixMatch 0x80000000 1)  p" for p :: "32 word"
      unfolding prefix_match_semantics_def pfxm_prefix_def pfxm_mask_def using s by(simp add: m)
    show "?t2 ?c p" for p unfolding rpf_loose_def rpf_loose_ign_default_def
      by(cases "~~ mask 31 && p_src p = 0"; (drule l | drule u); simp)
qed
end

corollary rpf_strict_correct:
assumes vpfx: "valid_prefixes rtbl"
shows "rpf_strict rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (routing_ipassmt_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
unfolding rpf_strict_def
  apply(intro iffI[rotated])
  apply(clarify)
  apply(auto dest: routing_ipassmt_wi_sound[OF vpfx])[1]
  apply(subst(asm) routing_ipassmt_wi[OF vpfx])
  apply blast
done

definition "rpf_semifeasible_round rtbl n space \<equiv>
let res = [(routing_oiface rr, wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space) . rr \<leftarrow> rtbl, routing_prefix rr = n] in (res,
wordinterval_setminus space (wordinterval_Union (map snd res)))"

primrec rpf_semifeasible_assignment_dups where
"rpf_semifeasible_assignment_dups _ _ 0 = []" |
"rpf_semifeasible_assignment_dups rtbl space (Suc n) = (let
  (res,rspace) = rpf_semifeasible_round rtbl n space in
  res @ rpf_semifeasible_assignment_dups rtbl rspace n)"

definition "rpf_semifeasible_wi (rtbl::'a :: len routing_rule list) \<equiv> reduce_range_destination
  (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0)))"
text\<open>One might think that @{term "Suc (len_of TYPE ('a :: len))"} is the right length of prefix to start from.
Unfortunately, @{const valid_prefix} does not ensure that the prefix isn't longer than what the type permits,
and so you'd miss those broken prefixes. Nobody cares, except for the proofs.
\<close>

lemma rpf_semifeasible_round_fst: "(\<exists>rr \<in> set rtbl. routing_prefix rr = n \<and> rspace = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space \<and> ifce = routing_oiface rr)
   \<longleftrightarrow> (\<exists>(p,spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)). ifce = p \<and> rspace = spc)"
   unfolding rpf_semifeasible_round_def Let_def fst_conv by(simp; blast)

lemma rpf_semifeasible_round_snd: "rr \<in> set rtbl \<Longrightarrow> routing_prefix rr = n \<Longrightarrow> wordinterval_empty (wordinterval_intersection (snd (rpf_semifeasible_round rtbl n space)) (prefix_to_wordinterval (routing_match rr)))"
  unfolding rpf_semifeasible_round_def Let_def snd_conv by(auto simp add: wordinterval_Union)

lemma rpf_semifeasible_round_snd':
  assumes vpfx: "valid_prefixes rtbl"
  assumes nm: "\<forall>ra\<in>set rtbl. routing_prefix ra = n \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip"
  assumes e: "ip \<in> wordinterval_to_set space"
  shows "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))"
proof -
  have " \<forall>x\<in>set rtbl \<inter> {rr. pfxm_length (routing_match rr) = n}. ip \<notin> prefix_to_wordset (routing_match x)"
    using nm prefix_match_semantics_wordset valid_prefixes_alt_def vpfx by fastforce
  with e show ?thesis by(simp add:  rpf_semifeasible_round_def Let_def wordinterval_Union)
qed

lemma ex_prod_splitI: "\<exists>(a,b) \<in> S. P (a,b) \<Longrightarrow> \<exists>a \<in> S. P a" by simp

lemma rpf_semifeasible_assignment_subset: "(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl space n) \<Longrightarrow> wordinterval_subset spc space"
proof(induction n arbitrary: space)
  case (Suc n)
  from Suc.prems[unfolded rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold set_append Set.Un_iff]
  have "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)) \<or> (p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" .
  thus ?case proof(elim disjE, goal_cases)
    case 1 thus ?case unfolding rpf_semifeasible_round_def Let_def fst_conv by force
  next
    case 2 with Suc.IH have "wordinterval_subset spc (snd (rpf_semifeasible_round rtbl n space))" .
    thus ?case unfolding rpf_semifeasible_round_def Let_def snd_conv by force
  qed
qed simp

lemma rpf_semifeasible_assignment_dups_fst:
  assumes vpfx: "valid_prefixes rtbl"
  assumes space: "ip \<in> wordinterval_to_set space"
shows "
    (\<exists>rr \<in> set rtbl. routing_prefix rr < n \<and> prefix_match_semantics (routing_match rr) ip \<and> ifce = routing_oiface rr \<and>
    (\<forall>ra \<in> set rtbl.  routing_prefix ra < n \<longrightarrow> routing_prefix ra > routing_prefix rr \<longrightarrow>  \<not>prefix_match_semantics (routing_match ra) ip))
   \<longleftrightarrow> (\<exists>(p,spc) \<in> set (rpf_semifeasible_assignment_dups rtbl space n). ifce = p \<and> ip \<in> wordinterval_to_set spc)"
proof(rule iffI, goal_cases)
  case 1 show ?case proof(insert 1 space, elim bexE conjE, induction n arbitrary: space)
    case (Suc n rr)
    show ?case proof(cases "routing_prefix rr = n")
      case False
      with \<open>routing_prefix rr < Suc n\<close> have *: "routing_prefix rr < n" by linarith
      have **: "\<forall>ra\<in>set rtbl. routing_prefix ra < n \<longrightarrow> routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip"
        using Suc.prems(6) by simp
      have ***: "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))"
        by (simp add: * Suc.prems(1) Suc.prems(6) rpf_semifeasible_round_snd' vpfx) (* it werks\<^sup>T\<^sup>M *)
      note Suc.IH[OF *** Suc.prems(2) * Suc.prems(4-5) **]
      thus ?thesis by(auto simp add: case_prod_unfold Let_def)
    next
      case True
      have "(\<exists>rra\<in>set rtbl.
      routing_prefix rra = n \<and>
      wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space =
      wordinterval_intersection (prefix_to_wordinterval (routing_match rra)) space \<and>
      ifce = routing_oiface rra)" by(intro bexI[where x=rr]; simp add: Suc.prems True)
      with rpf_semifeasible_round_fst obtain p spc where pspc:
        "(p, spc)\<in>set (fst (rpf_semifeasible_round rtbl n space))" "ifce = p"
        "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space" by fast
      have m: "ip \<in> prefix_to_wordset (routing_match rr)"
        using Suc.prems(2) Suc.prems(4) prefix_match_semantics_wordset valid_prefixes_alt_def vpfx by blast
      show ?thesis unfolding rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold fst_conv set_append bex_Un
        apply(intro disjI1)
        apply(rule ex_prod_splitI)
        apply(rule bexI[where x="(p,spc)",rotated])
        apply(fact pspc)
        apply(simp add: pspc m Suc.prems(1))
      done
    qed
  qed(subgoal_tac False; simp; fail)
next
  case 2
  then obtain p spc where
    "(p, spc)\<in>set (rpf_semifeasible_assignment_dups rtbl space n)" "ifce = p" "ip \<in> wordinterval_to_set spc" by blast
  with space show ?case proof(induction n arbitrary: space)
    case 0 thus ?case by simp
  next
    case (Suc n)
    from Suc.prems(2)[unfolded rpf_semifeasible_assignment_dups.simps Let_def case_prod_unfold fst_conv set_append Set.Un_iff]
    have *: "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space)) \<or> (p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" .
    show ?case proof(cases "\<exists>ra\<in>set rtbl. routing_prefix ra = n \<and> prefix_match_semantics (routing_match ra) ip")
      case True
      hence "\<not>(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" (is "\<not>?f")
      proof(intro notI)
        from True guess ra .. note ra = this
        hence *: "ip \<in> prefix_to_wordset (routing_match ra)" using vpfx using prefix_match_semantics_wordset valid_prefixes_alt_def by blast
        with Suc.prems have "prefix_to_wordset (routing_match ra) \<inter> wordinterval_to_set spc \<noteq> {}" by blast
        from rpf_semifeasible_round_snd[OF ra(1) ra(2)[THEN conjunct1]]
        have **: "wordinterval_empty (wordinterval_intersection (snd (rpf_semifeasible_round rtbl n space)) (prefix_to_wordinterval (routing_match ra)))" .
        assume ?f
        with rpf_semifeasible_assignment_subset have ***: "wordinterval_subset spc (snd (rpf_semifeasible_round rtbl n space))" .
        show False using Suc.prems(4) * **  *** by fastforce
      qed
      hence True': "(p, spc) \<in> set (fst (rpf_semifeasible_round rtbl n space))" using * by blast
      note True' Suc.prems(1,3-) rpf_semifeasible_round_fst[of rtbl n spc space ifce]
      then obtain rr where rr: "rr\<in>set rtbl"
        "routing_prefix rr = n"
        "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space"
        "p = routing_oiface rr" by blast
      have a: "prefix_match_semantics (routing_match rr) ip"
        using Suc.prems(4) prefix_match_semantics_wordset rr(1) rr(3) valid_prefixes_alt_def vpfx by fastforce
      show ?thesis
        by(intro bexI[where x=rr]) (simp_all add: rr Suc a)
    next
      case False
      have "(p, spc) \<notin> set (fst (rpf_semifeasible_round rtbl n space))" (is "\<not>?f")
      proof(intro notI)
        assume ?f with rpf_semifeasible_round_fst[of rtbl n spc space ifce] Suc.prems(3)
        obtain rr where rr: "rr\<in>set rtbl"
        "routing_prefix rr = n" "spc = wordinterval_intersection (prefix_to_wordinterval (routing_match rr)) space" "ifce = routing_oiface rr"  by blast
        hence "prefix_match_semantics (routing_match rr) ip" using vpfx Suc.prems(4)
          using prefix_match_semantics_wordset valid_prefixes_alt_def Int_iff prefix_to_wordinterval_set_eq wordinterval_intersection_set_eq by auto
        with False rr show False by blast
      qed
      with * have *: "(p, spc) \<in> set (rpf_semifeasible_assignment_dups rtbl (snd (rpf_semifeasible_round rtbl n space)) n)" by clarify
      have **: "ip \<in> wordinterval_to_set (snd (rpf_semifeasible_round rtbl n space))" using Suc.prems(4) * rpf_semifeasible_assignment_subset by fastforce
      from Suc.IH[OF ** * Suc.prems(3,4)] obtain rr where rr:
        "rr\<in>set rtbl"
        "routing_prefix rr < n"
        "prefix_match_semantics (routing_match rr) ip"
        "ifce = routing_oiface rr"
        "(\<forall>ra\<in>set rtbl. routing_prefix ra < n \<longrightarrow> routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) ip)" by blast
      show ?thesis
        apply(intro bexI[where x=rr])
        apply(simp_all add: rr)
        apply(intro conjI)
        using rr(2) apply(simp;fail)
        using rr(5) False apply fastforce
      done
    qed
  qed
qed

lemma fold_max_append: "fold max l (a::nat) = max a (fold max l 0)"
proof(induction l arbitrary: a)
  case (Cons l ls)
  show ?case by(simp add: Cons[of "(max l a) "] Cons[of l])
qed simp

lemma fold_max: "(f :: nat) \<in> set l \<Longrightarrow> f < Suc (fold max l 0)"
by(induction l; simp) (metis (no_types, lifting) fold_max_append lessI max_less_iff_conj not_less_eq) (* It werks\<^sup>T\<^sup>M *)

corollary rpf_semifeasible_correct:
  assumes vpfx: "valid_prefixes rtbl"
  shows "rpf_semifeasible rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_semifeasible_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
unfolding rpf_semifeasible_def rpf_semifeasible_wi_def
unfolding reduce_range_destination_def Let_def comp_def
proof(goal_cases)
  case 1
  let ?rs = "rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))" (* rs wie rattenschwanz *)
  show ?case (is "?l = ?r") proof -
  have maxpfx: "\<forall>ra\<in>set rtbl. routing_prefix ra < Suc (fold max (map routing_prefix rtbl) 0)"
    using fold_max[where l="map routing_prefix rtbl"] by simp
  have "?l = (\<exists>rr\<in>set rtbl.
      routing_prefix rr < Suc (fold max (map routing_prefix rtbl) 0) \<and>
      prefix_match_semantics (routing_match rr) (p_src p) \<and>
      p_iiface p = routing_oiface rr \<and>
      (\<forall>ra\<in>set rtbl.
          routing_prefix ra < Suc (fold max (map routing_prefix rtbl) 0) \<longrightarrow>
          routing_prefix rr < routing_prefix ra \<longrightarrow> \<not> prefix_match_semantics (routing_match ra) (p_src p)))"
    using maxpfx by auto
  with rpf_semifeasible_assignment_dups_fst[OF vpfx, of "p_src p" wordinterval_UNIV "Suc (fold max (map routing_prefix rtbl) 0)" "p_iiface p",
      unfolded wordinterval_UNIV_set_eq, OF UNIV_I]
  have "?l = (\<exists>(pa, spc)\<in>set ?rs.
        p_iiface p = pa \<and> p_src p \<in> wordinterval_to_set spc)" by linarith
  moreover have "(\<exists>(pa, spc)\<in>set (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))).
        p_iiface p = pa \<and> p_src p \<in> wordinterval_to_set spc) = ?r" (is "?l1 = ?r")
  proof
    assume ?l1
    then obtain pa spc where paspc:
      "(pa, spc)\<in>set ?rs"
      "p_iiface p = pa" "p_src p \<in> wordinterval_to_set spc" by blast
    from this(1) have *: "pa \<in> set (remdups (map fst (?rs)))" by force
    let ?rss = "wordinterval_Union(map snd [x\<leftarrow>?rs. pa = fst x])"
    show ?r
      apply(intro bexI[where x="(pa, ?rss)"])
      subgoal
        apply(simp add: paspc(2))
        apply(unfold wordinterval_Union set_map set_filter UN_iff)
        apply(intro bexI[where x=spc])
        apply(simp add: paspc(3);fail)
        using paspc(1) apply force
      done
      subgoal
        using * by fastforce
    done
  next
    assume ?r
    then obtain k l where kl: "(k, l)\<in>set (map (\<lambda>p. (p, wordinterval_Union
                              (map snd [x\<leftarrow>rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0)) . p = fst x])))
                 (remdups (map fst (rpf_semifeasible_assignment_dups rtbl wordinterval_UNIV (Suc (fold max (map routing_prefix rtbl) 0))))))"
     "p_iiface p = k" " p_src p \<in> wordinterval_to_set l" by blast
    from kl have "k \<in> set (remdups (map fst ?rs))" by auto
    from kl have "l = wordinterval_Union (map snd [x\<leftarrow>?rs . k = fst x])" by fastforce
    with kl(3) obtain lo where lo: "p_src p \<in> wordinterval_to_set lo" "(k, lo) \<in>  set ?rs" by(auto simp add: wordinterval_Union)
    show ?l1 by(intro bexI[where x="(k,lo)"]) (simp add: lo kl, fact lo)
  qed
  ultimately show ?case by linarith
  qed
qed

definition "rpf_feasible_wi rtbl \<equiv> reduce_range_destination (map (\<lambda>rr. (routing_oiface rr, prefix_to_wordinterval (routing_match rr))) rtbl)"

lemma rpf_feasible_correct:
  assumes vpfx: "valid_prefixes rtbl"
  shows "rpf_feasible rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_feasible_wi rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
  using vpfx unfolding reduce_range_destination_def rpf_feasible_def rpf_feasible_wi_def
  by(force simp add: wordinterval_Union prefix_match_semantics_wordset valid_prefixes_alt_def)

definition "rpf_loose_wi ifs rtbl \<equiv> let routed_space = foldr (wordinterval_union \<circ> prefix_to_wordinterval \<circ> routing_match) rtbl Empty_WordInterval in [(iface,routed_space). iface \<leftarrow> ifs]"
lemma rpf_loose_correct:
  assumes vpfx: "valid_prefixes rtbl"
  assumes ifsane: "p_iiface p \<in> set ifs"
  shows "rpf_loose rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_loose_wi ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
proof -
  from vpfx have *: "(\<exists>rr\<in>set rtbl. prefix_match_semantics (routing_match rr) (p )) =
        (p  \<in> wordinterval_to_set (foldr (wordinterval_union \<circ> prefix_to_wordinterval \<circ> routing_match) rtbl Empty_WordInterval))" for p
  proof(induction rtbl)
    case (Cons rr rtbl)
    have vpfx: "valid_prefix (routing_match rr)" using Cons.prems valid_prefixes_split by blast
    show ?case proof(cases "prefix_match_semantics (routing_match rr) p")
      case True thus ?thesis by(simp add: prefix_match_semantics_wordset[OF vpfx])
    next
      have vpfxs: "valid_prefixes rtbl" using Cons.prems valid_prefixes_split by blast
      case False
      with vpfx have ni: "p \<notin> prefix_to_wordset (routing_match rr)" using prefix_match_semantics_wordset by blast
      with False show ?thesis using Cons.IH[OF vpfxs] by simp
    qed
  qed simp
  thus ?thesis
  using vpfx ifsane
  unfolding rpf_loose_wi_def rpf_loose_def by simp
qed

definition "rpf_loose_ign_default_wi ifs \<equiv> rpf_loose_wi ifs \<circ> filter (\<lambda>rr. routing_match rr \<noteq> PrefixMatch 0 0)"
lemma rpf_loose_ign_default_correct:
  assumes vpfx: "valid_prefixes rtbl"
  assumes ifsane: "p_iiface p \<in> set ifs"
  shows "rpf_loose_ign_default rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_loose_ign_default_wi ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
proof -
  let ?rtf = "filter (\<lambda>rr. routing_match rr \<noteq> PrefixMatch 0 0)"
  have f: "rpf_loose_ign_default rtbl p = rpf_loose (?rtf rtbl) p" unfolding rpf_loose_def rpf_loose_ign_default_def by auto
  from vpfx have fpfx: "valid_prefixes (?rtf rtbl)" unfolding valid_prefixes_alt_def by simp
  show ?thesis
    unfolding rpf_loose_ign_default_wi_def comp_def f
    using rpf_loose_correct[OF fpfx ifsane] .
qed

datatype rpf_type = RPF_Strict | RPF_Feasible | RPF_Loose | RPF_LooseIgnDef | RPF_Semifeasible
primrec rpf_def_lookup where
"rpf_def_lookup RPF_Strict = rpf_strict" |
"rpf_def_lookup RPF_Feasible = rpf_feasible" |
"rpf_def_lookup RPF_Loose = rpf_loose" |
"rpf_def_lookup RPF_LooseIgnDef = rpf_loose_ign_default" |
"rpf_def_lookup RPF_Semifeasible = rpf_semifeasible"
fun rpf_wi_lookup where
"rpf_wi_lookup RPF_Strict _ = routing_ipassmt_wi" |
"rpf_wi_lookup RPF_Feasible _ = rpf_feasible_wi" |
"rpf_wi_lookup RPF_Loose ifs = rpf_loose_wi ifs" |
"rpf_wi_lookup RPF_LooseIgnDef ifs = rpf_loose_ign_default_wi ifs" |
"rpf_wi_lookup RPF_Semifeasible _ = rpf_semifeasible_wi"

theorem
assumes vpfx: "valid_prefixes rtbl"
assumes ifsane: "rpf \<in> {RPF_Loose, RPF_LooseIgnDef} \<Longrightarrow> p_iiface p \<in> set ifs"
shows "rpf_def_lookup rpf rtbl p \<longleftrightarrow> (\<exists>(k,l) \<in> set (rpf_wi_lookup rpf ifs rtbl). p_iiface p = k \<and> p_src p \<in> wordinterval_to_set l)"
using assms by(cases rpf; simp_all add: rpf_strict_correct rpf_semifeasible_correct rpf_feasible_correct rpf_loose_correct rpf_loose_ign_default_correct)

end


theory convergent
imports Main Limits Matrix
begin
lemma test :"∀e>0. ∃M. ∀m≥M. ∀n≥M. n>m⟶ dist ((X::nat⇒real) m) (X n) < e⟹∀e>0. ∃M. ∀m≥M. ∀n≥M. n<m⟶ dist (X m) (X n) < e⟹
∀e>0. ∃M. ∀m≥M. ∀n≥M. n=m⟶ dist (X m) (X n) < e⟹
         ∀e>0. ∃M. ∀m≥M. ∀n≥M. dist (X m) (X n) < e"
apply auto
apply(drule_tac x="e"in spec ,auto)
apply(drule_tac x="e"in spec ,auto)
apply(rule_tac x="max M Ma"in exI,auto)
apply(drule_tac x="m"in spec,auto )
apply(drule_tac x="m"in spec ,auto)
apply(drule_tac x="n"in spec ,auto)
done
lemma Cauchy_conv:"(∀e>0. ∃M. ∀n ≥ M. ∀m ≥ n. dist ((X::nat⇒real) m) (X n) < e) ⟹Cauchy X"
apply (simp add:Cauchy_def)
apply(rule test,auto)
apply(drule_tac x="e"in spec ,auto)
apply(rule_tac x="M"in exI,auto)
apply (simp add: dist_commute)
by (metis (full_types) dist_commute nat_less_le)
lemma Cauchy_conv_dual:"Cauchy X⟹(∀e>0. ∃M. ∀n ≥ M. ∀m ≥ n. dist ((X::nat⇒real) m) (X n) < e) "
apply (simp add:Cauchy_def)
apply auto
apply(drule_tac x="e"in spec ,auto)
apply(rule_tac x="M"in exI,auto)
done
lemma convergent_aux:" ∀e>0. ∃M. ∀n≥M. ∀m≥n. (dist  ((A m)::real)  (A n))*((dist  ((A m)::real)  (A n))) < e
                   ⟹∀e>0. ∃M. ∀n≥M. ∀m≥n. dist (A m) (A n) < e"
       apply(auto)
       apply(drule_tac x="e*e" in spec,auto)
       apply(rule_tac x="M" in exI)
       by (metis (full_types) less_eq_real_def mult_le_less_imp_less not_less)
lemma convergent_aux5:" 0 ≤ foldseq_transposed op + (λka. (Rep_matrix (A m) 0 ka - Rep_matrix (A n) 0 ka) * (Rep_matrix (A m) 0 ka - Rep_matrix (A n) 0 ka))
          N"
          apply(induct N,auto)
          done
lemma convergent_aux6:"foldseq_transposed op +
               (λka. (Rep_matrix (A m) (Suc N) ka - Rep_matrix (A n) (Suc N) ka) *
                     (Rep_matrix (A m) (Suc N) ka - Rep_matrix (A n) (Suc N) ka)) M≥0"
         apply(induct M,auto)
         done
lemma convergent_aux4:"0 ≤ foldseq_transposed op +
          (λk. foldseq_transposed op + (λka. (Rep_matrix (A m) k ka - Rep_matrix (A n) k ka) * (Rep_matrix (A m) k ka - Rep_matrix (A n) k ka))
                infinite)  N"
      apply(induct N,auto)
      apply(simp add:convergent_aux5)
      apply(simp add:convergent_aux6)
      done

lemma convergent_aux7:"i≥infinite∨j≥infinite⟶(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) infinite)
        infinite⟹i<infinite∧j<infinite⟶ (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) infinite)
        infinite⟹ (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) infinite)
        infinite"
using not_less by blast
lemma foldseq_aux:"∀n. (ff::nat⇒real) n≥0⟹foldseq_transposed op+ ff m≤foldseq_transposed op+ ff (m+a::nat)"
apply(induct a,auto)
apply(drule_tac x="Suc (m+a)" in spec,auto)
done
lemma foldseq_aux1:"∀n. (ff::nat⇒real) n≥0⟹m≤n⟹foldseq_transposed op+ ff m≤foldseq_transposed op+ ff n"
      using foldseq_aux le_Suc_ex by blast
lemma foldseq_aux2:"∀n. (ff::nat⇒real) n≥0⟹ff n≤foldseq_transposed op+ ff n"
apply(induct n,auto)
using dual_order.trans by blast
lemma convergent_aux9:" i < N ⟹ j < N ⟹
    (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N"
     apply (simp add: associative_def foldseq_assoc)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     apply(subgoal_tac "( foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i)≤
         foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "  foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N
          ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     prefer 2
     apply(rule foldseq_aux2,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
            ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     apply auto
     apply(subgoal_tac " foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j≤
        foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     apply(subgoal_tac" (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j")
     apply auto
     apply(subgoal_tac " Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j  ≤
       foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j ")
     prefer 2
      apply(rule foldseq_aux2,auto)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j) =
        Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j",auto)
     apply(simp add:mat_sub_def)
     apply(simp add:diff_matrix_def)
     done
lemma convergent_aux9_1:" i < N ⟹ j < N ⟹
    (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N"
     apply (simp add: associative_def foldseq_assoc)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     apply(subgoal_tac "( foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i)≤
         foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "  foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N
          ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     prefer 2
     apply(rule foldseq_aux2,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
            ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     apply auto
     apply(subgoal_tac " foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j≤
        foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     apply(subgoal_tac" (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j")
     apply auto
     apply(subgoal_tac " Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j  ≤
       foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j ")
     prefer 2
      apply(rule foldseq_aux2,auto)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j) =
        Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j",auto)
     apply(simp add:mat_sub_def)
     apply(simp add:diff_matrix_def)
     done

lemma convergent_aux3:" (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) infinite)
        infinite"
       apply(rule convergent_aux7 )
       apply(simp add: mat_sub_def diff_matrix_def)
       apply(rule conjI)
       apply auto[1]
       apply(subgoal_tac "Rep_matrix (A m) i j =0",simp)
       apply(subgoal_tac "Rep_matrix (A n) i j =0",simp)
       apply (simp add: associative_def foldseq_assoc)
       apply(simp add:convergent_aux4)
       apply (metis (mono_tags, hide_lams) ncols_max ncols_transpose nrows_le)+
       apply auto[1]
       apply(subgoal_tac "Rep_matrix (A m) i j =0",simp)
       apply(subgoal_tac "Rep_matrix (A n) i j =0",simp)
       apply (simp add: associative_def foldseq_assoc)
       apply(simp add:convergent_aux4)
       apply (metis (mono_tags, hide_lams) ncols_le nrows_max nrows_transpose)+
       apply (subgoal_tac "i < infinite ⟹ j < infinite ⟹
    (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) infinite)
        infinite ")
       apply blast
       apply(rule convergent_aux9)
       apply blast+
       done
lemma convergent_aux2:" all_sum_pow (mat_sub (A m) (A n)) ≥ (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j) "
      apply(simp add:all_sum_pow_def)
      apply(simp add:rows_sum_pow_def)
      apply(subgoal_tac " foldseq op +
        (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka)
              (ncols (mat_sub (A m) (A n))))
        (nrows (mat_sub (A m) (A n))) = foldseq op +
        (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka)
              (ncols (mat_sub (A m) (A n))))
       infinite",auto)
      prefer 2
      apply(rule foldseq_zerotail,auto)
      apply (simp add: foldseq_zero nrows)
      apply(subgoal_tac " (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka)
              (ncols (mat_sub (A m) (A n)))) = (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka)
               infinite)",auto)
      prefer 2
      apply(rule ext)
      apply(rule foldseq_zerotail,auto)
      using ncols apply blast
      apply(simp add:convergent_aux3)
      done
lemma convergent_aux1:" ∀e>0. ∃M. ∀n≥M. ∀m≥n. all_sum_pow (mat_sub (A m) (A n)) < e
      ⟹ ∀e>0. ∃M. ∀n≥M. ∀m≥n. (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j) < e"
     apply(auto)
     apply(drule_tac x="e" in spec,auto)
     apply(rule_tac x="M" in exI,auto)
     apply(drule_tac x="n"in spec ,auto)
     apply(drule_tac x="m"in spec ,auto)
     apply(subgoal_tac " all_sum_pow (mat_sub (A m) (A n)) ≥ (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)")
     apply auto
     apply(simp add:convergent_aux2)
     done
lemma convergent_aux15:" i < N ⟹ j < N ⟹
    (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq op + (λk. foldseq op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N"
     apply (simp add: associative_def foldseq_assoc)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     apply(subgoal_tac "( foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i)≤
         foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "  foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N
          ≤ foldseq_transposed op +
        (λk. foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) k ka * Rep_matrix (mat_sub (A m) (A n)) k ka) N) i")
     prefer 2
     apply(rule foldseq_aux2,auto)
     using aux5 apply auto[1]
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
            ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     apply auto
     apply(subgoal_tac " foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j≤
        foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) N")
     prefer 2
     apply(rule foldseq_aux1,auto)
     apply(subgoal_tac" (Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j)
    ≤ foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j")
     apply auto
     apply(subgoal_tac " Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j  ≤
       foldseq_transposed op + (λka. Rep_matrix (mat_sub (A m) (A n)) i ka * Rep_matrix (mat_sub (A m) (A n)) i ka) j ")
     prefer 2
      apply(rule foldseq_aux2,auto)
     apply(subgoal_tac "(Rep_matrix (A m) i j - Rep_matrix (A n) i j) * (Rep_matrix (A m) i j - Rep_matrix (A n) i j) =
        Rep_matrix (mat_sub (A m) (A n)) i j * Rep_matrix (mat_sub (A m) (A n)) i j",auto)
     apply(simp add:mat_sub_def)
     apply(simp add:diff_matrix_def)
     done
lemma fuck1:" ∀n. less (A n) (A (Suc n)) ⟹ Matrix.less (A m) (A (m + (a::nat)))"
apply (induct a,auto)
apply (simp add: less11)
apply(drule_tac x="m+a"in spec)
using transitivity by blast
lemma fuck:" ∀n. less (A n) (A (Suc n)) ⟹ n≥m⟹less (A m) (A n)"
by (metis add_Suc_right fuck1 le_less less11 less_imp_Suc_add)
lemma convergent_aux11:"∀n m. n≥m⟶less ((A::nat⇒matrix) m) (A n) ⟹∀ea>0. ∃M. ∀n≥M. ∀m≥n. (Tr (mat_sub (A m) (A n)))*(Tr (mat_sub (A m) (A n))) < ea⟹
            ∀ea>0. ∃M. ∀n≥M. ∀m≥n. Tr (mat_mult (mat_sub (A m) (A n)) (dag (mat_sub (A m) (A n)))) < ea"
            apply auto
            apply(drule_tac x="ea" in spec,auto)
            apply(rule_tac x="M" in exI,auto)
            apply(drule_tac x="n" in spec,auto)
            apply(drule_tac x="m" in spec,auto)
            apply(subgoal_tac " Tr (mat_mult (mat_sub (A m) (A n)) (dag (mat_sub (A m) (A n)))) ≤
              Tr (mat_sub (A m) (A n)) * Tr (mat_sub (A m) (A n))",auto)
            apply(rule advance)
            by (simp add: less_def)
lemma convergent_aux12_aux:"a≥0⟹a<sqrt e⟹a*a<e"
         using real_sqrt_less_iff by fastforce
lemma convergent_aux12:"∀n m. n≥m⟶less ((A::nat⇒matrix) m) (A n) ⟹ ∀eaa>0. ∃M. ∀n≥M. ∀m≥n. Tr (mat_sub (A m) (A n)) < eaa⟹
                     ∀eaa>0. ∃M. ∀n≥M. ∀m≥n. Tr (mat_sub (A m) (A n)) * Tr (mat_sub (A m) (A n)) < eaa"
          apply auto
          apply(drule_tac x="sqrt eaa" in spec,auto)
          apply(rule_tac x="M" in exI,auto)
          apply(drule_tac x="n" in spec,auto)
          apply(drule_tac x="m" in spec,auto)
          apply(subgoal_tac "Tr (mat_sub (A m) (A n)) ≥0")
          apply(rule convergent_aux12_aux)
          apply auto
          by (simp add: less_def positive_Tr)

lemma convergent:"  ∀n. positive (A n) ⟹ ∃B.∀n. Tr (A n) ≤B ⟹ ∀n. less (A n) (A (Suc n))
                       ⟹∀i j. convergent (λn. Rep_matrix (A n) i j)"
       apply(auto)
       apply(subgoal_tac " Cauchy (λn. Rep_matrix (A n) i j) ")
       apply (simp add: real_Cauchy_convergent)
       apply(rule Cauchy_conv)
       apply(rule convergent_aux,auto)
       apply(simp add:dist_real_def)
       apply(subgoal_tac " ∀e>0. ∃M. ∀n≥M. ∀m≥n. all_sum_pow (mat_sub (A m) (A n)) < e")
       apply (simp add: convergent_aux1,auto)
       apply(subgoal_tac "∃M. ∀n≥M. ∀m≥n. Tr (mat_mult (mat_sub (A m) (A n)) (dag (mat_sub (A m) (A n)))) < ea")
       apply(simp add:tr_pow)
       apply(cut_tac A="A" in convergent_aux11,auto)
       apply(simp add:fuck)
       apply(cut_tac A="A" in convergent_aux12,auto)
        apply(simp add:fuck)
        apply(simp add:tr_allo1)
        apply(subgoal_tac "Cauchy (λn. Tr (A n))")
        apply(subgoal_tac " ∀ee>0. ∃M. ∀n≥M. ∀m≥n. dist (Tr (A m)) (Tr (A n))<ee",auto)
        prefer 2
        apply(simp add: Cauchy_conv_dual)
        apply(simp add:dist_real_def)
        apply(drule_tac x="eaaa" in spec,auto)
        apply(rule_tac x="M" in exI,auto)
        apply(subgoal_tac "less (A n) (A m)")
        prefer 2
        using fuck apply blast
        apply(drule_tac x="n" in spec,auto)
        apply(subgoal_tac "convergent (λn. Tr (A n))")
        using Cauchy_convergent_iff apply blast
        apply(subgoal_tac "(λn. Tr (A n))---->(SUP i. Tr (A i)) ")
       using convergent_def apply blast
        apply(rule LIMSEQ_incseq_SUP)
        apply(simp add:bdd_above_def)
       apply(rule_tac x="B" in exI,auto)
       apply(simp add:incseq_def,auto)
       apply(subgoal_tac "less (A m) (A n)")
       apply(simp add:less_tr)
       apply(simp  add:fuck)
       done

end


theory Gensyn imports Main
begin

(*
 * A general-purpose datatype for expressing recursive syntax
 * Used as the syntax for language-components.
 *)

datatype ('x) gensyn =
  G "'x" "(('x) gensyn) list"

type_synonym gensyn_skel = "(unit) gensyn"

type_synonym param_gensyn = "(_) gensyn"

declare gensyn.splits [split]

fun gs_map :: "('x \<Rightarrow> 'y) \<Rightarrow> 'x gensyn \<Rightarrow> 'y gensyn" where
"gs_map f (G x l) = G (f x) (map (gs_map f) l)"

fun gs_map_opt :: "('x \<Rightarrow> 'y option) \<Rightarrow> 'x gensyn \<Rightarrow> 'y gensyn option" where
"gs_map_opt f (G x l) =
  (case (f x) of
    None \<Rightarrow> None
    | Some fx \<Rightarrow>
    (case List.those (List.map (gs_map_opt f) l) of
      None \<Rightarrow> None
      | Some fl \<Rightarrow> Some (G fx fl)))"

(* obtain a "skeleton" of a gensyn, reflecting structure
   but removing labels *)
definition gs_sk :: "'a gensyn \<Rightarrow> gensyn_skel" where
"gs_sk t = gs_map (\<lambda> _ . ()) t"

type_synonym childpath = "nat list"

(* Alternate induction principles for gensyn (the default one isn't strong enough on its own) *)

lemma gensyn_induct':
  assumes Lr : "(\<And> (x :: 'x) (l :: ('x) gensyn list) . P2 l \<Longrightarrow> P2 [(G x l)])"
  and Lrn : "P2 []"
  and Lrc : "\<And>t l . P2 [(t :: 'x gensyn)] \<Longrightarrow>
                         P2 l \<Longrightarrow>
                         P2 (t # l)"
  shows "P2 (l)"
proof-
  {   fix t
      have "P2 [t] \<and> (! x l . t = G x l \<longrightarrow> P2 l)"
      proof(induction t)
        case (G x l)
        then show ?case
          apply(induct l) using Lr Lrn Lrc
           apply(clarsimp)
          apply(clarsimp)
          apply(auto)
           apply(rule_tac Lr)
           apply(rule_tac Lrc) apply(auto)
          apply(rule_tac Lrc) apply(auto)
          done
 qed
     }
  thus ?thesis by auto
qed

lemma gensyn_induct:
  assumes Lr : "(\<And> (x :: 'x) (l :: ('x) gensyn list) . P2 l \<Longrightarrow> P1 (G x l))"
  and Lrn : "P2 []"
  and Lrc : "\<And>t l . P1 (t :: 'x gensyn) \<Longrightarrow>
                         P2 l \<Longrightarrow>
                         P2 (t # l)"
shows "P1 (t)"
proof-
  {   fix l
      have "P2 l \<and> (! h t . l = h#t \<longrightarrow> P1 h \<and> P2 t )" (*using Lr Lrn Lrc*)
proof(induction l rule:gensyn_induct')
  case (1 x l2)
  then show ?case apply(auto intro:Lr Lrn Lrc) done
next
  case 2
  then show ?case by (auto intro: Lr Lrn Lrc)
next
  case (3 t l)
  then show ?case
    apply(clarsimp)
    apply(rule_tac Lrc) apply(auto)
    done
qed }

  thus ?thesis apply(simp)
    done
qed

lemma gensyn_induct_full:
  assumes Lr : "(\<And> (x :: 'x) (l :: ('x) gensyn list) . P2 l \<Longrightarrow> P1  (G x l))"
  and Lrn : "P2 []"
  and Lrc : "\<And>t l . P1 (t :: 'x gensyn) \<Longrightarrow>
                         P2 l \<Longrightarrow>
                         P2 (t # l)"
  shows "P1 (t) \<and> P2 (l)"
proof-
  {   fix t
      have "P1 t \<and> (! x l . t = G x l \<longrightarrow> P2 l)"
      proof(induction t)
        case (G x l)
        then show ?case
          apply(induct l) using Lr Lrn Lrc
           apply(clarsimp)
          apply(clarsimp)
          apply(auto)
           apply(rule_tac Lr)
           apply(rule_tac Lrc) apply(auto)
          apply(rule_tac Lrc) apply(auto)
          done
 qed
     }
  thus ?thesis by auto
qed

end