(*
  File:      Treap.thy
  Authors:   Tobias Nipkow, Max Haslbeck
*)
section \<open>Treaps\<close>
theory Treap
imports
  "HOL-Library.Tree"
  "HOL.Orderings"
begin

definition treap :: "('k::linorder * 'p::linorder) tree \<Rightarrow> bool" where
"treap t = (bst (map_tree fst t) \<and> heap (map_tree snd t))"

abbreviation "keys t \<equiv> set_tree (map_tree fst t)"
abbreviation "prios t \<equiv> set_tree (map_tree snd t)"

function treap_of :: "('k::linorder * 'p::linorder) set \<Rightarrow> ('k * 'p) tree" where
"treap_of KP = (if infinite KP \<or> KP = {} then Leaf else
  let m = arg_min_on snd KP;
      L = {p \<in> KP. fst p < fst m};
      R = {p \<in> KP. fst p > fst m}
  in Node (treap_of L) m (treap_of R))"
by pat_completeness auto
termination
proof (relation "measure card")
  show "wf (measure card)"  by simp
next
  fix KP :: "('a \<times> 'b) set" and m L
  assume KP: "\<not> (infinite KP \<or> KP = {})"
  and m: "m = arg_min_on snd KP"
  and L: "L = {p \<in> KP. fst p < fst m}"
  have "m \<in> KP" using KP arg_min_if_finite(1) m by blast
  thus  "(L, KP) \<in> measure card" using KP L by(auto intro!: psubset_card_mono)
next
  fix KP :: "('a \<times> 'b) set" and m R
  assume KP: "\<not> (infinite KP \<or> KP = {})"
  and m: "m = arg_min_on snd KP"
  and R: "R = {p \<in> KP. fst m < fst p}"
  have "m \<in> KP" using KP arg_min_if_finite(1) m by blast
  thus  "(R, KP) \<in> measure card" using KP R by(auto intro!: psubset_card_mono)
qed

declare treap_of.simps [simp del]

lemma treap_of_unique:
  "\<lbrakk> treap t;  inj_on snd (set_tree t) \<rbrakk>
  \<Longrightarrow> treap_of (set_tree t) = t"
proof(induction "set_tree t" arbitrary: t rule: treap_of.induct)
  case (1 t)
  show ?case
  proof (cases "infinite (set_tree t) \<or> set_tree t = {}")
    case True
    thus ?thesis by(simp add: treap_of.simps)
  next
    case False
    let ?m = "arg_min_on snd (set_tree t)"
    let ?L = "{p \<in> set_tree t. fst p < fst ?m}"
    let ?R = "{p \<in> set_tree t. fst p > fst ?m}"
    obtain l a r where t: "t = Node l a r"
      using False by (cases t) auto
    have "\<forall>kp \<in> set_tree t. snd a \<le> snd kp"
      using "1.prems"(1)
      by(auto simp add: t treap_def ball_Un)
        (metis image_eqI snd_conv tree.set_map)+
    hence "a = ?m"
      by (metis "1.prems"(2) False arg_min_if_finite(1) arg_min_if_finite(2) inj_on_def
          le_neq_trans t tree.set_intros(2))
    have "treap l" "treap r" using "1.prems"(1) by(auto simp: treap_def t)
    have l: "set_tree l = {p \<in> set_tree t. fst p < fst a}"
      using "1.prems"(1) by(auto simp add: treap_def t ball_Un tree.set_map)
    have r: "set_tree r = {p \<in> set_tree t. fst p > fst a}"
      using "1.prems"(1) by(auto simp add: treap_def t ball_Un tree.set_map)
    have "l = treap_of ?L"
      using "1.hyps"(1)[OF False \<open>a = ?m\<close> l r \<open>treap l\<close>]
        l \<open>a = ?m\<close> "1.prems"(2)
      by (fastforce simp add: inj_on_def)
    have "r = treap_of ?R"
      using "1.hyps"(2)[OF False \<open>a = ?m\<close> l r \<open>treap r\<close>]
        r \<open>a = ?m\<close> "1.prems"(2)
      by (fastforce simp add: inj_on_def)
    have "t = Node (treap_of ?L) ?m (treap_of ?R)"
      using \<open>a = ?m\<close> \<open>l = treap_of ?L\<close> \<open>r = treap_of ?R\<close> by(subst t) simp
    thus ?thesis using False
      by (subst treap_of.simps) simp
  qed
qed

lemma treap_unique:
  "\<lbrakk> treap t1; treap t2; set_tree t1 = set_tree t2; inj_on snd (set_tree t1) \<rbrakk>
  \<Longrightarrow> t1 = t2"
  for t1 t2 :: "('k::linorder * 'p::linorder) tree"
by (metis treap_of_unique)

fun ins :: "'k::linorder \<Rightarrow> 'p::linorder \<Rightarrow> ('k \<times> 'p) tree \<Rightarrow> ('k \<times> 'p) tree" where
"ins k p Leaf = \<langle>Leaf, (k,p), Leaf\<rangle>" |
"ins k p \<langle>l, (k1,p1), r\<rangle> =
  (if k < k1 then
     (case ins k p l of
       \<langle>l2, (k2,p2), r2\<rangle> \<Rightarrow>
         if p1 \<le> p2 then \<langle>\<langle>l2, (k2,p2), r2\<rangle>, (k1,p1), r\<rangle>
         else \<langle>l2, (k2,p2), \<langle>r2, (k1,p1), r\<rangle>\<rangle>)
   else
   if k > k1 then
     (case ins k p r of
       \<langle>l2, (k2,p2), r2\<rangle> \<Rightarrow>
         if p1 \<le> p2 then \<langle>l, (k1,p1), \<langle>l2, (k2,p2), r2\<rangle>\<rangle>
         else \<langle>\<langle>l, (k1,p1), l2\<rangle>, (k2,p2), r2\<rangle>)
   else \<langle>l, (k1,p1), r\<rangle>)"

lemma ins_neq_Leaf: "ins k p t \<noteq> \<langle>\<rangle>"
  by (induction t rule: ins.induct) (auto split: tree.split)

lemma keys_ins: "keys (ins k p t) = Set.insert k (keys t)"
proof (induction t rule: ins.induct)
  case 2
  then show ?case
    by (simp add: ins_neq_Leaf split: tree.split prod.split) (safe; fastforce)
qed (simp)

lemma prios_ins: "prios (ins k p t) \<subseteq> {p} \<union> prios t"
apply(induction t rule: ins.induct)
 apply simp
  apply (simp add: ins_neq_Leaf split: tree.split prod.split)
  by (safe; fastforce)

lemma prios_ins': "k \<notin> keys t \<Longrightarrow> prios (ins k p t) = {p} \<union> prios t"
apply(induction t rule: ins.induct)
 apply simp
  apply (simp add: ins_neq_Leaf split: tree.split prod.split)
  by (safe; fastforce)

lemma set_tree_ins: "set_tree (ins k p t) \<subseteq> {(k,p)} \<union> set_tree t"
  by (induction t rule: ins.induct) (auto simp add: ins_neq_Leaf split: tree.split prod.split)

lemma set_tree_ins': "k \<notin> keys t \<Longrightarrow>  {(k,p)} \<union> set_tree t \<subseteq> set_tree (ins k p t)"
  by (induction t rule: ins.induct) (auto simp add: ins_neq_Leaf split: tree.split prod.split)

lemma set_tree_ins_eq: "k \<notin> keys t \<Longrightarrow> set_tree (ins k p t) = {(k,p)} \<union> set_tree t"
  using set_tree_ins set_tree_ins' by blast

lemma prios_ins_special:
  "\<lbrakk> ins k p t = Node l (k',p') r;  p' = p; p \<in> prios r \<union> prios l \<rbrakk>
  \<Longrightarrow> p \<in> prios t"
  by (induction k p t arbitrary: l k' p' r rule: ins.induct)
     (fastforce simp add: ins_neq_Leaf split: tree.splits prod.splits if_splits)+

lemma treap_NodeI:
  "\<lbrakk> treap l; treap r;
     \<forall>k' \<in> keys l. k' < k; \<forall>k' \<in> keys r. k < k';
     \<forall>p' \<in> prios l. p \<le> p'; \<forall>p' \<in> prios r. p \<le> p' \<rbrakk>
  \<Longrightarrow> treap (Node l (k,p) r)"
 by (auto simp: treap_def)

lemma treap_rotate1:
  assumes "treap l2" "treap r2" "treap r" "\<not> p1 \<le> p2" "k < k1" and
  ins: "ins k p l = Node l2 (k2,p2) r2" and treap_ins: "treap (ins k p l)"
  and treap: "treap \<langle>l, (k1, p1), r\<rangle>"
  shows "treap (Node l2 (k2,p2) (Node r2 (k1,p1) r))"
proof(rule treap_NodeI[OF \<open>treap l2\<close> treap_NodeI[OF \<open>treap r2\<close> \<open>treap r\<close>]])
  from keys_ins[of k p l] have 1: "keys r2 \<subseteq> {k} \<union> keys l" by(auto simp: ins)
  from treap have 2: "\<forall>k'\<in>keys l. k' < k1" by (simp add: treap_def)
  show "\<forall>k'\<in>keys r2. k' < k1" using 1 2 \<open>k < k1\<close> by blast
next
  from treap have 2: "\<forall>p'\<in>prios l. p1 \<le> p'" by (simp add: treap_def)
  show "\<forall>p'\<in>prios r2. p1 \<le> p'"
  proof
    fix p' assume "p' \<in> prios r2"
    hence "p' = p \<or> p' \<in> prios l" using prios_ins[of k p l] ins by auto
    thus "p1 \<le> p'"
    proof
      assume [simp]: "p' = p"
      have "p2 = p \<or> p2 \<in> prios l" using prios_ins[of k p l] ins by simp
      thus "p1 \<le> p'"
      proof
        assume "p2 = p"
        thus "p1 \<le> p'"
          using prios_ins_special[OF ins] \<open>p' \<in> prios r2\<close> 2 by auto
      next
        assume "p2 \<in> prios l"
        thus "p1 \<le> p'" using 2 \<open>\<not> p1 \<le> p2\<close> by blast
      qed
    next
      assume "p' \<in> prios l"
      thus "p1 \<le> p'" using 2 by blast
    qed
  qed
next
  have "k2 = k \<or> k2 \<in> keys l" using keys_ins[of k p l] ins by (auto)
  hence 1: "k2 < k1"
  proof
    assume "k2 = k" thus "k2 < k1" using \<open>k < k1\<close> by simp
  next
    assume "k2 \<in> keys l"
    thus "k2 < k1" using treap by (auto simp: treap_def)
  qed
  have 2: "\<forall>k'\<in>keys r2. k2 < k'"
    using treap_ins by(simp add: ins treap_def)
  have 3: "\<forall>k'\<in>keys r. k2 < k'"
    using 1 treap by(auto simp: treap_def)
  show "\<forall>k'\<in>keys \<langle>r2, (k1, p1), r\<rangle>. k2 < k'" using 1 2 3 by auto
next
  show "\<forall>p'\<in>prios \<langle>r2, (k1, p1), r\<rangle>. p2 \<le> p'"
    using ins treap_ins treap \<open>\<not> p1 \<le> p2\<close> by (auto simp: treap_def ball_Un)
qed (use ins treap_ins treap in \<open>auto simp: treap_def ball_Un\<close>)

lemma treap_rotate2:
  assumes "treap l" "treap l2" "treap r2" "\<not> p1 \<le> p2" "k1 < k" and
  ins: "ins k p r = Node l2 (k2,p2) r2" and treap_ins: "treap (ins k p r)"
  and treap: "treap \<langle>l, (k1, p1), r\<rangle>"
  shows "treap (Node (Node l (k1,p1) l2) (k2,p2) r2)"
proof(rule treap_NodeI[OF treap_NodeI[OF \<open>treap l\<close> \<open>treap l2\<close>] \<open>treap r2\<close>])
  from keys_ins[of k p r] have 1: "keys l2 \<subseteq> {k} \<union> keys r" by(auto simp: ins)
  from treap have 2: "\<forall>k'\<in>keys r. k1 < k'" by (simp add: treap_def)
  show "\<forall>k'\<in>keys l2. k1 < k'" using 1 2 \<open>k1 < k\<close> by blast
next
  from treap have 2: "\<forall>p'\<in>prios r. p1 \<le> p'" by (simp add: treap_def)
  show "\<forall>p'\<in>prios l2. p1 \<le> p'"
  proof
    fix p' assume "p' \<in> prios l2"
    hence "p' = p \<or> p' \<in> prios r" using prios_ins[of k p r] ins by auto
    thus "p1 \<le> p'"
    proof
      assume [simp]: "p' = p"
      have "p2 = p \<or> p2 \<in> prios r" using prios_ins[of k p r] ins by simp
      thus "p1 \<le> p'"
      proof
        assume "p2 = p"
        thus "p1 \<le> p'"
          using prios_ins_special[OF ins] \<open>p' \<in> prios l2\<close> 2 by auto
      next
        assume "p2 \<in> prios r"
        thus "p1 \<le> p'" using 2 \<open>\<not> p1 \<le> p2\<close> by blast
      qed
    next
      assume "p' \<in> prios r"
      thus "p1 \<le> p'" using 2 by blast
    qed
  qed
next
  have "k2 = k \<or> k2 \<in> keys r" using keys_ins[of k p r] ins by (auto)
  hence 1: "k1 < k2"
  proof
    assume "k2 = k" thus "k1 < k2" using \<open>k1 < k\<close> by simp
  next
    assume "k2 \<in> keys r"
    thus "k1 < k2" using treap by (auto simp: treap_def)
  qed
  have 2: "\<forall>k'\<in>keys l. k' < k2" using 1 treap by(auto simp: treap_def)
  have 3: "\<forall>k'\<in>keys l2. k' < k2"
    using treap_ins by(auto simp: ins treap_def)
  show "\<forall>k'\<in>keys \<langle>l, (k1, p1), l2\<rangle>. k' < k2" using 1 2 3 by auto
next
  show "\<forall>p'\<in>prios \<langle>l, (k1, p1), l2\<rangle>. p2 \<le> p'"
    using ins treap_ins treap \<open>\<not> p1 \<le> p2\<close> by (auto simp: treap_def ball_Un)
qed (use ins treap_ins treap in \<open>auto simp: treap_def ball_Un\<close>)

lemma treap_ins: "treap t \<Longrightarrow> treap (ins k p t)"
proof(induction t rule: ins.induct)
  case 1 thus ?case by (simp add: treap_def)
next
  case (2 k p l k1 p1 r)
  have "treap l" "treap r"
    using "2.prems" by(auto simp: treap_def tree.set_map)
  show ?case
  proof cases
    assume "k < k1"
    obtain l2 k2 p2 r2 where ins: "ins k p l = Node l2 (k2,p2) r2"
      by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
    note treap_ins = "2.IH"(1)[OF \<open>k < k1\<close> \<open>treap l\<close>]
    hence "treap l2" "treap r2" using ins by (auto simp add: treap_def)
    show ?thesis
    proof cases
      assume "p1 \<le> p2"
      have "treap (Node (Node l2 (k2,p2) r2) (k1,p1) r)"
        apply(rule treap_NodeI[OF treap_ins[unfolded ins] \<open>treap r\<close>])
        using ins treap_ins \<open>k < k1\<close> "2.prems" keys_ins[of k p l]
        by (auto simp add: treap_def ball_Un order_trans[OF \<open>p1 \<le> p2\<close>])
      thus ?thesis using \<open>k < k1\<close> ins \<open>p1 \<le> p2\<close> by simp
    next
      assume "\<not> p1 \<le> p2"
      have "treap (Node l2 (k2,p2) (Node r2 (k1,p1) r))"
        by(rule treap_rotate1[OF \<open>treap l2\<close> \<open>treap r2\<close>  \<open>treap r\<close> \<open>\<not> p1 \<le> p2\<close>
            \<open>k < k1\<close> ins treap_ins "2.prems"])
      thus ?thesis using \<open>k < k1\<close> ins \<open>\<not> p1 \<le> p2\<close> by simp
    qed
  next
    assume "\<not> k < k1"
    show ?thesis
    proof cases
    assume "k > k1"
    obtain l2 k2 p2 r2 where ins: "ins k p r = Node l2 (k2,p2) r2"
      by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
    note treap_ins = "2.IH"(2)[OF \<open>\<not> k < k1\<close> \<open>k > k1\<close> \<open>treap r\<close>]
    hence "treap l2" "treap r2" using ins by (auto simp add: treap_def)
    have fst: "\<forall>k' \<in> set_tree (map_tree fst (ins k p r)).
                 k' = k \<or> k' \<in> set_tree (map_tree fst r)"
      by(simp add: keys_ins)
    show ?thesis
    proof cases
      assume "p1 \<le> p2"
      have "treap (Node l (k1,p1) (ins k p r))"
        apply(rule treap_NodeI[OF \<open>treap l\<close> treap_ins])
        using ins treap_ins \<open>k > k1\<close> "2.prems" keys_ins[of k p r]
        by (auto simp: treap_def ball_Un order_trans[OF \<open>p1 \<le> p2\<close>])
      thus ?thesis using \<open>\<not> k < k1\<close> \<open>k > k1\<close> ins \<open>p1 \<le> p2\<close> by simp
    next
      assume "\<not> p1 \<le> p2"
      have "treap (Node (Node l (k1,p1) l2) (k2,p2) r2)"
        by(rule treap_rotate2[OF \<open>treap l\<close> \<open>treap l2\<close> \<open>treap r2\<close> \<open>\<not> p1 \<le> p2\<close>
             \<open>k1 < k\<close> ins treap_ins "2.prems"])
      thus ?thesis using \<open>\<not> k < k1\<close>  \<open>k > k1\<close> ins \<open>\<not> p1 \<le> p2\<close> by simp
    qed
    next
      assume "\<not> k > k1"
      hence "k = k1" using \<open>\<not> k < k1\<close> by auto
      thus ?thesis using "2.prems" by(simp)
    qed
  qed
qed

lemma treap_of_set_tree_unique:
  "\<lbrakk> finite A; inj_on fst A; inj_on snd A \<rbrakk>
  \<Longrightarrow> set_tree (treap_of A) = A"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  note IH = 1
  show ?case
  proof (cases "infinite A \<or> A = {}")
    assume "infinite A \<or> A = {}"
    with IH show ?thesis by (simp add: treap_of.simps)
  next
    assume not_inf_or_empty: "\<not> (infinite A \<or> A = {})"
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using not_inf_or_empty
      by (cases "treap_of A") (auto simp: Let_def elim!: treap_of.elims split: if_splits)
    have [simp]: "inj_on fst {p \<in> A. fst p < fst (arg_min_on snd A)}"
                 "inj_on snd {p \<in> A. fst p < fst (arg_min_on snd A)}"
                 "inj_on fst {p \<in> A. fst (arg_min_on snd A) < fst p}"
                 "inj_on snd {p \<in> A. fst (arg_min_on snd A) < fst p}"
      using IH by (auto intro: inj_on_subset)
    have lr: "l = treap_of ?L" "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have l: "set_tree l = ?L"
       using not_inf_or_empty IH by auto
     have "r = treap_of ?R"
       using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have r: "set_tree r = ?R"
      using not_inf_or_empty IH(2) by (auto)
    have a: "a = ?m"
      using t by (elim treap_of.elims) (simp add: Let_def split: if_splits)
    have "a \<noteq> fst (arg_min_on snd A)" if "(a,b) \<in> A" "(a, b) \<noteq> arg_min_on snd A" for a b
      using IH(4,5) that not_inf_or_empty arg_min_if_finite(1) inj_on_eq_iff by fastforce
    then have "a < fst (arg_min_on snd A)"
       if "(a,b) \<in> A" "(a, b) \<noteq> arg_min_on snd A" "fst (arg_min_on snd A) \<ge> a" for a b
      using le_neq_trans that by auto
    moreover have "arg_min_on snd A \<in> A"
      using not_inf_or_empty arg_min_if_finite by auto
    ultimately have A: "A = {?m} \<union> ?L \<union> ?R"
      by auto
    show ?thesis using l r a A t by force
  qed
qed

lemma treap_of_subset: "set_tree (treap_of A) \<subseteq> A"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  note IH = 1
  show ?case
  proof (cases "infinite A \<or> A = {}")
    assume "infinite A \<or> A = {}"
    with IH show ?thesis by (simp add: treap_of.simps)
  next
    assume not_inf_or_empty: "\<not> (infinite A \<or> A = {})"
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using not_inf_or_empty by (cases "treap_of A")
                                (auto simp add: Let_def  elim!: treap_of.elims split: if_splits)
    have "l = treap_of ?L" "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    have "set_tree l \<subseteq> ?L" "set_tree r \<subseteq> ?R"
    proof -
      have "set_tree (treap_of {p \<in> A. fst p < fst (arg_min_on snd A)})
            \<subseteq> {p \<in> A. fst p < fst (arg_min_on snd A)}"
        by (rule IH) (use not_inf_or_empty in auto)
      then show "set_tree l \<subseteq> ?L"
        using \<open>l = treap_of ?L\<close> by auto
    next
      have "set_tree (treap_of {p \<in> A. fst (arg_min_on snd A) < fst p})
            \<subseteq> {p \<in> A. fst (arg_min_on snd A) < fst p}"
        by (rule IH) (use not_inf_or_empty in auto)
      then show "set_tree r \<subseteq> ?R"
        using \<open>r = treap_of ?R\<close> by auto
    qed
    moreover have "a = ?m"
      using t by (auto elim!: treap_of.elims simp add: Let_def split: if_splits)
    moreover have "{?m} \<union> ?L \<union> ?R \<subseteq> A"
      using not_inf_or_empty arg_min_if_finite by auto
    ultimately show ?thesis by (auto simp add: t)
  qed
qed

lemma treap_treap_of:
  "treap (treap_of A)"
proof(induction "A" rule: treap_of.induct)
  case (1 A)
  show ?case
  proof (cases "infinite A \<or> A = {}")
    case True
    with 1 show ?thesis by (simp add: treap_of.simps treap_def)
  next
    case False
    let ?m = "arg_min_on snd A"
    let ?L = "{p \<in> A. fst p < fst ?m}"
    let ?R = "{p \<in> A. fst p > fst ?m}"
    obtain l a r where t: "treap_of A = Node l a r"
      using False by (cases "treap_of A") (auto simp: Let_def elim!: treap_of.elims split: if_splits)
    have l: "l = treap_of ?L"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have treap_l: "treap l"
      using False by (auto intro: 1)
    from l have keys_l: "keys l \<subseteq> fst ` ?L"
      by (auto simp add: tree.set_map intro!: image_mono treap_of_subset)
    have r: "r = treap_of ?R"
      using t by (auto simp: Let_def elim: treap_of.elims split: if_splits)
    then have treap_r: "treap r"
      using False by (auto intro: 1)
    from r have keys_r: "keys r \<subseteq> fst ` ?R"
      by (auto simp add: tree.set_map intro!: image_mono treap_of_subset)
    have prios: "prios l \<subseteq> snd ` A" "prios r \<subseteq> snd ` A"
      using l r treap_of_subset image_mono by (auto simp add: tree.set_map)
    have a: "a = ?m"
      using t by(auto simp: Let_def elim: treap_of.elims split: if_splits)
    have prios_l: "\<And>x. x \<in> prios l \<Longrightarrow> snd a \<le> x"
      by (drule rev_subsetD[OF _ prios(1)]) (use arg_min_least a False in fast)
    have prios_r: "\<And>x. x \<in> prios r \<Longrightarrow> snd a \<le> x"
      by (drule rev_subsetD[OF _ prios(2)]) (use arg_min_least a False in fast)
    show ?thesis
      using prios_r prios_l treap_l treap_r keys_l keys_r a
      by (auto simp add: t treap_def dest: rev_subsetD[OF _ keys_l] rev_subsetD[OF _ keys_r])
    qed
qed

lemma treap_Leaf: "treap \<langle>\<rangle>"
  by (simp add: treap_def)

lemma foldl_ins_treap: "treap t \<Longrightarrow> treap (foldl (\<lambda>t' (x, p). ins x p t') t xs)"
  using treap_ins by (induction xs arbitrary: t) auto

lemma foldl_ins_set_tree:
  assumes "inj_on fst (set ys)" "inj_on snd (set ys)" "distinct ys" "fst ` (set ys) \<inter> keys t = {}"
  shows "set_tree (foldl (\<lambda>t' (x, p). ins x p t') t ys) = set ys \<union> set_tree t"
  using assms
  by (induction ys arbitrary: t) (auto simp add: case_prod_beta' set_tree_ins_eq keys_ins)

lemma foldl_ins_treap_of:
  assumes "distinct ys" "inj_on fst (set ys)" "inj_on snd (set ys)"
 shows "(foldl (\<lambda>t' (x, p). ins x p t') Leaf ys) = treap_of (set ys)"
  using assms by (intro treap_unique) (auto simp: treap_Leaf foldl_ins_treap foldl_ins_set_tree
                                                  treap_treap_of treap_of_set_tree_unique)

fun cont:: "'k \<Rightarrow> 'p \<Rightarrow> ('k \<times> 'p) tree \<Rightarrow> bool" where
"cont k p \<langle>\<rangle> = False" |
"cont k p \<langle>l, (k1, p1), r\<rangle> = ((k = k1 \<and> p = p1) \<or> (cont k p l) \<or> (cont k p r))"

lemma cont_then_in_keys: "\<lbrakk>treap t; cont k p t\<rbrakk> \<Longrightarrow> k \<in> keys t"
  apply(induction t)
  apply(auto simp: treap_def tree.set_map)
  done

lemma cont_then_in_prios: "\<lbrakk>treap t; cont k p t\<rbrakk> \<Longrightarrow> p \<in> prios t"
  apply(induction t)
  apply(auto simp: treap_def tree.set_map)
  done

lemma sub_treap:
  assumes "treap \<langle>l, (k, p), r\<rangle>"
  shows "(treap l) \<and> (treap r)"
proof
  have 0: "bst (map_tree fst \<langle>l, (k, p), r\<rangle>)" using assms(1) by (auto simp add: treap_def)
  have 1: "heap (map_tree snd \<langle>l, (k, p), r\<rangle>)" using assms(1) by (auto simp add: treap_def)
  show "treap l" using 0 1 by (auto simp add: treap_def)
  show  "treap r" using 0 1 by (auto simp add: treap_def)
qed

lemma ins_cont:
  assumes  "treap t"
  shows "cont k p (ins k p t) \<or> k \<in> keys t"
proof(induction t rule: ins.induct)
  case (1 k p)
  then show ?case by (auto)
next
  case (2 k p l k1 p1 r)
  obtain  l2 k2 p2 r2 where ins: "ins k p l = Node l2 (k2,p2) r2"
    by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
  obtain  l3 k3 p3 r3 where ins_r: "ins k p r = Node l3 (k3,p3) r3"
      by (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
  then show ?case
  proof (cases "k < k1")
    case True
    then show ?thesis using  ins "2.IH" by (auto)
  next
    case 0: False
    then show ?thesis
    proof (cases "k = k1")
      case True
      then show ?thesis using  "2.IH" by (auto)
    next
      case False
      then have "k > k1" using 0 by (auto)
      then show ?thesis using ins_r "2.IH"  by (auto)
    qed
  qed
qed

lemma cont_ins_same: "\<lbrakk>treap t; cont k p t\<rbrakk> \<Longrightarrow> ins k p t = t"
proof(induction t rule: ins.induct)
  case (1 k p)
  then show ?case by (auto)
next
  case (2 k p l k1 p1 r)
  then show ?case
  proof (cases "k = k1")
    case True
    then show ?thesis by (auto)
  next
    case f: False
    then show ?thesis
    proof (cases "k < k1")
      case 0: True
      then have "\<forall> kr. (kr \<in> keys r) \<longrightarrow> kr > k"
        using "2.prems"
        by (auto  simp: treap_def tree.set_map)
      then have "k \<notin> keys r" by (auto simp: treap_def tree.set_map)
      then have "\<not> cont k p r"
        using "2.prems" cont_then_in_keys[of r k p] sub_treap
        by (auto)
      then have "cont k p l"
        using 0 "2.IH" "2.prems"
        by (auto simp: treap_def tree.set_map)
      then have a: "ins k p l = l" using 0 sub_treap[of l k1 p1 r] "2.IH" "2.prems" by (auto)
      obtain l2 k2 p2 r2 where get_p2: "ins k p l =  \<langle>l2, (k2, p2), r2\<rangle>"
        by  (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
      have "p2 \<in> prios l" using get_p2 a by (auto  simp: treap_def  tree.set_map)
      then have "p2 \<ge> p1" using get_p2 "2.prems" by (auto simp: treap_def  tree.set_map)
      then show ?thesis using 0 a get_p2 sub_treap[of l k1 p1 r] "2.IH" "2.prems" by (auto)
    next
      case 3: False
      then have "\<forall> kr. (kr \<in> keys l) \<longrightarrow> kr < k"
        using "2.prems"
        by (auto  simp: treap_def tree.set_map)
      then have "k \<notin> keys l" by (auto simp: treap_def tree.set_map)
      then have "\<not> cont k p l"
        using "2.prems" cont_then_in_keys[of l k p] sub_treap
        by (auto)
      then have "cont k p r"
        using 3 f "2.IH" "2.prems"
        by (auto simp: treap_def tree.set_map)
      then have a: "ins k p r = r" using 3 f sub_treap[of l k1 p1 r] "2.IH" "2.prems" by (auto)
      obtain l2 k2 p2 r2 where get_p2: "ins k p r =  \<langle>l2, (k2, p2), r2\<rangle>"
        by  (metis ins_neq_Leaf neq_Leaf_iff prod.collapse)
      have "p2 \<in> prios r" using get_p2 a by (auto  simp: treap_def  tree.set_map)
      then have "p2 \<ge> p1" using get_p2 "2.prems" by (auto simp: treap_def  tree.set_map)
      then show ?thesis using 3 f a get_p2 sub_treap[of l k1 p1 r] "2.IH" "2.prems" by (auto)
    qed
  qed
qed

lemma cont_subtreap:
 "\<lbrakk>\<not> cont k p r; \<not> cont k p l; k \<noteq>  k1 \<or> p \<noteq> p1\<rbrakk> \<Longrightarrow> \<not> cont k p \<langle>l, (k1, p1),r \<rangle> "
  apply(auto)
  done

fun disjoint_treap:: " ('k \<times>'p::linorder) tree \<Rightarrow> ('k \<times> 'p) tree \<Rightarrow> bool" where
"disjoint_treap \<langle>\<rangle> t2 = True" |
"disjoint_treap \<langle>l, (k, p), r\<rangle> t2 = ((cont k p t2) \<and> (disjoint_treap l t2) \<and> (disjoint_treap r t2))"

fun merge :: "('k::linorder \<times> 'p::linorder) tree \<Rightarrow> ('k \<times> 'p) tree \<Rightarrow> ('k \<times> 'p) tree" where
"merge t Leaf = t" |
"merge Leaf t = t" |
"merge \<langle>l1, (k1,p1), r1\<rangle>  \<langle>l2, (k2, p2), r2\<rangle> =
 (if p1 < p2 then
    \<langle>l1, (k1,p1), merge r1  \<langle>l2, (k2, p2), r2 \<rangle>\<rangle>
  else
     \<langle>merge \<langle>l1, (k1,p1), r1\<rangle> l2, (k2, p2), r2\<rangle>)
"

lemma subbst_is_bst:
   "\<lbrakk>bst  \<langle>l, (k), r\<rangle> \<rbrakk> \<Longrightarrow> bst l"
  apply (auto)
  done

lemma subheap_is_heap:
   "\<lbrakk>heap  \<langle>l, (p), r\<rangle> \<rbrakk> \<Longrightarrow> heap l \<and> heap r"
  apply (auto)
  done

lemma bst_union:
  assumes "bst l" "bst r"
    "disjoint (set_tree l) (set_tree r)"
    "\<forall>k' \<in> set_tree l.  k' < k"
    "\<forall>k'' \<in> set_tree r. k < k''"
  shows  "bst  \<langle>l, k, r\<rangle>"
  using assms by (auto)

lemma heap_union:
  assumes "heap l" "heap r"
    "disjoint (set_tree l) (set_tree r)"
    "\<forall>p' \<in> set_tree l.  p' > p"
    "\<forall>p'' \<in> set_tree r. p'' > p"
  shows  "heap  \<langle>l, p, r\<rangle>"
  using assms by (auto)

lemma submap_fst_is_map:
"\<lbrakk>treap  \<langle>l, (k,p), r\<rangle>;  \<langle>a, b, c\<rangle> = (map_tree fst \<langle>l, (k,p), r\<rangle>)\<rbrakk> \<Longrightarrow>  a = map_tree fst l \<and> b = k \<and> c = map_tree fst r"
  apply(auto)
  done

lemma submap_snd_is_map:
"\<lbrakk>treap  \<langle>l, (k,p), r\<rangle>;  \<langle>a, b, c\<rangle> = (map_tree snd \<langle>l, (k,p), r\<rangle>)\<rbrakk> \<Longrightarrow>  a = map_tree snd l \<and> b = p \<and> c = map_tree snd r"
  apply(auto)
  done

lemma subset_disj:
 "a  \<subseteq> b \<and> disjnt b c \<Longrightarrow> disjnt a c"
  using disjnt_def by (blast)

lemma treap_union:
  assumes   "treap l" "treap r"
    "\<forall>k' \<in> keys l. k' < k"
    "\<forall>k'' \<in> keys r. k < k''"
    "\<forall>p' \<in> prios l. p' \<ge> p"
    " \<forall>p'' \<in> prios r. p'' \<ge> p"
  shows "treap  \<langle>l, (k, p), r\<rangle>"
proof -
  obtain bst_l where get_bst_l: "bst_l = (map_tree fst l)" by (auto)
  obtain bst_r where get_bst_r: "bst_r = (map_tree fst r)" by (auto)
  have 0: "bst bst_l" using assms(1) get_bst_l  by (auto simp: treap_def)
  have 1: "bst bst_r" using assms(2) get_bst_r  by (auto simp: treap_def)
  have 2: "bst  \<langle>bst_l, k, bst_r\<rangle>"  using 0 1 get_bst_l get_bst_r assms(3) assms(4)  bst_union by (auto simp add: treap_def tree.set_map)

  obtain heap_l where get_heap_l: "heap_l = (map_tree snd l)" by (auto)
  obtain heap_r where get_heap_r: "heap_r = (map_tree snd r)" by (auto)
  have 3: "heap heap_l" using assms(1) get_heap_l  by (auto simp: treap_def)
  have 4: "heap heap_r" using assms(2) get_heap_r  by (auto simp: treap_def)
  have 5: "heap  \<langle>heap_l, p, heap_r\<rangle>"  using 3 4 get_heap_l get_heap_r assms(5) assms(6) heap_union by (auto simp add: treap_def tree.set_map)

  show  "treap  \<langle>l, (k, p), r\<rangle>" using 2 5 get_bst_l get_bst_r get_heap_l get_heap_r by (auto simp add: treap_def)
qed

lemma merge_treap_key_preserve:
" keys (merge t1 t2) = keys  t1 \<union> keys t2"
  apply(induction t1 t2 rule: merge.induct )
  apply(auto)
  done

lemma merge_treap_prios_preserve:
" prios (merge t1 t2) = prios  t1 \<union> prios t2"
  apply(induction t1 t2 rule: merge.induct )
  apply(auto)
  done

lemma merge_treap:
  "\<lbrakk>treap l; treap r ;(\<forall>k' \<in> keys l. \<forall>k'' \<in> keys r. k' < k'') \<rbrakk> \<Longrightarrow> treap (merge l r)"
proof(induction l r  rule: merge.induct)
  case (1 t)
  have "treap t" using "1.prems"(1) by (auto)
  then show ?case by (auto)
next
  case (2 v va vb)
  then show ?case using "2.prems"(2) by (auto)
next
  case (3 l1 k1 p1 r1 l2 k2 p2 r2)
  then show ?case
  proof (cases "p1 < p2")
      case 4: True
      obtain treap_r where get_treap_r: "treap_r = merge r1  \<langle>l2, (k2, p2), r2 \<rangle>" by (auto)
      obtain t2 where get_t2: "t2 =  \<langle>l2, (k2, p2), r2 \<rangle>" by (auto)
      have treap_r_is_treap: "treap treap_r"
        using 4 "3.IH"(1) "3.prems" get_treap_r sub_treap[of l1 k1 p1 r1]
        by (auto simp: treap_def tree.set_map)

      have keys_1: "\<forall>k' \<in> keys l1.  k' < k1" using "3.prems" by (auto simp: treap_def tree.set_map)

      have "\<forall>k''\<in>keys treap_r. k'' \<in> keys r1 \<or> k'' \<in> keys t2"
        using get_treap_r  get_t2 merge_treap_key_preserve[of r1 t2] by auto
      moreover have "\<forall>k''\<in>keys t2. k1 < k''" using get_t2 "3.prems" by (auto)
      moreover have "\<forall>k''\<in>keys r1. k1 < k''" using "3.prems"(1) by (auto simp: treap_def)
      ultimately have keys_2: "\<forall>k''\<in>keys treap_r. k1 < k''" by (auto)

      have l1_is_treap: "treap l1" using "3.prems"(1) sub_treap[of l1 k1 p1 r1] by (auto)

      have prios_1: "\<forall>p' \<in> prios l1.  p' \<ge> p1" using "3.prems" by (auto simp: treap_def tree.set_map)

      have "\<forall>p''\<in>prios t2. p2 \<le> p''" using get_t2 "3.prems"(2) by (auto simp: treap_def)
        then have "\<forall>p''\<in>prios t2. p1 \<le> p''" using 4  by (auto simp: treap_def tree.set_map)
      moreover have "\<forall>p''\<in>prios treap_r. p'' \<in> prios r1 \<or> p'' \<in> prios t2"
        using get_treap_r  get_t2 merge_treap_prios_preserve[of r1 t2] by auto
      moreover have "\<forall>p''\<in>prios r1. p1  \<le> p''" using "3.prems"(1) by (auto simp: treap_def)
      ultimately have prios_2: "\<forall>p''\<in>prios treap_r. p1 \<le> p''"  by (auto)

      show ?thesis
        using treap_union[of l1 treap_r k1 p1]  l1_is_treap treap_r_is_treap keys_1 keys_2 prios_1 prios_2 4 get_treap_r
        by (auto)
    next
      case 5: False
      obtain t1 where get_t1: "t1 =  \<langle>l1, (k1,p1), r1\<rangle> " by (auto)
      obtain treap_l where get_treap_l: "treap_l = merge \<langle>l1, (k1,p1), r1\<rangle> l2" by (auto)
      have treap_l_is_treap: "treap treap_l"
        using "3.IH" 5 "3.prems" sub_treap[of l2 k2 p2 r2] get_treap_l
        by (auto simp: treap_def tree.set_map)

      have keys_3: "\<forall>k' \<in> keys r2.  k' > k2" using "3.prems"(2) by (auto simp: treap_def tree.set_map)

      have "\<forall>k''\<in>keys treap_l. k'' \<in> keys l2 \<or> k'' \<in> keys t1"
        using get_treap_l  get_t1 merge_treap_key_preserve[of t1 l2] by auto
      moreover have "\<forall>k''\<in>keys t1. k2 > k''" using get_t1 "3.prems" by (auto)
      moreover have "\<forall>k''\<in>keys l2. k2 > k''" using "3.prems"(2) by (auto simp: treap_def)
      ultimately have keys_4: "\<forall>k''\<in>keys treap_l. k2 > k''" by (auto)

      have r2_is_treap: "treap r2" using "3.prems"(2) sub_treap[of l2 k2 p2 r2] by (auto)

      have prios_3: "\<forall>p' \<in> prios r2.  p' \<ge> p2" using "3.prems"(2) by (auto simp: treap_def tree.set_map)

      have "\<forall>p''\<in>prios t1. p1 \<le> p''" using get_t1 "3.prems"(1) by (auto simp: treap_def)
        then have "\<forall>p''\<in>prios t1. p2 \<le> p''" using 5  by (auto simp: treap_def tree.set_map)
      moreover have "\<forall>p''\<in>prios treap_l. p'' \<in> prios l2 \<or> p'' \<in> prios t1"
        using get_treap_l  get_t1 merge_treap_prios_preserve[of t1 l2] by auto
      moreover have "\<forall>p''\<in>prios l2. p2  \<le> p''" using "3.prems"(2) by (auto simp: treap_def)
      ultimately have prios_4: "\<forall>p''\<in>prios treap_l. p2 \<le> p''"  by (auto)

      show ?thesis
        using treap_union[of treap_l r2 k2 p2]  treap_l_is_treap r2_is_treap keys_3 keys_4 prios_3 prios_4 5 get_treap_l
        by (auto)
    next
  qed
qed

fun del:: "'k::linorder \<Rightarrow>  ('k \<times>'p::linorder) tree \<Rightarrow> ('k \<times> 'p) tree" where
"del k Leaf = Leaf" |

"del k \<langle>Leaf, (k1,p1), Leaf\<rangle> =
(if k = k1 then Leaf
else \<langle>Leaf, (k1,p1), Leaf\<rangle>)" |

"del k \<langle>l1, (k1,p1), Leaf\<rangle>  =
(if k = k1 then del k l1
else \<langle>del k l1, (k1,p1), Leaf\<rangle>)" |

"del k \<langle>Leaf, (k1,p1), r1\<rangle>  =
(if k = k1 then del k r1
else \<langle>Leaf, (k1,p1), del k r1\<rangle>)" |

"del k \<langle>l1, (k1,p1), r1\<rangle>  =
(if k = k1 then
merge (del k l1) (del k r1)
else \<langle>del k l1, (k1,p1), del k r1\<rangle>)
"

lemma treap_del:
"\<lbrakk>treap t \<rbrakk> \<Longrightarrow>  k \<notin> keys (del k t)"
proof(induction t  rule: del.induct)
  case (1 k)
  then show ?case by auto
next
  case (2 k k1 p1)
  then show ?case by auto
next
  case (3 k l1_l l1_k l1_r k1 p1)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "3.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    show ?thesis using "3.IH" 1 a by auto
  next
    case b: False
    have "k \<notin> keys treap_l" using "3.IH"(2) 1 b get_treap_l by auto
    then show ?thesis using b get_treap_l by auto
  qed
next
  case (4 k k1 p1 r1_l r1_k r1_r)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "4.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    show ?thesis using "4.IH" 2 a by auto
  next
    case b: False
    have "k \<notin> keys treap_r" using "4.IH"(2) 2 b get_treap_r by auto
    then show ?thesis using b get_treap_r  by auto
  qed
next
  case ("5_1" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.prems" sub_treap by auto
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    have "k \<notin> keys treap_l" using "5_1.IH"(1) 1 a get_treap_l by auto
    moreover have "k \<notin> keys treap_r" using "5_1.IH"(2) 2 a get_treap_r by auto
    ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_key_preserve[of treap_l treap_r] cont_then_in_keys  by auto
  next
    case b: False
    have " k \<notin> keys treap_l" using "5_1.IH"(3) 1 b get_treap_l by auto
    moreover have "k \<notin> keys treap_r" using "5_1.IH"(4) 2 b get_treap_r by auto
    ultimately  show ?thesis using b get_treap_r get_treap_l  by auto
  qed
next
 case ("5_2" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.prems" sub_treap by auto
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    have "k \<notin> keys treap_l" using "5_2.IH"(1) 1 a get_treap_l by auto
    moreover have "k \<notin> keys treap_r" using "5_2.IH"(2) 2 a get_treap_r by auto
    ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_key_preserve[of treap_l treap_r] cont_then_in_keys  by auto
  next
    case b: False
    have " k \<notin> keys treap_l" using "5_2.IH"(3) 1 b get_treap_l by auto
    moreover have "k \<notin> keys treap_r" using "5_2.IH"(4) 2 b get_treap_r by auto
    ultimately  show ?thesis using b get_treap_r get_treap_l  by auto
  qed
qed

lemma treap_del2:
"\<lbrakk>treap t \<rbrakk> \<Longrightarrow> (keys (del k t)) =  keys t - {k}"
proof(induction t  rule: del.induct)
  case (1 k)
  then show ?case by auto
next
  case (2 k k1 p1)
  then show ?case by (auto simp: treap_def)
next
    case (3 k l1_l l1_k l1_r k1 p1)
    then show ?case by (auto simp: treap_def)
next
    case (4 k k1 p1 r1_l r1_k r1_r)
    then show ?case by (auto simp: treap_def)
next
    case ("5_1" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
    obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
    obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
    have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.prems" sub_treap by auto
    have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.prems" sub_treap by auto
    then show ?case
    proof (cases "k = k1")
      case a: True
      have " keys treap_l =  keys  \<langle>l1_l, l1_k, l1_r\<rangle> - {k}" using "5_1.IH"(1) 1 a get_treap_l by auto
      moreover have  " keys treap_r =  keys  \<langle>r1_l, r1_k, r1_r\<rangle> - {k}" using "5_1.IH"(2) 2 a get_treap_r by auto
      ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_key_preserve[of treap_l treap_r]  by auto
  next
    case b: False
    have " keys treap_l =  keys  \<langle>l1_l, l1_k, l1_r\<rangle> - {k}" using "5_1.IH"(3) 1 b get_treap_l by auto
    moreover have " keys treap_r =  keys  \<langle>r1_l, r1_k, r1_r\<rangle> - {k}" using "5_1.IH"(4) 2 b get_treap_r by auto
    ultimately show ?thesis using b get_treap_r get_treap_l  by auto
  qed
next
  case ("5_2" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
    obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
    obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
    have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.prems" sub_treap by auto
    have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.prems" sub_treap by auto
    then show ?case
    proof (cases "k = k1")
      case a: True
      have " keys treap_l =  keys  \<langle>l1_l, l1_k, l1_r\<rangle> - {k}" using "5_2.IH"(1) 1 a get_treap_l by auto
      moreover have  " keys treap_r =  keys  \<langle>r1_l, r1_k, r1_r\<rangle> - {k}" using "5_2.IH"(2) 2 a get_treap_r by auto
      ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_key_preserve[of treap_l treap_r]  by auto
  next
    case b: False
    have " keys treap_l =  keys  \<langle>l1_l, l1_k, l1_r\<rangle> - {k}" using "5_2.IH"(3) 1 b get_treap_l by auto
    moreover have " keys treap_r =  keys  \<langle>r1_l, r1_k, r1_r\<rangle> - {k}" using "5_2.IH"(4) 2 b get_treap_r by auto
    ultimately show ?thesis using b get_treap_r get_treap_l  by auto
  qed
qed

lemma treap_del3:
"\<lbrakk>treap t \<rbrakk> \<Longrightarrow>  (prios (del k t)) \<subseteq>  prios t"
proof(induction t  rule: del.induct)
  case (1 k)
  then show ?case by auto
next
  case (2 k k1 p1)
  then show ?case by (auto simp: treap_def)
next
    case (3 k l1_l l1_k l1_r k1 p1)
    then show ?case by (auto simp: treap_def)
next
    case (4 k k1 p1 r1_l r1_k r1_r)
    then show ?case by (auto simp: treap_def)
next
    case ("5_1" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
    obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
    obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
    have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.prems" sub_treap by auto
    have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.prems" sub_treap by auto
    then show ?case
    proof (cases "k = k1")
      case a: True
      have " prios treap_l \<subseteq>  prios  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.IH"(1) 1 a get_treap_l by auto
      moreover have  " prios treap_r \<subseteq>  prios  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.IH"(2) 2 a get_treap_r by auto
      ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_prios_preserve[of treap_l treap_r]  by auto
  next
    case b: False
    have " prios treap_l \<subseteq>  prios  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.IH"(3) 1 b get_treap_l by auto
    moreover have " prios treap_r \<subseteq>  prios  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.IH"(4) 2 b get_treap_r by auto
    ultimately show ?thesis using b get_treap_r get_treap_l  by auto
  qed
next
  case ("5_2" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
    obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
    obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
    have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.prems" sub_treap by auto
    have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.prems" sub_treap by auto
    then show ?case
    proof (cases "k = k1")
      case a: True
      have " prios treap_l \<subseteq>  prios  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.IH"(1) 1 a get_treap_l by auto
      moreover have  " prios treap_r \<subseteq>  prios  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.IH"(2) 2 a get_treap_r by auto
      ultimately show ?thesis using a get_treap_r get_treap_l merge_treap_prios_preserve[of treap_l treap_r]  by auto
  next
    case b: False
    have " prios treap_l \<subseteq>  prios  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.IH"(3) 1 b get_treap_l by auto
    moreover have " prios treap_r \<subseteq>  prios  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.IH"(4) 2 b get_treap_r by auto
    ultimately show ?thesis using b get_treap_r get_treap_l  by auto
  qed
qed

lemma treap_del4:
"\<lbrakk>treap t \<rbrakk> \<Longrightarrow>  treap (del k t)"
proof(induction t  rule: del.induct)
  case (1 k)
  then show ?case by auto
next
  case (2 k k1 p1)
  then show ?case by (auto simp: treap_def)
next
  case (3 k l1_l l1_k l1_r k1 p1)
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "3.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    show ?thesis using "3.IH"(1) 1 a by auto
  next
    case b: False

    have "\<forall>k'\<in>keys l1. k' < k1" using  get_l1 "3.prems"  by (auto simp: treap_def)
    moreover have  "keys l1 - {k} = keys treap_l" using get_l1 get_treap_l 1 treap_del2[of l1 k] by auto
    ultimately have keys_ok: "\<forall>k'\<in>keys treap_l. k' < k1"  by auto

    have "\<forall>p'\<in>prios l1. p1 \<le> p'" using  get_l1 "3.prems"  by (auto simp: treap_def)
    moreover have  "prios  treap_l \<subseteq> prios l1" using get_l1 get_treap_l 1 treap_del3[of l1 k] by auto
    ultimately have prios_ok: "\<forall>p'\<in> prios treap_l. p' \<ge> p1"  by auto

    have "treap (treap_l)" using "3.IH"(2) 1 b get_treap_l by (auto)
    then show ?thesis using b get_treap_l treap_union[of treap_l Leaf k1 p1] keys_ok prios_ok by (auto simp: treap_def)
  qed
next
  case (4 k k1 p1 r1_l r1_k r1_r)
  obtain r1 where get_r1: "r1 =  \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "4.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    show ?thesis using "4.IH"(1) 1 a by auto
  next
    case b: False

    have "\<forall>k'\<in>keys r1. k1 < k'" using  get_r1 "4.prems"  by (auto simp: treap_def)
    moreover have  "keys r1 - {k} = keys treap_r" using get_r1 get_treap_r 1 treap_del2[of r1 k] by auto
    ultimately have keys_ok: "\<forall>k'\<in>keys treap_r. k1 < k'"  by auto

    have "\<forall>p'\<in>prios r1. p1 \<le> p'" using  get_r1 "4.prems"  by (auto simp: treap_def)
    moreover have  "prios  treap_r \<subseteq> prios r1" using get_r1 get_treap_r 1 treap_del3[of r1 k] by auto
    ultimately have prios_ok: "\<forall>p'\<in> prios treap_r. p1 \<le> p'"  by auto

    have "treap (treap_r)" using "4.IH"(2) 1 b get_treap_r by (auto)
    then show ?thesis using b get_treap_r treap_union[of Leaf treap_r k1 p1] keys_ok prios_ok by (auto simp: treap_def)
  qed
next
  case ("5_1" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" using get_l1 by (auto)
  obtain r1 where get_r1: "r1 =  \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" using get_r1 by (auto)
  have 1: "treap l1" using get_l1 "5_1.prems" sub_treap by auto
  have 2: "treap r1" using get_r1 "5_1.prems" sub_treap by auto

  have  "\<forall>k'\<in>keys l1. k' < k1" using  get_l1 "5_1.prems"  by (auto simp: treap_def)
  moreover have  "keys l1 - {k} = keys treap_l" using get_l1 get_treap_l 1 treap_del2[of l1 k] by auto
  ultimately have keys_l_ok: "\<forall>k'\<in>keys treap_l. k' < k1" by auto

  have "\<forall>p'\<in>prios l1. p1 \<le> p'" using  get_l1 "5_1.prems"  by (auto simp: treap_def)
  moreover have  "prios  treap_l \<subseteq> prios l1" using get_l1 get_treap_l 1 treap_del3[of l1 k] by auto
  ultimately have prios_l_ok: "\<forall>p'\<in> prios treap_l. p1  \<le> p'"  by auto

  have "\<forall>k'\<in>keys r1. k1 < k'" using  get_r1 "5_1.prems"  by (auto simp: treap_def)
  moreover have  "keys r1 - {k} = keys treap_r" using get_r1 get_treap_r 2 treap_del2[of r1 k] by auto
  ultimately have keys_r_ok: "\<forall>k''\<in>keys treap_r. k'' > k1"  by auto

  have "\<forall>p'\<in>prios r1. p1 \<le> p'" using  get_r1 "5_1.prems"  by (auto simp: treap_def)
  moreover have  "prios  treap_r \<subseteq> prios r1" using get_r1 get_treap_r 2 treap_del3[of r1 k] by auto
  ultimately have prios_r_ok: "\<forall>p'\<in> prios treap_r. p1 \<le> p'"  by auto

  then show ?case
  proof (cases "k = k1")
    case a: True

    have "treap (treap_l)" using "5_1.IH"(1) 1 a get_treap_l get_l1 by (auto)
    moreover have  "treap (treap_r)" using "5_1.IH"(2) 2 a get_treap_r get_r1 by (auto)
    moreover have "\<forall>k'\<in>keys treap_l. \<forall>k''\<in>keys treap_r. k'  <  k''"
      using keys_l_ok keys_r_ok less_trans
      by (blast)
    ultimately show ?thesis
       using merge_treap[of treap_l treap_r] using get_treap_l get_treap_r a by auto
  next
    case b: False

    have "treap (treap_l)" using "5_1.IH"(3) 1 b get_treap_l get_l1 by (auto)
    moreover have  "treap (treap_r)" using "5_1.IH"(4) 2 b get_treap_r get_r1 by (auto)
    ultimately show ?thesis
      using b get_treap_l get_treap_r treap_union[of treap_l treap_r k1 p1] keys_l_ok prios_l_ok keys_r_ok prios_r_ok
      by (auto simp: treap_def)
  qed
next
  case ("5_2" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain treap_l where get_treap_l: "treap_l = del k \<langle>l1_l, l1_k, l1_r\<rangle>" using get_l1 by (auto)
  obtain r1 where get_r1: "r1 =  \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  obtain treap_r where get_treap_r: "treap_r = del k \<langle>r1_l, r1_k, r1_r\<rangle>" using get_r1 by (auto)
  have 1: "treap l1" using get_l1 "5_2.prems" sub_treap by auto
  have 2: "treap r1" using get_r1 "5_2.prems" sub_treap by auto

  have  "\<forall>k'\<in>keys l1. k' < k1" using  get_l1 "5_2.prems"  by (auto simp: treap_def)
  moreover have  "keys l1 - {k} = keys treap_l" using get_l1 get_treap_l 1 treap_del2[of l1 k] by auto
  ultimately have keys_l_ok: "\<forall>k'\<in>keys treap_l. k' < k1" by auto

  have "\<forall>p'\<in>prios l1. p1 \<le> p'" using  get_l1 "5_2.prems"  by (auto simp: treap_def)
  moreover have  "prios  treap_l \<subseteq> prios l1" using get_l1 get_treap_l 1 treap_del3[of l1 k] by auto
  ultimately have prios_l_ok: "\<forall>p'\<in> prios treap_l. p1  \<le> p'"  by auto

  have "\<forall>k'\<in>keys r1. k1 < k'" using  get_r1 "5_2.prems"  by (auto simp: treap_def)
  moreover have  "keys r1 - {k} = keys treap_r" using get_r1 get_treap_r 2 treap_del2[of r1 k] by auto
  ultimately have keys_r_ok: "\<forall>k''\<in>keys treap_r. k'' > k1"  by auto

  have "\<forall>p'\<in>prios r1. p1 \<le> p'" using  get_r1 "5_2.prems"  by (auto simp: treap_def)
  moreover have  "prios  treap_r \<subseteq> prios r1" using get_r1 get_treap_r 2 treap_del3[of r1 k] by auto
  ultimately have prios_r_ok: "\<forall>p'\<in> prios treap_r. p1 \<le> p'"  by auto

  then show ?case
  proof (cases "k = k1")
    case a: True

    have "treap (treap_l)" using "5_2.IH"(1) 1 a get_treap_l get_l1 by (auto)
    moreover have  "treap (treap_r)" using "5_2.IH"(2) 2 a get_treap_r get_r1 by (auto)
    moreover have "\<forall>k'\<in>keys treap_l. \<forall>k''\<in>keys treap_r. k'  <  k''"
      using keys_l_ok keys_r_ok less_trans
      by (blast)
    ultimately show ?thesis
       using merge_treap[of treap_l treap_r] using get_treap_l get_treap_r a by auto
  next
    case b: False

    have "treap (treap_l)" using "5_2.IH"(3) 1 b get_treap_l get_l1 by (auto)
    moreover have  "treap (treap_r)" using "5_2.IH"(4) 2 b get_treap_r get_r1 by (auto)
    ultimately show ?thesis
      using b get_treap_l get_treap_r treap_union[of treap_l treap_r k1 p1] keys_l_ok prios_l_ok keys_r_ok prios_r_ok
      by (auto simp: treap_def)
  qed
qed

lemma treap_del5:
"\<lbrakk>treap t; k \<notin> keys t \<rbrakk> \<Longrightarrow>  t = (del k t)"
proof(induction t  rule: del.induct)
  case (1 k)
  then show ?case by auto
next
  case (2 k k1 p1)
  then show ?case by auto
next
  case (3 k l1_l l1_k l1_r k1 p1)
  obtain t where get_t: "t =  \<langle>\<langle>l1_l, l1_k, l1_r\<rangle>, (k1,p1), Leaf \<rangle>" by auto
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "3.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    then have " k \<in> keys t " using get_t  by (auto simp: treap_def)
    then show ?thesis using a "3.prems"(2) by auto
  next
    case b: False

    have "keys l1 \<subseteq> keys t" using get_t get_l1 by (auto simp: treap_def)
    then have "k \<notin> keys l1" using get_t get_l1 "3.prems" by auto
    then show ?thesis using "3.IH"(2) 1 b get_l1 by auto
  qed
next
  case (4 k k1 p1 r1_l r1_k r1_r)
  obtain t where get_t: "t =  \<langle>Leaf, (k1,p1), \<langle>r1_l, r1_k, r1_r\<rangle>\<rangle>" by auto
  obtain r1 where get_r1: "r1 = \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "4.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    then have " k \<in> keys t " using get_t  by (auto simp: treap_def)
    then show ?thesis using a "4.prems"(2) by auto
  next
    case b: False

    have "keys r1 \<subseteq> keys t" using get_t get_r1 by (auto simp: treap_def)
    then have "k \<notin> keys r1" using get_t get_r1 "4.prems" by auto
    then show ?thesis using "4.IH"(2) 2 b get_r1 by auto
  qed
next
  case ("5_1" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
  obtain t where get_t: "t =  \<langle>\<langle>l1_l, l1_k, l1_r\<rangle>, (k1,p1),  \<langle>r1_l, r1_k, r1_r\<rangle>\<rangle>" by auto
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain r1 where get_r1: "r1 = \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_1.prems" sub_treap by auto
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_1.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    then have " k \<in> keys t " using get_t  by (auto simp: treap_def)
    then show ?thesis using a "5_1.prems"(2) by auto
  next
    case b: False

    have "keys l1 \<subseteq> keys t" using get_t get_l1 by (auto simp: treap_def)
    then have "k \<notin> keys l1" using get_t get_l1 "5_1.prems" by auto
    then have l1_ok: "l1 = del k l1" using get_l1 1 "5_1.IH"(3) b by auto

    have "keys r1 \<subseteq> keys t" using get_t get_r1 by (auto simp: treap_def)
    then have "k \<notin> keys r1" using get_t get_r1 "5_1.prems" by auto
    then have r1_ok: "r1 = del k r1" using get_r1 2 "5_1.IH"(4) b by auto

    show ?thesis using b get_l1 get_r1 l1_ok r1_ok by auto
  qed
next
  case ("5_2" k l1_l l1_k l1_r k1 p1 r1_l r1_k r1_r)
 obtain t where get_t: "t =  \<langle>\<langle>l1_l, l1_k, l1_r\<rangle>, (k1,p1),  \<langle>r1_l, r1_k, r1_r\<rangle>\<rangle>" by auto
  obtain l1 where get_l1: "l1 =  \<langle>l1_l, l1_k, l1_r\<rangle>" by (auto)
  obtain r1 where get_r1: "r1 = \<langle>r1_l, r1_k, r1_r\<rangle>" by (auto)
  have 1: "treap  \<langle>l1_l, l1_k, l1_r\<rangle>" using "5_2.prems" sub_treap by auto
  have 2: "treap  \<langle>r1_l, r1_k, r1_r\<rangle>" using "5_2.prems" sub_treap by auto
  then show ?case
  proof (cases "k = k1")
    case a: True
    then have " k \<in> keys t " using get_t  by (auto simp: treap_def)
    then show ?thesis using a "5_2.prems"(2) by auto
  next
    case b: False

    have "keys l1 \<subseteq> keys t" using get_t get_l1 by (auto simp: treap_def)
    then have "k \<notin> keys l1" using get_t get_l1 "5_2.prems" by auto
    then have l1_ok: "l1 = del k l1" using get_l1 1 "5_2.IH"(3) b by auto

    have "keys r1 \<subseteq> keys t" using get_t get_r1 by (auto simp: treap_def)
    then have "k \<notin> keys r1" using get_t get_r1 "5_2.prems" by auto
    then have r1_ok: "r1 = del k r1" using get_r1 2 "5_2.IH"(4) b by auto

    show ?thesis using b get_l1 get_r1 l1_ok r1_ok by auto
  qed
qed

end


section \<open>Missing Lemmas on Vectors and Matrices\<close>

text \<open>We provide some results on vector spaces which should be merged into Jordan-Normal-Form/Matrix.\<close>
theory Missing_Matrix
  imports Jordan_Normal_Form.Matrix
begin

lemma orthogonalD': assumes "orthogonal vs"
  and "v \<in> set vs" and "w \<in> set vs"
shows "(v \<bullet> w = 0) = (v \<noteq> w)"
proof -
  from assms(2) obtain i where v: "v = vs ! i" and i: "i < length vs" by (auto simp: set_conv_nth)
  from assms(3) obtain j where w: "w = vs ! j" and j: "j < length vs" by (auto simp: set_conv_nth)
  from orthogonalD[OF assms(1) i j, folded v w] orthogonalD[OF assms(1) i i, folded v v]
  show ?thesis using v w by auto
qed

lemma zero_mat_mult_vector[simp]: "x \<in> carrier_vec nc \<Longrightarrow> 0\<^sub>m nr nc *\<^sub>v x = 0\<^sub>v nr"
  by (intro eq_vecI, auto)

lemma add_diff_cancel_right_vec:
  "a \<in> carrier_vec n \<Longrightarrow> (b :: 'a :: cancel_ab_semigroup_add vec) \<in> carrier_vec n \<Longrightarrow>
    (a + b) - b = a"
  by (intro eq_vecI, auto)

lemma elements_four_block_mat_id:
  assumes c: "A \<in> carrier_mat nr1 nc1" "B \<in> carrier_mat nr1 nc2"
    "C \<in> carrier_mat nr2 nc1" "D \<in> carrier_mat nr2 nc2"
  shows
    "elements_mat (four_block_mat A B C D) =
   elements_mat A \<union> elements_mat B \<union> elements_mat C \<union> elements_mat D"
    (is "elements_mat ?four = ?X")
proof
  show "elements_mat ?four \<subseteq> ?X"
    by (rule elements_four_block_mat[OF c])
  have 4: "?four \<in> carrier_mat (nr1 + nr2) (nc1 + nc2)" using c by auto
  {
    fix x
    assume "x \<in> ?X"
    then consider (A) "x \<in> elements_mat A"
      | (B) "x \<in> elements_mat B"
      | (C) "x \<in> elements_mat C"
      | (D) "x \<in> elements_mat D" by auto
    hence "x \<in> elements_mat ?four"
    proof (cases)
      case A
      from elements_matD[OF this] obtain i j
        where *: "i < nr1" "j < nc1" and x: "x = A $$ (i,j)"
        using c by auto
      from elements_matI[OF 4, of i j x] * c
      show ?thesis unfolding x by auto
    next
      case B
      from elements_matD[OF this] obtain i j
        where *: "i < nr1" "j < nc2" and x: "x = B $$ (i,j)"
        using c by auto
      from elements_matI[OF 4, of i "nc1 + j" x] * c
      show ?thesis unfolding x by auto
    next
      case C
      from elements_matD[OF this] obtain i j
        where *: "i < nr2" "j < nc1" and x: "x = C $$ (i,j)"
        using c by auto
      from elements_matI[OF 4, of "nr1 + i" j x] * c
      show ?thesis unfolding x by auto
    next
      case D
      from elements_matD[OF this] obtain i j
        where *: "i < nr2" "j < nc2" and x: "x = D $$ (i,j)"
        using c by auto
      from elements_matI[OF 4, of "nr1 + i" "nc1 + j" x] * c
      show ?thesis unfolding x by auto
    qed
  }
  thus "elements_mat ?four \<supseteq> ?X" by blast
qed

lemma elements_mat_append_rows: "A \<in> carrier_mat nr n \<Longrightarrow> B \<in> carrier_mat nr2 n \<Longrightarrow>
  elements_mat (A @\<^sub>r B) = elements_mat A \<union> elements_mat B"
  unfolding append_rows_def
  by (subst elements_four_block_mat_id, auto)

lemma elements_mat_uminus[simp]: "elements_mat (-A) = uminus ` elements_mat A"
  unfolding elements_mat_def by auto

lemma vec_set_uminus[simp]: "vec_set (-A) = uminus ` vec_set A"
  unfolding vec_set_def by auto

definition append_cols :: "'a :: zero mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat"  (infixr "@\<^sub>c" 65) where
  "A @\<^sub>c B = (A\<^sup>T @\<^sub>r B\<^sup>T)\<^sup>T"

lemma carrier_append_cols[simp, intro]:
  "A \<in> carrier_mat nr nc1 \<Longrightarrow>
   B \<in> carrier_mat nr nc2 \<Longrightarrow> (A @\<^sub>c B) \<in> carrier_mat nr (nc1 + nc2)"
  unfolding append_cols_def by auto

lemma elements_mat_transpose_mat[simp]: "elements_mat (A\<^sup>T) = elements_mat A"
  unfolding elements_mat_def by auto

lemma elements_mat_append_cols: "A \<in> carrier_mat n nc \<Longrightarrow> B \<in> carrier_mat n nc1
  \<Longrightarrow> elements_mat (A @\<^sub>c B) = elements_mat A \<union> elements_mat B"
  unfolding append_cols_def elements_mat_transpose_mat
  by (subst elements_mat_append_rows, auto)

lemma vec_first_index:
  assumes v: "dim_vec v \<ge> n"
    and i: "i < n"
  shows "(vec_first v n) $ i = v $ i"
  unfolding vec_first_def using assms by simp

lemma vec_last_index:
  assumes v: "v \<in> carrier_vec (n + m)"
    and i: "i < m"
  shows "(vec_last v m) $ i = v $ (n + i)"
  unfolding vec_last_def using assms by simp

lemma vec_first_add:
  assumes "dim_vec x \<ge> n"
    and "dim_vec y \<ge> n"
  shows"vec_first (x + y) n = vec_first x n + vec_first y n"
  unfolding vec_first_def using assms by auto

lemma vec_first_zero[simp]: "m \<le> n \<Longrightarrow> vec_first (0\<^sub>v n) m = 0\<^sub>v m"
  unfolding vec_first_def by auto

lemma vec_first_smult:
  "\<lbrakk> m \<le> n; x \<in> carrier_vec n \<rbrakk> \<Longrightarrow> vec_first (c \<cdot>\<^sub>v x) m = c \<cdot>\<^sub>v vec_first x m"
  unfolding vec_first_def by auto

lemma elements_mat_mat_of_row[simp]: "elements_mat (mat_of_row v) = vec_set v"
  by (auto simp: mat_of_row_def elements_mat_def vec_set_def)

lemma vec_set_append_vec[simp]: "vec_set (v @\<^sub>v w) = vec_set v \<union> vec_set w"
  by (metis list_of_vec_append set_append set_list_of_vec)

lemma vec_set_vNil[simp]: "set\<^sub>v vNil = {}" using set_list_of_vec by force

lemma add_diff_eq_vec: fixes y :: "'a :: group_add vec"
  shows "y \<in> carrier_vec n \<Longrightarrow> x \<in> carrier_vec n \<Longrightarrow> z \<in> carrier_vec n \<Longrightarrow> y + (x - z) = y + x - z"
  by (intro eq_vecI, auto simp: add_diff_eq)

definition "mat_of_col v = (mat_of_row v)\<^sup>T"

lemma elements_mat_mat_of_col[simp]: "elements_mat (mat_of_col v) = vec_set v"
  unfolding mat_of_col_def by auto

lemma mat_of_col_dim[simp]: "dim_row (mat_of_col v) = dim_vec v"
  "dim_col (mat_of_col v) = 1"
  "mat_of_col v \<in> carrier_mat (dim_vec v) 1"
  unfolding mat_of_col_def by auto

lemma col_mat_of_col[simp]: "col (mat_of_col v) 0 = v"
  unfolding mat_of_col_def by auto

lemma mult_mat_of_col: "A \<in> carrier_mat nr nc \<Longrightarrow> v \<in> carrier_vec nc \<Longrightarrow>
                        A * mat_of_col v = mat_of_col (A *\<^sub>v v)"
  by (intro mat_col_eqI, auto)

lemma mat_mult_append_cols: fixes A :: "'a :: comm_semiring_0 mat"
  assumes A: "A \<in> carrier_mat nr nc1"
    and B: "B \<in> carrier_mat nr nc2"
    and v1: "v1 \<in> carrier_vec nc1"
    and v2: "v2 \<in> carrier_vec nc2"
  shows "(A @\<^sub>c B) *\<^sub>v (v1 @\<^sub>v v2) = A *\<^sub>v v1 + B *\<^sub>v v2"
proof -
  have "(A @\<^sub>c B) *\<^sub>v (v1 @\<^sub>v v2) = (A @\<^sub>c B) *\<^sub>v col (mat_of_col (v1 @\<^sub>v v2)) 0" by auto
  also have "\<dots> = col ((A @\<^sub>c B) * mat_of_col (v1 @\<^sub>v v2)) 0" by auto
  also have "(A @\<^sub>c B) * mat_of_col (v1 @\<^sub>v v2) = ((A @\<^sub>c B) * mat_of_col (v1 @\<^sub>v v2))\<^sup>T\<^sup>T"
    by auto
  also have "((A @\<^sub>c B) * mat_of_col (v1 @\<^sub>v v2))\<^sup>T =
             (mat_of_row (v1 @\<^sub>v v2))\<^sup>T\<^sup>T * (A\<^sup>T @\<^sub>r B\<^sup>T)\<^sup>T\<^sup>T"
    unfolding append_cols_def mat_of_col_def
  proof (rule transpose_mult, force, unfold transpose_carrier_mat, rule mat_of_row_carrier)
    have "A\<^sup>T \<in> carrier_mat nc1 nr" using A by auto
    moreover have "B\<^sup>T \<in> carrier_mat nc2 nr" using B by auto
    ultimately have "A\<^sup>T @\<^sub>r B\<^sup>T \<in> carrier_mat (nc1 + nc2) nr" by auto
    hence "dim_row (A\<^sup>T @\<^sub>r B\<^sup>T) = nc1 + nc2" by auto
    thus "v1 @\<^sub>v v2 \<in> carrier_vec (dim_row (A\<^sup>T @\<^sub>r B\<^sup>T))" using v1 v2 by auto
  qed
  also have "\<dots> = (mat_of_row (v1 @\<^sub>v v2)) * (A\<^sup>T @\<^sub>r B\<^sup>T)" by auto
  also have "\<dots> = mat_of_row v1 * A\<^sup>T + mat_of_row v2 * B\<^sup>T"
    using mat_of_row_mult_append_rows[OF v1 v2] A B by auto
  also have "\<dots>\<^sup>T = (mat_of_row v1 * A\<^sup>T)\<^sup>T + (mat_of_row v2 * B\<^sup>T)\<^sup>T"
    using transpose_add A B by auto
  also have "(mat_of_row v1 * A\<^sup>T)\<^sup>T = A\<^sup>T\<^sup>T * ((mat_of_row v1)\<^sup>T)"
    using transpose_mult A v1 transpose_carrier_mat mat_of_row_carrier(1)
    by metis
  also have "(mat_of_row v2 * B\<^sup>T)\<^sup>T = B\<^sup>T\<^sup>T * ((mat_of_row v2)\<^sup>T)"
    using transpose_mult B v2 transpose_carrier_mat mat_of_row_carrier(1)
    by metis
  also have "A\<^sup>T\<^sup>T * ((mat_of_row v1)\<^sup>T) + B\<^sup>T\<^sup>T * ((mat_of_row v2)\<^sup>T) =
             A * mat_of_col v1 + B * mat_of_col v2"
    unfolding mat_of_col_def by auto
  also have "col \<dots> 0 = col (A * mat_of_col v1) 0 + col (B * mat_of_col v2) 0"
    using assms by auto
  also have "\<dots> = col (mat_of_col (A *\<^sub>v v1)) 0 + col (mat_of_col (B *\<^sub>v v2)) 0"
    using mult_mat_of_col assms by auto
  also have "\<dots> = A *\<^sub>v v1 + B *\<^sub>v v2" by auto
  finally show ?thesis by auto
qed

lemma vec_first_append:
  assumes "v \<in> carrier_vec n"
  shows "vec_first (v @\<^sub>v w) n = v"
proof -
  have "v @\<^sub>v w = vec_first (v @\<^sub>v w) n @\<^sub>v vec_last (v @\<^sub>v w) (dim_vec w)"
    using vec_first_last_append assms by simp
  thus ?thesis using append_vec_eq[OF assms] by simp
qed

lemma vec_le_iff_diff_le_0: fixes a :: "'a :: ordered_ab_group_add vec"
  shows "(a \<le> b) = (a - b \<le> 0\<^sub>v (dim_vec a))"
  unfolding less_eq_vec_def by auto

definition "mat_row_first A n \<equiv> mat n (dim_col A) (\<lambda> (i, j). A $$ (i, j))"

definition "mat_row_last A n \<equiv> mat n (dim_col A) (\<lambda> (i, j). A $$ (dim_row A - n + i, j))"

lemma mat_row_first_carrier[simp]: "mat_row_first A n \<in> carrier_mat n (dim_col A)"
  unfolding mat_row_first_def by simp

lemma mat_row_first_dim[simp]:
  "dim_row (mat_row_first A n) = n"
  "dim_col (mat_row_first A n) = dim_col A"
  unfolding mat_row_first_def by simp_all

lemma mat_row_last_carrier[simp]: "mat_row_last A n \<in> carrier_mat n (dim_col A)"
  unfolding mat_row_last_def by simp

lemma mat_row_last_dim[simp]:
  "dim_row (mat_row_last A n) = n"
  "dim_col (mat_row_last A n) = dim_col A"
  unfolding mat_row_last_def by simp_all

lemma mat_row_first_nth[simp]: "i < n \<Longrightarrow> row (mat_row_first A n) i = row A i"
  unfolding mat_row_first_def row_def by fastforce

lemma append_rows_nth:
  assumes "A \<in> carrier_mat nr1 nc"
    and "B \<in> carrier_mat nr2 nc"
  shows "i < nr1 \<Longrightarrow> row (A @\<^sub>r B) i = row A i"
    and "\<lbrakk> i \<ge> nr1; i < nr1 + nr2 \<rbrakk> \<Longrightarrow> row (A @\<^sub>r B) i = row B (i - nr1)"
  unfolding append_rows_def using row_four_block_mat assms by auto

lemma mat_of_row_last_nth[simp]:
  "i < n \<Longrightarrow> row (mat_row_last A n) i = row A (dim_row A - n + i)"
  unfolding mat_row_last_def row_def by auto

lemma mat_row_first_last_append:
  assumes "dim_row A = m + n"
  shows "(mat_row_first A m) @\<^sub>r (mat_row_last A n) = A"
proof (rule eq_rowI)
  show "dim_row (mat_row_first A m @\<^sub>r mat_row_last A n) = dim_row A"
    unfolding append_rows_def using assms by fastforce
  show "dim_col (mat_row_first A m @\<^sub>r mat_row_last A n) = dim_col A"
    unfolding append_rows_def by fastforce
  fix i
  assume i: "i < dim_row A"
  show "row (mat_row_first A m @\<^sub>r mat_row_last A n) i = row A i"
  proof cases
    assume i: "i < m"
    thus ?thesis using append_rows_nth(1)[OF mat_row_first_carrier[of A m]
          mat_row_last_carrier[of A n] i] by simp
  next
    assume i': "\<not> i < m"
    thus ?thesis using append_rows_nth(2)[OF mat_row_first_carrier[of A m]
          mat_row_last_carrier[of A n]] i assms by simp
  qed
qed

definition "mat_col_first A n \<equiv> (mat_row_first A\<^sup>T n)\<^sup>T"

definition "mat_col_last A n \<equiv> (mat_row_last A\<^sup>T n)\<^sup>T"

lemma mat_col_first_carrier[simp]: "mat_col_first A n \<in> carrier_mat (dim_row A) n"
  unfolding mat_col_first_def by fastforce

lemma mat_col_first_dim[simp]:
  "dim_row (mat_col_first A n) = dim_row A"
  "dim_col (mat_col_first A n) = n"
  unfolding mat_col_first_def by simp_all

lemma mat_col_last_dim[simp]:
  "dim_row (mat_col_last A n) = dim_row A"
  "dim_col (mat_col_last A n) = n"
  unfolding mat_col_last_def by simp_all

lemma mat_col_first_nth[simp]:
  "\<lbrakk> i < n; i < dim_col A \<rbrakk> \<Longrightarrow> col (mat_col_first A n) i = col A i"
  unfolding mat_col_first_def by force

lemma append_cols_nth:
  assumes "A \<in> carrier_mat nr nc1"
    and "B \<in> carrier_mat nr nc2"
  shows "i < nc1 \<Longrightarrow> col (A @\<^sub>c B) i = col A i"
    and "\<lbrakk> i \<ge> nc1; i < nc1 + nc2 \<rbrakk> \<Longrightarrow> col (A @\<^sub>c B) i = col B (i - nc1)"
  unfolding append_cols_def append_rows_def using row_four_block_mat assms
  by auto

lemma mat_of_col_last_nth[simp]:
  "\<lbrakk> i < n; i < dim_col A \<rbrakk> \<Longrightarrow> col (mat_col_last A n) i = col A (dim_col A - n + i)"
  unfolding mat_col_last_def by auto

lemma mat_col_first_last_append:
  assumes "dim_col A = m + n"
  shows "(mat_col_first A m) @\<^sub>c (mat_col_last A n) = A"
  unfolding append_cols_def mat_col_first_def mat_col_last_def
  using mat_row_first_last_append[of "A\<^sup>T"] assms by simp

lemma mat_of_row_dim_row_1: "(dim_row A = 1) = (A = mat_of_row (row A 0))"
proof
  show "dim_row A = 1 \<Longrightarrow> A = mat_of_row (row A 0)" by force
  show "A = mat_of_row (row A 0) \<Longrightarrow> dim_row A = 1" using mat_of_row_dim(1) by metis
qed

lemma mat_of_col_dim_col_1: "(dim_col A = 1) = (A = mat_of_col (col A 0))"
proof
  show "dim_col A = 1 \<Longrightarrow> A = mat_of_col (col A 0)"
    unfolding mat_of_col_def by auto
  show "A = mat_of_col (col A 0) \<Longrightarrow> dim_col A = 1" by (metis mat_of_col_dim(2))
qed

definition vec_of_scal :: "'a \<Rightarrow> 'a vec" where "vec_of_scal x \<equiv> vec 1 (\<lambda> i. x)"

lemma vec_of_scal_dim[simp]:
  "dim_vec (vec_of_scal x) = 1"
  "vec_of_scal x \<in> carrier_vec 1"
  unfolding vec_of_scal_def by auto

lemma index_vec_of_scal[simp]: "(vec_of_scal x) $ 0 = x"
  unfolding vec_of_scal_def by auto

lemma row_mat_of_col[simp]: "i < dim_vec v \<Longrightarrow> row (mat_of_col v) i = vec_of_scal (v $ i)"
  unfolding mat_of_col_def by auto

lemma vec_of_scal_dim_1: "(v \<in> carrier_vec 1) = (v = vec_of_scal (v $ 0))"
  by(standard, auto simp del: One_nat_def, metis vec_of_scal_dim(2))

lemma mult_mat_of_row_vec_of_scal: fixes x :: "'a :: comm_ring_1"
  shows "mat_of_col v *\<^sub>v vec_of_scal x = x \<cdot>\<^sub>v v"
  by (auto simp add: scalar_prod_def)

lemma smult_pos_vec[simp]: fixes l :: "'a :: linordered_ring_strict"
  assumes l: "l > 0"
  shows "(l \<cdot>\<^sub>v v \<le> 0\<^sub>v n) = (v \<le> 0\<^sub>v n)"
proof (cases "dim_vec v = n")
  case True
  have "i < n \<Longrightarrow> ((l \<cdot>\<^sub>v v) $ i \<le> 0) \<longleftrightarrow> v $ i \<le> 0" for i using True
      mult_le_cancel_left_pos[OF l, of _ 0] by simp
  thus ?thesis using True unfolding less_eq_vec_def by auto
qed (auto simp: less_eq_vec_def)

lemma finite_elements_mat[simp]: "finite (elements_mat A)"
  unfolding elements_mat_def by (rule finite_set)

lemma finite_vec_set[simp]: "finite (vec_set A)"
  unfolding vec_set_def by auto

lemma lesseq_vecI: assumes "v \<in> carrier_vec n" "w \<in> carrier_vec n"
  "\<And> i. i < n \<Longrightarrow> v $ i \<le> w $ i"
shows "v \<le> w"
  using assms unfolding less_eq_vec_def by auto

lemma lesseq_vecD: assumes "w \<in> carrier_vec n"
  and "v \<le> w"
  and "i < n"
shows "v $ i \<le> w $ i"
  using assms unfolding less_eq_vec_def by auto

lemma vec_add_mono: fixes a :: "'a :: ordered_ab_semigroup_add vec"
  assumes dim: "dim_vec b = dim_vec d"
    and ab: "a \<le> b"
    and cd: "c \<le> d"
  shows "a + c \<le> b + d"
proof -
  have "\<And> i. i < dim_vec d \<Longrightarrow> (a + c) $ i \<le> (b + d) $ i"
  proof -
    fix i
    assume id: "i < dim_vec d"
    have ic: "i < dim_vec c" using id cd unfolding less_eq_vec_def by auto
    have ib: "i < dim_vec b" using id dim by auto
    have ia: "i < dim_vec a" using ib ab unfolding less_eq_vec_def by auto
    have "a $ i \<le> b $ i" using ab ia ib unfolding less_eq_vec_def by auto
    moreover have "c $ i \<le> d $ i" using cd ic id unfolding less_eq_vec_def by auto
    ultimately have abcdi: "a $ i + c $ i \<le> b $ i + d $ i" using add_mono by auto
    have "(a + c) $ i = a $ i + c $ i" using index_add_vec(1) ic by auto
    also have "\<dots> \<le> b $ i + d $ i" using abcdi by auto
    also have "b $ i + d $ i = (b + d) $ i" using index_add_vec(1) id by auto
    finally show "(a + c) $ i \<le> (b + d) $ i" by auto
  qed
  then show "a + c \<le> b + d" unfolding less_eq_vec_def
    using dim index_add_vec(2) cd less_eq_vec_def by auto
qed

lemma smult_nneg_npos_vec: fixes l :: "'a :: ordered_semiring_0"
  assumes l: "l \<ge> 0"
    and v: "v \<le> 0\<^sub>v n"
  shows "l \<cdot>\<^sub>v v \<le> 0\<^sub>v n"
proof -
  {
    fix i
    assume i: "i < n"
    then have vi: "v $ i \<le> 0" using v unfolding less_eq_vec_def by simp
    then have "(l \<cdot>\<^sub>v v) $ i = l * v $ i" using v i unfolding less_eq_vec_def by auto
    also have "l * v $ i \<le> 0" by (rule mult_nonneg_nonpos[OF l vi])
    finally have "(l \<cdot>\<^sub>v v) $ i \<le> 0" by auto
  }
  then show ?thesis using v unfolding less_eq_vec_def by auto
qed

lemma smult_vec_nonneg_eq: fixes c :: "'a :: field"
  shows "c \<noteq> 0 \<Longrightarrow> (c \<cdot>\<^sub>v x = c \<cdot>\<^sub>v y) = (x = y)"
proof -
  have "c \<noteq> 0 \<Longrightarrow> c \<cdot>\<^sub>v x = c \<cdot>\<^sub>v y \<Longrightarrow> x = y"
    by (metis smult_smult_assoc[of "1 / c" "c"] nonzero_divide_eq_eq one_smult_vec)
  thus "c \<noteq> 0 \<Longrightarrow> ?thesis" by auto
qed

lemma distinct_smult_nonneg: fixes c :: "'a :: field"
  assumes c: "c \<noteq> 0"
  shows "distinct lC \<Longrightarrow> distinct (map ((\<cdot>\<^sub>v) c) lC)"
proof (induction lC)
  case (Cons v lC)
  from Cons.prems have "v \<notin> set lC" by fastforce
  hence "c \<cdot>\<^sub>v v \<notin> set (map ((\<cdot>\<^sub>v) c) lC)" using smult_vec_nonneg_eq[OF c] by fastforce
  moreover have "map ((\<cdot>\<^sub>v) c) (v # lC) = c \<cdot>\<^sub>v v # map ((\<cdot>\<^sub>v) c) lC" by simp
  ultimately show ?case using Cons.IH Cons.prems by simp
qed auto

lemma exists_vec_append: "(\<exists> x \<in> carrier_vec (n + m). P x) \<longleftrightarrow> (\<exists> x1 \<in> carrier_vec n. \<exists> x2 \<in> carrier_vec m. P (x1 @\<^sub>v x2))"
proof
  assume "\<exists>x \<in> carrier_vec (n + m). P x"
  from this obtain x where xcarr: "x \<in> carrier_vec (n+m)" and Px: "P x" by auto
  have "x = vec n (\<lambda> i. x $ i) @\<^sub>v vec m (\<lambda> i. x $ (n + i))"
    by (rule eq_vecI, insert xcarr, auto)
  hence "P x = P (vec n (\<lambda> i. x $ i) @\<^sub>v vec m (\<lambda> i. x $ (n + i)))" by simp
  also have 1: "\<dots>" using xcarr Px calculation by blast
  finally show "\<exists>x1\<in>carrier_vec n. \<exists>x2\<in>carrier_vec m. P (x1 @\<^sub>v x2)" using 1 vec_carrier by blast
next
  assume "(\<exists> x1 \<in> carrier_vec n. \<exists> x2 \<in> carrier_vec m. P (x1 @\<^sub>v x2))"
  from this obtain x1 x2 where x1: "x1 \<in> carrier_vec n"
    and x2: "x2 \<in> carrier_vec m" and P12: "P (x1 @\<^sub>v x2)" by auto
  define x where "x = x1 @\<^sub>v x2"
  have xcarr: "x \<in> carrier_vec (n+m)" using x1 x2 by (simp add: x_def)
  have "P x" using P12 xcarr using x_def by blast
  then show "(\<exists> x \<in> carrier_vec (n + m). P x)" using xcarr by auto
qed

end


(* Author: R. Thiemann *)

subsection \<open>Perron-Frobenius theorem via Brouwer's fixpoint theorem.\<close>

theory Perron_Frobenius
imports
  "HOL-Analysis.Brouwer_Fixpoint"
  Perron_Frobenius_Aux
begin

text \<open>We follow the textbook proof of Serre \<^cite>\<open>\<open>Theorem 5.2.1\<close> in "SerreMatrices"\<close>.\<close>

context
  fixes A :: "complex ^ 'n ^ 'n :: finite"
  assumes rnnA: "real_non_neg_mat A"
begin

private abbreviation(input) sr where "sr \<equiv> spectral_radius A"

private definition max_v_ev :: "(complex^'n) \<times> complex" where
  "max_v_ev = (SOME v_ev. eigen_vector A (fst v_ev) (snd v_ev)
  \<and> norm (snd v_ev) = sr)"

private definition "max_v = (1 / norm1 (fst max_v_ev)) *\<^sub>R fst max_v_ev"
private definition "max_ev = snd max_v_ev"

private lemma max_v_ev:
  "eigen_vector A max_v max_ev"
  "norm max_ev = sr"
  "norm1 max_v = 1"
proof -
  obtain v ev where id: "max_v_ev = (v,ev)" by force
  from spectral_radius_ev[of A] someI_ex[of "\<lambda> v_ev. eigen_vector A (fst v_ev) (snd v_ev)
  \<and> norm (snd v_ev) = sr", folded max_v_ev_def, unfolded id]
  have v: "eigen_vector A v ev" and ev: "norm ev = sr" by auto
  from normalize_eigen_vector[OF v] ev
  show "eigen_vector A max_v max_ev" "norm max_ev = sr" "norm1 max_v = 1"
    unfolding max_v_def max_ev_def id by auto
qed

text \<open>In the definition of S, we use the linear norm instead of the
  default euclidean norm which is defined via the type-class.
  The reason is that S is not convex if one uses the euclidean norm.\<close>

private definition B :: "real ^ 'n ^ 'n" where "B \<equiv> \<chi> i j. Re (A $ i $ j)"
private definition S where "S = {v :: real ^ 'n . norm1 v = 1 \<and> (\<forall> i. v $ i \<ge> 0) \<and>
  (\<forall> i. (B *v v) $ i \<ge> sr * (v $ i))}"
private definition f :: "real ^ 'n \<Rightarrow> real ^ 'n" where
  "f v = (1 / norm1 (B *v v)) *\<^sub>R (B *v v)"

private

private lemma boundedS: "bounded S"
proof -
  {
    fix v :: "real ^ 'n"
    from norm1_ge_norm[of v] have "norm1 v = 1 \<Longrightarrow> norm v \<le> 1" by auto
  }
  thus ?thesis
  unfolding S_def bounded_iff
  by (auto intro!: exI[of _ 1])
qed

private lemma compactS: "compact S"
  using boundedS closedS
  by (simp add: compact_eq_bounded_closed)

private lemmas rnn = real_non_neg_matD[OF rnnA]

lemma B_norm: "B $ i $ j = norm (A $ i $ j)"
  using rnn[of i j]
  by (cases "A $ i $ j", auto simp: B_def)

lemma mult_B_mono: assumes "\<And> i. v $ i \<ge> w $ i"
  shows "(B *v v) $ i \<ge> (B *v w) $ i" unfolding matrix_vector_mult_def vec_lambda_beta
  by (rule sum_mono, rule mult_left_mono[OF assms], unfold B_norm, auto)

private lemma non_emptyS: "S \<noteq> {}"
proof -
  let ?v = "(\<chi> i. norm (max_v $ i)) :: real ^ 'n"
  have "norm1 max_v = 1" by (rule max_v_ev(3))
  hence nv: "norm1 ?v = 1" unfolding norm1_def by auto
  {
    fix i
    have "sr * (?v $ i) = sr * norm (max_v $ i)" by auto
    also have "\<dots> = (norm max_ev) * norm (max_v $ i)" using max_v_ev by auto
    also have "\<dots> = norm ((max_ev *s max_v) $ i)" by (auto simp: norm_mult)
    also have "max_ev *s max_v = A *v max_v" using max_v_ev(1)[unfolded eigen_vector_def] by auto
    also have "norm ((A *v max_v) $ i) \<le> (B *v ?v) $ i"
      unfolding matrix_vector_mult_def vec_lambda_beta
      by (rule sum_norm_le, auto simp: norm_mult B_norm)
    finally have "sr * (?v $ i) \<le> (B *v ?v) $ i" .
  } note le = this
  have "?v \<in> S" unfolding S_def using nv le by auto
  thus ?thesis by blast
qed

private lemma convexS: "convex S"
proof (rule convexI)
  fix v w a b
  assume *: "v \<in> S" "w \<in> S" "0 \<le> a" "0 \<le> b" "a + b = (1 :: real)"
  let ?lin = "a *\<^sub>R v + b *\<^sub>R w"
  from * have 1: "norm1 v = 1" "norm1 w = 1" unfolding S_def by auto
  have "norm1 ?lin = a * norm1 v + b * norm1 w"
    unfolding norm1_def sum_distrib_left sum.distrib[symmetric]
  proof (rule sum.cong)
    fix i :: 'n
    from * have "v $ i \<ge> 0" "w $ i \<ge> 0" unfolding S_def by auto
    thus "norm (?lin $ i) = a * norm (v $ i) + b * norm (w $ i)"
      using *(3-4) by auto
  qed simp
  also have "\<dots> = 1" using *(5) 1 by auto
  finally have norm1: "norm1 ?lin = 1" .
  {
    fix i
    from * have "0 \<le> v $ i" "sr * v $ i \<le> (B *v v) $ i" unfolding S_def by auto
    with \<open>a \<ge> 0\<close> have a: "a * (sr * v $ i) \<le> a * (B *v v) $ i" by (intro mult_left_mono)
    from * have "0 \<le> w $ i" "sr * w $ i \<le> (B *v w) $ i" unfolding S_def by auto
    with \<open>b \<ge> 0\<close> have b: "b * (sr * w $ i) \<le> b * (B *v w) $ i" by (intro mult_left_mono)
    from a b have "a * (sr * v $ i) + b * (sr * w $ i) \<le> a * (B *v v) $ i + b * (B *v w) $ i" by auto
  } note le = this
  have switch[simp]: "\<And> x y. x * a * y = a * x * y"  "\<And> x y. x * b * y = b * x * y" by auto
  have [simp]: "x \<in> {v,w} \<Longrightarrow> a * (r * x $h i) = r * (a * x $h i)" for a r i x by auto
  show "a *\<^sub>R v + b *\<^sub>R w \<in> S" using * norm1 le unfolding S_def
    by (auto simp: matrix_vect_scaleR matrix_vector_right_distrib ring_distribs)
qed

private abbreviation (input) r :: "real \<Rightarrow> complex" where
  "r \<equiv> of_real"

private abbreviation rv :: "real ^'n \<Rightarrow> complex ^'n" where
  "rv v \<equiv> \<chi> i. r (v $ i)"

private lemma rv_0: "(rv v = 0) = (v = 0)"
  by (simp add: of_real_hom.map_vector_0 map_vector_def vec_eq_iff)

private lemma rv_mult: "A *v rv v = rv (B *v v)"
proof -
  have "map_matrix r B = A"
    using rnnA unfolding map_matrix_def B_def real_non_neg_mat_def map_vector_def elements_mat_h_def
    by vector
  thus ?thesis
    using of_real_hom.matrix_vector_mult_hom[of B, where 'a = complex]
    unfolding map_vector_def by auto
qed

context
  assumes zero_no_ev: "\<And> v. v \<in> S \<Longrightarrow> A *v rv v \<noteq> 0"
begin
private lemma normB_S: assumes v: "v \<in> S"
  shows "norm1 (B *v v) \<noteq> 0"
proof -
  from zero_no_ev[OF v, unfolded rv_mult rv_0]
  show ?thesis by auto
qed

private lemma image_f: "f ` S \<subseteq> S"
proof -
  {
    fix v
    assume v: "v \<in> S"
    hence norm: "norm1 v = 1" and ge: "\<And> i. v $ i \<ge> 0" "\<And> i. sr * v $ i \<le> (B *v v) $ i" unfolding S_def by auto
    from normB_S[OF v] have normB: "norm1 (B *v v) > 0" using norm1_nonzero by auto
    have fv: "f v = (1 / norm1 (B *v v)) *\<^sub>R (B *v v)" unfolding f_def by auto
    from normB have Bv0: "B *v v \<noteq> 0" unfolding norm1_0_iff[symmetric] by linarith
    have norm: "norm1 (f v) = 1" unfolding fv using normB Bv0 by simp
    define c where "c = (1 / norm1 (B *v v))"
    have c: "c > 0" unfolding c_def using normB by auto
    {
      fix i
      have 1: "f v $ i \<ge> 0" unfolding fv c_def[symmetric] using c ge
        by (auto simp: matrix_vector_mult_def sum_distrib_left B_norm intro!: sum_nonneg)
      have id1: "\<And> i. (B *v f v) $ i = c * ((B *v (B *v v)) $ i)"
        unfolding f_def c_def matrix_vect_scaleR by simp
      have id3: "\<And> i. sr * f v $ i = c * ((B *v (sr *\<^sub>R v)) $ i)"
        unfolding f_def c_def[symmetric] matrix_vect_scaleR by auto
      have 2: "sr * f v $ i \<le> (B *v f v) $ i" unfolding id1 id3
        unfolding mult_le_cancel_iff2[OF \<open>c > 0\<close>]
        by (rule mult_B_mono, insert ge(2), auto)
      note 1 2
    }
    with norm have "f v \<in> S" unfolding S_def by auto
  }
  thus ?thesis by blast
qed

private lemma cont_f: "continuous_on S f"
  unfolding f_def[abs_def] continuous_on using normB_S
  unfolding norm1_def
  by (auto intro!: tendsto_eq_intros)

qualified lemma perron_frobenius_positive_ev:
  "\<exists> v. eigen_vector A v (r sr) \<and> real_non_neg_vec v"
proof -
  from brouwer[OF compactS convexS non_emptyS cont_f image_f]
    obtain v where v: "v \<in> S" and fv: "f v = v" by auto
  define ev where "ev = norm1 (B *v v)"
  from normB_S[OF v] have "ev \<noteq> 0" unfolding ev_def by auto
  with norm1_ge_0[of "B *v v", folded ev_def] have norm: "ev > 0" by auto
  from arg_cong[OF fv[unfolded f_def], of "\<lambda> (w :: real ^ 'n). ev *\<^sub>R w"] norm
  have ev: "B *v v = ev *s v" unfolding ev_def[symmetric] scalar_mult_eq_scaleR by simp
  with v[unfolded S_def] have ge: "\<And> i. sr * v $ i \<le> ev * v $ i" by auto
  have "A *v rv v = rv (B *v v)" unfolding rv_mult ..
  also have "\<dots> = ev *s rv v" unfolding ev vec_eq_iff
    by (simp add: scaleR_conv_of_real scaleR_vec_def)
  finally have ev: "A *v rv v = ev *s rv v" .
  from v have v0: "v \<noteq> 0" unfolding S_def by auto
  hence "rv v \<noteq> 0" unfolding rv_0 .
  with ev have ev: "eigen_vector A (rv v) ev" unfolding eigen_vector_def by auto
  hence "eigen_value A ev" unfolding eigen_value_def by auto
  from spectral_radius_max[OF this] have le: "norm (r ev) \<le> sr" .
  from v0 obtain i where "v $ i \<noteq> 0" unfolding vec_eq_iff by auto
  from v have "v $ i \<ge> 0" unfolding S_def by auto
  with \<open>v $ i \<noteq> 0\<close> have "v $ i > 0" by auto
  with ge[of i] have ge: "sr \<le> ev" by auto
  with le have sr: "r sr = ev" by auto
  from v have *: "real_non_neg_vec (rv v)" unfolding S_def real_non_neg_vec_def vec_elements_h_def by auto
  show ?thesis unfolding sr
    by (rule exI[of _ "rv v"], insert * ev norm, auto)
qed
end

qualified lemma perron_frobenius_both:
  "\<exists> v. eigen_vector A v (r sr) \<and> real_non_neg_vec v"
proof (cases "\<forall> v \<in> S. A *v rv v \<noteq> 0")
  case True
  show ?thesis
    by (rule Perron_Frobenius.perron_frobenius_positive_ev[OF rnnA], insert True, auto)
next
  case False
  then obtain v where v: "v \<in> S" and A0: "A *v rv v = 0" by auto
  hence id: "A *v rv v = 0 *s rv v" and v0: "v \<noteq> 0" unfolding S_def by auto
  from v0 have "rv v \<noteq> 0" unfolding rv_0 .
  with id have ev: "eigen_vector A (rv v) 0" unfolding eigen_vector_def by auto
  hence "eigen_value A 0" unfolding eigen_value_def ..
  from spectral_radius_max[OF this] have 0: "0 \<le> sr" by auto
  from v[unfolded S_def] have ge: "\<And> i. sr * v $ i \<le> (B *v v) $ i" by auto
  from v[unfolded S_def] have rnn: "real_non_neg_vec (rv v)"
    unfolding real_non_neg_vec_def vec_elements_h_def by auto
  from v0 obtain i where "v $ i \<noteq> 0" unfolding vec_eq_iff by auto
  from v have "v $ i \<ge> 0" unfolding S_def by auto
  with \<open>v $ i \<noteq> 0\<close> have vi: "v $ i > 0" by auto
  from rv_mult[of v, unfolded A0] have "rv (B *v v) = 0" by simp
  hence "B *v v = 0" unfolding rv_0 .
  from ge[of i, unfolded this] vi have ge: "sr \<le> 0" by (simp add: mult_le_0_iff)
  with \<open>0 \<le> sr\<close> have "sr = 0" by auto
  show ?thesis unfolding \<open>sr = 0\<close> using rnn ev by auto
qed
end

text \<open>Perron Frobenius: The largest complex eigenvalue of a real-valued non-negative matrix
  is a real one, and it has a real-valued non-negative eigenvector.\<close>

lemma perron_frobenius:
  assumes "real_non_neg_mat A"
  shows "\<exists>v. eigen_vector A v (of_real (spectral_radius A)) \<and> real_non_neg_vec v"
  by (rule Perron_Frobenius.perron_frobenius_both[OF assms])

text \<open>And a version which ignores the eigenvector.\<close>

lemma perron_frobenius_eigen_value:
  assumes "real_non_neg_mat A"
  shows "eigen_value A (of_real (spectral_radius A))"
  using perron_frobenius[OF assms] unfolding eigen_value_def by blast

end


theory Grandfather
  imports Main
begin

text \<open>
  First prove the following formula, which is valid in classical predicate
  logic, informally with pen and paper.  Use case distinctions and/or proof by
  contradiction.

  {\it  If every poor man has a rich father,\\
   then there is a rich man who has a rich grandfather.}
\<close>

theorem rich_grandfather: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by auto
  qed
  then obtain x where x: "rich x" by auto
  show ?thesis

  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by simp
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

text \<open>
  Now prove the formula in Isabelle using a sequence of rule applications (i.e.\
  only using the methods @{term rule}, @{term erule} and @{term assumption}).
\<close>

(*<*) end (*>*)


(*<*)
theory Quorums
imports Consensus_Types
begin
(*>*)

subsection \<open>Quorums\<close>
(******************************************************************************)

locale quorum =
  fixes Quorum :: "'a set set"
  assumes
    qintersect: "\<lbrakk> Q \<in> Quorum; Q' \<in> Quorum \<rbrakk> \<Longrightarrow> Q \<inter> Q' \<noteq> {}"
    \<comment> \<open>Non-emptiness needed for some invariants of Coordinated Voting\<close>
    and Quorum_not_empty: "\<exists>Q. Q \<in> Quorum"

lemma (in quorum) quorum_non_empty: "Q \<in> Quorum \<Longrightarrow> Q \<noteq> {}"
by (auto dest: qintersect)

lemma (in quorum) empty_not_quorum: "{} \<in> Quorum \<Longrightarrow> False"
  using quorum_non_empty
  by blast

locale quorum_process = quorum Quorum
  for Quorum :: "process set set"

locale mono_quorum = quorum_process +
  assumes mono_quorum: "\<lbrakk> Q \<in> Quorum; Q \<subseteq> Q' \<rbrakk> \<Longrightarrow> Q' \<in> Quorum"

lemma (in mono_quorum) UNIV_quorum:
  "UNIV \<in> Quorum"
  using Quorum_not_empty mono_quorum
  by(blast)

definition majs :: "(process set) set" where
  "majs \<equiv> {S. card S > N div 2}"

lemma majsI:
  "N div 2 < card S \<Longrightarrow> S \<in> majs"
  by(simp add: majs_def)

lemma card_Compl:
  fixes S :: "('a :: finite) set"
  shows "card (-S) = card (UNIV :: 'a set) - card S"
proof-
  have "card S + card (-S) = card (UNIV :: 'a set)"
    by(rule card_Un_disjoint[of S "-S", simplified Compl_partition, symmetric])
      (auto)
  thus ?thesis
    by simp
qed

lemma majorities_intersect:
  "card (Q :: process set) + card Q' > N \<Longrightarrow> Q \<inter> Q' \<noteq> {}"
  by (metis card_Un_disjoint card_mono finite not_le top_greatest)

interpretation majorities: mono_quorum majs
proof
  fix Q Q' assume "Q \<in> majs" "Q' \<in> majs"
  thus "Q \<inter> Q' \<noteq> {}"
    by (intro majorities_intersect) (auto simp add: majs_def)
next
  show "\<exists>Q. Q \<in> majs"
    apply(rule_tac x=UNIV in exI)
    apply(auto simp add: majs_def intro!: div_less_dividend finite_UNIV_card_ge_0)
    done
next
  fix Q Q'
  assume "Q \<in> majs" "Q \<subseteq> Q'"
  thus "Q' \<in> majs" using card_mono[OF _ \<open>Q \<subseteq> Q'\<close>]
    by(auto simp add: majs_def)
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BubSortIsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "((bubsort xs) = (isort xs))"
  oops

end


theory set_cover
  imports clique
begin

datatype 'a set_cover = SC "'a set" "'a set set"

definition invar :: "'a set_cover => bool" where
"invar sc = (
    case sc of (SC U S) => (\<forall>s \<in> S. s \<subseteq> U)
)"

fun cover :: "'a set_cover => 'a set set => bool" where
"cover (SC U S) C = (\<Union>{s. s \<in> C} = U)"

lemma cover_snd_def : "\<lbrakk>invar (SC U S); C \<subseteq> S\<rbrakk> \<Longrightarrow> cover (SC U S) C = (\<forall>e \<in> U. \<exists>s \<in> C. e \<in> s)"
by (auto simp add: invar_def)

fun vc_to_sc :: "'a graph => 'a set set_cover" where
"vc_to_sc (V, E) = SC E {s0. \<exists>a \<in> V. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}"

fun T_vc_to_sc :: "'a graph => nat" where
"T_vc_to_sc (V, E) = \<Sum> {c. \<exists>a \<in> V. c = card {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}"

theorem invar_vc_to_sc : "clique.invar (V, E) \<Longrightarrow> invar (vc_to_sc (V, E))"
by (auto simp add: invar_def clique.invar_def)

theorem vc_to_sc_correct :
assumes "clique.invar (V, E)"
shows "vertex_cover (V, E) S = cover (vc_to_sc (V, E)) {s0. \<exists>a \<in> S. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}"
proof

  assume "vertex_cover (V, E) S"
  hence "\<forall>e \<in> E. \<exists>x \<in> S. x \<in> e" by auto

  moreover have "\<forall>e \<in> E. \<exists>a\<in>V. \<exists>b\<in>V. e = {a, b}"
  using assms apply (auto simp: clique.invar_def) by (metis card_2_iff insert_iff)

  ultimately have  "\<forall>e \<in> E. \<exists>x \<in> S. e \<in> {s. \<exists>b\<in>V. s = {x, b} \<and> s \<in> E}" by fastforce

  hence "\<forall>e \<in> E. \<exists>s \<in> {s0. \<exists>a \<in> S. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}. e \<in> s"
  using mem_Collect_eq by (smt (verit))

  then show "cover (vc_to_sc (V, E)) {s0. \<exists>a \<in> S. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}"
  by auto
next
  assume "cover (vc_to_sc (V, E)) {s0. \<exists>a \<in> S. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}}"
  then show "vertex_cover (V, E) S" by auto
qed

lemma "clique.invar (V, E) \<Longrightarrow> finite V \<Longrightarrow> finite E \<Longrightarrow> card {s0. \<exists>a \<in> V. s0 = {s. \<exists>b\<in>V. s = {a, b} \<and> s \<in> E}} = card V"
apply (induction V rule: remove_induct)
apply (auto simp add: clique.invar_def)
sorry

theorem vc_to_sc_polynomial :
assumes "clique.invar (V, E)" "finite V" "finite E"
shows "T_vc_to_sc (V, E) = card E * 2"
using assms proof (induction E rule: remove_induct)
  case empty
  then show ?case by simp
next
  case infinite
  then show ?case by simp
next
  case (remove A)
  then show ?case apply auto sorry
qed

end