theory BPlusTree
  imports Main "HOL-Data_Structures.Sorted_Less" "HOL-Data_Structures.Cmp" "HOL-Library.Multiset"
begin

(* some setup to cover up the redefinition of sorted in Sorted_Less
   but keep the lemmas *)
hide_const (open) Sorted_Less.sorted
abbreviation "sorted_less \<equiv> Sorted_Less.sorted"

section "Definition of the B-Plus-Tree"

subsection "Datatype definition"

text "B-Plus-Trees are basically B-Trees, that don't have empty Leafs but Leafs that contain
the relevant data. "

datatype 'a bplustree = Leaf (vals: "'a list") | Node (keyvals: "('a bplustree * 'a) list") (lasttree: "'a bplustree")

type_synonym 'a bplustree_list =  "('a bplustree * 'a) list"
type_synonym 'a bplustree_pair =  "('a bplustree * 'a)"

abbreviation subtrees where "subtrees xs \<equiv> (map fst xs)"
abbreviation separators where "separators xs \<equiv> (map snd xs)"

subsection "Inorder and Set"

text "The set of B-Plus-tree needs to be manually defined, regarding only the leaves.
This overrides the default instantiation."

fun set_nodes :: "'a bplustree \<Rightarrow> 'a set" where
  "set_nodes (Leaf ks) = {}" |
  "set_nodes (Node ts t) = \<Union>(set (map set_nodes (subtrees ts))) \<union> (set (separators ts)) \<union> set_nodes t"

fun set_leaves :: "'a bplustree \<Rightarrow> 'a set" where
  "set_leaves (Leaf ks) = set ks" |
  "set_leaves (Node ts t) = \<Union>(set (map set_leaves (subtrees ts))) \<union> set_leaves t"

text "The inorder is a view of only internal seperators"

fun inorder :: "'a bplustree \<Rightarrow> 'a list" where
  "inorder (Leaf ks) = []" |
  "inorder (Node ts t) = concat (map (\<lambda> (sub, sep). inorder sub @ [sep]) ts) @ inorder t"

abbreviation "inorder_list ts \<equiv> concat (map (\<lambda> (sub, sep). inorder sub @ [sep]) ts)"

text "The leaves view considers only its leafs."

fun leaves :: "'a bplustree \<Rightarrow> 'a list" where
  "leaves (Leaf ks) = ks" |
  "leaves (Node ts t) = concat (map leaves (subtrees ts)) @ leaves t"

abbreviation "leaves_list ts \<equiv> concat (map leaves (subtrees ts))"

fun leaf_nodes where
"leaf_nodes (Leaf xs) = [Leaf xs]" |
"leaf_nodes (Node ts t) = concat (map leaf_nodes (subtrees ts)) @ leaf_nodes t"

abbreviation "leaf_nodes_list ts \<equiv> concat (map leaf_nodes (subtrees ts))"

text "And the elems view contains all elements of the tree"
(* NOTE this doesn't help *)

fun elems :: "'a bplustree \<Rightarrow> 'a list" where
  "elems (Leaf ks) = ks" |
  "elems (Node ts t) = concat (map (\<lambda> (sub, sep). elems sub @ [sep]) ts) @ elems t"

abbreviation "elems_list ts \<equiv> concat (map (\<lambda> (sub, sep). elems sub @ [sep]) ts)"

(* this abbreviation makes handling the list much nicer *)
thm leaves.simps
thm inorder.simps
thm elems.simps

value "leaves (Node [(Leaf [], (0::nat)), (Node [(Leaf [], 1), (Leaf [], 10)] (Leaf []), 12), ((Leaf []), 30), ((Leaf []), 100)] (Leaf []))"

subsection "Height and Balancedness"

class height =
  fixes height :: "'a \<Rightarrow> nat"

instantiation bplustree :: (type) height
begin

fun height_bplustree :: "'a bplustree \<Rightarrow> nat" where
  "height (Leaf ks) = 0" |
  "height (Node ts t) = Suc (Max (height ` (set (subtrees ts@[t]))))"

instance ..

end

text "Balancedness is defined is close accordance to the definition by Ernst"

fun bal:: "'a bplustree \<Rightarrow> bool" where
  "bal (Leaf ks) = True" |
  "bal (Node ts t) = (
    (\<forall>sub \<in> set (subtrees ts). height sub = height t) \<and>
    (\<forall>sub \<in> set (subtrees ts). bal sub) \<and> bal t
  )"

value "height (Node [(Leaf [], (0::nat)), (Node [(Leaf [], 1), (Leaf [], 10)] (Leaf []), 12), ((Leaf []), 30), ((Leaf []), 100)] (Leaf []))"
value "bal (Node [(Leaf [], (0::nat)), (Node [(Leaf [], 1), (Leaf [], 10)] (Leaf []), 12), ((Leaf []), 30), ((Leaf []), 100)] (Leaf []))"

subsection "Order"

text "The order of a B-tree is defined just as in the original paper by Bayer."

(* alt1: following knuths definition to allow for any
   natural number as order and resolve ambiguity *)
(* alt2: use range [k,2*k] allowing for valid bplustrees
   from k=1 onwards NOTE this is what I ended up implementing *)

fun order:: "nat \<Rightarrow> 'a bplustree \<Rightarrow> bool" where
  "order k (Leaf ks) = ((length ks \<ge> k)  \<and> (length ks \<le> 2*k))" |
  "order k (Node ts t) = (
  (length ts \<ge> k)  \<and>
  (length ts \<le> 2*k) \<and>
  (\<forall>sub \<in> set (subtrees ts). order k sub) \<and> order k t
)"

text \<open>The special condition for the root is called \textit{root\_order}\<close>

(* the invariant for the root of the bplustree *)
fun root_order:: "nat \<Rightarrow> 'a bplustree \<Rightarrow> bool" where
  "root_order k (Leaf ks) = (length ks \<le> 2*k)" |
  "root_order k (Node ts t) = (
  (length ts > 0) \<and>
  (length ts \<le> 2*k) \<and>
  (\<forall>s \<in> set (subtrees ts). order k s) \<and> order k t
)"

subsection "Auxiliary Lemmas"

(* auxiliary lemmas when handling sets *)
lemma separators_split:
  "set (separators (l@(a,b)#r)) = set (separators l) \<union> set (separators r) \<union> {b}"
  by simp

lemma subtrees_split:
  "set (subtrees (l@(a,b)#r)) = set (subtrees l) \<union> set (subtrees r) \<union> {a}"
  by simp

(* height and set lemmas *)

lemma finite_set_ins_swap:
  assumes "finite A"
  shows "max a (Max (Set.insert b A)) = max b (Max (Set.insert a A))"
  using Max_insert assms max.commute max.left_commute by fastforce

lemma finite_set_in_idem:
  assumes "finite A"
  shows "max a (Max (Set.insert a A)) = Max (Set.insert a A)"
  using Max_insert assms max.commute max.left_commute by fastforce

lemma height_Leaf: "height t = 0 \<longleftrightarrow> (\<exists>ks. t = (Leaf ks))"
  by (induction t) (auto)

lemma height_bplustree_order:
  "height (Node (ls@[a]) t) = height (Node (a#ls) t)"
  by simp

lemma height_bplustree_sub:
  "height (Node ((sub,x)#ls) t) = max (height (Node ls t)) (Suc (height sub))"
  by simp

lemma height_bplustree_last:
  "height (Node ((sub,x)#ts) t) = max (height (Node ts sub)) (Suc (height t))"
  by (induction ts) auto

lemma set_leaves_leaves: "set (leaves t) = set_leaves t"
  apply(induction t)
   apply(auto)
  done

lemma set_nodes_nodes: "set (inorder t) = set_nodes t"
  apply(induction t)
   apply(auto simp add: rev_image_eqI)
  done

lemma child_subset_leaves: "p \<in> set t \<Longrightarrow> set_leaves (fst p) \<subseteq> set_leaves (Node t n)"
  apply(induction p arbitrary: t n)
  apply(auto)
  done

lemma child_subset: "p \<in> set t \<Longrightarrow> set_nodes (fst p) \<subseteq> set_nodes (Node t n)"
  apply(induction p arbitrary: t n)
  apply(auto)
  done

lemma some_child_sub:
  assumes "(sub,sep) \<in> set t"
  shows "sub \<in> set (subtrees t)"
    and "sep \<in> set (separators t)"
  using assms by force+

(* balancedness lemmas *)

lemma bal_all_subtrees_equal: "bal (Node ts t) \<Longrightarrow> (\<forall>s1 \<in> set (subtrees ts). \<forall>s2 \<in> set (subtrees ts). height s1 = height s2)"
  by (metis BPlusTree.bal.simps(2))

lemma fold_max_set: "\<forall>x \<in> set t. x = f \<Longrightarrow> fold max t f = f"
  apply(induction t)
   apply(auto simp add: max_def_raw)
  done

lemma height_bal_tree: "bal (Node ts t) \<Longrightarrow> height (Node ts t) = Suc (height t)"
  by (induction ts) auto

lemma bal_split_last:
  assumes "bal (Node (ls@(sub,sep)#rs) t)"
  shows "bal (Node (ls@rs) t)"
    and "height (Node (ls@(sub,sep)#rs) t) = height (Node (ls@rs) t)"
  using assms by auto

lemma bal_split_right:
  assumes "bal (Node (ls@rs) t)"
  shows "bal (Node rs t)"
    and "height (Node rs t) = height (Node (ls@rs) t)"
  using assms by (auto simp add: image_constant_conv)

lemma bal_split_left:
  assumes "bal (Node (ls@(a,b)#rs) t)"
  shows "bal (Node ls a)"
    and "height (Node ls a) = height (Node (ls@(a,b)#rs) t)"
  using assms by (auto simp add: image_constant_conv)

lemma bal_substitute: "\<lbrakk>bal (Node (ls@(a,b)#rs) t); height t = height c; bal c\<rbrakk> \<Longrightarrow> bal (Node (ls@(c,b)#rs) t)"
  unfolding bal.simps
  by auto

lemma bal_substitute_subtree: "\<lbrakk>bal (Node (ls@(a,b)#rs) t); height a = height c; bal c\<rbrakk> \<Longrightarrow> bal (Node (ls@(c,b)#rs) t)"
  using bal_substitute
  by auto

lemma bal_substitute_separator: "bal (Node (ls@(a,b)#rs) t) \<Longrightarrow> bal (Node (ls@(a,c)#rs) t)"
  unfolding bal.simps
  by auto

(* order lemmas *)

lemma order_impl_root_order: "\<lbrakk>k > 0; order k t\<rbrakk> \<Longrightarrow> root_order k t"
  apply(cases t)
   apply(auto)
  done

(* sorted leaves implies that some sublists are sorted. This can be followed directly *)

lemma sorted_inorder_list_separators: "sorted_less (inorder_list ts) \<Longrightarrow> sorted_less (separators ts)"
  apply(induction ts)
   apply (auto simp add: sorted_lems)
  done

corollary sorted_inorder_separators: "sorted_less (inorder (Node ts t)) \<Longrightarrow> sorted_less (separators ts)"
  using sorted_inorder_list_separators sorted_wrt_append
  by auto

lemma sorted_inorder_list_subtrees:
  "sorted_less (inorder_list ts) \<Longrightarrow> \<forall> sub \<in> set (subtrees ts). sorted_less (inorder sub)"
  apply(induction ts)
   apply (auto simp add: sorted_lems)+
  done

corollary sorted_inorder_subtrees: "sorted_less (inorder (Node ts t)) \<Longrightarrow> \<forall> sub \<in> set (subtrees ts). sorted_less (inorder sub)"
  using sorted_inorder_list_subtrees sorted_wrt_append by auto

lemma sorted_inorder_list_induct_subtree:
  "sorted_less (inorder_list (ls@(sub,sep)#rs)) \<Longrightarrow> sorted_less (inorder sub)"
  by (simp add: sorted_wrt_append)

corollary sorted_inorder_induct_subtree:
  "sorted_less (inorder (Node (ls@(sub,sep)#rs) t)) \<Longrightarrow> sorted_less (inorder sub)"
  by (simp add: sorted_wrt_append)

lemma sorted_inorder_induct_last: "sorted_less (inorder (Node ts t)) \<Longrightarrow> sorted_less (inorder t)"
  by (simp add: sorted_wrt_append)

lemma sorted_leaves_list_subtrees:
  "sorted_less (leaves_list ts) \<Longrightarrow> \<forall> sub \<in> set (subtrees ts). sorted_less (leaves sub)"
  apply(induction ts)
   apply (auto simp add: sorted_wrt_append)+
  done

corollary sorted_leaves_subtrees: "sorted_less (leaves (Node ts t)) \<Longrightarrow> \<forall> sub \<in> set (subtrees ts). sorted_less (leaves sub)"
  using sorted_leaves_list_subtrees sorted_wrt_append by auto

lemma sorted_leaves_list_induct_subtree:
  "sorted_less (leaves_list (ls@(sub,sep)#rs)) \<Longrightarrow> sorted_less (leaves sub)"
  by (simp add: sorted_wrt_append)

corollary sorted_leaves_induct_subtree:
  "sorted_less (leaves (Node (ls@(sub,sep)#rs) t)) \<Longrightarrow> sorted_less (leaves sub)"
  by (simp add: sorted_wrt_append)

lemma sorted_leaves_induct_last: "sorted_less (leaves (Node ts t)) \<Longrightarrow> sorted_less (leaves t)"
  by (simp add: sorted_wrt_append)

text "Additional lemmas on the sortedness of the whole tree, which is
correct alignment of navigation structure and leave data"

fun inbetween where
"inbetween f l Nil t u = f l t u" |
"inbetween f l ((sub,sep)#xs) t u = (f l sub sep \<and> inbetween f sep xs t u)"

thm fold_cong

lemma cong_inbetween[fundef_cong]: "
\<lbrakk>a = b; xs = ys; \<And>l' u' sub sep. (sub,sep) \<in> set ys \<Longrightarrow> f l' sub u' = g l' sub u'; \<And>l' u'. f l' a u' = g l' b u'\<rbrakk>
  \<Longrightarrow> inbetween f l xs a u = inbetween g l ys b u"
  apply(induction ys arbitrary: l a b u xs)
  apply auto
  apply fastforce+
  done

(* adding l < u makes sorted_less inorder not necessary anymore *)
fun aligned :: "'a ::linorder \<Rightarrow> _" where
"aligned l (Leaf ks) u = (l < u \<and> (\<forall>x \<in> set ks. l < x \<and> x \<le> u))" |
"aligned l (Node ts t) u = (inbetween aligned l ts t u)"

lemma sorted_less_merge: "sorted_less (as@[a]) \<Longrightarrow> sorted_less (a#bs) \<Longrightarrow> sorted_less (as@a#bs)"
  using sorted_mid_iff by blast

thm aligned.simps

lemma leaves_cases: "x \<in> set (leaves (Node ts t)) \<Longrightarrow> (\<exists>(sub,sep) \<in> set ts. x \<in> set (leaves sub)) \<or> x \<in> set (leaves t)"
  apply (induction ts)
  apply auto
  done

lemma align_sub: "aligned l (Node ts t) u \<Longrightarrow> (sub,sep) \<in> set ts \<Longrightarrow> \<exists>l' \<in> set (separators ts) \<union> {l}. aligned l' sub sep"
  apply(induction ts arbitrary: l)
  apply auto
  done

lemma align_last: "aligned l (Node (ts@[(sub,sep)]) t) u \<Longrightarrow> aligned sep t u"
  apply(induction ts arbitrary: l)
  apply auto
  done

lemma align_last': "aligned l (Node ts t) u \<Longrightarrow> \<exists>l' \<in> set (separators ts) \<union> {l}. aligned l' t u"
  apply(induction ts arbitrary: l)
  apply auto
  done

lemma aligned_sorted_inorder: "aligned l t u \<Longrightarrow> sorted_less (l#(inorder t)@[u])"
proof(induction l t u rule: aligned.induct)
  case (2 l ts t u)
  then show ?case
  proof(cases ts)
    case Nil
    then show ?thesis
      using 2 by auto
  next
    case Cons
    then obtain ts' sub sep where ts_split: "ts = ts'@[(sub,sep)]"
      by (metis list.distinct(1) rev_exhaust surj_pair)
    moreover from 2 have "sorted_less (l#(inorder_list ts))"
    proof (induction ts arbitrary: l)
      case (Cons a ts')
      then show ?case
      proof (cases a)
        case (Pair sub sep)
        then have "aligned l sub sep" "inbetween aligned sep ts' t u"
          using "Cons.prems" by simp+
        then have "aligned sep (Node ts' t) u"
          by simp
        then have "sorted_less (sep#inorder_list ts')"
          using Cons
          by (metis insert_iff list.set(2))
        moreover have "sorted_less (l#inorder sub@[sep])"
          using Cons
          by (metis Pair \<open>aligned l sub sep\<close> list.set_intros(1))
        ultimately show ?thesis
          using Pair sorted_less_merge[of "l#inorder sub" sep "inorder_list ts'"]
          by simp
      qed
    qed simp
    moreover have "sorted_less (sep#inorder t@[u])"
    proof -
      from 2 have "aligned sep t u"
        using align_last ts_split by blast
      then show ?thesis
        using "2.IH" by blast
    qed
    ultimately show ?thesis
      using sorted_less_merge[of "l#inorder_list ts'@inorder sub" sep "inorder t@[u]"]
      by simp
  qed
qed simp

lemma separators_in_inorder_list: "set (separators ts) \<subseteq> set (inorder_list ts)"
  apply (induction ts)
  apply auto
  done

lemma separators_in_inorder: "set (separators ts) \<subseteq> set (inorder (Node ts t))"
  by fastforce

lemma aligned_sorted_separators: "aligned l (Node ts t) u \<Longrightarrow> sorted_less (l#(separators ts)@[u])"
  by (smt (verit, ccfv_threshold) aligned_sorted_inorder separators_in_inorder sorted_inorder_separators sorted_lems(2) sorted_wrt.simps(2) sorted_wrt_append subset_eq)

lemma aligned_leaves_inbetween: "aligned l t u \<Longrightarrow> \<forall>x \<in> set (leaves t). l < x \<and> x \<le> u"
proof (induction l t u rule: aligned.induct)
  case (1 l ks u)
  then show ?case by auto
next
  case (2 l ts t u)
  have *: "sorted_less (l#inorder (Node ts t)@[u])"
    using "2.prems" aligned_sorted_inorder by blast
  show ?case
  proof
    fix x assume "x \<in> set (leaves (Node ts t))"
    then consider (sub) "\<exists>(sub,sep) \<in> set ts. x \<in> set (leaves sub)" | (last) "x \<in> set (leaves t)"
      by fastforce
    then show "l < x \<and> x \<le> u"
    proof (cases)
      case sub
      then obtain sub sep where "(sub,sep) \<in> set ts" "x \<in> set (leaves sub)" by auto
      then obtain l' where "aligned l' sub sep" "l' \<in> set (separators ts) \<union> {l}"
        using "2.prems"(1) \<open>(sub, sep) \<in> set ts\<close> align_sub by blast
      then have "\<forall>x \<in> set (leaves sub). l' < x \<and> x \<le> sep"
        using "2.IH"(1) \<open>(sub,sep) \<in> set ts\<close> by auto
      moreover from * have "l \<le> l'"
          by (metis Un_insert_right \<open>l' \<in> set (separators ts) \<union> {l}\<close> append_Cons boolean_algebra_cancel.sup0 dual_order.eq_iff insert_iff less_imp_le separators_in_inorder sorted_snoc sorted_wrt.simps(2) subset_eq)
      moreover from * have  "sep \<le> u"
        by (metis \<open>(sub, sep) \<in> set ts\<close> less_imp_le list.set_intros(1) separators_in_inorder some_child_sub(2) sorted_mid_iff2 sorted_wrt_append subset_eq)
      ultimately show ?thesis
        by (meson \<open>x \<in> set (leaves sub)\<close> order.strict_trans1 order.trans)
    next
      case last
      then obtain l' where "aligned l' t u" "l' \<in> set (separators ts) \<union> {l}"
        using align_last' "2.prems" by blast
      then have "\<forall>x \<in> set (leaves t). l' < x \<and> x \<le> u"
        using "2.IH"(2) by auto
      moreover from * have "l \<le> l'"
        by (metis Un_insert_right \<open>l' \<in> set (separators ts) \<union> {l}\<close> append_Cons boolean_algebra_cancel.sup0 dual_order.eq_iff insert_iff less_imp_le separators_in_inorder sorted_snoc sorted_wrt.simps(2) subset_eq)
      ultimately show ?thesis
        by (meson \<open>x \<in> set (leaves t)\<close> order.strict_trans1 order.trans)
    qed
  qed
qed

lemma aligned_leaves_list_inbetween: "aligned l (Node ts t) u \<Longrightarrow> \<forall>x \<in> set (leaves_list ts). l < x \<and> x \<le> u"
  by (metis Un_iff aligned_leaves_inbetween leaves.simps(2) set_append)

lemma aligned_split_left: "aligned l (Node (ls@(sub,sep)#rs) t) u \<Longrightarrow> aligned l (Node ls sub) sep"
  apply(induction ls arbitrary: l)
  apply auto
  done

lemma aligned_split_right: "aligned l (Node (ls@(sub,sep)#rs) t) u \<Longrightarrow> aligned sep (Node rs t) u"
  apply(induction ls arbitrary: l)
  apply auto
  done

lemma aligned_subst: "aligned l (Node (ls@(sub', subl)#(sub,subsep)#rs) t) u \<Longrightarrow> aligned subl subsub subsep \<Longrightarrow>
aligned l (Node (ls@(sub',subl)#(subsub,subsep)#rs) t) u"
  apply (induction ls arbitrary: l)
  apply auto
  done

lemma aligned_subst_emptyls: "aligned l (Node ((sub,subsep)#rs) t) u \<Longrightarrow> aligned l subsub subsep \<Longrightarrow>
aligned l (Node ((subsub,subsep)#rs) t) u"
  by auto

lemma aligned_subst_last: "aligned l (Node (ts'@[(sub', sep')]) t) u \<Longrightarrow> aligned sep' t' u \<Longrightarrow>
  aligned l (Node (ts'@[(sub', sep')]) t') u"
  apply (induction ts' arbitrary: l)
  apply auto
  done

fun Laligned :: "'a ::linorder bplustree \<Rightarrow> _" where
"Laligned (Leaf ks) u = (\<forall>x \<in> set ks. x \<le> u)" |
"Laligned (Node ts t) u = (case ts of [] \<Rightarrow> (Laligned t u) |
 (sub,sep)#ts' \<Rightarrow> ((Laligned sub sep) \<and> inbetween aligned sep ts' t u))"

lemma Laligned_nonempty_Node: "Laligned (Node ((sub,sep)#ts') t) u =
  ((Laligned sub sep) \<and> inbetween aligned sep ts' t u)"
  by simp

lemma aligned_imp_Laligned: "aligned l t u \<Longrightarrow> Laligned t u"
  apply (induction l t u rule: aligned.induct)
  apply simp
  subgoal for l ts t u
    apply(cases ts)
     apply auto
    apply blast
    done
  done

lemma Laligned_split_left: "Laligned (Node (ls@(sub,sep)#rs) t) u \<Longrightarrow> Laligned (Node ls sub) sep"
  apply(cases ls)
  apply (auto dest!: aligned_imp_Laligned)
  apply (meson aligned.simps(2) aligned_split_left)
  done

lemma Laligned_split_right: "Laligned (Node (ls@(sub,sep)#rs) t) u \<Longrightarrow> aligned sep (Node rs t) u"
  apply(cases ls)
  apply (auto split!: list.splits dest!: aligned_imp_Laligned)
  apply (meson aligned.simps(2) aligned_split_right)
  done

lemma Lalign_sub: "Laligned (Node ((a,b)#ts) t) u \<Longrightarrow> (sub,sep) \<in> set ts \<Longrightarrow> \<exists>l' \<in> set (separators ts) \<union> {b}. aligned l' sub sep"
  apply(induction ts arbitrary: a b)
    apply (auto dest!: aligned_imp_Laligned)
  done

lemma Lalign_last: "Laligned (Node (ts@[(sub,sep)]) t) u \<Longrightarrow> aligned sep t u"
  by (cases ts) (auto simp add: align_last)

lemma Lalign_last': "Laligned (Node ((a,b)#ts) t) u \<Longrightarrow> \<exists>l' \<in> set (separators ts) \<union> {b}. aligned l' t u"
  apply(induction ts arbitrary: a b)
  apply (auto dest!: aligned_imp_Laligned)
  done

lemma Lalign_Llast: "Laligned (Node ts t) u \<Longrightarrow> Laligned t u"
  apply(cases ts)
  apply auto
  using aligned_imp_Laligned Lalign_last' Laligned_nonempty_Node
  by metis

lemma Laligned_sorted_inorder: "Laligned t u \<Longrightarrow> sorted_less ((inorder t)@[u])"
proof(induction t u rule: Laligned.induct)
  case (1 ks u)
  then show ?case by auto
next
  case (2 ts t u)
  then show ?case
    apply (cases ts)
    apply auto
    by (metis aligned.simps(2) aligned_sorted_inorder append_assoc inorder.simps(2) sorted_less_merge)
qed

lemma Laligned_sorted_separators: "Laligned (Node ts t) u \<Longrightarrow> sorted_less ((separators ts)@[u])"
  by (smt (verit, del_insts) Laligned_sorted_inorder separators_in_inorder sorted_inorder_separators sorted_wrt_append subset_eq)

lemma Laligned_leaves_inbetween: "Laligned t u \<Longrightarrow> \<forall>x \<in> set (leaves t). x \<le> u"
proof (induction t u rule: Laligned.induct)
  case (1 ks u)
  then show ?case by auto
next
  case (2 ts t u)
  have *: "sorted_less (inorder (Node ts t)@[u])"
    using "2.prems" Laligned_sorted_inorder by blast
  show ?case
  proof (cases ts)
    case Nil
    show ?thesis
    proof
      fix x assume "x \<in> set (leaves (Node ts t))"
      then have "x \<in> set (leaves t)"
        using Nil by auto
      moreover have "Laligned t u"
        using "2.prems" Nil by auto
      ultimately show "x \<le> u"
        using "2.IH"(1) Nil
        by simp
    qed
  next
    case (Cons h ts')
    then obtain a b where h_split: "h = (a,b)"
      by (cases h)
    show ?thesis
    proof
    fix x assume "x \<in> set (leaves (Node ts t))"
    then consider (first) "x \<in> set (leaves a)" | (sub) "\<exists>(sub,sep) \<in> set ts'. x \<in> set (leaves sub)" | (last) "x \<in> set (leaves t)"
      using Cons h_split by fastforce
    then show "x \<le> u"
      proof (cases)
        case first
        moreover have "Laligned a b"
          using "2.prems" Cons h_split by auto
        moreover have "b \<le> u"
          by (metis "*" h_split less_imp_le list.set_intros(1) local.Cons separators_in_inorder some_child_sub(2) sorted_wrt_append subsetD)
        ultimately show ?thesis
          using "2.IH"(2)[OF Cons sym[OF h_split]]
          by auto
      next
        case sub
        then obtain sub sep where "(sub,sep) \<in> set ts'" "x \<in> set (leaves sub)" by auto
        then obtain l' where "aligned l' sub sep" "l' \<in> set (separators ts') \<union> {b}"
          using "2.prems" Lalign_sub h_split local.Cons by blast
        then have "\<forall>x \<in> set (leaves sub). l' < x \<and> x \<le> sep"
          by (meson aligned_leaves_inbetween)
        moreover from * have  "sep \<le> u"
          by (metis "2.prems" Laligned_sorted_separators \<open>(sub, sep) \<in> set ts'\<close> insert_iff less_imp_le list.set(2) local.Cons some_child_sub(2) sorted_wrt_append)
        ultimately show ?thesis
          by (meson \<open>x \<in> set (leaves sub)\<close> order.strict_trans1 order.trans)
      next
        case last
        then obtain l' where "aligned l' t u" "l' \<in> set (separators ts') \<union> {b}"
          using "2.prems" Lalign_last' h_split local.Cons by blast
        then have "\<forall>x \<in> set (leaves t). l' < x \<and> x \<le> u"
          by (meson aligned_leaves_inbetween)
        then show ?thesis
          by (meson \<open>x \<in> set (leaves t)\<close> order.strict_trans1 order.trans)
      qed
    qed
  qed
qed

lemma Laligned_leaves_list_inbetween: "Laligned (Node ts t) u \<Longrightarrow> \<forall>x \<in> set (leaves_list ts). x \<le> u"
  by (metis Un_iff Laligned_leaves_inbetween leaves.simps(2) set_append)

lemma Laligned_subst_last: "Laligned (Node (ts'@[(sub', sep')]) t) u \<Longrightarrow> aligned sep' t' u \<Longrightarrow>
  Laligned (Node (ts'@[(sub', sep')]) t') u"
  apply (cases ts')
  apply (auto)
  by (meson aligned.simps(2) aligned_subst_last)

lemma Laligned_subst: "Laligned (Node (ls@(sub', subl)#(sub,subsep)#rs) t) u \<Longrightarrow> aligned subl subsub subsep \<Longrightarrow>
Laligned (Node (ls@(sub',subl)#(subsub,subsep)#rs) t) u"
  apply (induction ls)
  apply auto
  apply (meson aligned.simps(2) aligned_subst)
  done

lemma concat_leaf_nodes_leaves: "(concat (map leaves (leaf_nodes t))) = leaves t"
  apply(induction t rule: leaf_nodes.induct)
  subgoal by auto
  subgoal for ts t
    apply(induction ts)
    apply simp
    apply auto
    done
  done

lemma leaf_nodes_not_empty: "leaf_nodes t \<noteq> []"
  by (induction t) auto

end


(*
  File:      Maximal_Consistent_Sets.thy
  Author:    Asta Halkjær From

  Maximal Consistent Sets based on the transfinite Lindenbaum construction in the textbook
  "Model Theory" by Chang and Keisler (Elsevier Science Publishers 1990)
*)

theory Maximal_Consistent_Sets imports "HOL-Cardinals.Cardinal_Order_Relation" begin

context wo_rel begin

lemma underS_bound: \<open>a \<in> underS n \<Longrightarrow> b \<in> underS n \<Longrightarrow> a \<in> under b \<or> b \<in> under a\<close>
  by (meson BNF_Least_Fixpoint.underS_Field REFL Refl_under_in in_mono under_ofilter ofilter_linord)

lemma finite_underS_bound:
  assumes \<open>finite X\<close> \<open>X \<subseteq> underS n\<close> \<open>X \<noteq> {}\<close>
  shows \<open>\<exists>a \<in> X. \<forall>b \<in> X. b \<in> under a\<close>
  using assms
proof (induct X rule: finite_induct)
  case (insert x F)
  then show ?case
  proof (cases \<open>F = {}\<close>)
    case True
    then show ?thesis
      using insert underS_bound by fast
  next
    case False
    then show ?thesis
    using insert underS_bound by (metis TRANS insert_absorb insert_iff insert_subset under_trans)
  qed
qed simp

lemma finite_bound_under:
  assumes \<open>finite p\<close> \<open>p \<subseteq> (\<Union>n \<in> Field r. f n)\<close>
  shows \<open>\<exists>m. p \<subseteq> (\<Union>n \<in> under m. f n)\<close>
    using assms
proof (induct rule: finite_induct)
  case (insert x p)
  then obtain m where \<open>p \<subseteq> (\<Union>n \<in> under m. f n)\<close>
    by fast
  moreover obtain m' where \<open>x \<in> f m'\<close> \<open>m' \<in> Field r\<close>
    using insert(4) by blast
  then have \<open>x \<in> (\<Union>n \<in> under m'. f n)\<close>
    using REFL Refl_under_in by fast
  ultimately have \<open>{x} \<union> p \<subseteq> (\<Union>n \<in> under m. f n) \<union> (\<Union>n \<in> under m'. f n)\<close>
    by fast
  then show ?case
    by (metis SUP_union Un_commute insert_is_Un sup.absorb_iff2 ofilter_linord under_ofilter)
qed simp

end

locale MCS_Lim_Ord =
  fixes r :: \<open>'a rel\<close>
  assumes WELL: \<open>Well_order r\<close>
    and isLimOrd_r: \<open>isLimOrd r\<close>
  fixes consistent :: \<open>'a set \<Rightarrow> bool\<close>
  assumes consistent_hereditary: \<open>consistent S \<Longrightarrow> S' \<subseteq> S \<Longrightarrow> consistent S'\<close>
    and inconsistent_finite: \<open>\<And>S. \<not> consistent S \<Longrightarrow> \<exists>S' \<subseteq> S. finite S' \<and> \<not> consistent S'\<close>
begin

definition extendS :: \<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a set\<close> where
  \<open>extendS S n prev \<equiv> if consistent ({n} \<union> prev) then {n} \<union> prev else prev\<close>

definition extendL :: \<open>('a \<Rightarrow> 'a set) \<Rightarrow> 'a \<Rightarrow> 'a set\<close> where
  \<open>extendL rec n \<equiv> \<Union>m \<in> underS r n. rec m\<close>

definition extend :: \<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set\<close> where
  \<open>extend S n \<equiv> worecZSL r S (extendS S) extendL n\<close>

lemma wo_rel_r: \<open>wo_rel r\<close>
  by (simp add: WELL wo_rel.intro)

lemma adm_woL_extendL: \<open>adm_woL r extendL\<close>
  unfolding extendL_def wo_rel.adm_woL_def[OF wo_rel_r] by blast

definition Extend :: \<open>'a set \<Rightarrow> 'a set\<close> where
  \<open>Extend S \<equiv> \<Union>n \<in> Field r. extend S n\<close>

lemma extend_subset: \<open>n \<in> Field r \<Longrightarrow> S \<subseteq> extend S n\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    unfolding extend_def wo_rel.worecZSL_zero[OF wo_rel_r adm_woL_extendL]
    by simp
next
  case (2 i)
  moreover from this have \<open>i \<in> Field r\<close>
    by (meson FieldI1 wo_rel.succ_in wo_rel_r)
  ultimately show ?case
    unfolding extend_def extendS_def
      wo_rel.worecZSL_succ[OF wo_rel_r adm_woL_extendL 2(1)] by auto
next
  case (3 i)
  then show ?case
    unfolding extend_def extendL_def
      wo_rel.worecZSL_isLim[OF wo_rel_r adm_woL_extendL 3(1-2)]
    using wo_rel_r by (metis SUP_upper2 emptyE underS_I wo_rel.zero_in_Field wo_rel.zero_smallest)
qed

lemma Extend_subset': \<open>Field r \<noteq> {} \<Longrightarrow> S \<subseteq> Extend S\<close>
  unfolding Extend_def using extend_subset by fast

lemma extend_underS: \<open>m \<in> underS r n \<Longrightarrow> extend S m \<subseteq> extend S n\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    unfolding extend_def using wo_rel_r by (simp add: wo_rel.underS_zero)
next
  case (2 i)
  moreover from this have \<open>m = i \<or> m \<in> underS r i\<close>
    by (metis wo_rel.less_succ underS_E underS_I wo_rel_r)
  ultimately show ?case
    unfolding extend_def extendS_def
      wo_rel.worecZSL_succ[OF wo_rel_r adm_woL_extendL 2(1)]
    by auto
next
  case (3 i)
  then show ?case
    unfolding extend_def extendL_def
      wo_rel.worecZSL_isLim[OF wo_rel_r adm_woL_extendL 3(1-2)]
    by blast
qed

lemma extend_under: \<open>m \<in> under r n \<Longrightarrow> extend S m \<subseteq> extend S n\<close>
  using extend_underS wo_rel_r
  by (metis empty_iff in_Above_under set_eq_subset wo_rel.supr_greater wo_rel.supr_under underS_I
      under_Field under_empty)

lemma consistent_extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (extend S n)\<close>
  using assms
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    unfolding extend_def wo_rel.worecZSL_zero[OF wo_rel_r adm_woL_extendL] .
next
  case (2 i)
  then show ?case
    unfolding extend_def extendS_def
      wo_rel.worecZSL_succ[OF wo_rel_r adm_woL_extendL 2(1)]
    by auto
next
  case (3 i)
  show ?case
  proof (rule ccontr)
    assume \<open>\<not> consistent (extend S i)\<close>
    then obtain S' where S': \<open>finite S'\<close> \<open>S' \<subseteq> (\<Union>n \<in> underS r i. extend S n)\<close> \<open>\<not> consistent S'\<close>
      unfolding extend_def extendL_def
        wo_rel.worecZSL_isLim[OF wo_rel_r adm_woL_extendL 3(1-2)]
      using inconsistent_finite by auto
    then obtain ns where ns: \<open>S' \<subseteq> (\<Union>n \<in> ns. extend S n)\<close> \<open>ns \<subseteq> underS r i\<close> \<open>finite ns\<close>
      by (metis finite_subset_Union finite_subset_image)
    moreover have \<open>ns \<noteq> {}\<close>
      using S'(3) assms calculation(1) consistent_hereditary by auto
    ultimately obtain j where \<open>\<forall>n \<in> ns. n \<in> under r j\<close> \<open>j \<in> underS r i\<close>
      using wo_rel.finite_underS_bound wo_rel_r ns by (meson subset_iff)
    then have \<open>\<forall>n \<in> ns. extend S n \<subseteq> extend S j\<close>
      using extend_under by fast
    then have \<open>S' \<subseteq> extend S j\<close>
      using S' ns(1) by blast
    then show False
      using 3(3) \<open>\<not> consistent S'\<close> assms consistent_hereditary \<open>j \<in> underS r i\<close> by blast
  qed
qed

lemma consistent_Extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (Extend S)\<close>
  unfolding Extend_def
proof (rule ccontr)
  assume \<open>\<not> consistent (\<Union>n \<in> Field r. extend S n)\<close>
  then obtain S' where \<open>finite S'\<close> \<open>S' \<subseteq> (\<Union>n \<in> Field r. extend S n)\<close> \<open>\<not> consistent S'\<close>
    using inconsistent_finite by metis
  then obtain m where \<open>S' \<subseteq> (\<Union>n \<in> under r m. extend S n)\<close> \<open>m \<in> Field r\<close>
    using wo_rel.finite_bound_under wo_rel_r
    by (metis SUP_le_iff assms consistent_hereditary emptyE under_empty)
  then have \<open>S' \<subseteq> extend S m\<close>
    using extend_under by fast
  moreover have \<open>consistent (extend S m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    using \<open>\<not> consistent S'\<close> consistent_hereditary by blast
qed

definition maximal' :: \<open>'a set \<Rightarrow> bool\<close> where
  \<open>maximal' S \<equiv> \<forall>p \<in> Field r. consistent ({p} \<union> S) \<longrightarrow> p \<in> S\<close>

lemma Extend_bound: \<open>n \<in> Field r \<Longrightarrow> extend S n \<subseteq> Extend S\<close>
  unfolding Extend_def by blast

lemma maximal'_Extend: \<open>maximal' (Extend S)\<close>
  unfolding maximal'_def
proof safe
  fix p
  assume *: \<open>p \<in> Field r\<close> \<open>consistent ({p} \<union> Extend S)\<close>
  then have \<open>{p} \<union> extend S p \<subseteq> {p} \<union> Extend S\<close>
    unfolding Extend_def by blast
  then have **: \<open>consistent ({p} \<union> extend S p)\<close>
    using * consistent_hereditary by blast
  moreover have succ: \<open>aboveS r p \<noteq> {}\<close>
    using * isLimOrd_r wo_rel.isLimOrd_aboveS wo_rel_r by fast
  then have \<open>succ r p \<in> Field r\<close>
    using wo_rel_r by (simp add: wo_rel.succ_in_Field)
  moreover have \<open>p \<in> extend S (succ r p)\<close>
    using ** unfolding extend_def extendS_def
      wo_rel.worecZSL_succ[OF wo_rel_r adm_woL_extendL succ]
    by simp
  ultimately show \<open>p \<in> Extend S\<close>
    using Extend_bound by fast
qed

end

locale MCS =
  fixes consistent :: \<open>'a set \<Rightarrow> bool\<close>
  assumes infinite_UNIV: \<open>infinite (UNIV :: 'a set)\<close>
    and \<open>consistent S \<Longrightarrow> S' \<subseteq> S \<Longrightarrow> consistent S'\<close>
    and \<open>\<And>S. \<not> consistent S \<Longrightarrow> \<exists>S' \<subseteq> S. finite S' \<and> \<not> consistent S'\<close>

sublocale MCS \<subseteq> MCS_Lim_Ord \<open>|UNIV|\<close>
proof
  show \<open>Well_order |UNIV|\<close>
    by simp
next
  have \<open>infinite ( Field |UNIV :: 'a set| )\<close>
    using infinite_UNIV by simp
  with card_order_infinite_isLimOrd card_of_Card_order
  show \<open>isLimOrd |UNIV :: 'a set|\<close> .
next
  fix S S'
  show \<open>consistent S \<Longrightarrow> S' \<subseteq> S \<Longrightarrow> consistent S'\<close>
    using MCS_axioms unfolding MCS_def by blast
next
  fix S S'
  show \<open>\<not> consistent S \<Longrightarrow> \<exists>S' \<subseteq> S. finite S' \<and> \<not> consistent S'\<close>
    using MCS_axioms unfolding MCS_def by blast
qed

context MCS begin

lemma Extend_subset: \<open>S \<subseteq> Extend S\<close>
  by (simp add: Extend_subset')

definition maximal :: \<open>'a set \<Rightarrow> bool\<close> where
  \<open>maximal S \<equiv> \<forall>p. consistent ({p} \<union> S) \<longrightarrow> p \<in> S\<close>

lemma maximal_maximal': \<open>maximal S \<longleftrightarrow> maximal' S\<close>
  unfolding maximal_def maximal'_def by simp

lemma maximal_Extend: \<open>maximal (Extend S)\<close>
  using maximal'_Extend maximal_maximal' by fast

end

end