theory Short_Theory_13_15
  imports "HOL-IMP.Abs_Int1"
begin

datatype sign' = Neg | Zero | Pos

type_synonym sign = "sign' set"

lemma sign_ext: "UNIV = {Neg, Zero, Pos}"
proof auto
  fix x
  show "\<lbrakk>x \<noteq> Neg; x \<noteq> Zero\<rbrakk> \<Longrightarrow> x = Pos"
  proof (cases x, auto)
  qed
qed

lemma card_sign' [simp]: "card (UNIV :: sign) = 3" by (auto simp: sign_ext)

lemma finite_sign' [simp, intro!]: "finite (UNIV :: sign' set)" by (auto simp: sign_ext)

lemma finite_sign [simp, intro!]: "finite (UNIV :: sign set)" by (simp add: Finite_Set.finite_set)

text\<open>Instantiation of class \<^class>\<open>order\<close> with type \<^typ>\<open>sign\<close>:\<close>

text\<open>Instantiation of class \<^class>\<open>semilattice_sup_top\<close> with type \<^typ>\<open>sign\<close>:\<close>

instantiation set :: (type) semilattice_sup_top
begin
instance ..
end

text\<open>Now we define the functions used for instantiating the abstract
interpretation locales. Note that the Isabelle terminology is
\emph{interpretation}, not \emph{instantiation} of locales, but we use
instantiation to avoid confusion with abstract interpretation.\<close>

fun \<gamma>_sign' :: "sign' \<Rightarrow> val set" where
  "\<gamma>_sign' Neg = {i. i < 0}" |
  "\<gamma>_sign' Zero  = {0}" |
  "\<gamma>_sign' Pos  = {i. 0 < i}"

fun \<gamma>_sign :: "sign \<Rightarrow> val set" where
  "\<gamma>_sign S = {i. \<exists>s\<in>S. i \<in> \<gamma>_sign' s}"

fun num_sign :: "val \<Rightarrow> sign" where
"num_sign i = (if i < 0 then {Neg} else if 0 < i then {Pos} else {Zero})"

fun plus_sign' :: "sign' \<Rightarrow> sign' \<Rightarrow> sign" where
  "plus_sign' Neg Pos = UNIV" |
  "plus_sign' Pos Neg = UNIV" |
  "plus_sign' Zero s = {s}" |
  "plus_sign' s _ = {s}"

fun plus_sign :: "sign \<Rightarrow> sign \<Rightarrow> sign" where
  "plus_sign S1 S2 = {s. \<exists>s1\<in>S1. \<exists>s2\<in>S2. s \<in> plus_sign' s1 s2}"

text\<open>First we instantiate the abstract value interface and prove that the
functions on type \<^typ>\<open>sign\<close> have all the necessary properties:\<close>

lemma val_tricho_0:
  fixes x :: val
  obtains (BNeg) "x < 0" | (BZero) "x = 0" | (BPos) "x > 0"
  by (rule linorder_cases)

lemma \<gamma>_sign_top [simp]: "\<gamma>_sign UNIV = UNIV"
proof auto
  fix x :: val
  show "\<exists>s. x \<in> \<gamma>_sign' s"
  proof (cases rule: val_tricho_0 [of x])
    case BNeg
    then have "x \<in> \<gamma>_sign' Neg" by auto
    then show ?thesis by blast
  next
    case BZero
    then have "x \<in> \<gamma>_sign' Zero" by auto
    then show ?thesis by blast
  next
    case BPos
    then have "x \<in> \<gamma>_sign' Pos" by auto
    then show ?thesis by blast
  qed
qed

lemma Neg_\<gamma>_sign [dest]: "\<lbrakk>x < 0; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Neg \<in> S"
proof auto
  fix s
  assume assm: "s \<in> S" "x < 0" "x \<in> \<gamma>_sign' s"
  from assm(2, 3) have "s = Neg" by (cases s) auto
  with assm(1) show "Neg \<in> S" by simp
qed

lemma Zero_\<gamma>_sign [dest]: "\<lbrakk>x = 0; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Zero \<in> S"
proof auto
  fix s
  assume assm: "s \<in> S" "0 \<in> \<gamma>_sign' s"
  from assm(2) have "s = Zero" by (cases s) auto
  with assm(1) show "Zero \<in> S" by simp
qed

lemma Pos_\<gamma>_sign [dest]: "\<lbrakk>0 < x; x \<in> \<gamma>_sign S\<rbrakk> \<Longrightarrow> Pos \<in> S"
proof auto
  fix s
  assume assm: "s \<in> S" "0 < x" "x \<in> \<gamma>_sign' s"
  from assm(2, 3) have "s = Pos" by (cases s) auto
  with assm(1) show "Pos \<in> S" by simp
qed

global_interpretation Val_semilattice
where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
proof (standard, goal_cases)
  case (1 a b)
  then show ?case by auto
next
  case 2
  then show ?case
  proof auto
    fix x :: val
    show "\<exists>s. x \<in> \<gamma>_sign' s"
    proof (cases rule: val_tricho_0 [of x])
      case BNeg
      then have "x \<in> \<gamma>_sign' Neg" by auto
      then show ?thesis by blast
    next
      case BZero
      then have "x \<in> \<gamma>_sign' Zero" by auto
      then show ?thesis by blast
    next
      case BPos
      then have "x \<in> \<gamma>_sign' Pos" by auto
      then show ?thesis by blast
    qed
  qed
next
  case (3 i)
  then show ?case by auto
next
  case (4 i1 a1 i2 a2)
  show ?case
  proof (cases rule: val_tricho_0 [of i1];
      cases rule: val_tricho_0 [of i2];
      cases rule: val_tricho_0 [of "i1 + i2"];
      linarith?)
    {
      assume "i1 < 0"
      with 4(1) have H1: "Neg \<in> a1" by (simp add: Neg_\<gamma>_sign)
      {
        assume "i2 < 0"
        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
        moreover assume "i1 + i2 < 0"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
      {
        assume "i2 = 0"
        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
        moreover assume "i1 + i2 < 0"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
      {
        assume "i2 > 0"
        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
        from H1 H2 have "plus_sign a1 a2 = UNIV" by force
        then have "\<gamma>_sign (plus_sign a1 a2) = UNIV" using \<gamma>_sign_top by auto
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by auto
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
      }
    }
    {
      assume "i1 = 0"
      with 4(1) have H1: "Zero \<in> a1" by (simp add: Zero_\<gamma>_sign)
      {
        assume "i2 < 0"
        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
        from H1 H2 have "Neg \<in> plus_sign a1 a2" by force
        moreover assume "i1 + i2 < 0"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
      {
        assume "i2 = 0"
        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
        from H1 H2 have "Zero \<in> plus_sign a1 a2" by force
        moreover assume "i1 + i2 = 0"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
      {
        assume "i2 > 0"
        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
        moreover assume "0 < i1 + i2"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
    }
    {
      assume "0 < i1"
      with 4(1) have H1: "Pos \<in> a1" by (simp add: Pos_\<gamma>_sign)
      {
        assume "i2 < 0"
        with 4(2) have H2: "Neg \<in> a2" by (simp add: Neg_\<gamma>_sign)
        from H1 H2 have "plus_sign a1 a2 = UNIV" by force
        then have "\<gamma>_sign (plus_sign a1 a2) = UNIV" using \<gamma>_sign_top by auto
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by auto
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
        then show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" .
      }
      {
        assume "i2 = 0"
        with 4(2) have H2: "Zero \<in> a2" by (simp add: Zero_\<gamma>_sign)
        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
        moreover assume "0 < i1 + i2"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
      {
        assume "0 < i2"
        with 4(2) have H2: "Pos \<in> a2" by (simp add: Pos_\<gamma>_sign)
        from H1 H2 have "Pos \<in> plus_sign a1 a2" by force
        moreover assume "0 < i1 + i2"
        ultimately show "i1 + i2 \<in> \<gamma>_sign (plus_sign a1 a2)" by fastforce
      }
    }
  qed
qed

text\<open>In case 4 we needed to refer to particular variables.
Writing (i x y z) fixes the names of the variables in case i to be x, y and z
in the left-to-right order in which the variables occur in the subgoal.
Underscores are anonymous placeholders for variable names we don't care to fix.\<close>

text\<open>Instantiating the abstract interpretation locale requires no more
proofs (they happened in the instatiation above) but delivers the
instantiated abstract interpreter which we call \<open>AI_parity\<close>:\<close>

global_interpretation Abs_Int
where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
defines aval_sign = aval' and step_sign = step' and AI_sign = AI
  ..

global_interpretation Abs_Int_mono
where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
proof (standard, goal_cases)
  case (1 a1 b1 a2 b2) thus ?case
    by(induct b1 b2 rule: plus_sign.induct) auto
qed

definition m_sign :: "sign \<Rightarrow> nat" where
"m_sign x = 3 - card x"

global_interpretation Abs_Int_measure
where \<gamma> = \<gamma>_sign and num' = num_sign and plus' = plus_sign
and m = m_sign and h = "3"
proof (standard, goal_cases)
  case (1 x) thus ?case by(auto simp add: m_sign_def)
next
  case (2 x y)
  have "y \<subseteq> UNIV" by auto
  then show ?case unfolding m_sign_def
    by (metis "2" card_sign' diff_less_mono2 finite_sign' finite_subset less_le_trans psubset_card_mono)
qed

thm AI_Some_measure

end


theory ex_2_7
  imports Main
begin
datatype 'a tree2 = Leaf 'a | Node "'a tree2" 'a "'a tree2"
fun mirror::"'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Leaf a) = Leaf a" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

fun pre_order::"'a tree2 \<Rightarrow> 'a list" where
"pre_order (Leaf a) = [a]" |
"pre_order (Node l a r) = a # ((pre_order l) @ (pre_order r))"

fun post_order::"'a tree2 \<Rightarrow> 'a list" where
"post_order (Leaf a) = [a]" |
"post_order (Node l a r) = (post_order l) @ (post_order r) @ [a]"

theorem pre_post:"pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
  by (auto)
end


(*  Title:      HOL/Statespace/DistinctTreeProver.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>Distinctness of Names in a Binary Tree \label{sec:DistinctTreeProver}\<close>

theory DistinctTreeProver
imports Main
begin

text \<open>A state space manages a set of (abstract) names and assumes
that the names are distinct. The names are stored as parameters of a
locale and distinctness as an assumption. The most common request is
to proof distinctness of two given names. We maintain the names in a
balanced binary tree and formulate a predicate that all nodes in the
tree have distinct names. This setup leads to logarithmic certificates.
\<close>

subsection \<open>The Binary Tree\<close>

datatype 'a tree = Node "'a tree" 'a bool "'a tree" | Tip

text \<open>The boolean flag in the node marks the content of the node as
deleted, without having to build a new tree. We prefer the boolean
flag to an option type, so that the ML-layer can still use the node
content to facilitate binary search in the tree. The ML code keeps the
nodes sorted using the term order. We do not have to push ordering to
the HOL level.\<close>

subsection \<open>Distinctness of Nodes\<close>

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
  "set_of Tip = {}"
| "set_of (Node l x d r) = (if d then {} else {x}) \<union> set_of l \<union> set_of r"

primrec all_distinct :: "'a tree \<Rightarrow> bool"
where
  "all_distinct Tip = True"
| "all_distinct (Node l x d r) =
    ((d \<or> (x \<notin> set_of l \<and> x \<notin> set_of r)) \<and>
      set_of l \<inter> set_of r = {} \<and>
      all_distinct l \<and> all_distinct r)"

text \<open>Given a binary tree \<^term>\<open>t\<close> for which
\<^const>\<open>all_distinct\<close> holds, given two different nodes contained in the tree,
we want to write a ML function that generates a logarithmic
certificate that the content of the nodes is distinct. We use the
following lemmas to achieve this.\<close>

lemma all_distinct_left: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct l"
  by simp

lemma all_distinct_right: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct r"
  by simp

lemma distinct_left: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of l \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_right: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_left_right:
    "all_distinct (Node l z b r) \<Longrightarrow> x \<in> set_of l \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma in_set_root: "x \<in> set_of (Node l x False r)"
  by simp

lemma in_set_left: "y \<in> set_of l \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma in_set_right: "y \<in> set_of r \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma swap_neq: "x \<noteq> y \<Longrightarrow> y \<noteq> x"
  by blast

lemma neq_to_eq_False: "x\<noteq>y \<Longrightarrow> (x=y)\<equiv>False"
  by simp

subsection \<open>Containment of Trees\<close>

text \<open>When deriving a state space from other ones, we create a new
name tree which contains all the names of the parent state spaces and
assume the predicate \<^const>\<open>all_distinct\<close>. We then prove that the new
locale interprets all parent locales. Hence we have to show that the
new distinctness assumption on all names implies the distinctness
assumptions of the parent locales. This proof is implemented in ML. We
do this efficiently by defining a kind of containment check of trees
by ``subtraction''.  We subtract the parent tree from the new tree. If
this succeeds we know that \<^const>\<open>all_distinct\<close> of the new tree
implies \<^const>\<open>all_distinct\<close> of the parent tree.  The resulting
certificate is of the order \<^term>\<open>n * log(m)\<close> where \<^term>\<open>n\<close> is
the size of the (smaller) parent tree and \<^term>\<open>m\<close> the size of the
(bigger) new tree.\<close>

primrec delete :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "delete x Tip = None"
| "delete x (Node l y d r) = (case delete x l of
                                Some l' \<Rightarrow>
                                 (case delete x r of
                                    Some r' \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r')
                                  | None \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r))
                               | None \<Rightarrow>
                                  (case delete x r of
                                     Some r' \<Rightarrow> Some (Node l y (d \<or> (x=y)) r')
                                   | None \<Rightarrow> if x=y \<and> \<not>d then Some (Node l y True r)
                                             else None))"

lemma delete_Some_set_of: "delete x t = Some t' \<Longrightarrow> set_of t' \<subseteq> set_of t"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    with Node.hyps
    have l'_l: "set_of l' \<subseteq> set_of l"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with l'_l Some x_l_Some del
      show ?thesis
        by (auto split: if_split_asm)
    next
      case None
      with l'_l Some x_l_Some del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with Some x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    next
      case None
      with x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_Some_all_distinct:
  "delete x t = Some t' \<Longrightarrow> all_distinct t \<Longrightarrow> all_distinct t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  have "all_distinct (Node l y d r)" by fact
  then obtain
    dist_l: "all_distinct l" and
    dist_r: "all_distinct r" and
    d: "d \<or> (y \<notin> set_of l \<and> y \<notin> set_of r)" and
    dist_l_r: "set_of l \<inter> set_of r = {}"
    by auto
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some dist_l]
    have dist_l': "all_distinct l'"
      by simp
    from delete_Some_set_of [OF x_l_Some]
    have l'_l: "set_of l' \<subseteq> set_of l".
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".

      with dist_l' dist_r' l'_l Some x_l_Some del d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with l'_l dist_l'  x_l_Some del d dist_l_r dist_r
      show ?thesis
        by fastforce
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".
      with Some dist_r' x_l_None del dist_l d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with x_l_None del dist_l dist_r d dist_l_r
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_None_set_of_conv: "delete x t = None = (x \<notin> set_of t)"
proof (induct t)
  case Tip thus ?case by simp
next
  case (Node l y d r)
  thus ?case
    by (auto split: option.splits)
qed

lemma delete_Some_x_set_of:
  "delete x t = Some t' \<Longrightarrow> x \<in> set_of t \<and> x \<notin> set_of t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some]
    obtain x_l: "x \<in> set_of l" "x \<notin> set_of l'"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_l Some x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with x_l None x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    then have x_notin_l: "x \<notin> set_of l"
      by (simp add: delete_None_set_of_conv)
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_notin_l Some x_l_None del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with None x_l_None x_notin_l del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  qed
qed

primrec subtract :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "subtract Tip t = Some t"
| "subtract (Node l x b r) t =
     (case delete x t of
        Some t' \<Rightarrow> (case subtract l t' of
                     Some t'' \<Rightarrow> subtract r t''
                    | None \<Rightarrow> None)
       | None \<Rightarrow> None)"

lemma subtract_Some_set_of_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x b r)
  have sub: "subtract (Node l x b r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''" .
        with Some sub_l_Some del_x_Some sub t2''_t2' t2'_t2
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_set_of:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_None_set_of_conv [of x t\<^sub>2] Some
    have x_t2: "x \<in> set_of t\<^sub>2"
      by simp
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have r_t\<^sub>2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from Some sub_l_Some del_x_Some sub r_t\<^sub>2'' l_t2' t2'_t2 t2''_t2' x_t2
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2]
    have dist_t2': "all_distinct t\<^sub>2'" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_t2''': "all_distinct t\<^sub>2'''" .
        from Some sub_l_Some del_x_Some sub
             dist_t2'''
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_dist_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<inter> set_of t = {}"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some ]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}" .
        from subtract_Some_set_of_res [OF Some]
        have t2'''_t2'': "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''".

        from Some sub_l_Some del_x_Some sub t2'''_t2'' dist_l_t2'' dist_r_t2'''
             t2''_t2' t2'_t2 x_not_t2'
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t\<^sub>1"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2 ]
    have dist_t2': "all_distinct t\<^sub>2'" .
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp

    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2' ]
      have dist_l: "all_distinct l" .
      from subtract_Some_all_distinct_res [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      from subtract_Some_set_of [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_dist_res [OF Some]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_r: "all_distinct r" .
        from subtract_Some_set_of [OF Some]
        have r_t2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from subtract_Some_dist_res [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}".

        from dist_l dist_r Some sub_l_Some del_x_Some r_t2'' l_t2' x_t2 x_not_t2'
             t2''_t2' dist_l_t2'' dist_r_t2'''
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma delete_left:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_l: "delete x l = Some l'"
  shows "delete x (Node l y d r) = Some (Node l' y d r)"
proof -
  from delete_Some_x_set_of [OF del_l]
  obtain x: "x \<in> set_of l"
    by simp
  with dist
  have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_l dist
    by (auto split: option.splits)
qed

lemma delete_right:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_r: "delete x r = Some r'"
  shows "delete x (Node l y d r) = Some (Node l y d r')"
proof -
  from delete_Some_x_set_of [OF del_r]
  obtain x: "x \<in> set_of r"
    by simp
  with dist
  have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_r dist
    by (auto split: option.splits)
qed

lemma delete_root:
  assumes dist: "all_distinct (Node l x False r)"
  shows "delete x (Node l x False r) = Some (Node l x True r)"
proof -
  from dist have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)
  moreover
  from dist have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)
  ultimately show ?thesis
    using dist
       by (auto split: option.splits)
qed

lemma subtract_Node:
 assumes del: "delete x t = Some t'"
 assumes sub_l: "subtract l t' = Some t''"
 assumes sub_r: "subtract r t'' = Some t'''"
 shows "subtract (Node l x False r) t = Some t'''"
using del sub_l sub_r
by simp

lemma subtract_Tip: "subtract Tip t = Some t"
  by simp

text \<open>Now we have all the theorems in place that are needed for the
certificate generating ML functions.\<close>

ML_file \<open>distinct_tree_prover.ML\<close>

end


header "Stack Machine and Compilation"

theory Chapter3_ex3_10_ASM imports AExp begin

subsection "Stack Machine"

text_raw{*\snip{ASMinstrdef}{0}{1}{% *}
datatype instr = LOADI val | LOAD vname | ADD
text_raw{*}%endsnip*}

text_raw{*\snip{ASMstackdef}{1}{2}{% *}
type_synonym stack = "val list"
text_raw{*}%endsnip*}

fun head :: "'a list \<Rightarrow> 'a option" where
"head (x # _) = Some x" |
"head []      = None"

abbreviation "hd2 xs == head (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

text{* \noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.*}

text_raw{*\snip{ASMexeconedef}{0}{1}{% *}

fun liftOption2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> 'c option" where
"liftOption2 _ _        None     = None" |
"liftOption2 _ None     _        = None" |
"liftOption2 f (Some x) (Some y) = Some (f x y)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)"   |
"exec1 (LOAD x)  s stk = Some (s x # stk)" |
"exec1 ADD       _ stk = liftOption2 (\<lambda> x y. (x + y) # tl2 stk) (hd2 stk) (head stk)"
text_raw{*}%endsnip*}

text_raw{*\snip{ASMexecdef}{1}{2}{% *}

fun bind :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option" where
"bind None     _ = None" |
"bind (Some x) f = f x"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec []       _ stk = Some stk" |
"exec (i # is) s stk =
 (case exec1 i s stk of
   None      \<Rightarrow> None |
   Some stk' \<Rightarrow> exec is s stk')"

text_raw{*}%endsnip*}

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1 @ is2) s stk = (case exec is1 s stk of None \<Rightarrow> None | Some stk' \<Rightarrow> exec is2 s stk')"
apply(induction is1 arbitrary: stk)
apply(auto split: option.split)
done

subsection "Compilation"

text_raw{*\snip{ASMcompdef}{0}{2}{% *}
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n)       = [LOADI n]" |
"comp (V x)       = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw{*}%endsnip*}

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
apply(induction a arbitrary: stk)
apply (auto)
done

end


(*
  File:     Nearest_Neighbors.thy
  Author:   Martin Rau, TU München
*)

section \<open>Nearest Neighbor Search on the \<open>k\<close>-d Tree\<close>

theory Nearest_Neighbors
imports
  KD_Tree
begin

text \<open>
  Verifying nearest neighbor search on the k-d tree. Given a \<open>k\<close>-d tree and a point \<open>p\<close>,
  which might not be in the tree, find the points \<open>ps\<close> that are closest to \<open>p\<close> using the
  Euclidean metric.
\<close>

subsection \<open>Auxiliary Lemmas about \<open>sorted_wrt\<close>\<close>

lemma
  assumes "sorted_wrt f xs"
  shows sorted_wrt_take: "sorted_wrt f (take n xs)"
  and sorted_wrt_drop: "sorted_wrt f (drop n xs)"
proof -
  have "sorted_wrt f (take n xs @ drop n xs)"
    using assms by simp
  thus "sorted_wrt f (take n xs)" "sorted_wrt f (drop n xs)"
    using sorted_wrt_append by blast+
qed

definition sorted_wrt_dist :: "('k::finite) point \<Rightarrow> 'k point list \<Rightarrow> bool" where
  "sorted_wrt_dist p \<equiv> sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. dist p\<^sub>0 p \<le> dist p\<^sub>1 p)"

lemma sorted_wrt_dist_insort_key:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
  by (induction ps) (auto simp: sorted_wrt_dist_def set_insort_key)

lemma sorted_wrt_dist_take_drop:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>p\<^sub>0 \<in> set (take n ps). \<forall>p\<^sub>1 \<in> set (drop n ps). dist p\<^sub>0 p \<le> dist p\<^sub>1 p"
  using assms sorted_wrt_append[of _ "take n ps" "drop n ps"] by (simp add: sorted_wrt_dist_def)

lemma sorted_wrt_dist_last_take_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (take n ps)) p \<le> dist (last ps) p"
  using assms unfolding sorted_wrt_dist_def by (induction ps arbitrary: n) (auto simp add: take_Cons')

lemma sorted_wrt_dist_last_insort_key_eq:
  assumes "sorted_wrt_dist p ps" "insort_key (\<lambda>q. dist q p) q ps \<noteq> ps @ [q]"
  shows "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
  using assms unfolding sorted_wrt_dist_def by (induction ps) (auto)

lemma sorted_wrt_dist_last:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>q \<in> set ps. dist q p \<le> dist (last ps) p"
proof (cases "ps = []")
  case True
  thus ?thesis by simp
next
  case False
  then obtain ps' p' where [simp]:"ps = ps' @ [p']"
    using rev_exhaust by blast
  hence "sorted_wrt_dist p (ps' @ [p'])"
    using assms by blast
  thus ?thesis
    unfolding sorted_wrt_dist_def using sorted_wrt_append[of _ ps' "[p']"] by simp
qed

subsection \<open>Neighbors Sorted wrt. Distance\<close>

definition upd_nbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k point list \<Rightarrow> 'k point list" where
  "upd_nbors n p q ps = take n (insort_key (\<lambda>q. dist q p) q ps)"

lemma sorted_wrt_dist_nbors:
  assumes "sorted_wrt_dist p ps"
  shows "sorted_wrt_dist p (upd_nbors n p q ps)"
proof -
  have "sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
    using assms sorted_wrt_dist_insort_key by blast
  thus ?thesis
    by (simp add: sorted_wrt_dist_def sorted_wrt_take upd_nbors_def)
qed

lemma sorted_wrt_dist_nbors_diff:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>r \<in> set ps \<union> {q} - set (upd_nbors n p q ps). \<forall>s \<in> set (upd_nbors n p q ps). dist s p \<le> dist r p"
proof -
  let ?ps' = "insort_key (\<lambda>q. dist q p) q ps"
  have "set ps \<union> { q } = set ?ps'"
    by (simp add: set_insort_key)
  moreover have "set ?ps' = set (take n ?ps') \<union> set (drop n ?ps')"
    using append_take_drop_id set_append by metis
  ultimately have "set ps \<union> { q } - set (take n ?ps') \<subseteq> set (drop n ?ps')"
    by blast
  moreover have "sorted_wrt_dist p ?ps'"
    using assms sorted_wrt_dist_insort_key by blast
  ultimately show ?thesis
    unfolding upd_nbors_def using sorted_wrt_dist_take_drop by blast
qed

lemma sorted_wrt_dist_last_upd_nbors_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (upd_nbors n p q ps)) p \<le> dist (last ps) p"
proof (cases "insort_key (\<lambda>q. dist q p) q ps = ps @ [q]")
  case True
  thus ?thesis
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono by auto
next
  case False
  hence "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
    using sorted_wrt_dist_last_insort_key_eq assms by blast
  moreover have "dist (last (upd_nbors  n p q ps)) p \<le> dist (last (insort_key (\<lambda>q. dist q p) q ps)) p"
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono[of p "insort_key (\<lambda>q. dist q p) q ps"]
    by (simp add: sorted_wrt_dist_insort_key)
  ultimately show ?thesis
    by simp
qed

subsection \<open>The Recursive Nearest Neighbor Algorithm\<close>

fun nearest_nbors :: "nat \<Rightarrow> ('k::finite) point list \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_nbors n ps p (Leaf q) = upd_nbors n p q ps"
| "nearest_nbors n ps p (Node k v l r) = (
    if p$k \<le> v then
      let candidates = nearest_nbors n ps p l in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p r
    else
      let candidates = nearest_nbors n ps p r in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p l
  )"

subsection \<open>Auxiliary Lemmas\<close>

lemma cutoff_r:
  assumes "invar (Node k v l r)"
  assumes "p$k \<le> v" "dist p c \<le> dist (p$k) v"
  shows "\<forall>q \<in> set_kdt r. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt r"
  have "dist p c \<le> dist (p$k) v"
    using assms(3) by blast
  also have "... \<le> dist (p$k) v + dist v (q$k)"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

lemma cutoff_l:
  assumes "invar (Node k v l r)"
  assumes "v \<le> p$k" "dist p c \<le> dist v (p$k)"
  shows "\<forall>q \<in> set_kdt l. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt l"
  have "dist p c \<le> dist v (p$k)"
    using assms(3) by blast
  also have "... \<le> dist v (p$k) + dist (q$k) v"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

subsection \<open>The Main Theorems\<close>

lemma set_nns:
  "set (nearest_nbors n ps p kdt) \<subseteq> set_kdt kdt \<union> set ps"
  apply (induction kdt arbitrary: ps)
  apply (auto simp: Let_def upd_nbors_def set_insort_key)
  using in_set_takeD set_insort_key by fastforce

lemma length_nns:
  "length (nearest_nbors n ps p kdt) = min n (size_kdt kdt + length ps)"
  by (induction kdt arbitrary: ps) (auto simp: Let_def upd_nbors_def)

lemma length_nns_gt_0:
  "0 < n \<Longrightarrow> 0 < length (nearest_nbors n ps p kdt)"
  by (induction kdt arbitrary: ps) (auto simp: Let_def upd_nbors_def)

lemma length_nns_n:
  assumes "(set_kdt kdt \<union> set ps) - set (nearest_nbors n ps p kdt) \<noteq> {}"
  shows "length (nearest_nbors n ps p kdt) = n"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case B
    let ?nns = "nearest_nbors n ?nnsl p r"
    have "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt l \<union> set ps - set (nearest_nbors n ps p l) = {})"
      using Node.IH(1) by blast
    hence "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt r \<union> set ?nnsl - set ?nns \<noteq> {})"
      using B Node.prems by auto
    moreover have "length ?nnsl = n \<longrightarrow> ?thesis"
      using B by (auto simp: length_nns)
    ultimately show ?thesis
      using B Node.IH(2) by force
  next
    case D
    let ?nns = "nearest_nbors n ?nnsr p l"
    have "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt r \<union> set ps - set (nearest_nbors n ps p r) = {})"
      using Node.IH(2) by blast
    hence "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt l \<union> set ?nnsr - set ?nns \<noteq> {})"
      using D Node.prems by auto
    moreover have "length ?nnsr = n \<longrightarrow> ?thesis"
      using D by (auto simp: length_nns)
    ultimately show ?thesis
      using D Node.IH(1) by force
  qed auto
qed (auto simp: upd_nbors_def min_def set_insort_key)

lemma sorted_nns:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (nearest_nbors n ps p kdt)"
  using sorted_wrt_dist_nbors by (induction kdt arbitrary: ps) (auto simp: Let_def)

lemma distinct_nns:
  assumes "invar kdt" "distinct ps" "set ps \<inter> set_kdt kdt = {}"
  shows "distinct (nearest_nbors n ps p kdt)"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  have "set ps \<inter> set_kdt l = {}" "set ps \<inter> set_kdt r = {}"
    using Node.prems(3) by auto
  hence DCLR: "distinct ?nnsl" "distinct ?nnsr"
    using Node invar_l invar_r by blast+
  have "set ?nnsl \<inter> set_kdt r = {}" "set ?nnsr \<inter> set_kdt l = {}"
    using Node.prems(1,3) set_nns by fastforce+
  hence "distinct (nearest_nbors n ?nnsl p r)" "distinct (nearest_nbors n ?nnsr p l)"
    using Node.IH(1,2) Node.prems(1,2) DCLR invar_l invar_r by blast+
  thus ?case
    using DCLR by (auto simp add: Let_def)
qed (auto simp: upd_nbors_def distinct_insort)

theorem dist_nns:
  assumes "invar kdt" "sorted_wrt_dist p ps" "set ps \<inter> set_kdt kdt = {}" "distinct ps" "0 < n"
  shows "\<forall>q \<in> set_kdt kdt \<union> set ps - set (nearest_nbors n ps p kdt). dist (last (nearest_nbors n ps p kdt)) p \<le> dist q p"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)

  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"

  have IHL: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nnsl. dist (last ?nnsl) p \<le> dist q p"
    using Node.IH(1) Node.prems invar_l invar_set by auto
  have IHR: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nnsr. dist (last ?nnsr) p \<le> dist q p"
    using Node.IH(2) Node.prems invar_r invar_set by auto

  have SORTED_L: "sorted_wrt_dist p ?nnsl"
    using sorted_nns Node.prems(2) by blast
  have SORTED_R: "sorted_wrt_dist p ?nnsr"
    using sorted_nns Node.prems(2) by blast

  have DISTINCT_L: "distinct ?nnsl"
    using Node.prems distinct_nns invar_set invar_l by fastforce
  have DISTINCT_R: "distinct ?nnsr"
    using Node.prems distinct_nns invar_set invar_r
    by (metis inf_bot_right inf_sup_absorb inf_sup_aci(3) sup.commute)

  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case A
    hence "\<forall>q \<in> set_kdt r. dist (last ?nnsl) p \<le> dist q p"
      using Node.prems(1,2) cutoff_r by (metis dist_commute)
    thus ?thesis
      using IHL A by auto
  next
    case B

    let ?nns = "nearest_nbors n ?nnsl p r"

    have "set ?nnsl \<subseteq> set_kdt l \<union> set ps" "set ps \<inter> set_kdt r = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsl \<inter> set_kdt r = {}"
      using Node.prems(1) by fastforce
    hence IHLR: "\<forall>q \<in> set_kdt r \<union> set ?nnsl - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(2)[OF _ SORTED_L _ DISTINCT_L Node.prems(5)] Node.prems(1) invar_r by blast

    have "\<forall>q \<in> set ps - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by auto

    have "\<forall>q \<in> set_kdt l - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt l - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt l - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by blast

    show ?thesis
      using B R L by auto
  next
    case C
    hence "\<forall>q \<in> set_kdt l. dist (last ?nnsr) p \<le> dist q p"
      using Node.prems(1,2) cutoff_l by (metis dist_commute less_imp_le)
    thus ?thesis
      using IHR C by auto
  next
    case D

    let ?nns = "nearest_nbors n ?nnsr p l"

    have "set ?nnsr \<subseteq> set_kdt r \<union> set ps" "set ps \<inter> set_kdt l = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsr \<inter> set_kdt l = {}"
      using Node.prems(1) by fastforce
    hence IHRL: "\<forall>q \<in> set_kdt l \<union> set ?nnsr - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(1)[OF _ SORTED_R _ DISTINCT_R Node.prems(5)] Node.prems(1) invar_l by blast

    have "\<forall>q \<in> set ps - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by auto

    have "\<forall>q \<in> set_kdt r - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt r - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt r - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by blast

    show ?thesis
      using D R L by auto
  qed
qed (auto simp: sorted_wrt_dist_nbors_diff upd_nbors_def)

subsection \<open>Nearest Neighbors Definition and Theorems\<close>

definition nearest_neighbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_neighbors n p kdt = nearest_nbors n [] p kdt"

theorem length_nearest_neighbors:
  "length (nearest_neighbors n p kdt) = min n (size_kdt kdt)"
  by (simp add: length_nns nearest_neighbors_def)

theorem sorted_wrt_dist_nearest_neighbors:
  "sorted_wrt_dist p (nearest_neighbors n p kdt)"
  using sorted_nns unfolding nearest_neighbors_def sorted_wrt_dist_def by force

theorem distinct_nearest_neighbors:
  assumes "invar kdt"
  shows "distinct (nearest_neighbors n p kdt)"
  using assms by (simp add: distinct_nns nearest_neighbors_def)

theorem dist_nearest_neighbors:
  assumes "invar kdt" "nns = nearest_neighbors n p kdt"
  shows "\<forall>q \<in> (set_kdt kdt - set nns). \<forall>r \<in> set nns. dist r p \<le> dist q p"
proof (cases "0 < n")
  case True
  have "\<forall>q \<in> set_kdt kdt - set nns. dist (last nns) p \<le> dist q p"
    using nearest_neighbors_def dist_nns[OF assms(1), of p "[]", OF _ _ _ True] assms(2)
    by (simp add: nearest_neighbors_def sorted_wrt_dist_def)
  hence "\<forall>q \<in> set_kdt kdt - set nns. \<forall>n \<in> set nns. dist n p \<le> dist q p"
    using assms(2) sorted_wrt_dist_nearest_neighbors[of p n kdt] sorted_wrt_dist_last[of p nns] by force
  thus ?thesis
    using nearest_neighbors_def by blast
next
  case False
  hence "length nns = 0"
    using assms(2) unfolding nearest_neighbors_def by (auto simp: length_nns)
  thus ?thesis
    by simp
qed

end


section \<open>Intervals are Borel measurable\<close>

theory Median
  imports "HOL-Probability.Hoeffding" "HOL-Library.Multiset"
begin

text \<open>This section contains a proof that intervals are Borel measurable, where an interval is
defined as a convex subset of linearly ordered space, more precisely, a set is an interval, if
for each triple of points $x < y < z$: If $x$ and $z$ are in the set so is $y$.
This includes ordinary intervals like @{term "{a..b}"}, @{term "{a<..<b}"} but also for example
@{term [show_types] "{(x::rat). x * x < 2}"} which cannot be expressed in the standard notation.

In the @{theory "HOL-Analysis.Borel_Space"} there are proofs for the measurability of each specific
type of interval, but those unfortunately do not help if we want to express the result about the
median bound for arbitrary types of intervals.\<close>

definition interval :: "('a :: linorder) set \<Rightarrow> bool" where
  "interval I = (\<forall>x y z. x \<in> I \<longrightarrow> z \<in> I \<longrightarrow> x \<le> y \<longrightarrow> y \<le> z \<longrightarrow> y \<in> I)"

definition up_ray :: "('a :: linorder) set \<Rightarrow> bool" where
  "up_ray I = (\<forall>x y. x \<in> I \<longrightarrow> x \<le> y \<longrightarrow> y \<in> I)"

lemma up_ray_borel:
  assumes "up_ray (I :: (('a :: linorder_topology) set))"
  shows "I \<in> borel"
proof (cases "closed I")
  case True
  then show ?thesis using borel_closed by blast
next
  case False
  hence b:"\<not> closed I" by blast

  have "open I"
  proof (rule Topological_Spaces.openI)
    fix x
    assume c:"x \<in> I"
    show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> I"
    proof (cases "\<exists>y. y < x \<and> y \<in> I")
      case True
      then obtain y where a:"y < x \<and> y \<in> I" by blast
      have "open {y<..}" by simp
      moreover have "x \<in> {y<..}" using a by simp
      moreover have "{y<..} \<subseteq> I"
        apply (rule subsetI)
        using a assms(1) apply (simp add: up_ray_def)
        by (metis less_le_not_le)
      ultimately show ?thesis by blast
    next
      case False
      hence "I \<subseteq> {x..}" using linorder_not_less by auto
      moreover have "{x..} \<subseteq> I"
        using c assms(1)  apply (simp add: up_ray_def)
        by blast
      ultimately have "I = {x..}"
        by (rule order_antisym)
      moreover have "closed {x..}" by simp
      ultimately have "False" using b by auto
      then show ?thesis by simp
    qed
  qed
  then show ?thesis by simp
qed

definition down_ray :: "('a :: linorder) set \<Rightarrow> bool" where
  "down_ray I = (\<forall>x y. y \<in> I \<longrightarrow> x \<le> y \<longrightarrow> x \<in> I)"

lemma down_ray_borel:
  assumes "down_ray (I :: (('a :: linorder_topology) set))"
  shows "I \<in> borel"
proof -
  have "up_ray (-I)" using assms
    by (simp add: up_ray_def down_ray_def, blast)
  hence "(-I) \<in> borel" using up_ray_borel by blast
  thus "I \<in> borel"
    by (metis borel_comp double_complement)
qed

text \<open>Main result of this section:\<close>

lemma interval_borel:
  assumes "interval (I :: (('a :: linorder_topology) set))"
  shows "I \<in> borel"
proof (cases "I = {}")
  case True
  then show ?thesis by simp
next
  case False
  then obtain x where a:"x \<in> I" by blast
  have "\<And>y z. y \<in> I \<union> {x..} \<Longrightarrow> y \<le> z \<Longrightarrow> z \<in> I \<union> {x..}"
    by (metis assms a interval_def  IntE UnE Un_Int_eq(1) Un_Int_eq(2) atLeast_iff nle_le order.trans)
  hence "up_ray (I \<union> {x..})"
    using up_ray_def by blast
  hence b:"I \<union> {x..} \<in> borel"
    using up_ray_borel by blast

  have "\<And>y z. y \<in> I \<union> {..x} \<Longrightarrow> z \<le> y \<Longrightarrow> z \<in> I \<union> {..x}"
    by (metis assms a interval_def UnE UnI1 UnI2 atMost_iff dual_order.trans linorder_le_cases)
  hence "down_ray (I \<union> {..x})"
    using down_ray_def by blast
  hence c:"I \<union> {..x} \<in> borel"
    using down_ray_borel by blast

  have "I = (I \<union> {x..}) \<inter> (I \<union> {..x})"
    using a by fastforce

  then show ?thesis using b c
    by (metis sets.Int)
qed

section \<open>Order statistics are Borel measurable\<close>

text \<open>This section contains a proof that order statistics of Borel measurable random variables are
themselves Borel measurable.

The proof relies on the existence of branch-free comparison-sort algorithms. Given a sequence length
these algorithms perform compare-swap operations on predefined pairs of positions. In particular the
result of a comparison does not affect future operations. An example for a branch-free comparison
sort algorithm is shell-sort and also bubble-sort without the early exit.

The advantage of using such a comparison-sort algorithm is that it can be lifted to work on random
variables, where the result of a comparison-swap operation on two random variables @{term"X"} and
@{term"Y"} can be represented as the expressions @{term "\<lambda>\<omega>. min (X \<omega>) (Y \<omega>)"} and
@{term "\<lambda>\<omega>. max (X \<omega>) (Y \<omega>)"}.

Because taking the point-wise minimum (resp. maximum) of two random variables is still
Borel measurable, and because the entire sorting operation can be represented using such
compare-swap operations, we can show that all order statistics are Borel measuable.\<close>

fun sort_primitive where
  "sort_primitive i j f k = (if k = i then min (f i) (f j) else (if k = j then max (f i) (f j) else f k))"

fun sort_map where
  "sort_map f n = fold id [sort_primitive j i. i <- [0..<n], j <- [0..<i]] f"

lemma sort_map_ind:
  "sort_map f (Suc n) = fold id [sort_primitive j n. j <- [0..<n]] (sort_map f n)"
  by simp

lemma sort_map_strict_mono:
  fixes f :: "nat \<Rightarrow> 'b :: linorder"
  shows "j < n \<Longrightarrow> i < j \<Longrightarrow> sort_map f n i \<le> sort_map f n j"
proof (induction n arbitrary: i j)
  case 0
  then show ?case by simp
next
  case (Suc n)
  define g where "g = (\<lambda>k. fold id [sort_primitive j n. j <- [0..<k]] (sort_map f n))"
  define k where "k = n"
  have a:"(\<forall>i j. j < n \<longrightarrow> i < j \<longrightarrow> g k i \<le> g k j) \<and> (\<forall>l. l < k \<longrightarrow> g k l \<le> g k n)"
  proof (induction k)
    case 0
    then show ?case using Suc by (simp add:g_def del:sort_map.simps)
  next
    case (Suc k)
    have "g (Suc k) = sort_primitive k n (g k)"
      by (simp add:g_def)
    then show ?case using Suc
      apply (cases "g k k \<le> g k n")
       apply (simp add:min_def max_def)
       using less_antisym apply blast
      apply (cases "g k n \<le> g k k")
       apply (simp add:min_def max_def)
       apply (metis less_antisym max.coboundedI2 max.orderE)
      by simp
  qed

  hence "\<And>i j. j < Suc n \<Longrightarrow> i < j \<Longrightarrow> g n i \<le> g n j"
    apply (simp add:k_def) using less_antisym by blast
  moreover have "sort_map f (Suc n) = g n"
    by (simp add:sort_map_ind g_def del:sort_map.simps)
  ultimately show ?case
    apply (simp del:sort_map.simps)
    using Suc by blast
qed

lemma sort_map_mono:
  fixes f :: "nat \<Rightarrow> 'b :: linorder"
  shows "j < n \<Longrightarrow> i \<le> j \<Longrightarrow> sort_map f n i \<le> sort_map f n j"
  by (metis sort_map_strict_mono eq_iff le_imp_less_or_eq)

lemma sort_map_perm:
  fixes f :: "nat \<Rightarrow> 'b :: linorder"
  shows "image_mset (sort_map f n) (mset [0..<n]) = image_mset f (mset [0..<n])"
proof -
  define is_swap where "is_swap = (\<lambda>(ts :: ((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b)). \<exists>i < n. \<exists>j < n. ts = sort_primitive i j)"
  define t :: "((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b) list"
    where "t = [sort_primitive j i. i <- [0..<n], j <- [0..<i]]"

  have a: "\<And>x f. is_swap x \<Longrightarrow> image_mset (x f) (mset_set {0..<n}) = image_mset f (mset_set {0..<n})"
  proof -
    fix x
    fix f :: "nat \<Rightarrow> 'b :: linorder"
    assume "is_swap x"
    then obtain i j where x_def: "x = sort_primitive i j" and i_bound: "i < n" and j_bound:"j < n"
      using is_swap_def by blast
    define inv where "inv = mset_set {k. k < n \<and> k \<noteq> i \<and> k \<noteq> j}"
    have b:"{0..<n} = {k. k < n \<and> k \<noteq> i \<and> k \<noteq> j} \<union> {i,j}"
      apply (rule order_antisym, rule subsetI, simp, blast, rule subsetI, simp)
      using i_bound j_bound by meson
    have c:"\<And>k. k \<in># inv \<Longrightarrow> (x f) k = f k"
      by (simp add:x_def inv_def)
    have "image_mset (x f) inv = image_mset f inv"
      apply (rule multiset_eqI)
      using c multiset.map_cong0 by force
    moreover have "image_mset (x f) (mset_set {i,j}) = image_mset f (mset_set {i,j})"
      apply (cases "i = j")
      by (simp add:x_def max_def min_def)+
    moreover have "mset_set {0..<n} = inv + mset_set {i,j}"
      by (simp only:inv_def b, rule mset_set_Union, simp, simp, simp)
    ultimately show "image_mset (x f) (mset_set {0..<n}) = image_mset f (mset_set {0..<n})"
      by simp
  qed

  have "(\<forall>x \<in> set t. is_swap x) \<Longrightarrow> image_mset (fold id t f) (mset [0..<n]) = image_mset f (mset [0..<n])"
    by (induction t arbitrary:f, simp, simp add:a)
  moreover have "\<And>x. x \<in> set t \<Longrightarrow> is_swap x"
    apply (simp add:t_def is_swap_def)
    by (meson atLeastLessThan_iff imageE less_imp_le less_le_trans)
  ultimately have "image_mset (fold id t f) (mset [0..<n]) = image_mset f (mset [0..<n])" by blast
  then show ?thesis by (simp add:t_def)
qed

lemma list_eq_iff:
  assumes "mset xs = mset ys"
  assumes "sorted xs"
  assumes "sorted ys"
  shows "xs = ys"
  using assms properties_for_sort by blast

lemma sort_map_eq_sort:
  fixes f :: "nat \<Rightarrow> ('b :: linorder)"
  shows "map (sort_map f n) [0..<n] = sort (map f [0..<n])" (is "?A = ?B")
proof -
  have "mset ?A = mset ?B"
    using sort_map_perm[where f="f" and n="n"]
    by (simp del:sort_map.simps)
  moreover have "sorted ?B"
    by simp
  moreover have "sorted ?A"
    apply (subst sorted_wrt_iff_nth_less)
    apply (simp del:sort_map.simps)
    by (metis sort_map_mono nat_less_le)
  ultimately show "?A = ?B"
    using list_eq_iff by blast
qed

lemma order_statistics_measurable_aux:
  fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
  assumes "n \<ge> 1"
  assumes "j < n"
  assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
  shows "(\<lambda>x. (sort_map (\<lambda>i. X i x) n) j) \<in> measurable M borel"
proof -
  have n_ge_0:"n > 0" using assms by simp
  define is_swap where "is_swap = (\<lambda>(ts :: ((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b)). \<exists>i < n. \<exists>j < n. ts = sort_primitive i j)"
  define t :: "((nat \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b) list"
    where "t = [sort_primitive j i. i <- [0..<n], j <- [0..<i]]"

  define meas_ptw :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
    where "meas_ptw = (\<lambda>f. (\<forall>k. k < n \<longrightarrow> f k \<in> borel_measurable M))"

  have ind_step:
    "\<And>x (g :: nat \<Rightarrow> 'a \<Rightarrow> 'b). meas_ptw g \<Longrightarrow> is_swap x \<Longrightarrow> meas_ptw (\<lambda>k \<omega>. x (\<lambda>i. g i \<omega>) k)"
  proof -
    fix x g
    assume "meas_ptw g"
    hence a:"\<And>k. k < n \<Longrightarrow> g k \<in> borel_measurable M" by (simp add:meas_ptw_def)
    assume "is_swap x"
    then obtain i j where x_def:"x=sort_primitive i j" and i_le:"i < n" and j_le:"j < n"
      by (simp add:is_swap_def, blast)
    have "\<And>k. k < n \<Longrightarrow> (\<lambda>\<omega>. x (\<lambda>i. g i \<omega>) k) \<in> borel_measurable M"
    proof -
      fix k
      assume "k < n"
      thus " (\<lambda>\<omega>. x (\<lambda>i. g i \<omega>) k) \<in> borel_measurable M"
        apply (simp add:x_def)
        apply (cases "k = i", simp)
        using a i_le j_le borel_measurable_min apply blast
        apply (cases "k = j", simp)
        using a i_le j_le borel_measurable_max apply blast
        using a by simp
    qed
    thus "meas_ptw (\<lambda>k \<omega>. x (\<lambda>i. g i \<omega>) k)"
      by (simp add:meas_ptw_def)
  qed

  have "(\<forall>x \<in> set t. is_swap x) \<Longrightarrow> meas_ptw (\<lambda> k \<omega>. (fold id t (\<lambda>k. X k \<omega>)) k)"
  proof (induction t rule:rev_induct)
    case Nil
    then show ?case using assms by (simp add:meas_ptw_def)
  next
    case (snoc x xs)
    have a:"meas_ptw (\<lambda>k \<omega>. fold (\<lambda>a. a) xs (\<lambda>k. X k \<omega>) k)" using snoc by simp
    have b:"is_swap x" using snoc by simp
    show ?case using ind_step[OF a b] by simp
  qed
  moreover have "\<And>x. x \<in> set t \<Longrightarrow> is_swap x"
    apply (simp add:t_def is_swap_def)
    by (meson atLeastLessThan_iff imageE less_imp_le less_le_trans)
  ultimately show ?thesis using assms
    by (simp add:t_def[symmetric] meas_ptw_def)
qed

text \<open>Main results of this section:\<close>

lemma order_statistics_measurable:
  fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
  assumes "n \<ge> 1"
  assumes "j < n"
  assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
  shows "(\<lambda>x. (sort (map (\<lambda>i. X i x) [0..<n])) ! j) \<in> measurable M borel"
  apply (subst sort_map_eq_sort[symmetric])
  using assms by (simp add:order_statistics_measurable_aux del:sort_map.simps)

definition median where
  "median n f =  sort (map f [0..<n]) ! (n div 2)"

lemma median_measurable:
  fixes X :: "nat \<Rightarrow> 'a \<Rightarrow> ('b :: {linorder_topology, second_countable_topology})"
  assumes "n \<ge> 1"
  assumes "\<And>i. i < n \<Longrightarrow> X i \<in> measurable M borel"
  shows "(\<lambda>x. median n (\<lambda>i. X i x)) \<in> measurable M borel"
  apply (simp add:median_def)
  apply (rule order_statistics_measurable[OF assms(1) _ assms(2)])
  using assms(1) by force+

section \<open>The Median Method\<close>

text \<open>This section contains the proof for the probability that the median of independent random
variables will be in an interval with high probability if the individual variables are in the
same interval with probability larger than $\frac{1}{2}$.

The proof starts with the elementary observation that the median of a seqeuence with $n$ elements
is in an interval $I$ if at least half of them are in $I$. This works because after sorting the
sequence the elements that will be in the interval must necessarily form a consecutive subsequence,
if its length is larger than $\frac{n}{2}$ the median must be in it.

The remainder follows the proof in \<^cite>\<open>\<open>\textsection 2.1\<close> in "alon1999"\<close> using the Hoeffding inequality
to estimate the probability that at least half of the sequence elements will be in the interval $I$.\<close>

lemma interval_rule:
  assumes "interval I"
  assumes "a \<le> x" "x \<le> b"
  assumes "a \<in> I"
  assumes "b \<in> I"
  shows "x \<in> I"
  using assms(1) apply (simp add:interval_def)
  using assms by blast

lemma sorted_int:
  assumes "interval I"
  assumes "sorted xs"
  assumes "k < length xs" "i \<le> j" "j \<le> k "
  assumes "xs ! i \<in> I" "xs ! k \<in> I"
  shows "xs ! j \<in> I"
  apply (rule interval_rule[where a="xs ! i" and b="xs ! k"])
  using assms by (simp add: sorted_nth_mono)+

lemma mid_in_interval:
  assumes "2*length (filter (\<lambda>x. x \<in> I) xs) > length xs"
  assumes "interval I"
  assumes "sorted xs"
  shows "xs ! (length xs div 2) \<in> I"
proof -
  have "length (filter (\<lambda>x. x \<in> I) xs) > 0"  using assms(1) by linarith
  then obtain v where v_1: "v < length xs" and v_2: "xs ! v \<in> I"
    by (metis filter_False in_set_conv_nth length_greater_0_conv)

  define J where "J = {k. k < length xs \<and> xs ! k \<in> I}"

  have card_J_min: "2*card J > length xs"
    using assms(1) by (simp add:J_def length_filter_conv_card)

  consider
    (a) "xs ! (length xs div 2) \<in> I" |
    (b) "xs ! (length xs div 2) \<notin> I \<and> v > (length xs div 2)" |
    (c) "xs ! (length xs div 2) \<notin> I \<and> v < (length xs div 2)"
    by (metis linorder_cases v_2)
  thus ?thesis
  proof (cases)
    case a
    then show ?thesis by simp
  next
    case b
    have p:"\<And>k. k \<le> length xs div 2 \<Longrightarrow> xs ! k \<notin> I"
      using b v_2 sorted_int[OF assms(2) assms(3) v_1, where j="length xs div 2"] apply simp by blast
    have "card J \<le> card {Suc (length xs div 2)..<length xs}"
      apply (rule card_mono, simp)
      apply (rule subsetI, simp add:J_def not_less_eq_eq[symmetric])
      using p by metis
    hence "card J \<le> length xs - (Suc (length xs div 2))"
      using card_atLeastLessThan by metis
    hence "length xs \<le> 2*( length xs - (Suc (length xs div 2)))"
      using card_J_min by linarith
    hence "False"
      apply (simp add:nat_distrib)
      apply (subst (asm) le_diff_conv2) using b v_1 apply linarith
      by simp
    then show ?thesis by simp
  next
    case c
    have p:"\<And>k. k \<ge> length xs div 2 \<Longrightarrow> k < length xs \<Longrightarrow> xs ! k \<notin> I"
      using c v_1 v_2 sorted_int[OF assms(2) assms(3), where i ="v" and j="length xs div 2"] apply simp by blast
    have "card J \<le> card {0..<(length xs div 2)}"
      apply (rule card_mono, simp)
      apply (rule subsetI, simp add:J_def not_less_eq_eq[symmetric])
      using p linorder_le_less_linear by blast
    hence "card J \<le> (length xs div 2)"
      using card_atLeastLessThan by simp
    then show ?thesis using card_J_min by linarith
  qed
qed

lemma median_est:
  assumes "interval I"
  assumes "2*card {k. k < n \<and> f k \<in> I} > n"
  shows "median n f \<in> I"
proof -
  have a:"{k. k < n \<and> f k \<in> I} = {i. i < n \<and> map f [0..<n] ! i \<in> I}"
    apply (rule order_antisym, rule subsetI, simp)
    by (rule subsetI, simp, metis add_0 diff_zero nth_map_upt)

  show ?thesis
    apply (simp add:median_def)
    apply (rule mid_in_interval[where I="I" and xs="sort (map f [0..<n])", simplified])
     using assms a apply (simp add:filter_sort comp_def length_filter_conv_card)
    by (simp add:assms)
qed

text \<open>Main results of this section:\<close>

theorem (in prob_space) median_bound:
  fixes n :: nat
  fixes I :: "('b :: {linorder_topology, second_countable_topology}) set"
  assumes "interval I"
  assumes "\<alpha> > 0"
  assumes "\<epsilon> \<in> {0<..<1}"
  assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
  assumes "n \<ge> - ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
  assumes "\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. X i \<omega> \<in> I) \<ge> 1/2+\<alpha>"
  shows "\<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> I) \<ge> 1-\<epsilon>"
proof -
  define Y :: "nat \<Rightarrow> 'a \<Rightarrow> real" where "Y = (\<lambda>i. indicator I \<circ> (X i))"

  define t where "t = (\<Sum>i = 0..<n. expectation (Y i)) - n/2"
  have "0 < -ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
    apply (rule divide_pos_pos)
     apply (simp, subst ln_less_zero_iff)
    using assms by auto
  also have "... \<le> real n" using assms by simp
  finally have "real n > 0" by simp
  hence n_ge_1:"n \<ge> 1" by linarith
  hence n_ge_0:"n > 0" by simp

  have ind_comp: "\<And>i. indicator I \<circ> (X i) = indicator {\<omega>. X i \<omega> \<in> I}"
    by (rule ext, simp add:indicator_def comp_def)

  have "\<alpha> * n \<le> (\<Sum> i =0..<n. 1/2 + \<alpha>) - n/2"
    by (simp add:algebra_simps)
  also have "... \<le> (\<Sum> i = 0..<n. expectation (Y i)) - n/2"
    apply (rule diff_right_mono, rule sum_mono)
    using assms(6) by (simp add:Y_def ind_comp Collect_conj_eq inf_commute)
  also have "... = t" by (simp add:t_def)
  finally have t_ge_a: "t \<ge> \<alpha> * n" by simp

  have d: "0 \<le> \<alpha> * n"
    apply (rule mult_nonneg_nonneg)
    using assms(2) n_ge_0 by simp+
  also have "... \<le> t" using t_ge_a by simp
  finally have t_ge_0: "t \<ge> 0" by simp

  have  "(\<alpha> * n)\<^sup>2 \<le> t\<^sup>2" using t_ge_a d power_mono by blast
  hence t_ge_a_sq: "\<alpha>\<^sup>2 * real n * real n \<le> t\<^sup>2"
    by (simp add:algebra_simps power2_eq_square)

  have Y_indep: "indep_vars (\<lambda>_. borel) Y {0..<n}"
    apply (subst Y_def)
    apply (rule indep_vars_compose[where M'="(\<lambda>_. borel)", OF assms(4)])
    using interval_borel[OF assms(1)] by simp

  hence b:"Hoeffding_ineq M {0..<n} Y (\<lambda>i. 0) (\<lambda>i. 1)"
    apply (simp add:Hoeffding_ineq_def indep_interval_bounded_random_variables_def)
    by (simp add:prob_space_axioms indep_interval_bounded_random_variables_axioms_def Y_def Y_indep)

  have c: "\<And>\<omega>. (\<Sum>i = 0..<n. Y i \<omega>) > n/2 \<Longrightarrow> median n (\<lambda>i. X i \<omega>) \<in> I"
  proof -
    fix \<omega>
    assume "(\<Sum>i = 0..<n. Y i \<omega>) > n/2"
    hence "n < 2 * card ({0..<n} \<inter> {i. X i \<omega> \<in> I})"
      by (simp add:Y_def indicator_def)
    also have "... = 2 * card {i. i < n \<and> X i \<omega> \<in> I}"
      apply (simp, rule arg_cong[where f="card"])
      by (rule order_antisym, rule subsetI, simp, rule subsetI, simp)
    finally have "2 * card {i. i < n \<and> X i \<omega> \<in> I} > n" by simp
    thus "median n (\<lambda>i. X i \<omega>) \<in> I"
      using median_est[OF assms(1)] by simp
  qed

  have "1 - \<epsilon> \<le> 1- exp (- (2 * \<alpha>\<^sup>2 * real n))"
    apply (simp, subst ln_ge_iff[symmetric])
    using assms(3) apply simp
    using assms(5) apply (subst (asm) pos_divide_le_eq)
     apply (simp add: assms(2) power2_eq_square)
    by (simp add: mult_of_nat_commute)
  also have "... \<le> 1- exp (- (2 * t\<^sup>2 / real n))"
    apply simp
    apply (subst pos_le_divide_eq) using n_ge_0 apply simp
    using t_ge_a_sq by linarith
  also have "... \<le> 1 - \<P>(\<omega> in M. (\<Sum>i = 0..<n. Y i \<omega>) \<le> n/2)"
    using Hoeffding_ineq.Hoeffding_ineq_le[OF b, where \<epsilon>="t", simplified] n_ge_0 t_ge_0
    by (simp add:t_def)
  also have "... = \<P>(\<omega> in M. (\<Sum>i = 0..<n. Y i \<omega>) > n/2)"
    apply (subst prob_compl[symmetric])
     apply measurable
     using Y_indep apply (simp add:indep_vars_def)
    apply (rule arg_cong2[where f="measure"], simp)
    by (rule order_antisym, rule subsetI, simp add:not_le, rule subsetI, simp add:not_le)
  also have "... \<le> \<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> I)"
    apply (rule finite_measure_mono)
     apply (rule subsetI) using c apply simp
    using interval_borel[OF assms(1)] apply measurable
    apply (rule median_measurable[OF n_ge_1])
    using assms(4) by (simp add:indep_vars_def)
  finally show ?thesis by simp
qed

text \<open>This is a specialization of the above to closed real intervals.\<close>

corollary (in prob_space) median_bound_1:
  assumes "\<alpha> > 0"
  assumes "\<epsilon> \<in> {0<..<1}"
  assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
  assumes "n \<ge> - ln \<epsilon> / (2 * \<alpha>\<^sup>2)"
  assumes "\<forall>i \<in> {0..<n}. \<P>(\<omega> in M. X i \<omega> \<in> ({a..b} :: real set)) \<ge> 1/2+\<alpha>"
  shows "\<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> {a..b}) \<ge> 1-\<epsilon>"
  apply (rule median_bound[OF _ assms(1) assms(2) assms(3) assms(4)])
   apply (simp add:interval_def)
  using assms(5) by auto

text \<open>This is a specialization of the above, where $\alpha = \frac{1}{6}$ and the interval is described
using a mid point @{term "\<mu>"} and radius @{term "\<delta>"}. The choice of $\alpha = \frac{1}{6}$ implies
a success probability per random variable of $\frac{2}{3}$. It is a commonly chosen success
probability for Monte-Carlo algorithms (cf. \<^cite>\<open>\<open>\textsection 4\<close> in "baryossef2002"\<close> or
\<^cite>\<open>\<open>\textsection 1\<close> in "kane2010"\<close>).\<close>

corollary (in prob_space) median_bound_2:
  fixes \<mu> \<delta> :: real
  assumes "\<epsilon> \<in> {0<..<1}"
  assumes "indep_vars (\<lambda>_. borel) X {0..<n}"
  assumes "n \<ge> -18 * ln \<epsilon>"
  assumes "\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. abs (X i \<omega> - \<mu>) > \<delta>) \<le> 1/3"
  shows "\<P>(\<omega> in M. abs (median n (\<lambda>i. X i \<omega>) - \<mu>) \<le> \<delta>) \<ge> 1-\<epsilon>"
proof -
  have b:"\<And>i. i < n \<Longrightarrow> space M - {\<omega> \<in> space M. X i \<omega> \<in> {\<mu> - \<delta>..\<mu> + \<delta>}} =  {\<omega> \<in> space M. abs (X i \<omega> - \<mu>) > \<delta>}"
    apply (rule order_antisym, rule subsetI, simp, linarith)
    by (rule subsetI, simp, linarith)

  have "\<And>i. i < n \<Longrightarrow> 1 - \<P>(\<omega> in M. X i \<omega> \<in> {\<mu>- \<delta>..\<mu>+\<delta>}) \<le> 1/3"
    apply (subst prob_compl[symmetric])
     apply (measurable)
     using assms(2) apply (simp add:indep_vars_def)
    apply (subst b, simp)
    using assms(4) by simp

  hence a:"\<And>i. i < n \<Longrightarrow> \<P>(\<omega> in M. X i \<omega> \<in> {\<mu>- \<delta>..\<mu>+\<delta>}) \<ge> 2/3" by simp

  have "1-\<epsilon> \<le> \<P>(\<omega> in M. median n (\<lambda>i. X i \<omega>) \<in> {\<mu>-\<delta>..\<mu>+\<delta>})"
    apply (rule median_bound_1[OF _ assms(1) assms(2), where \<alpha>="1/6"], simp)
     using assms(3) apply (simp add:power2_eq_square)
    using a by simp
  also have "... = \<P>(\<omega> in M. abs (median n (\<lambda>i. X i \<omega>) - \<mu>) \<le> \<delta>)"
    apply (rule arg_cong2[where f="measure"], simp)
    apply (rule order_antisym, rule subsetI, simp, linarith)
    by (rule subsetI, simp, linarith)
  finally show ?thesis by simp
qed

section \<open>Some additional results about the median\<close>

lemma sorted_mono_map:
  assumes "sorted xs"
  assumes "mono f"
  shows "sorted (map f xs)"
  using assms apply (simp add:sorted_wrt_map)
  apply (rule sorted_wrt_mono_rel[where P="(\<le>)"])
  by (simp add:mono_def, simp)

text \<open>This could be added to @{theory "HOL.List"}:\<close>
lemma map_sort:
  assumes "mono f"
  shows "sort (map f xs) = map f (sort xs)"
  apply (rule properties_for_sort)
   apply simp
  by (rule sorted_mono_map, simp, simp add:assms)

lemma median_cong:
  assumes "\<And>i. i < n \<Longrightarrow> f i = g i"
  shows "median n f = median n g"
  apply (cases "n = 0", simp add:median_def)
  apply (simp add:median_def)
  apply (rule arg_cong2[where f="(!)"])
   apply (rule arg_cong[where f="sort"], rule map_cong, simp, simp add:assms)
  by simp

lemma median_restrict:
  "median n (\<lambda>i \<in> {0..<n}.f i) = median n f"
  by (rule median_cong, simp)

lemma median_commute_mono:
  assumes "n > 0"
  assumes "mono g"
  shows "g (median n f) = median n (g \<circ> f)"
  apply (simp add: median_def del:map_map)
  apply (subst map_map[symmetric])
  apply (subst map_sort[OF assms(2)])
  apply (subst nth_map, simp) using assms apply fastforce
  by simp

lemma median_rat:
  assumes "n > 0"
  shows "real_of_rat (median n f) = median n (\<lambda>i. real_of_rat (f i))"
  apply (subst (2) comp_def[where g="f", symmetric])
  apply (rule median_commute_mono[OF assms(1)])
  by (simp add: mono_def of_rat_less_eq)

lemma median_const:
  assumes "k > 0"
  shows "median k (\<lambda>i \<in> {0..<k}. a) = a"
proof -
  have b: "sorted (map (\<lambda>_. a) [0..<k])"
    by (subst sorted_wrt_map, simp)
  have a: "sort (map (\<lambda>_. a) [0..<k]) = map (\<lambda>_. a) [0..<k]"
    by (subst sorted_sort_id[OF b], simp)
  have "median k (\<lambda>i \<in> {0..<k}. a) = median k (\<lambda>_. a)"
    by (subst median_restrict, simp)
  also have "... = a"
    apply (simp add:median_def a)
    apply (subst nth_map)
    using assms by simp+
  finally show ?thesis by simp
qed

end


(*  Title:      ZF/Constructible/Normal.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Closed Unbounded Classes and Normal Functions\<close>

theory Normal imports Main begin

text\<open>
One source is the book

Frank R. Drake.
\emph{Set Theory: An Introduction to Large Cardinals}.
North-Holland, 1974.
\<close>

subsection \<open>Closed and Unbounded (c.u.) Classes of Ordinals\<close>

definition
  Closed :: "(i=>o) => o" where
    "Closed(P) == \<forall>I. I \<noteq> 0 \<longrightarrow> (\<forall>i\<in>I. Ord(i) \<and> P(i)) \<longrightarrow> P(\<Union>(I))"

definition
  Unbounded :: "(i=>o) => o" where
    "Unbounded(P) == \<forall>i. Ord(i) \<longrightarrow> (\<exists>j. i<j \<and> P(j))"

definition
  Closed_Unbounded :: "(i=>o) => o" where
    "Closed_Unbounded(P) == Closed(P) \<and> Unbounded(P)"

subsubsection\<open>Simple facts about c.u. classes\<close>

lemma ClosedI:
     "[| !!I. [| I \<noteq> 0; \<forall>i\<in>I. Ord(i) \<and> P(i) |] ==> P(\<Union>(I)) |]
      ==> Closed(P)"
by (simp add: Closed_def)

lemma ClosedD:
     "[| Closed(P); I \<noteq> 0; !!i. i\<in>I ==> Ord(i); !!i. i\<in>I ==> P(i) |]
      ==> P(\<Union>(I))"
by (simp add: Closed_def)

lemma UnboundedD:
     "[| Unbounded(P);  Ord(i) |] ==> \<exists>j. i<j \<and> P(j)"
by (simp add: Unbounded_def)

lemma Closed_Unbounded_imp_Unbounded: "Closed_Unbounded(C) ==> Unbounded(C)"
by (simp add: Closed_Unbounded_def)

text\<open>The universal class, V, is closed and unbounded.
      A bit odd, since C. U. concerns only ordinals, but it's used below!\<close>
theorem Closed_Unbounded_V [simp]: "Closed_Unbounded(\<lambda>x. True)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of ordinals, @{term Ord}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Ord   [simp]: "Closed_Unbounded(Ord)"
by (unfold Closed_Unbounded_def Closed_def Unbounded_def, blast)

text\<open>The class of limit ordinals, @{term Limit}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Limit [simp]: "Closed_Unbounded(Limit)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def Limit_Union,
       clarify)
apply (rule_tac x="i++nat" in exI)
apply (blast intro: oadd_lt_self oadd_LimitI Limit_nat Limit_has_0)
done

text\<open>The class of cardinals, @{term Card}, is closed and unbounded.\<close>
theorem Closed_Unbounded_Card  [simp]: "Closed_Unbounded(Card)"
apply (simp add: Closed_Unbounded_def Closed_def Unbounded_def Card_Union)
apply (blast intro: lt_csucc Card_csucc)
done

subsubsection\<open>The intersection of any set-indexed family of c.u. classes is
      c.u.\<close>

text\<open>The constructions below come from Kunen, \emph{Set Theory}, page 78.\<close>
locale cub_family =
  fixes P and A
  fixes next_greater \<comment> "the next ordinal satisfying class @{term A}"
  fixes sup_greater  \<comment> "sup of those ordinals over all @{term A}"
  assumes closed:    "a\<in>A ==> Closed(P(a))"
      and unbounded: "a\<in>A ==> Unbounded(P(a))"
      and A_non0: "A\<noteq>0"
  defines "next_greater(a,x) == \<mu> y. x<y \<and> P(a,y)"
      and "sup_greater(x) == \<Union>a\<in>A. next_greater(a,x)"

text\<open>Trivial that the intersection is closed.\<close>
lemma (in cub_family) Closed_INT: "Closed(\<lambda>x. \<forall>i\<in>A. P(i,x))"
by (blast intro: ClosedI ClosedD [OF closed])

text\<open>All remaining effort goes to show that the intersection is unbounded.\<close>

lemma (in cub_family) Ord_sup_greater:
     "Ord(sup_greater(x))"
by (simp add: sup_greater_def next_greater_def)

lemma (in cub_family) Ord_next_greater:
     "Ord(next_greater(a,x))"
by (simp add: next_greater_def Ord_Least)

text\<open>@{term next_greater} works as expected: it returns a larger value
and one that belongs to class @{term "P(a)"}.\<close>
lemma (in cub_family) next_greater_lemma:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x)) \<and> x < next_greater(a,x)"
apply (simp add: next_greater_def)
apply (rule exE [OF UnboundedD [OF unbounded]])
  apply assumption+
apply (blast intro: LeastI2 lt_Ord2)
done

lemma (in cub_family) next_greater_in_P:
     "[| Ord(x); a\<in>A |] ==> P(a, next_greater(a,x))"
by (blast dest: next_greater_lemma)

lemma (in cub_family) next_greater_gt:
     "[| Ord(x); a\<in>A |] ==> x < next_greater(a,x)"
by (blast dest: next_greater_lemma)

lemma (in cub_family) sup_greater_gt:
     "Ord(x) ==> x < sup_greater(x)"
apply (simp add: sup_greater_def)
apply (insert A_non0)
apply (blast intro: UN_upper_lt next_greater_gt Ord_next_greater)
done

lemma (in cub_family) next_greater_le_sup_greater:
     "a\<in>A ==> next_greater(a,x) \<le> sup_greater(x)"
apply (simp add: sup_greater_def)
apply (blast intro: UN_upper_le Ord_next_greater)
done

lemma (in cub_family) omega_sup_greater_eq_UN:
     "[| Ord(x); a\<in>A |]
      ==> sup_greater^\<omega> (x) =
          (\<Union>n\<in>nat. next_greater(a, sup_greater^n (x)))"
apply (simp add: iterates_omega_def)
apply (rule le_anti_sym)
apply (rule le_implies_UN_le_UN)
apply (blast intro: leI next_greater_gt Ord_iterates Ord_sup_greater)
txt\<open>Opposite bound:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (rule UN_least_le)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
apply (rule_tac a="succ(n)" in UN_upper_le)
apply (simp_all add: next_greater_le_sup_greater)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) P_omega_sup_greater:
     "[| Ord(x); a\<in>A |] ==> P(a, sup_greater^\<omega> (x))"
apply (simp add: omega_sup_greater_eq_UN)
apply (rule ClosedD [OF closed])
apply (blast intro: ltD, auto)
apply (blast intro: Ord_iterates Ord_next_greater Ord_sup_greater)
apply (blast intro: next_greater_in_P Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) omega_sup_greater_gt:
     "Ord(x) ==> x < sup_greater^\<omega> (x)"
apply (simp add: iterates_omega_def)
apply (rule UN_upper_lt [of 1], simp_all)
 apply (blast intro: sup_greater_gt)
apply (blast intro: Ord_UN Ord_iterates Ord_sup_greater)
done

lemma (in cub_family) Unbounded_INT: "Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
apply (unfold Unbounded_def)
apply (blast intro!: omega_sup_greater_gt P_omega_sup_greater)
done

lemma (in cub_family) Closed_Unbounded_INT:
     "Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a,x))"
by (simp add: Closed_Unbounded_def Closed_INT Unbounded_INT)

theorem Closed_Unbounded_INT:
    "(!!a. a\<in>A ==> Closed_Unbounded(P(a)))
     ==> Closed_Unbounded(\<lambda>x. \<forall>a\<in>A. P(a, x))"
apply (case_tac "A=0", simp)
apply (rule cub_family.Closed_Unbounded_INT [OF cub_family.intro])
apply (simp_all add: Closed_Unbounded_def)
done

lemma Int_iff_INT2:
     "P(x) \<and> Q(x)  \<longleftrightarrow>  (\<forall>i\<in>2. (i=0 \<longrightarrow> P(x)) \<and> (i=1 \<longrightarrow> Q(x)))"
by auto

theorem Closed_Unbounded_Int:
     "[| Closed_Unbounded(P); Closed_Unbounded(Q) |]
      ==> Closed_Unbounded(\<lambda>x. P(x) \<and> Q(x))"
apply (simp only: Int_iff_INT2)
apply (rule Closed_Unbounded_INT, auto)
done

subsection \<open>Normal Functions\<close>

definition
  mono_le_subset :: "(i=>i) => o" where
    "mono_le_subset(M) == \<forall>i j. i\<le>j \<longrightarrow> M(i) \<subseteq> M(j)"

definition
  mono_Ord :: "(i=>i) => o" where
    "mono_Ord(F) == \<forall>i j. i<j \<longrightarrow> F(i) < F(j)"

definition
  cont_Ord :: "(i=>i) => o" where
    "cont_Ord(F) == \<forall>l. Limit(l) \<longrightarrow> F(l) = (\<Union>i<l. F(i))"

definition
  Normal :: "(i=>i) => o" where
    "Normal(F) == mono_Ord(F) \<and> cont_Ord(F)"

subsubsection\<open>Immediate properties of the definitions\<close>

lemma NormalI:
     "[|!!i j. i<j ==> F(i) < F(j);  !!l. Limit(l) ==> F(l) = (\<Union>i<l. F(i))|]
      ==> Normal(F)"
by (simp add: Normal_def mono_Ord_def cont_Ord_def)

lemma mono_Ord_imp_Ord: "[| Ord(i); mono_Ord(F) |] ==> Ord(F(i))"
apply (auto simp add: mono_Ord_def)
apply (blast intro: lt_Ord)
done

lemma mono_Ord_imp_mono: "[| i<j; mono_Ord(F) |] ==> F(i) < F(j)"
by (simp add: mono_Ord_def)

lemma Normal_imp_Ord [simp]: "[| Normal(F); Ord(i) |] ==> Ord(F(i))"
by (simp add: Normal_def mono_Ord_imp_Ord)

lemma Normal_imp_cont: "[| Normal(F); Limit(l) |] ==> F(l) = (\<Union>i<l. F(i))"
by (simp add: Normal_def cont_Ord_def)

lemma Normal_imp_mono: "[| i<j; Normal(F) |] ==> F(i) < F(j)"
by (simp add: Normal_def mono_Ord_def)

lemma Normal_increasing:
  assumes i: "Ord(i)" and F: "Normal(F)" shows"i \<le> F(i)"
using i
proof (induct i rule: trans_induct3)
  case 0 thus ?case by (simp add: subset_imp_le F)
next
  case (succ i)
  hence "F(i) < F(succ(i))" using F
    by (simp add: Normal_def mono_Ord_def)
  thus ?case using succ.hyps
    by (blast intro: lt_trans1)
next
  case (limit l)
  hence "l = (\<Union>y<l. y)"
    by (simp add: Limit_OUN_eq)
  also have "... \<le> (\<Union>y<l. F(y))" using limit
    by (blast intro: ltD le_implies_OUN_le_OUN)
  finally have "l \<le> (\<Union>y<l. F(y))" .
  moreover have "(\<Union>y<l. F(y)) \<le> F(l)" using limit F
    by (simp add: Normal_imp_cont lt_Ord)
  ultimately show ?case
    by (blast intro: le_trans)
qed

subsubsection\<open>The class of fixedpoints is closed and unbounded\<close>

text\<open>The proof is from Drake, pages 113--114.\<close>

lemma mono_Ord_imp_le_subset: "mono_Ord(F) ==> mono_le_subset(F)"
apply (simp add: mono_le_subset_def, clarify)
apply (subgoal_tac "F(i)\<le>F(j)", blast dest: le_imp_subset)
apply (simp add: le_iff)
apply (blast intro: lt_Ord2 mono_Ord_imp_Ord mono_Ord_imp_mono)
done

text\<open>The following equation is taken for granted in any set theory text.\<close>
lemma cont_Ord_Union:
     "[| cont_Ord(F); mono_le_subset(F); X=0 \<longrightarrow> F(0)=0; \<forall>x\<in>X. Ord(x) |]
      ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (frule Ord_set_cases)
apply (erule disjE, force)
apply (thin_tac "X=0 \<longrightarrow> Q" for Q, auto)
 txt\<open>The trival case of @{term "\<Union>X \<in> X"}\<close>
 apply (rule equalityI, blast intro: Ord_Union_eq_succD)
 apply (simp add: mono_le_subset_def UN_subset_iff le_subset_iff)
 apply (blast elim: equalityE)
txt\<open>The limit case, @{term "Limit(\<Union>X)"}:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply (simp add: OUN_Union_eq cont_Ord_def)
apply (rule equalityI)
txt\<open>First inclusion:\<close>
 apply (rule UN_least [OF OUN_least])
 apply (simp add: mono_le_subset_def, blast intro: leI)
txt\<open>Second inclusion:\<close>
apply (rule UN_least)
apply (frule Union_upper_le, blast, blast intro: Ord_Union)
apply (erule leE, drule ltD, elim UnionE)
 apply (simp add: OUnion_def)
 apply blast+
done

lemma Normal_Union:
     "[| X\<noteq>0; \<forall>x\<in>X. Ord(x); Normal(F) |] ==> F(\<Union>(X)) = (\<Union>y\<in>X. F(y))"
apply (simp add: Normal_def)
apply (blast intro: mono_Ord_imp_le_subset cont_Ord_Union)
done

lemma Normal_imp_fp_Closed: "Normal(F) ==> Closed(\<lambda>i. F(i) = i)"
apply (simp add: Closed_def ball_conj_distrib, clarify)
apply (frule Ord_set_cases)
apply (auto simp add: Normal_Union)
done

lemma iterates_Normal_increasing:
     "[| n\<in>nat;  x < F(x);  Normal(F) |]
      ==> F^n (x) < F^(succ(n)) (x)"
apply (induct n rule: nat_induct)
apply (simp_all add: Normal_imp_mono)
done

lemma Ord_iterates_Normal:
     "[| n\<in>nat;  Normal(F);  Ord(x) |] ==> Ord(F^n (x))"
by (simp add: Ord_iterates)

text\<open>THIS RESULT IS UNUSED\<close>
lemma iterates_omega_Limit:
     "[| Normal(F);  x < F(x) |] ==> Limit(F^\<omega> (x))"
apply (frule lt_Ord)
apply (simp add: iterates_omega_def)
apply (rule increasing_LimitI)
   \<comment>"this lemma is @{thm increasing_LimitI [no_vars]}"
 apply (blast intro: UN_upper_lt [of "1"]   Normal_imp_Ord
                     Ord_UN Ord_iterates lt_imp_0_lt
                     iterates_Normal_increasing, clarify)
apply (rule bexI)
 apply (blast intro: Ord_in_Ord [OF Ord_iterates_Normal])
apply (rule UN_I, erule nat_succI)
apply (blast intro:  iterates_Normal_increasing Ord_iterates_Normal
                     ltD [OF lt_trans1, OF succ_leI, OF ltI])
done

lemma iterates_omega_fixedpoint:
     "[| Normal(F); Ord(a) |] ==> F(F^\<omega> (a)) = F^\<omega> (a)"
apply (frule Normal_increasing, assumption)
apply (erule leE)
 apply (simp_all add: iterates_omega_triv [OF sym])  (*for subgoal 2*)
apply (simp add:  iterates_omega_def Normal_Union)
apply (rule equalityI, force simp add: nat_succI)
txt\<open>Opposite inclusion:
@{subgoals[display,indent=0,margin=65]}
\<close>
apply clarify
apply (rule UN_I, assumption)
apply (frule iterates_Normal_increasing, assumption, assumption, simp)
apply (blast intro: Ord_trans ltD Ord_iterates_Normal Normal_imp_Ord [of F])
done

lemma iterates_omega_increasing:
     "[| Normal(F); Ord(a) |] ==> a \<le> F^\<omega> (a)"
apply (unfold iterates_omega_def)
apply (rule UN_upper_le [of 0], simp_all)
done

lemma Normal_imp_fp_Unbounded: "Normal(F) ==> Unbounded(\<lambda>i. F(i) = i)"
apply (unfold Unbounded_def, clarify)
apply (rule_tac x="F^\<omega> (succ(i))" in exI)
apply (simp add: iterates_omega_fixedpoint)
apply (blast intro: lt_trans2 [OF _ iterates_omega_increasing])
done

theorem Normal_imp_fp_Closed_Unbounded:
     "Normal(F) ==> Closed_Unbounded(\<lambda>i. F(i) = i)"
by (simp add: Closed_Unbounded_def Normal_imp_fp_Closed
              Normal_imp_fp_Unbounded)

subsubsection\<open>Function \<open>normalize\<close>\<close>

text\<open>Function \<open>normalize\<close> maps a function \<open>F\<close> to a
      normal function that bounds it above.  The result is normal if and
      only if \<open>F\<close> is continuous: succ is not bounded above by any
      normal function, by @{thm [source] Normal_imp_fp_Unbounded}.
\<close>
definition
  normalize :: "[i=>i, i] => i" where
    "normalize(F,a) == transrec2(a, F(0), \<lambda>x r. F(succ(x)) \<union> succ(r))"

lemma Ord_normalize [simp, intro]:
     "[| Ord(a); !!x. Ord(x) ==> Ord(F(x)) |] ==> Ord(normalize(F, a))"
apply (induct a rule: trans_induct3)
apply (simp_all add: ltD def_transrec2 [OF normalize_def])
done

lemma normalize_increasing:
  assumes ab: "a < b" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "normalize(F,a) < normalize(F,b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> normalize(F,x) < normalize(F,b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (auto simp add: le_iff def_transrec2 [OF normalize_def] intro: Un_upper2_lt F)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "normalize(F,x) < normalize(F,succ(x))"
        by (blast intro: limit elim: ltE)
      hence "normalize(F,x) < (\<Union>j<l. normalize(F,j))"
        by (blast intro: OUN_upper_lt lt_Ord F sc)
      thus ?case using limit
        by (simp add: def_transrec2 [OF normalize_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_normalize:
     "(!!x. Ord(x) ==> Ord(F(x))) ==> Normal(normalize(F))"
apply (rule NormalI)
apply (blast intro!: normalize_increasing)
apply (simp add: def_transrec2 [OF normalize_def])
done

theorem le_normalize:
  assumes a: "Ord(a)" and coF: "cont_Ord(F)" and F: "!!x. Ord(x) ==> Ord(F(x))"
  shows "F(a) \<le> normalize(F,a)"
using a
proof (induct a rule: trans_induct3)
  case 0 thus ?case by (simp add: F def_transrec2 [OF normalize_def])
next
  case (succ a)
  thus ?case
    by (simp add: def_transrec2 [OF normalize_def] Un_upper1_le F )
next
  case (limit l)
  thus ?case using F coF [unfolded cont_Ord_def]
    by (simp add: def_transrec2 [OF normalize_def] le_implies_OUN_le_OUN ltD)
qed

subsection \<open>The Alephs\<close>
text \<open>This is the well-known transfinite enumeration of the cardinal
numbers.\<close>

definition
  Aleph :: "i => i"  ("\<aleph>_" [90] 90) where
    "Aleph(a) == transrec2(a, nat, \<lambda>x r. csucc(r))"

lemma Card_Aleph [simp, intro]:
     "Ord(a) ==> Card(Aleph(a))"
apply (erule trans_induct3)
apply (simp_all add: Card_csucc Card_nat Card_is_Ord
                     def_transrec2 [OF Aleph_def])
done

lemma Aleph_increasing:
  assumes ab: "a < b" shows "Aleph(a) < Aleph(b)"
proof -
  { fix x
    have "Ord(b)" using ab by (blast intro: lt_Ord2)
    hence "x < b \<Longrightarrow> Aleph(x) < Aleph(b)"
    proof (induct b arbitrary: x rule: trans_induct3)
      case 0 thus ?case by simp
    next
      case (succ b)
      thus ?case
        by (force simp add: le_iff def_transrec2 [OF Aleph_def]
                  intro: lt_trans lt_csucc Card_is_Ord)
    next
      case (limit l)
      hence sc: "succ(x) < l"
        by (blast intro: Limit_has_succ)
      hence "\<aleph> x < (\<Union>j<l. \<aleph>j)" using limit
        by (blast intro: OUN_upper_lt Card_is_Ord ltD lt_Ord)
      thus ?case using limit
        by (simp add: def_transrec2 [OF Aleph_def])
    qed
  } thus ?thesis using ab .
qed

theorem Normal_Aleph: "Normal(Aleph)"
apply (rule NormalI)
apply (blast intro!: Aleph_increasing)
apply (simp add: def_transrec2 [OF Aleph_def])
done

end