(* Authors:  René Neumann and Florian Haftmann, TU Muenchen *)

section \<open>Relating Functional Binomial Queues To The Abstract Priority Queues\<close>

theory PQ_Implementation
imports PQ Binomial_Queue
begin

notation
  "PQ.values" ("|(_)|")
  and "PQ.priorities" ("\<parallel>(_)\<parallel>")

text \<open>
  \noindent Naming convention: prefix \<open>bt_\<close> for bintrees, \<open>bts_\<close> for bintree lists,
  no prefix for binqueues.
\<close>

primrec bt_dfs :: "(('a::linorder, 'b) bintree \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) bintree \<Rightarrow> 'c list"
  and bts_dfs :: "(('a::linorder, 'b) bintree \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) bintree list  \<Rightarrow> 'c list" where
  "bt_dfs f (Node a v ts) = f (Node a v ts) # bts_dfs f ts"
| "bts_dfs f [] = []"
| "bts_dfs f (t # ts) = bt_dfs f t @ bts_dfs f ts"

lemma bt_dfs_simp:
  "bt_dfs f t = f t # bts_dfs f (children t)"
  by (cases t) simp_all

lemma bts_dfs_append [simp]:
  "bts_dfs f (ts @ rs) = bts_dfs f ts @ bts_dfs f rs"
  by (induct ts) simp_all

lemma set_bts_dfs_rev:
  "set (bts_dfs f (rev ts)) = set (bts_dfs f ts)"
  by (induct ts) auto

lemma bt_dfs_comp:
  "bt_dfs (f \<circ> g) t = map f (bt_dfs g t)"
  "bts_dfs (f \<circ> g) ts = map f (bts_dfs g ts)"
  by (induct t and ts rule: bt_dfs.induct bts_dfs.induct) simp_all

lemma bt_dfs_comp_distinct:
  "distinct (bt_dfs (f \<circ> g) t) \<Longrightarrow> distinct (bt_dfs g t)"
  "distinct (bts_dfs (f \<circ> g) ts) \<Longrightarrow> distinct (bts_dfs g ts)"
  by (simp_all add: bt_dfs_comp distinct_map [of f])

lemma bt_dfs_distinct_children:
  "distinct (bt_dfs f x) \<Longrightarrow> distinct (bts_dfs f (children x))"
  by (cases x) simp

fun dfs :: "(('a::linorder, 'b) bintree \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) binqueue \<Rightarrow> 'c list" where
  "dfs f [] = []"
| "dfs f (None # xs) = dfs f xs"
| "dfs f (Some t # xs) = bt_dfs f t @ dfs f xs"

lemma dfs_append:
  "dfs f (xs @ ys) = (dfs f xs) @ (dfs f ys)"
  by (induct xs) simp_all

lemma set_dfs_rev:
  "set (dfs f (rev xs)) = set (dfs f xs)"
  by (induct xs) (auto simp add: dfs_append)

lemma set_dfs_Cons:
  "set (dfs f (x # xs)) = set (dfs f xs) \<union> set (dfs f [x])"
proof -
  have "set (dfs f (x # xs)) = set (dfs f (rev xs @ [x]))"
    using set_dfs_rev[of f "rev xs @ [x]"] by simp
  thus ?thesis by (simp add: dfs_append set_dfs_rev)
qed

lemma dfs_comp_distinct:
  "distinct (dfs (f \<circ> g) xs) \<Longrightarrow> distinct (dfs g xs)"
  by (simp add: dfs_comp distinct_map[of f])

lemma dfs_distinct_member:
  "distinct (dfs f xs) \<Longrightarrow>
   Some x \<in> set xs \<Longrightarrow>
   distinct (bt_dfs f x)"
proof (induct xs arbitrary: x)
  case (Some r xs t) then show ?case by (cases "t = r") simp_all
qed simp_all

lemma dfs_map_Some_idem:
  "dfs f (map Some xs) = bts_dfs f xs"
  by (induct xs) simp_all

primrec alist :: "('a, 'b) bintree \<Rightarrow> ('b \<times> 'a)" where
  "alist (Node a v _) = (v, a)"

lemma alist_split_pre:
  "val t = (fst \<circ> alist) t"
  "priority t = (snd \<circ> alist) t"
  by (cases t, simp)+

lemma alist_split:
  "val = fst \<circ> alist"
  "priority = snd \<circ> alist"
  by (auto intro!: ext simp add: alist_split_pre)

lemma alist_split_set:
  "set (dfs val xs) = fst ` set (dfs alist xs)"
  "set (dfs priority xs) = snd ` set (dfs alist xs)"
  by (auto simp add: dfs_comp alist_split)

lemma in_set_in_alist:
  assumes "Some t \<in> set xs"
  shows "(val t, priority t) \<in> set (dfs alist xs)"
using assms
proof (induct xs)
  case (Some x xs) then show ?case
  proof (cases "Some t \<in> set xs")
    case False with Some show ?thesis by (cases t) (auto simp add: bt_dfs_simp)
  qed simp
qed simp_all

abbreviation vals where "vals \<equiv> dfs val"
abbreviation prios where "prios \<equiv> dfs priority"
abbreviation elements where "elements \<equiv> dfs alist"

primrec
  bt_augment :: "('a::linorder, 'b) bintree \<Rightarrow> ('b, 'a) PQ.pq \<Rightarrow> ('b, 'a) PQ.pq"
and
  bts_augment :: "('a::linorder, 'b) bintree list \<Rightarrow> ('b, 'a) PQ.pq \<Rightarrow> ('b, 'a) PQ.pq"
where
  "bt_augment (Node a v ts) q = PQ.push v a (bts_augment ts q)"
| "bts_augment [] q = q"
| "bts_augment (t # ts) q = bts_augment ts (bt_augment t q)"

lemma bts_augment [simp]:
  "bts_augment = fold bt_augment"
proof (rule ext)
  fix ts :: "('a, 'b) bintree list"
  show "bts_augment ts = fold bt_augment ts"
    by (induct ts) simp_all
qed

lemma bt_augment_Node [simp]:
  "bt_augment (Node a v ts) q = PQ.push v a (fold bt_augment ts q)"
  by (simp add: bts_augment)

lemma bt_augment_simp:
  "bt_augment t q = PQ.push (val t) (priority t) (fold bt_augment (children t) q)"
  by (cases t) (simp_all add: bts_augment)

declare bt_augment.simps [simp del] bts_augment.simps [simp del]

fun pqueue :: "('a::linorder, 'b) binqueue \<Rightarrow> ('b, 'a) PQ.pq" where
  Empty: "pqueue [] = PQ.empty"
| None: "pqueue (None # xs) = pqueue xs"
| Some: "pqueue (Some t # xs) = bt_augment t (pqueue xs)"

lemma bt_augment_v_subset:
  "set |q| \<subseteq> set |bt_augment t q|"
  "set |q| \<subseteq> set |bts_augment ts q|"
  by (induct t and ts arbitrary: q and q rule: bt_augment.induct bts_augment.induct) auto

lemma bt_augment_v_in:
  "v \<in> set |q| \<Longrightarrow> v \<in> set |bt_augment t q|"
  "v \<in> set |q| \<Longrightarrow> v \<in> set |bts_augment ts q|"
  using bt_augment_v_subset[of q] by auto

lemma bt_augment_v_union:
  "set |bt_augment t (bt_augment r q)| =
    set |bt_augment t q| \<union> set |bt_augment r q|"
  "set |bts_augment ts (bt_augment r q)| =
    set |bts_augment ts q| \<union> set |bt_augment r q|"
proof (induct t and ts arbitrary: q r and q r rule: bt_augment.induct bts_augment.induct)
  case Nil_bintree
    from bt_augment_v_subset[of q] show ?case by auto
qed auto

lemma bt_val_augment:
  shows "set (bt_dfs val t) \<union> set |q| = set |bt_augment t q|"
  and   "set (bts_dfs val ts) \<union> set |q| = set |bts_augment ts q|"
proof (induct t and ts rule: bt_augment.induct bts_augment.induct)
  case (Cons_bintree r rs)
  have "set |bts_augment rs (bt_augment r q)| =
    set |bts_augment rs q| \<union> set |bt_augment r q|"
    by (simp only: bt_augment_v_union)

  with bt_augment_v_subset[of q]
    have "set |bts_augment rs (bt_augment r q)| =
      set |bts_augment rs q| \<union> set |bt_augment r q| \<union> set |q|"
    by auto
  with Cons_bintree show ?case by auto
qed auto

lemma vals_pqueue:
  "set (vals xs) = set |pqueue xs|"
  by (induct xs) (simp_all add: bt_val_augment)

lemma bt_augment_v_push:
  "set |bt_augment t (PQ.push v a q)| = set |bt_augment t q| \<union> {v}"
  "set |bts_augment ts (PQ.push v a q)| = set |bts_augment ts q| \<union> {v}"
  using bt_val_augment[where q = "PQ.push v a q"] by (simp_all add: bt_val_augment)

lemma bt_augment_v_push_commute:
  "set |bt_augment t (PQ.push v a q)| = set |PQ.push v a (bt_augment t q)|"
  "set |bts_augment ts (PQ.push v a q)| = set |PQ.push v a (bts_augment ts q)|"
  by (simp_all add: bt_augment_v_push del: bts_augment)

lemma bts_augment_v_union:
  "set |bt_augment t (bts_augment rs q)| =
    set |bt_augment t q| \<union> set |bts_augment rs q|"
  "set |bts_augment ts (bts_augment rs q)| =
    set |bts_augment ts q| \<union> set |bts_augment rs q|"
proof (induct t and ts arbitrary: q rs and q rs rule: bt_augment.induct bts_augment.induct)
  case Nil_bintree
  from bt_augment_v_subset[of q] show ?case by auto

next
  case (Cons_bintree x xs)
  let ?L = "set |bts_augment xs (bt_augment x (bts_augment rs q))|"

  from bt_augment_v_union
    have *: "\<And> q. set |bts_augment xs (bt_augment x q)| =
      set |bts_augment xs q| \<union> set |bt_augment x q|" by simp

  with Cons_bintree
    have "?L =
      set |bts_augment xs q| \<union> set |bts_augment rs q| \<union> set |bt_augment x q|"
      by auto
  with * show ?case by auto
qed simp

lemma bt_augment_v_commute:
  "set |bt_augment t (bt_augment r q)| = set |bt_augment r (bt_augment t q)|"
  "set |bt_augment t (bts_augment rs q)| = set |bts_augment rs (bt_augment t q)|"
  "set |bts_augment ts (bts_augment rs q)| =
    set |bts_augment rs (bts_augment ts q)|"
  unfolding bts_augment_v_union bt_augment_v_union by auto

lemma bt_augment_v_merge:
  "set |bt_augment (merge t r) q| = set |bt_augment t (bt_augment r q)|"
  by (simp add: bt_augment_simp [symmetric] bt_augment_v_push
    bt_augment_v_commute merge_def)

lemma vals_merge [simp]:
  "set (bt_dfs val (merge t r)) = set (bt_dfs val t) \<union> set (bt_dfs val r)"
  by (auto simp add: bt_dfs_simp merge_def)

lemma vals_merge_distinct:
  "distinct (bt_dfs val t) \<Longrightarrow> distinct (bt_dfs val r) \<Longrightarrow>
   set (bt_dfs val t) \<inter> set (bt_dfs val r) = {} \<Longrightarrow>
   distinct (bt_dfs val (merge t r))"
  by (auto simp add: bt_dfs_simp merge_def)

lemma vals_add_Cons:
  "set (vals (add x xs)) = set (vals (x # xs))"
proof (cases x)
  case (Some t) then show ?thesis
    by (induct xs arbitrary: x t) auto
qed simp

lemma vals_add_distinct:
  assumes "distinct (vals xs)"
  and "distinct (dfs val [x])"
  and "set (vals xs) \<inter> set (dfs val [x]) = {}"
  shows "distinct (vals (add x xs))"
using assms
proof (cases x)
  case (Some t) with assms show ?thesis
  proof (induct xs arbitrary: x t)
    case (Some r xs)
    then have "set (bt_dfs val t) \<inter> set (bt_dfs val r) = {}" by auto
    with Some have "distinct (bt_dfs val (merge t r))" by (simp add: vals_merge_distinct)
    moreover
    with Some have "set (vals xs) \<inter> set (bt_dfs val (merge t r)) = {}" by auto

    moreover note Some
    ultimately show ?case by simp
  qed auto
qed simp

lemma vals_insert [simp]:
  "set (vals (insert a v xs)) = set (vals xs) \<union> {v}"
  by (simp add: insert_def vals_add_Cons)

lemma insert_v_push:
  "set (vals (insert a v xs)) = set |PQ.push v a (pqueue xs)|"
  by (simp add: vals_pqueue[symmetric])

lemma vals_meld:
  "set (dfs val (meld xs ys)) = set (dfs val xs) \<union> set (dfs val ys)"
proof (induct xs ys rule: meld.induct)
  case (3 xs y ys) then show ?case
  using set_dfs_Cons[of val y "meld xs ys"] using set_dfs_Cons[of val y ys] by auto
next
  case (4 x xs ys) then show ?case
  using set_dfs_Cons[of val x "meld xs ys"] using set_dfs_Cons[of val x xs] by auto
next
  case (5 x xs y ys) then show ?case by (auto simp add: vals_add_Cons)
qed simp_all

lemma vals_meld_distinct:
  "distinct (dfs val xs) \<Longrightarrow> distinct (dfs val ys) \<Longrightarrow>
   set (dfs val xs) \<inter> set (dfs val ys) = {} \<Longrightarrow>
   distinct (dfs val (meld xs ys))"
proof (induct xs ys rule: meld.induct)
  case (3 xs y ys) then show ?case
  proof (cases y)
    case None with "3" show ?thesis by simp
  next
    case (Some t)
    from "3" have A: "set (vals xs) \<inter> set (vals ys) = {}"
      using set_dfs_Cons[of val y ys] by auto

    moreover
    from Some "3" have "set (bt_dfs val t) \<inter> set (vals xs) = {}" by auto

    moreover
    from Some "3" have "set (bt_dfs val t) \<inter> set (vals ys) = {}" by simp

    ultimately have "set (bt_dfs val t) \<inter> set (vals (meld xs ys)) = {}"
      by (auto simp add: vals_meld)
    with "3" Some show ?thesis by auto
  qed
next
  case (4 x xs ys) then show ?case
  proof (cases x)
    case None with "4" show ?thesis by simp
  next
    case (Some t)
    from "4" have "set (vals xs) \<inter> set (vals ys) = {}"
      using set_dfs_Cons[of val x xs] by auto

    moreover
    from Some "4" have "set (bt_dfs val t) \<inter> set (vals xs) = {}" by simp

    moreover
    from Some "4" have "set (bt_dfs val t) \<inter> set (vals ys) = {}" by auto

    ultimately have "set (bt_dfs val t) \<inter> set (vals (meld xs ys)) = {}"
      by (auto simp add: vals_meld)
    with "4" Some show ?thesis by auto
  qed
next
  case (5 x xs y ys) then
  have "set (vals xs) \<inter> set (vals ys) = {}" by (auto simp add: set_dfs_Cons)
  with "5" have "distinct (vals (meld xs ys))" by simp

  moreover
  from "5" have "set (bt_dfs val x) \<inter> set (bt_dfs val y) = {}" by auto
  with "5" have "distinct (bt_dfs val (merge x y))"
    by (simp add: vals_merge_distinct)

  moreover
  from "5" have "set (vals (meld xs ys)) \<inter> set (bt_dfs val (merge x y)) = {}"
    by (auto simp add: vals_meld)

  ultimately show ?case by (simp add: vals_add_distinct)
qed simp_all

lemma bt_augment_alist_subset:
  "set (PQ.alist_of q) \<subseteq> set (PQ.alist_of (bt_augment t q))"
  "set (PQ.alist_of q) \<subseteq> set (PQ.alist_of (bts_augment ts q))"
proof (induct t and ts arbitrary: q and q rule: bt_augment.induct bts_augment.induct)
  case (Node a v rs)
  show ?case using Node[of q] by (auto simp add: bt_augment_simp set_insort_key)
qed auto

lemma bt_augment_alist_in:
  "(v,a) \<in> set (PQ.alist_of q) \<Longrightarrow> (v,a) \<in> set (PQ.alist_of (bt_augment t q))"
  "(v,a) \<in> set (PQ.alist_of q) \<Longrightarrow> (v,a) \<in> set (PQ.alist_of (bts_augment ts q))"
  using bt_augment_alist_subset[of q] by auto

lemma bt_augment_alist_union:
  "distinct (bts_dfs val (r # [t])) \<Longrightarrow>
   set (bts_dfs val (r # [t])) \<inter> set |q| = {} \<Longrightarrow>
   set (PQ.alist_of (bt_augment t (bt_augment r q))) =
     set (PQ.alist_of (bt_augment t q)) \<union> set (PQ.alist_of (bt_augment r q))"

  "distinct (bts_dfs val (r # ts)) \<Longrightarrow>
   set (bts_dfs val (r # ts)) \<inter> set |q| = {} \<Longrightarrow>
   set (PQ.alist_of (bts_augment ts (bt_augment r q))) =
     set (PQ.alist_of (bts_augment ts q)) \<union> set (PQ.alist_of (bt_augment r q))"
proof (induct t and ts arbitrary: q r and q r rule: bt_augment.induct bts_augment.induct)
  case Nil_bintree
  from bt_augment_alist_subset[of q] show ?case by auto
next
  case (Node a v rs) then
  have
    "set (PQ.alist_of (bts_augment rs (bt_augment r q))) =
     set (PQ.alist_of (bts_augment rs q)) \<union> set (PQ.alist_of (bt_augment r q))"
    by simp

  moreover
  from Node.prems have *: "v \<notin> set |bts_augment rs q| \<union> set |bt_augment r q|" unfolding bt_val_augment[symmetric] by simp
  hence "v \<notin> set |bts_augment rs (bt_augment r q)|" by (unfold bt_augment_v_union)

  moreover
  from * have "v \<notin> set |bts_augment rs q|" by simp

  ultimately show ?case by (simp add: set_insort_key)
next
  case (Cons_bintree x xs) then
  have \<comment> \<open>FIXME: ugly... and slow\<close>
    "distinct (bts_dfs val (x # xs))" and
    "distinct (bts_dfs val (r # xs))" and
    "distinct (bts_dfs val [r,x])" and
    "set (bts_dfs val (x # xs)) \<inter> set |bt_augment r q| = {}" and
    "set (bts_dfs val (x # xs)) \<inter> set |q| = {}" and
    "set (bts_dfs val [r, x]) \<inter> set |q| = {}" and
    "set (bts_dfs val (r # xs)) \<inter> set |q| = {}"
    unfolding bt_val_augment[symmetric] by auto
  with Cons_bintree.hyps show ?case by auto
qed

lemma bt_alist_augment:
  "distinct (bt_dfs val t) \<Longrightarrow>
   set (bt_dfs val t) \<inter> set |q| = {} \<Longrightarrow>
   set (bt_dfs alist t) \<union> set (PQ.alist_of q) = set (PQ.alist_of (bt_augment t q))"

  "distinct (bts_dfs val ts) \<Longrightarrow>
   set (bts_dfs val ts) \<inter> set |q| = {} \<Longrightarrow>
   set (bts_dfs alist ts) \<union> set (PQ.alist_of q) =
     set (PQ.alist_of (bts_augment ts q))"
proof (induct t and ts rule: bt_augment.induct bts_augment.induct)
  case Nil_bintree then show ?case by simp
next
  case (Node a v rs)
  hence "v \<notin> set |bts_augment rs q|"
    unfolding bt_val_augment[symmetric] by simp
  with Node show ?case by (simp add: set_insort_key)
next
  case (Cons_bintree r rs) then
  have "set (PQ.alist_of (bts_augment (r # rs) q)) =
    set (PQ.alist_of (bts_augment rs q)) \<union> set (PQ.alist_of (bt_augment r q))"
    using bt_augment_alist_union by simp
  with Cons_bintree bt_augment_alist_subset show ?case by auto
qed

lemma alist_pqueue:
  "distinct (vals xs) \<Longrightarrow> set (dfs alist xs) = set (PQ.alist_of (pqueue xs))"
  by (induct xs) (simp_all add: vals_pqueue bt_alist_augment)

lemma alist_pqueue_priority:
  "distinct (vals xs) \<Longrightarrow> (v, a) \<in> set (dfs alist xs)
    \<Longrightarrow> PQ.priority (pqueue xs) v = Some a"
  by (simp add: alist_pqueue PQ.priority_def)

lemma prios_pqueue:
  "distinct (vals xs) \<Longrightarrow> set (prios xs) = set \<parallel>pqueue xs\<parallel>"
  by (auto simp add: alist_pqueue priorities_set alist_split_set)

lemma alist_merge [simp]:
  "distinct (bt_dfs val t) \<Longrightarrow> distinct (bt_dfs val r) \<Longrightarrow>
   set (bt_dfs val t) \<inter> set (bt_dfs val r) = {} \<Longrightarrow>
   set (bt_dfs alist (merge t r)) = set (bt_dfs alist t) \<union> set (bt_dfs alist r)"
  by (auto simp add: bt_dfs_simp merge_def alist_split)

lemma alist_add_Cons:
  assumes "distinct (vals (x#xs))"
  shows "set (dfs alist (add x xs)) = set (dfs alist (x # xs))"
using assms proof (induct xs arbitrary: x)
  case Empty then show ?case by (cases x) simp_all
next
  case None then show ?case by (cases x) simp_all
next
  case (Some y ys) then
  show ?case
  proof (cases x)
    case (Some t)
    note prem = Some.prems Some

    from prem have "distinct (bt_dfs val (merge t y))"
      by (auto simp add: bt_dfs_simp merge_def)
    with prem have "distinct (vals (Some (merge t y) # ys))" by auto
    with prem Some.hyps
      have "set (dfs alist (add (Some (merge t y)) ys)) =
        set (dfs alist (Some (merge t y) # ys))" by simp

    moreover
    from prem have "set (bt_dfs val t) \<inter> set (bt_dfs val y) = {}" by auto
    with prem
      have "set (bt_dfs alist (merge t y)) =
        set (bt_dfs alist t) \<union> set (bt_dfs alist y)"
      by simp

    moreover note prem and Un_assoc

    ultimately
    show ?thesis by simp
  qed simp
qed

lemma alist_insert [simp]:
  "distinct (vals xs) \<Longrightarrow>
   v \<notin> set (vals xs) \<Longrightarrow>
   set (dfs alist (insert a v xs)) = set (dfs alist xs) \<union> {(v,a)}"
  by (simp add: insert_def alist_add_Cons)

lemma insert_push:
  "distinct (vals xs) \<Longrightarrow>
   v \<notin> set (vals xs) \<Longrightarrow>
   set (dfs alist (insert a v xs)) = set (PQ.alist_of (PQ.push v a (pqueue xs)))"
  by (simp add: alist_pqueue vals_pqueue set_insort_key)

lemma insert_p_push:
  assumes "distinct (vals xs)"
  and "v \<notin> set (vals xs)"
  shows "set (prios (insert a v xs)) = set \<parallel>PQ.push v a (pqueue xs)\<parallel>"
proof -
  from assms
    have "set (dfs alist (insert a v xs)) =
      set (PQ.alist_of (PQ.push v a (pqueue xs)))"
    by (rule insert_push)
  thus ?thesis by (simp add: alist_split_set priorities_set)
qed

lemma empty_empty:
  "normalized xs \<Longrightarrow> xs = empty \<longleftrightarrow> PQ.is_empty (pqueue xs)"
proof (rule iffI)
  assume "xs = []" then show "PQ.is_empty (pqueue xs)" by simp
next
  assume N: "normalized xs" and E: "PQ.is_empty (pqueue xs)"
  show "xs = []"
  proof (rule ccontr)
    assume "xs \<noteq> []"
    with N have "set (vals xs) \<noteq> {}"
      by (induct xs) (simp_all add: bt_dfs_simp dfs_append)
    hence "set |pqueue xs| \<noteq> {}" by (simp add: vals_pqueue)

    moreover
    from E have "set |pqueue xs| = {}" by (simp add: is_empty_empty)

    ultimately show False by simp
  qed
qed

lemma bt_dfs_Min_priority:
  assumes "is_heap t"
  shows "priority t = Min (set (bt_dfs priority t))"
using assms
proof (induct "priority t" "children t" arbitrary: t)
  case is_heap_list_Nil then show ?case by (simp add: bt_dfs_simp)
next
  case (is_heap_list_Cons rs r t) note cons = this
  let ?M = "Min (set (bt_dfs priority t))"

  obtain t' where "t' = Node (priority t) (val t) rs" by auto
  hence ot: "rs = children t'" "priority t' = priority t" by simp_all
  with is_heap_list_Cons have "priority t = Min (set (bt_dfs priority t'))"
    by simp
  with ot
    have "priority t = Min (Set.insert (priority t) (set (bts_dfs priority rs)))"
    by (simp add: bt_dfs_simp)

  moreover
  from cons have "priority r = Min (set (bt_dfs priority r))" by simp

  moreover
  from cons have "children t = r # rs" by simp
  then have "bts_dfs priority (children t) =
    (bt_dfs priority r) @ (bts_dfs priority rs)" by simp
  hence "bt_dfs priority t =
    priority t # (bt_dfs priority r @ bts_dfs priority rs)"
    by (simp add: bt_dfs_simp)
  hence A: "?M = Min
    (Set.insert (priority t) (set (bt_dfs priority r) \<union> set (bts_dfs priority rs)))"
    by simp

  have "Set.insert (priority t) (set (bt_dfs priority r)
    \<union> set (bts_dfs priority rs)) =
    Set.insert (priority t) (set (bts_dfs priority rs)) \<union> set (bt_dfs priority r)"
    by auto
  with A have "?M = Min
    (Set.insert (priority t) (set (bts_dfs priority rs)) \<union> set (bt_dfs priority r))"
    by simp

  with Min_Un
    [of "Set.insert (priority t) (set (bts_dfs priority rs))" "set (bt_dfs priority r)"]
  have "?M =
    ord_class.min (Min (Set.insert (priority t) (set (bts_dfs priority rs))))
      (Min (set (bt_dfs priority r)))"
    by (auto simp add: bt_dfs_simp)

  ultimately
  have "?M = ord_class.min (priority t) (priority r)" by simp

  with \<open>priority t \<le> priority r\<close> show ?case by (auto simp add: ord_class.min_def)
qed

lemma is_binqueue_min_Min_prios:
  assumes "is_binqueue l xs"
  and "normalized xs"
  and "xs \<noteq> []"
  shows "min xs = Some (Min (set (prios xs)))"
using assms
proof (induct xs)
  case (Some l xs x) then show ?case
  proof (cases "xs \<noteq> []")
    case False with Some show ?thesis
      using bt_dfs_Min_priority[of x] by (simp add: min_single)
  next
    case True note T = this Some

    from T have "normalized xs" by simp
    with \<open>xs \<noteq> []\<close> have "prios xs \<noteq> []" by (induct xs) (simp_all add: bt_dfs_simp)
    with T show ?thesis
      using Min_Un[of "set (bt_dfs priority x)" "set (prios xs)"]
      using bt_dfs_Min_priority[of x]
      by (auto simp add: bt_dfs_simp ord_class.min_def)
  qed
qed simp_all

lemma min_p_min:
  assumes "is_binqueue l xs"
  and "xs \<noteq> []"
  and "normalized xs"
  and "distinct (vals xs)"
  and "distinct (prios xs)"
  shows "min xs = PQ.priority (pqueue xs) (PQ.min (pqueue xs))"
proof -
  from \<open>xs \<noteq> []\<close> \<open>normalized xs\<close> have "\<not> PQ.is_empty (pqueue xs)"
    by (simp add: empty_empty)

  moreover
  from assms have "min xs = Some (Min (set (prios xs)))"
    by (simp add: is_binqueue_min_Min_prios)
  with \<open>distinct (vals xs)\<close> have "min xs = Some (Min (set \<parallel>pqueue xs\<parallel> ))"
    by (simp add: prios_pqueue)

  ultimately show ?thesis
   by (simp add: priority_Min_priorities [where q = "pqueue xs"] )
qed

lemma find_min_p_min:
  assumes "is_binqueue l xs"
  and "xs \<noteq> []"
  and "normalized xs"
  and "distinct (vals xs)"
  and "distinct (prios xs)"
  shows "priority (the (find_min xs)) =
    the (PQ.priority (pqueue xs) (PQ.min (pqueue xs)))"
proof -
  from assms have "min xs \<noteq> None" by (simp add: normalized_min_not_None)
  from assms have "min xs = PQ.priority (pqueue xs) (PQ.min (pqueue xs))"
    by (simp add: min_p_min)
  with \<open>min xs \<noteq> None\<close> show ?thesis by (auto simp add: min_eq_find_min_Some)
qed

lemma find_min_v_min:
  assumes "is_binqueue l xs"
  and "xs \<noteq> []"
  and "normalized xs"
  and "distinct (vals xs)"
  and "distinct (prios xs)"
  shows "val (the (find_min xs)) = PQ.min (pqueue xs)"
proof -
  from assms have "min xs \<noteq> None" by (simp add: normalized_min_not_None)
  then obtain a where oa: "Some a = min xs" by auto
  then obtain t where ot: "find_min xs = Some t" "priority t = a"
    using min_eq_find_min_Some [of xs a] by auto

  hence *: "(val t, a) \<in> set (dfs alist xs)"
    by (auto simp add: find_min_exist in_set_in_alist)

  have "PQ.min (pqueue xs) = val t"
  proof (rule ccontr)
    assume A: "PQ.min (pqueue xs) \<noteq> val t"
    then obtain t' where ot':"PQ.min (pqueue xs) = t'" by simp
    with A have NE: "val t \<noteq> t'" by simp

    from ot' oa assms have "(t', a) \<in> set (dfs alist xs)"
      by (simp add: alist_pqueue PQ.priority_def min_p_min)

    with * NE have "\<not> distinct (prios xs)"
      unfolding alist_split(2)
      unfolding dfs_comp
      by (induct ("dfs alist xs")) (auto simp add: rev_image_eqI)
    with \<open>distinct (prios xs)\<close> show False by simp
  qed
  with ot show ?thesis by auto
qed

lemma alist_normalize_idem:
  "dfs alist (normalize xs) = dfs alist xs"
unfolding normalize_def
proof (induct xs rule: rev_induct)
  case (snoc x xs) then show ?case by (cases x) (simp_all add: dfs_append)
qed simp

lemma dfs_match_not_in:
  "(\<forall> t. Some t \<in> set xs \<longrightarrow> priority t \<noteq> a) \<Longrightarrow>
    set (dfs f (map (match a) xs)) = set (dfs f xs)"
by (induct xs) simp_all

lemma dfs_match_subset:
  "set (dfs f (map (match a) xs)) \<subseteq> set (dfs f xs)"
proof (induct xs rule: list.induct)
  case (Cons x xs) then show ?case by (cases x) auto
qed simp

lemma dfs_match_distinct:
  "distinct (dfs f xs) \<Longrightarrow> distinct (dfs f (map (match a) xs))"
proof (induct xs rule: list.induct)
  case (Cons x xs) then show ?case
    using dfs_match_subset[of f a xs]
    by (cases x, auto)
qed simp

lemma dfs_match:
  "distinct (prios xs) \<Longrightarrow>
   distinct (dfs f xs) \<Longrightarrow>
   Some t \<in> set xs \<Longrightarrow>
   priority t = a \<Longrightarrow>
   set (dfs f (map (match a) xs)) = set (dfs f xs) - set (bt_dfs f t)"
proof (induct xs arbitrary: t)
  case (Some r xs t) then show ?case
  proof (cases "t = r")
    case True
    from Some have "priority r \<notin> set (prios xs)" by (auto simp add: bt_dfs_simp)
    with Some True have "a \<notin> set (prios xs)" by simp
    hence "\<forall> s. Some s \<in> set xs \<longrightarrow> priority s \<noteq> a"
      by (induct xs) (auto simp add: bt_dfs_simp)
    hence "set (dfs f (map (match a) xs)) = set (dfs f xs)"
      by (simp add: dfs_match_not_in)
    with True Some show ?thesis by auto
  next
    case False
    with Some.prems have "Some t \<in> set xs" by simp
    with \<open>priority t = a\<close> have "a \<in> set (prios xs)"
    proof (induct xs)
      case (Some x xs) then show ?case
        by (cases "t = x") (simp_all add: bt_dfs_simp)
    qed simp_all
    with False Some have "priority r \<noteq> a" by (auto simp add: bt_dfs_simp)

    moreover
    from Some False
      have "set (dfs f (map (match a) xs)) = set (dfs f xs) - set (bt_dfs f t)"
      by simp

    moreover
    from Some.prems False have "set (bt_dfs f t) \<inter> set (bt_dfs f r) = {}"
      by (induct xs) auto
    hence "set (bt_dfs f r) - set (bt_dfs f t) = set (bt_dfs f r)" by auto

    ultimately show ?thesis by auto
  qed
qed simp_all

lemma alist_meld:
  "distinct (dfs val xs) \<Longrightarrow> distinct (dfs val ys) \<Longrightarrow>
   set (dfs val xs) \<inter> set (dfs val ys) = {} \<Longrightarrow>
   set (dfs alist (meld xs ys)) = set (dfs alist xs) \<union> set (dfs alist ys)"
proof (induct xs ys rule: meld.induct)
  case (3 xs y ys)
  have "set (dfs alist (y # meld xs ys)) =
    set (dfs alist xs) \<union> set (dfs alist (y # ys))"
  proof -
    note assms = "3"
    from assms have "set (vals xs) \<inter> set (vals ys) = {}"
      using set_dfs_Cons[of val y ys] by auto

    moreover
    from assms have "distinct (vals ys)" by (cases y) simp_all

    moreover
    from assms have "distinct (vals xs)" by simp

    moreover note assms
    ultimately have "set (dfs alist (meld xs ys)) =
      set (dfs alist xs) \<union> set (dfs alist ys)" by simp

    hence "set (dfs alist (y # meld xs ys)) =
      set (dfs alist [y]) \<union> set (dfs alist xs) \<union> set (dfs alist ys)"
      using set_dfs_Cons[of alist y "meld xs ys"] by auto

    then show ?thesis using set_dfs_Cons[of alist y ys] by auto
  qed
  thus ?case by simp
next
  case (4 x xs ys)
  have "set (dfs alist (x # meld xs ys)) =
    set (dfs alist (x # xs)) \<union> set (dfs alist ys)"
  proof - (* this is the same as for 3 minus some renaming *)
    note assms = "4"
    from assms have "set (vals xs) \<inter> set (vals ys) = {}"
      using set_dfs_Cons[of val x xs] by auto

    moreover
    from assms have "distinct (vals xs)" by (cases x) simp_all

    moreover
    from assms have "distinct (vals ys)" by simp

    moreover note assms
    ultimately have "set (dfs alist (meld xs ys)) =
      set (dfs alist xs) \<union> set (dfs alist ys)" by simp

    hence "set (dfs alist (x # meld xs ys)) =
      set (dfs alist [x]) \<union> set (dfs alist xs) \<union> set (dfs alist ys)"
      using set_dfs_Cons[of alist x "meld xs ys"] by auto

    then show ?thesis using set_dfs_Cons[of alist x xs] by auto
  qed
  thus ?case by simp
next
  case (5 x xs y ys)
  have "set (dfs alist (add (Some (merge x y)) (meld xs ys))) =
    set (bt_dfs alist x) \<union> set (dfs alist xs)
    \<union> set (bt_dfs alist y) \<union> set (dfs alist ys)"
  proof -
    note assms = "5"

    from assms have "distinct (bt_dfs val x)" "distinct (bt_dfs val y)" by simp_all
    moreover from assms have xyint:
      "set (bt_dfs val x) \<inter> set (bt_dfs val y) = {}" by (auto simp add: set_dfs_Cons)
    ultimately have *: "set (dfs alist [Some (merge x y)]) =
      set (bt_dfs alist x) \<union> set (bt_dfs alist y)" by auto

    moreover
    from assms
      have **: "set (dfs alist (meld xs ys)) = set (dfs alist xs) \<union> set (dfs alist ys)"
      by (auto simp add: set_dfs_Cons)

    moreover
    from assms have "distinct (vals (Some (merge x y) # meld xs ys))"
    proof -
      from assms xyint have "distinct (bt_dfs val (merge x y))"
        by (simp add: vals_merge_distinct)

      moreover
      from assms have
        "distinct (vals xs)"
        and "distinct (vals ys)"
        and "set (vals xs) \<inter> set (vals ys) = {}"
        by (auto simp add: set_dfs_Cons)
      hence "distinct (vals (meld xs ys))" by (rule vals_meld_distinct)

      moreover
      from assms
        have "set (bt_dfs val (merge x y)) \<inter> set (vals (meld xs ys)) = {}"
        by (auto simp add: vals_meld)

      ultimately show ?thesis by simp
    qed

    ultimately show ?thesis by (auto simp add: alist_add_Cons)
  qed
  thus ?case by auto
qed simp_all

lemma alist_delete_min:
  assumes "distinct (vals xs)"
  and "distinct (prios xs)"
  and "find_min xs = Some (Node a v ts)"
  shows "set (dfs alist (delete_min xs)) = set (dfs alist xs) - {(v, a)}"
proof -
  from \<open>distinct (vals xs)\<close> have d: "distinct (dfs alist xs)"
    using dfs_comp_distinct[of fst alist "xs"]
    by (simp only: alist_split)

  from assms have IN: "Some (Node a v ts) \<in> set xs"
    by (simp add: find_min_exist)
  hence sub: "set (bts_dfs alist ts) \<subseteq> set (dfs alist xs)"
    by (induct xs) (auto simp add: bt_dfs_simp)

  from d IN have "(v,a) \<notin> set (bts_dfs alist ts)"
    using dfs_distinct_member[of alist xs "Node a v ts"] by simp
  with sub have "set (bts_dfs alist ts) \<subseteq> set (dfs alist xs) - {(v,a)}" by blast
  hence nu: "set (bts_dfs alist ts) \<union> (set (dfs alist xs) - {(v,a)}) =
    set (dfs alist xs) - {(v,a)}" by auto

  from assms have "distinct (vals (map (match a) xs))"
    by (simp add: dfs_match_distinct)

  moreover
  from IN assms have "distinct (bts_dfs val ts)"
    using dfs_distinct_member[of val xs "Node a v ts"]
    by (simp add: bt_dfs_distinct_children)
  hence "distinct (vals (map Some (rev ts)))"
    by (simp add: bts_dfs_rev_distinct dfs_map_Some_idem)

  moreover
  from assms IN have "set (dfs val (map (match a) xs)) =
    set (dfs val xs) - set (bt_dfs val (Node a v ts))"
    by (simp add: dfs_match)
  hence "set (vals (map (match a) xs)) \<inter> set (vals (map Some (rev ts))) = {}"
    by (auto simp add: dfs_map_Some_idem set_bts_dfs_rev)

  ultimately
  have "set (dfs alist (meld (map Some (rev ts)) (map (match a) xs))) =
    set (dfs alist (map Some (rev ts))) \<union> set (dfs alist (map (match a) xs))"
    using alist_meld by auto

  with assms d IN nu show ?thesis
    by (simp add: delete_min_def alist_normalize_idem set_bts_dfs_rev dfs_map_Some_idem
     dfs_match Diff_insert2 [of "set (dfs alist xs)" "(v,a)" "set (bts_dfs alist ts)"])
qed

lemma alist_remove_min:
  assumes "is_binqueue l xs"
  and "distinct (vals xs)"
  and "distinct (prios xs)"
  and "normalized xs"
  and "xs \<noteq> []"
  shows "set (dfs alist (delete_min xs)) =
  set (PQ.alist_of (PQ.remove_min (pqueue xs)))"
proof -
  from assms obtain t where ot: "find_min xs = Some t"
    using normalized_find_min_exists by auto
  with assms show ?thesis
  proof (cases t)
    case (Node a v ys)
    from assms have "\<not> PQ.is_empty (pqueue xs)" by (simp add: empty_empty)
    hence "set (PQ.alist_of (PQ.remove_min (pqueue xs))) =
      set (PQ.alist_of (pqueue xs)) - {(PQ.min (pqueue xs),
        the (PQ.priority (pqueue xs) (PQ.min (pqueue xs))))}"
      by (simp add: set_alist_of_remove_min[of "pqueue xs"] del: alist_of_remove_min)

    moreover
    from assms ot Node
    have "set (dfs alist (delete_min xs)) = set (dfs alist xs) - {(v, a)}"
      using alist_delete_min[of xs] by simp

    moreover
    from Node ot have "priority (the (find_min xs)) = a" by simp
    with assms have "a = the (PQ.priority (pqueue xs) (PQ.min (pqueue xs)))"
      by (simp add: find_min_p_min)

    moreover
    from Node ot have "val (the (find_min xs)) = v" by simp
    with assms have "v = PQ.min (pqueue xs)" by (simp add: find_min_v_min)

    moreover note \<open>distinct (vals xs)\<close>
    ultimately show ?thesis by (simp add: alist_pqueue)
  qed
qed

no_notation
  "PQ.values" ("|(_)|")
  and "PQ.priorities" ("\<parallel>(_)\<parallel>")

end


theory LastVotingDefs
imports "../HOModel"
begin

section {* Verification of the \emph{LastVoting} Consensus Algorithm *}

text {*
  The \emph{LastVoting} algorithm can be considered as a representation of
  Lamport's Paxos consensus algorithm~\cite{lamport:part-time}
  in the Heard-Of model. It is a coordinated algorithm designed to
  tolerate benign failures. Following~\cite{charron:heardof}, we formalize
  its proof of correctness in Isabelle, using the framework of theory @{text HOModel}.
*}

subsection {* Model of the Algorithm *}

text {*
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable @{text "'proc"}
  of the generic CHO model.
*}

typedecl Proc -- {* the set of processes *}
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   -- {* number of processes *}

text {*
  The algorithm proceeds in \emph{phases} of $4$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
*}

definition phase where "phase (r::nat) \<equiv> r div 4"

definition step where "step (r::nat) \<equiv> r mod 4"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * 4) + step r = r"
  by (auto simp add: phase_def step_def)

text {*
  The following record models the local state of a process.
*}

record 'val pstate =
  x :: 'val                -- {* current value held by process *}
  vote :: "'val option"    -- {* value the process voted for, if any *}
  commt :: bool            -- {* did the process commit to the vote? *}
  ready :: bool            -- {* for coordinators: did the round finish successfully? *}
  timestamp :: nat         -- {* time stamp of current value *}
  decide :: "'val option"  -- {* value the process has decided on, if any *}
  coord\<Phi> :: Proc           -- {* coordinator for current phase *}

text {*
  Possible messages sent during the execution of the algorithm.
*}

datatype 'val msg =
  ValStamp "'val" "nat"
| Vote "'val"
| Ack
| Null  -- {* dummy message in case nothing needs to be sent *}

text {*
  Characteristic predicates on messages.
*}

definition isValStamp where "isValStamp m \<equiv> \<exists>v ts. m = ValStamp v ts"

definition isVote where "isVote m \<equiv> \<exists>v. m = Vote v"

definition isAck where "isAck m \<equiv> m = Ack"

text {*
  Selector functions to retrieve components of messages. These functions
  have a meaningful result only when the message is of an appropriate kind.
*}

fun val where
  "val (ValStamp v ts) = v"
| "val (Vote v) = v"

fun stamp where
  "stamp (ValStamp v ts) = ts"

text {*
  The @{text x} field of the initial state is unconstrained, all other
  fields are initialized appropriately.
*}

definition LV_initState where
  "LV_initState p st crd \<equiv>
     vote st = None
   \<and> \<not>(commt st)
   \<and> \<not>(ready st)
   \<and> timestamp st = 0
   \<and> decide st = None
   \<and> coord\<Phi> st = crd"

text {*
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
*}

-- {* processes from which values and timestamps were received *}
definition valStampsRcvd where
  "valStampsRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   {q . \<exists>v ts. msgs q = Some (ValStamp v ts)}"

definition highestStampRcvd where
  "highestStampRcvd msgs \<equiv>
   Max {ts . \<exists>q v. (msgs::Proc \<rightharpoonup> 'val msg) q = Some (ValStamp v ts)}"

text {*
  In step 0, each process sends its current @{text x} and @{text timestamp}
  values to its coordinator.

  A process that considers itself to be a coordinator updates its
  @{text vote} field if it has received messages from a majority of processes.
  It then sets its @{text commt} field to true.
*}

definition send0 where
  "send0 r p q st \<equiv>
   if q = coord\<Phi> st then ValStamp (x st) (timestamp st) else Null"

definition next0 where
  "next0 r p st msgs crd st' \<equiv>
      if p = coord\<Phi> st \<and> card (valStampsRcvd msgs) > N div 2
      then (\<exists>p v. msgs p = Some (ValStamp v (highestStampRcvd msgs))
                \<and> st' = st \<lparr> vote := Some v, commt := True \<rparr> )
      else st' = st"

text {*
  In step 1, coordinators that have committed send their vote to all
  processes.

  Processes update their @{text x} and @{text timestamp} fields if they
  have received a vote from their coordinator.
*}

definition send1 where
  "send1 r p q st \<equiv>
   if p = coord\<Phi> st \<and> commt st then Vote (the (vote st)) else Null"

definition next1 where
  "next1 r p st msgs crd st' \<equiv>
   if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
   then st' = st \<lparr> x := val (the (msgs (coord\<Phi> st))), timestamp := Suc(phase r) \<rparr>
   else st' = st"

text {*
  In step 2, processes that have current timestamps send an acknowledgement
  to their coordinator.

  A coordinator sets its @{text ready} field to true if it receives a majority
  of acknowledgements.
*}

definition send2 where
  "send2 r p q st \<equiv>
   if timestamp st = Suc(phase r) \<and> q = coord\<Phi> st then Ack else Null"

-- {* processes from which an acknowledgement was received *}
definition acksRcvd where
  "acksRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   { q . msgs q \<noteq> None \<and> isAck (the (msgs q)) }"

definition next2 where
  "next2 r p st msgs crd st' \<equiv>
   if p = coord\<Phi> st \<and> card (acksRcvd msgs) > N div 2
   then st' = st \<lparr> ready := True \<rparr>
   else st' = st"

text {*
  In step 3, coordinators that are ready send their vote to all processes.

  Processes that received a vote from their coordinator decide on that value.
  Coordinators reset their @{text ready} and @{text commt} fields to false.
  All processes reset the coordinators as indicated by the parameter of
  the operator.
*}

definition send3 where
  "send3 r p q st \<equiv>
   if p = coord\<Phi> st \<and> ready st then Vote (the (vote st)) else Null"

definition next3 where
  "next3 r p st msgs crd st' \<equiv>
      (if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
       then decide st' = Some (val (the (msgs (coord\<Phi> st))))
       else decide st' = decide st)
   \<and> (if p = coord\<Phi> st
      then \<not>(ready st') \<and> \<not>(commt st')
      else ready st' = ready st \<and> commt st' = commt st)
   \<and> x st' = x st
   \<and> vote st' = vote st
   \<and> timestamp st' = timestamp st
   \<and> coord\<Phi> st' = crd"

text {*
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
*}

definition LV_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg" where
  "LV_sendMsg (r::nat) \<equiv>
   if step r = 0 then send0 r
   else if step r = 1 then send1 r
   else if step r = 2 then send2 r
   else send3 r"

definition
  LV_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<rightharpoonup> 'val msg)
                       \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> bool"
  where
  "LV_nextState r \<equiv>
   if step r = 0 then next0 r
   else if step r = 1 then next1 r
   else if step r = 2 then next2 r
   else next3 r"

subsection {* Communication Predicate for \emph{LastVoting} *}

text {*
  We now define the communication predicate that will be assumed for the
  correctness proof of the \emph{LastVoting} algorithm.
  The ``per-round'' part is trivial: integrity and agreement are always ensured.

  For the ``global'' part, Charron-Bost and Schiper propose a predicate
  that requires the existence of infinitely many phases @{text ph} such that:
  \begin{itemize}
  \item all processes agree on the same coordinator @{text c},
  \item @{text c} hears from a strict majority of processes in steps 0 and 2
    of phase @{text ph}, and
  \item every process hears from @{text c} in steps 1 and 3 (this is slightly
    weaker than the predicate that appears in~\cite{charron:heardof}, but
    obviously sufficient).
  \end{itemize}

  Instead of requiring infinitely many such phases, we only assume the
  existence of one such phase (Charron-Bost and Schiper note that this is enough.)
*}

definition
  LV_commPerRd where
  "LV_commPerRd r (HO::Proc HO) (coord::Proc coord) \<equiv> True"

definition
  LV_commGlobal where
  "LV_commGlobal HOs coords \<equiv>
      \<exists>ph::nat. \<exists>c::Proc.
           (\<forall>p. coords (4*ph) p = c)
         \<and> card (HOs (4*ph) c) > N div 2
         \<and> card (HOs (4*ph+2) c) > N div 2
         \<and> (\<forall>p. c \<in> HOs (4*ph+1) p \<inter> HOs (4*ph+3) p)"

subsection {* The \emph{LastVoting} Heard-Of Machine *}

text {*
  We now define the coordinated HO machine for the \emph{LastVoting} algorithm
  by assembling the algorithm definition and its communication-predicate.
*}

definition LV_CHOMachine where
  "LV_CHOMachine \<equiv>
    \<lparr> CinitState = LV_initState,
      sendMsg = LV_sendMsg,
      CnextState = LV_nextState,
      CHOcommPerRd = LV_commPerRd,
      CHOcommGlobal = LV_commGlobal \<rparr>"

abbreviation
  "LV_M \<equiv> (LV_CHOMachine::(Proc, 'val pstate, 'val msg) CHOMachine)"

end


theory drop
imports Main
begin
lemma lemma_a [thy_expl]: "prop_56.drop x3 Nil2 = Nil2"
by (hipster_induct_schemes prop_56.drop.simps)

lemma lemma_aa [thy_expl]: "prop_56.drop (S Z) (prop_56.drop x3 y3) = prop_56.drop (S x3) y3"
by (hipster_induct_schemes prop_56.drop.simps)

lemma unknown [thy_expl]: "prop_56.drop x (prop_56.drop y z) = prop_56.drop y (prop_56.drop x z)"
oops

lemma unknown [thy_expl]: "prop_56.drop (S x) (prop_56.drop y z) =
prop_56.drop (S y) (prop_56.drop x z)"
oops

end


header {*\subsection{CISK (Controlled Interruptible Separation Kernel)}*}

theory CISK
  imports ISK
begin

text {*
  This section presents a generic model of a Controlled Interruptible Separation Kernel (CISK).
  It formulates security, i.e., intransitive noninterference.
  For a presentation of this model, see Section 2 of~\cite{Verbeek2013}.
*}

text {*
  First, a locale is defined that defines all generic functions and all proof obligations (see Section 2.3 of ~\cite{Verbeek2013}).
*}
locale Controllable_Interruptible_Separation_Kernel = -- "CISK"
fixes kstep :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" -- "Executes one atomic kernel action"
  and output_f :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'output_t" -- "Returns the observable behavior"
  and s0 :: "'state_t" -- "The initial state"
  and current :: "'state_t => 'dom_t" -- "Returns the currently active domain"
  and cswitch :: "time_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t" -- "Performs a context switch"
  and interrupt :: "time_t \<Rightarrow> bool" -- "Returns t iff an interrupt occurs in the given state at the given time"
  and kinvolved :: "'action_t \<Rightarrow> 'dom_t set" -- "Returns the set of domains that are involved in the given action"
  and ifp :: "'dom_t \<Rightarrow> 'dom_t \<Rightarrow> bool" -- "The security policy."
  and vpeq :: "'dom_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t \<Rightarrow> bool" -- "View partitioning equivalence"
  and AS_set :: "('action_t list) set" -- "Returns a set of valid action sequences, i.e., the attack surface"
  and invariant :: "'state_t \<Rightarrow> bool" -- "Returns an inductive state-invariant"
  and AS_precondition :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" -- "Returns the preconditions under which the given action can be executed."
  and aborting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" -- "Returns true iff the action is aborted."
  and waiting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" -- "Returns true iff execution of the given action is delayed."
  and set_error_code :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" -- "Sets an error code when actions are aborted."
assumes vpeq_transitive: " \<forall> a b c u. (vpeq u a b \<and> vpeq u b c) \<longrightarrow> vpeq u a c"
    and vpeq_symmetric: "\<forall> a b u. vpeq u a b \<longrightarrow> vpeq u b a"
    and vpeq_reflexive: "\<forall> a u. vpeq u a a"
    and ifp_reflexive: "\<forall> u . ifp u u"
    and weakly_step_consistent: "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> invariant s \<and> AS_precondition s (current s) a \<and> invariant t \<and> AS_precondition t (current t) a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
    and locally_respects: "\<forall> a s u. \<not>ifp (current s) u  \<and> invariant s \<and> AS_precondition s (current s) a \<longrightarrow> vpeq u s (kstep s a)"
    and output_consistent: "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
    and step_atomicity: "\<forall> s a . current (kstep s a) = current s"
    and cswitch_independent_of_state: "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
    and cswitch_consistency: "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
    and empty_in_AS_set: "[] \<in> AS_set"
    and invariant_s0: "invariant s0"
    and invariant_after_cswitch: "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
    and precondition_after_cswitch: "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
    and AS_prec_first_action: "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
    and AS_prec_after_step: "\<forall> s a a' . (\<exists> aseq \<in> AS_set . is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not>aborting s (current s) a \<and> \<not> waiting s (current s) a\<longrightarrow> AS_precondition (kstep s a) (current s) a'"
    and AS_prec_dom_independent: "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
    and spec_of_invariant: "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
    and aborting_switch_independent: "\<forall> n s . aborting (cswitch n s) = aborting s"
    and aborting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> aborting s d a \<longrightarrow> aborting (set_error_code s a') d a"
    and aborting_after_step: "\<forall> s a d . current s \<noteq> d \<longrightarrow> aborting (kstep s a) d = aborting s d" (* TODO: I think this PO can be removed *)
    and aborting_consistent: "\<forall> s t u . vpeq u s t \<longrightarrow> aborting s u = aborting t u"
    and waiting_switch_independent: "\<forall> n s . waiting (cswitch n s) = waiting s"
    and waiting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> waiting s d a \<longrightarrow> waiting (set_error_code s a') d a"
    and waiting_consistent: "\<forall>s t u a . vpeq (current s) s t \<and> (\<forall> d \<in> kinvolved a . vpeq d s t) \<and> vpeq u s t \<longrightarrow> waiting s u a = waiting t u a"
    and spec_of_waiting: "\<forall> s a . waiting s (current s) a \<longrightarrow> kstep s a = s"
    and set_error_consistent: "\<forall> s t u a . vpeq u s t \<longrightarrow> vpeq u (set_error_code s a) (set_error_code t a)"
    and set_error_locally_respects: "\<forall> s u a . \<not>ifp (current s) u \<longrightarrow> vpeq u s (set_error_code s a)"
    and current_set_error_code: "\<forall> s a . current (set_error_code s a) = current s"
    and precondition_after_set_error_code: "\<forall> s d a a'. AS_precondition s d a \<and> aborting s (current s) a' \<longrightarrow> AS_precondition (set_error_code s a') d a"
    and invariant_after_set_error_code: "\<forall> s a . invariant s \<longrightarrow> invariant (set_error_code s a)"
    and involved_ifp: "\<forall> s a . \<forall> d \<in> (kinvolved a) . AS_precondition s (current s) a \<longrightarrow> ifp d (current s)"
begin

subsubsection{* Execution semantics *}

text{*
  Control is based on generic functions \emph{aborting}, \emph{waiting} and \emph{set\_error\_code}.
  Function \emph{aborting} decides whether a certain action is aborting, given its domain and the state.
  If so, then function set\_error\_code will be used to update the state, possibly communicating to other domains that an action has been aborted.
  Function \emph{waiting} can delay the execution of an action.
  This behavior is implemented in function CISK\_control.
*}
function CISK_control :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t execution \<Rightarrow> ('action_t option \<times> 'action_t execution \<times> 'state_t)"
where "CISK_control s d []                = (None,[],s)" -- "The thread is empty"
    | "CISK_control s d ([]#[])           = (None,[],s)" -- "The current action sequence has been finished and the thread has no next action sequences to execute"
    | "CISK_control s d ([]#(as'#execs')) = (None,as'#execs',s)" -- "The current action sequence has been finished. Skip to the next sequence"
    | "CISK_control s d ((a#as)#execs')   = (if aborting s d a then
                                                  (None, execs',set_error_code s a)
                                               else if waiting s d a then
                                                  (Some a, (a#as)#execs',s)
                                               else
                                                  (Some a, as#execs',s))" -- "Executing an action sequence"
by pat_completeness auto
termination by lexicographic_order

text{*
  Function \emph{run} defines the execution semantics.
  This function is presented in ~\cite{Verbeek2013} by pseudo code (see Algorithm 1).
  Before defining the run function, we define accessor functions for the control mechanism.
  Functions next\_action, next\_execs and next\_state correspond to ``control.a'', ``control.x'' and ``control.s'' in ~\cite{Verbeek2013}.
*}
abbreviation next_action::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'action_t option"
where "next_action \<equiv> Kernel.next_action current CISK_control"
abbreviation next_execs::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution)"
where "next_execs  \<equiv> Kernel.next_execs current CISK_control"
abbreviation next_state::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "next_state  \<equiv> Kernel.next_state current CISK_control"
text {*
*}
text {*
  A thread is empty iff either it has no further action sequences to execute, or when the current action sequence is finished and there are no further action sequences to execute.
*}
abbreviation thread_empty::"'action_t execution \<Rightarrow> bool"
where "thread_empty exec \<equiv> exec = [] \<or> exec = [[]]"

text{*
  The following function defines the execution semantics of CISK, using function CISK\_control.
*}
function run :: "time_t \<Rightarrow> 'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "run 0 s execs = s"
| "interrupt (Suc n) \<Longrightarrow> run (Suc n) s execs = run n (cswitch (Suc n) s) execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> thread_empty(execs (current s)) \<Longrightarrow> run (Suc n) s execs = run n s execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> \<not>thread_empty(execs (current s)) \<Longrightarrow>
      run (Suc n) s execs = (let control_a = next_action s execs;
                                 control_s = next_state s execs;
                                 control_x = next_execs s execs in
                             case control_a of None \<Rightarrow> run n control_s control_x
                                         | (Some a) \<Rightarrow> run n (kstep control_s a) control_x)"
using not0_implies_Suc by (metis prod_cases3,auto)
termination by lexicographic_order

subsubsection {* Formulations of security *}

text{*
  The definitions of security as presented in Section 2.2 of~\cite{Verbeek2013}.
*}

abbreviation kprecondition
  where "kprecondition s a \<equiv> invariant s \<and> AS_precondition s (current s) a"
definition realistic_execution
where "realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
definition realistic_executions :: "('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "realistic_executions execs \<equiv> \<forall>d. realistic_execution (execs d)"
abbreviation involved where "involved \<equiv> Kernel.involved kinvolved"
abbreviation step where "step \<equiv> Kernel.step kstep"
abbreviation purge where "purge \<equiv> Separation_Kernel.purge realistic_execution ifp"
abbreviation ipurge_l where "ipurge_l \<equiv> Separation_Kernel.ipurge_l kinvolved ifp"
abbreviation ipurge_r where "ipurge_r \<equiv> Separation_Kernel.ipurge_r realistic_execution kinvolved ifp"

definition NI_unrelated::bool
where "NI_unrelated
  \<equiv> \<forall> execs a n . realistic_executions execs \<longrightarrow>
                      (let s_f = run n s0 execs in
                         output_f s_f a = output_f (run n s0 (purge execs (current s_f))) a)"
definition NI_indirect_sources::bool
where "NI_indirect_sources
  \<equiv> \<forall> execs a n. realistic_executions execs \<longrightarrow>
                    (let s_f = run n s0 execs in
                      output_f (run n s0 (ipurge_l execs (current s_f))) a =
                      output_f (run n s0 (ipurge_r execs (current s_f))) a)"
definition isecure::bool
where "isecure \<equiv> NI_unrelated \<and> NI_indirect_sources"

subsubsection {*Proofs*}
text{*
  The final theorem is unwinding\_implies\_isecure\_CISK.
  This theorem shows that any interpretation of locale CISK is secure.

  To prove this theorem, the refinement framework is used.
  CISK is a refinement of ISK, as the only idfference is the control function.
  In ISK, this function is a generic function called \emph{control}, in CISK it is interpreted in function \emph{CISK\_control}.
  It is proven that function \emph{CISK\_control} satisfies all the proof obligations concerning generic function \emph{control}.
  In other words, \emph{CISK\_control} is proven to be an interpretation of control.
  Therefore, all theorems on run\_total apply to the run function of CISK as well.
*}

lemma next_action_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in>  involved (next_action s execs) . vpeq d s t) \<and> current s = current t  \<longrightarrow> next_action s execs = next_action t execs"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in>  involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
   have "aborting t (current s) = aborting s (current s)" by auto
  from current_s_t this waiting_consistent vpeq_involved
    have "next_action s execs = next_action t execs"
    unfolding Kernel.next_action_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_execs_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in> involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
     have 1: "aborting t (current s) = aborting s (current s)" by auto
  from 1 vpeq current_s_t vpeq_involved waiting_consistent[THEN spec,THEN spec,THEN spec,THEN spec,where x3=s and x2=t and x1="current s" and x="the (next_action s execs)"]
    have "fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
    unfolding Kernel.next_action_def Kernel.involved_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split add: split_if_asm)
}
thus ?thesis by auto
qed

lemma next_state_consistent:
shows "\<forall> s t u execs . vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
proof-
{
  fix s t u execs
  assume vpeq_s_t: "vpeq (current s) s t \<and> vpeq u s t"
  assume current_s_t: "current s = current t"
  from vpeq_s_t current_s_t
    have "vpeq u (next_state s execs) (next_state t execs)"
    unfolding Kernel.next_state_def
    using aborting_consistent set_error_consistent
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma current_next_state:
shows "\<forall> s execs . current (next_state s execs) = current s"
proof-
{
  fix s execs
  have "current (next_state s execs) = current s"
    unfolding Kernel.next_state_def
    using current_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma locally_respects_next_state:
shows "\<forall> s u execs. \<not>ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
proof-
{
  fix s u execs
  assume "\<not>ifp (current s) u"
  hence "vpeq u s (next_state s execs)"
    unfolding Kernel.next_state_def
    using vpeq_reflexive set_error_locally_respects
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma CISK_control_spec:
shows "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
proof-
{
  fix s d aseqs
  have "case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_cswitch:
shows "\<forall> s n d aseqs . fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s n d aseqs
  have "fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
  using aborting_switch_independent waiting_switch_independent
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_next_state:
shows "\<forall> s execs d . current s \<noteq> d \<longrightarrow> fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
proof-
{
  fix s execs d aseqs
  assume 1: "current s \<noteq> d"
  have "fst (CISK_control (next_state s execs) d aseqs) = None \<or> fst (CISK_control (next_state s execs) d aseqs) = fst (CISK_control s d aseqs)"
    proof(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp)
    case (4 sa da a as execs')
      thus ?thesis
          unfolding Kernel.next_state_def
          using aborting_error_update waiting_error_update 1
          by(cases "(sa,current sa,execs (current sa))" rule: CISK_control.cases,auto split: split_if_asm)
    qed
}
thus ?thesis by auto
qed

lemma next_action_after_step:
shows "\<forall> s a d aseqs . current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s a d aseqs
  assume 1: "current s \<noteq> d"
  from this aborting_after_step
    have  "fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
    unfolding Kernel.step_def
    by(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp,cases a,auto)
}
thus ?thesis by auto
qed

lemma next_state_precondition:
shows "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
proof-
{
  fix s a d execs
  assume "AS_precondition s d a"
  hence "AS_precondition (next_state s execs) d a"
    unfolding Kernel.next_state_def
    using precondition_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_state_invariant:
shows "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
proof-
{
  fix s execs
  assume "invariant s"
  hence "invariant (next_state s execs)"
    unfolding Kernel.next_state_def
    using invariant_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_from_execs:
shows "\<forall> s execs . next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
proof-
{
  fix s execs
  {
    fix a
    assume 1: "next_action s execs = Some a"
    from 1 have "a \<in> actions_in_execution (execs (current s))"
      unfolding Kernel.next_action_def actions_in_execution_def
      by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split add: split_if_asm)
  }
  hence "next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
    unfolding B_def
    by (cases "next_action s execs",auto)
}
thus ?thesis unfolding B_def by (auto)
qed

lemma next_execs_subset:
shows "\<forall>s execs u . actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
proof-
{
  fix s execs u
  have "actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
    unfolding Kernel.next_execs_def actions_in_execution_def
    by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split add: split_if_asm)
}
thus ?thesis by auto
qed

theorem unwinding_implies_isecure_CISK:
shows isecure
proof-
  interpret int: Interruptible_Separation_Kernel kstep output_f s0 current cswitch interrupt kprecondition realistic_execution CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting
    proof (unfold_locales)
      show "\<forall>a b c u. vpeq u a b \<and> vpeq u b c \<longrightarrow> vpeq u a c"
        using vpeq_transitive by blast
      show "\<forall>a b u. vpeq u a b \<longrightarrow> vpeq u b a"
        using vpeq_symmetric by blast
      show "\<forall>a u. vpeq u a a"
        using vpeq_reflexive by blast
      show "\<forall>u. ifp u u"
        using ifp_reflexive by blast
      show "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> kprecondition s a \<and> kprecondition t a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
        using weakly_step_consistent by blast
      show "\<forall> a s u. \<not>ifp (current s) u  \<and> kprecondition s a \<longrightarrow> vpeq u s (kstep s a)"
        using locally_respects by blast
      show "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
        using output_consistent by blast
      show "\<forall> s a . current (kstep s a) = current s"
        using step_atomicity by blast
      show "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
        using cswitch_independent_of_state by blast
      show "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
        using cswitch_consistency by blast
      show "\<forall>s t execs. vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> next_action s execs = next_action t execs"
        using next_action_consistent by blast
      show "\<forall>s t execs.
        vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow>
        fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
        using next_execs_consistent by blast
      show " \<forall>s t u execs. vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
        using next_state_consistent by auto
      show " \<forall>s execs. current (next_state s execs) = current s"
        using current_next_state by auto
      show "\<forall>s u execs. \<not> ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
        using locally_respects_next_state by auto
      show "[] \<in> AS_set"
        using empty_in_AS_set by blast
      show "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
        using invariant_after_cswitch by blast
      show "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
        using precondition_after_cswitch by blast
      show "invariant s0"
        using invariant_s0 by blast
      show "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
        using AS_prec_first_action by blast
      show "\<forall>s a a'. (\<exists>aseq\<in>AS_set. is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not> aborting s (current s) a \<and> \<not> waiting s (current s) a \<longrightarrow>
             AS_precondition (kstep s a) (current s) a'"
        using AS_prec_after_step by blast
      show "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
        using AS_prec_dom_independent by blast
      show "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
        using spec_of_invariant by blast
      show "\<And>s a. kprecondition s a \<equiv> kprecondition s a"
        by auto
      show "\<And>aseq. realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
        unfolding realistic_execution_def
        by auto
      show "\<forall>s a. \<forall> d \<in> involved a. kprecondition s (the a) \<longrightarrow> ifp d (current s)"
        using involved_ifp unfolding Kernel.involved_def by (auto split: option.splits)
      show "\<forall>s execs. next_action s execs \<rightharpoonup> (\<lambda>a. a \<in> actions_in_execution (execs (current s)))"
        using next_action_from_execs by blast
      show "\<forall>s execs u. actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
        using next_execs_subset by blast
      show "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
        using CISK_control_spec by blast
      show "\<forall>s n d aseqs. fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_cswitch by auto
      show "\<forall>s execs d.
       current s \<noteq> d \<longrightarrow>
       fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
        using next_action_after_next_state by auto
      show "\<forall>s a d aseqs. current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_step by auto
      show "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
        using next_state_precondition by auto
      show "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
        using next_state_invariant by auto
      show "\<forall>s a. waiting s (current s) a \<longrightarrow> kstep s a = s"
        using spec_of_waiting by blast
  qed

  note interpreted=`Interruptible_Separation_Kernel kstep output_f s0 current cswitch kprecondition realistic_execution CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting`
  note run_total_induct = Interruptible_Separation_Kernel.run_total.induct[of kstep output_f s0 current cswitch kprecondition realistic_execution
                                                                             CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting _ interrupt]
  have run_equals_run_total:
     "\<And> n s execs . run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
     proof-
        fix n s execs
        show "run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
          using interpreted int.step_def
          by(induct n s execs rule: run_total_induct,auto split: option.splits)
     qed
  from interpreted
    have 0: "Interruptible_Separation_Kernel.isecure_total kstep output_f s0 current cswitch interrupt realistic_execution CISK_control kinvolved ifp"
    by (metis int.unwinding_implies_isecure_total)
  from 0 run_equals_run_total
    have 1: "NI_unrelated"
    by (metis realistic_executions_def int.isecure_total_def int.realistic_executions_def int.NI_unrelated_total_def NI_unrelated_def)
  from 0 run_equals_run_total
    have 2: "NI_indirect_sources"
    by (metis realistic_executions_def int.NI_indirect_sources_total_def int.isecure_total_def int.realistic_executions_def NI_indirect_sources_def)
  from 1 2 show ?thesis unfolding isecure_def by auto
qed

end
end


theory Relation_Algebra_MaxIndSet_Atom
  imports "~~/src/HOL/Hoare/Hoare_Logic"
          "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Cardinal"
           "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Orders"
            "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Points"

begin
text{* This theory contains the correctness proof of the Maximum Independent Set algorithm
presented in "Cardinality of Relations and Relational Approximation Algorithms" by Berghammer et al.
Our version of the program uses partial identities and partial points, instead of vectors and points.*}

declare [[show_sorts,show_types]]

text{* minpoint is called the function point() in the underlying paper. It is defined by the
properties it should fulfill. *}

class minatom =
  fixes minatom :: "'a \<Rightarrow> 'a"

class relation_algebra_minatom = relation_algebra_card + minatom +
  assumes minatom_sub:  "minatom x \<le> x"
  and     minatom_point:"x \<noteq> bot \<longrightarrow> is_partial_point (minatom x)"

context relation_algebra_minatom
  begin

text{* ";" is a symbol used in Hoare_Logic, thus we have to change the notation here.*}

no_notation
  composition (infixl ";" 75)
notation
  composition (infixl "\<bullet>" 75)

text{* Below we define the maximum degree and prove some properties about it. *}

definition max_deg  :: "'a \<Rightarrow> nat"
   where "max_deg x \<equiv> Max { |x\<bullet>y\<bullet>top \<sqinter> 1'| |y . is_partial_point y}"

definition is_symm :: "'a \<Rightarrow> bool"
  where "is_symm x \<longleftrightarrow> x = x\<^sup>\<smile>"

lemma auxmax_1:
  assumes fin: "finite  { x . P x }"
    and "v \<in> { x . P x }"
  shows "f v \<le> Max { f y |y. P y }"
proof(rule Max_ge)
  show "finite {f y |y::'b. P y}"
    by (simp add: fin)
next
  show "f v \<in> {f y |y::'b. P y}"
    using assms(2) by blast
qed

lemma sum_bounded:
  fixes K:: "nat"
    (*f:: 'a \<Rightarrow> nat   (Betrags-Funktion) *)
  assumes leq: "\<And>x. x\<in>A \<Longrightarrow> f x \<le> K"
    and fin: "finite A"
  shows "( \<Sum>x\<in>A . f x ) \<le> (card A)*K"
  using leq sum_bounded_above by force

text{* The pre-, postcondition and invariant are defined below. *}

definition pre :: "'a \<Rightarrow> nat \<Rightarrow> bool"
 where "pre r k  \<longleftrightarrow> is_irrefl r \<and> is_symm r \<and> k = max_deg r"

definition post :: "'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
  where "post r k s \<longleftrightarrow>
    r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> s\<^sup>c \<sqinter> 1' \<and> (\<forall>t .is_test t \<and> r\<bullet>t\<bullet>top \<sqinter> 1' \<sqsubseteq> t\<^sup>c \<sqinter> 1' \<longrightarrow> |t| \<le> |s| * (k+1))"

definition inv :: "'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a  \<Rightarrow> bool"
  where "inv r k s v \<longleftrightarrow>
    pre r k \<and> r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> s\<^sup>c \<sqinter> 1' \<and> (r\<bullet>s\<bullet>top \<sqinter> 1') \<squnion> s = v \<and> is_test s \<and> is_test v"

text{* In the following we prove the correctness of the program. *}

theorem correctness: "VARS r k s v p
  { pre r k }
  s := bot;
  v := bot;
  WHILE v \<noteq> 1'
    INV { inv r k s v }
     DO p := minatom (v\<^sup>c \<sqinter> 1');
        s := s \<squnion> p;
        v := v \<squnion> p \<squnion> (r\<bullet>p\<bullet>top \<sqinter> 1')
     OD
  { post r k s }"

proof (vcg_simp)
  (* Proof of first ProofObligation (PO1) *)
  fix r::'a and k::nat
  assume hpre: "pre r k"
  show "inv r k bot bot"
    by (simp add: hpre local.inv_def local.is_test_def)
next
  (* Proof of (PO3)*)
  fix r s v :: 'a and k :: nat
  let ?p = "minatom (v\<^sup>c \<sqinter> 1')"
  assume hinv: "inv r k s v \<and> v \<noteq> 1'"
  have auxvec1: "is_test(v\<^sup>c \<sqinter> 1')"
    by (simp add: local.is_test_def)
  have ppoint: "is_partial_point ?p"
    by (metis hinv local.antisym local.galois_aux2 local.inf.commute local.inv_def local.is_test_def local.minatom_point)
  have aux: "s \<sqsubseteq> v "
    using hinv local.inv_def by auto
  have aux1: "r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> v"
    using hinv local.inv_def by auto
  have aux2: "(r\<bullet>s\<bullet>top \<sqinter> 1') \<squnion> s = v"
    using hinv local.inv_def by blast
  have hp: "r\<bullet>?p\<bullet>top \<sqsubseteq> ?p\<^sup>c"
          proof -
            have a: "?p\<bullet>top\<bullet>?p\<^sup>\<smile> \<sqsubseteq> 1'"
              using local.is_atom_def local.is_partial_point_def ppoint by blast
            have b: "?p\<bullet>top\<bullet>?p\<^sup>\<smile> \<sqsubseteq> r\<^sup>c"
              by (metis a hinv local.comp_anti local.double_compl local.dual_order.trans local.inv_def local.is_irrefl_def pre_def)
            thus ?thesis
              by (simp add: local.compl_le_swap1 local.conv_galois_2)
          qed
  show "inv r k (s \<squnion> ?p) (v \<squnion> ?p \<squnion> r\<bullet>?p\<bullet>top \<sqinter> 1')" unfolding inv_def
  proof (intro conjI)
    show hpre: "pre r k"
      using hinv inv_def by blast
    next
    show "is_test (s \<squnion> ?p)"
      using hinv local.inv_def local.is_partial_point_def local.test_sum ppoint by blast
    next
    show "is_test (v \<squnion> ?p \<squnion> r \<bullet>?p\<bullet>top \<sqinter> 1')"
      using hinv local.inv_def local.is_partial_point_def local.is_test_def ppoint by auto
    show "(r\<bullet>(s \<squnion> ?p)\<bullet>top \<sqinter> 1') \<squnion> (s \<squnion> ?p) = v \<squnion> ?p \<squnion> (r\<bullet>?p\<bullet>top \<sqinter> 1')"
    proof -
      have "(r\<bullet>(s \<squnion> ?p)\<bullet>top \<sqinter> 1') \<squnion> (s \<squnion> ?p) = (r\<bullet>s\<bullet>top \<sqinter> 1') \<squnion> (r\<bullet>?p\<bullet>top \<sqinter> 1') \<squnion> (s \<squnion> ?p)"
        by (simp add: local.distrib_left local.distrib_right local.inf_sup_distrib2)
      also have "\<dots> = ((r\<bullet>s\<bullet>top \<sqinter> 1') \<squnion> s) \<squnion> (r\<bullet>?p\<bullet>top \<sqinter> 1') \<squnion> ?p"
        by (simp add: local.sup_assoc local.sup_left_commute)
      also have "\<dots> = v \<squnion> ?p \<squnion> (r\<bullet>?p\<bullet>top \<sqinter> 1')"
        using aux2 local.sup.assoc local.sup.commute by auto
      finally show ?thesis
        by blast
    qed
    show a: "r\<bullet>(s \<squnion> ?p)\<bullet>top \<sqinter> 1' \<sqsubseteq> (s \<squnion> ?p)\<^sup>c \<sqinter> 1'"
      apply(simp add: distrib_left distrib_right)
    proof (intro conjI)
      show b:"(r\<bullet>s\<bullet>top \<squnion> r\<bullet>?p\<bullet>top) \<sqinter> 1' \<sqsubseteq> ?p\<^sup>c"
        apply (simp add: inf_sup_distrib2)
      proof (intro conjI)
        show  "r\<bullet>?p\<bullet>top \<sqinter> 1' \<sqsubseteq> ?p\<^sup>c"
          using hp local.inf.coboundedI1 by blast
        show "r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> ?p\<^sup>c"
        proof -
          have a: "r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> v "
            by (simp add: aux1)
          also have "\<dots> \<sqsubseteq> v \<squnion> 1'\<^sup>c"
            by simp
          also have "\<dots> \<sqsubseteq> ?p\<^sup>c"
            by (metis local.comp_anti local.compl_sup local.double_compl local.minatom_sub)
          finally show ?thesis
            by blast
        qed
      qed
      show "(r\<bullet>s\<bullet>top \<squnion> r\<bullet>?p\<bullet>top) \<sqinter> 1' \<sqsubseteq> s\<^sup>c"
        apply (simp add: inf_sup_distrib2)
      proof (intro conjI)
        show "r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> s\<^sup>c"
          using hinv local.inv_def by auto
        show "r\<bullet>?p\<bullet>top \<sqinter> 1' \<sqsubseteq> s\<^sup>c"
        proof -
          have 1: "r\<bullet>s\<bullet>top \<sqsubseteq> ?p\<^sup>c"
            by (smt b local.dual_order.trans local.galois_2 local.inf.bounded_iff local.inf.cobounded2 local.less_eq_def local.minatom_sub local.sup_ge1)
          have 2: "r\<^sup>\<smile>\<bullet>s \<sqsubseteq> (?p\<bullet>top)\<^sup>c"
            using "1" hinv is_symm_def local.conv_galois_2 local.inv_def pre_def by auto
          have 3: "r\<bullet>?p\<bullet>top \<sqsubseteq> s\<^sup>c"
            by (metis "2" local.comp_assoc local.compl_le_swap1 local.conv_galois_1 local.double_compl)
          thus ?thesis
            by (simp add: local.inf.coboundedI1)
        qed
      qed
    qed
  qed
next
    (* Proof of (PO2) *)
  fix r s v :: 'a and k :: nat
  assume hinv: "inv r k s v \<and> v = 1'"
  show "post r k s" unfolding post_def
    proof (intro conjI)
      show "r\<bullet>s\<bullet>top \<sqinter> 1' \<sqsubseteq> s\<^sup>c \<sqinter> 1'"
        using hinv local.inv_def by blast
      next
      show "\<forall>t. is_test t \<and> r\<bullet>t\<bullet>top \<sqinter> 1' \<sqsubseteq> t\<^sup>c \<sqinter> 1' \<longrightarrow> |t| \<le> |s| * (k+1)"
        proof
          fix t
          show "is_test t \<and> r\<bullet>t\<bullet>top \<sqinter> 1' \<sqsubseteq> t\<^sup>c \<sqinter> 1' \<longrightarrow> |t| \<le> |s| * (k+1)"
            proof
            assume ht: "is_test t \<and> r\<bullet>t\<bullet>top \<sqinter> 1' \<sqsubseteq> t\<^sup>c \<sqinter> 1'"
            show "|t| \<le> |s| * (k+1)"
            proof -
              have finpp: "finite {x|x. is_partial_point x \<and> x \<sqsubseteq> s}"
                using fin_partial_points_p by auto
              have finppf: "finite {x\<bullet>top|x. is_partial_point x \<and> x \<sqsubseteq> s}"
                using fin_partial_points_fun by fastforce
              have "|t| \<le> |1'|"
                using ht local.cardmono local.is_test_def by auto
              also have "\<dots> = |v|"
                by (simp add: hinv)
              also have "\<dots> = |(r\<bullet>s\<bullet>top \<sqinter> 1') \<squnion> s|"
                using hinv local.inv_def by auto
              also have "\<dots> \<le> |(r\<bullet>s\<bullet>top \<sqinter> 1')| + |s|"
                by (metis le_add1 local.cardsimp)
              also have "\<dots> = |r\<bullet>\<Squnion> {x|x. is_partial_point x \<and> x \<sqsubseteq> s}\<bullet>top \<sqinter> 1'| + |s|"
                using hinv local.inv_def local.test_partial_points by auto
              also have "\<dots> = |r\<bullet>\<Squnion> {x\<bullet>top|x. is_partial_point x \<and> x \<sqsubseteq> s} \<sqinter> 1'| + |s|"
                using sum_comp_distr_left finpp local.mult_assoc by fastforce
              also have "\<dots> = |\<Squnion> {r\<bullet>(x\<bullet>top)|x. is_partial_point x \<and> x \<sqsubseteq> s} \<sqinter> 1'| + |s|"
                using sum_comp_distr_right_fun finpp by fastforce
              also have "\<dots> = |\<Squnion> {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s}| + |s|"
                using sum_cap_distr_right_fun finpp by fastforce
              also have "\<dots> \<le> (\<Sum> z \<in> {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s}. |z| ) + |s|"
                using sumleq_fun finpp by auto
              also have "\<dots> \<le> (\<Sum> z \<in> {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s}. k ) + |s|"
                proof -
     have a: "(\<Sum> z \<in> {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s}. |z| ) \<le> card {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s} * k"
      proof (rule sum_bounded)
        show "finite {r\<bullet>(x\<bullet>top) \<sqinter> 1' |x::'a. is_partial_point x \<and> x \<sqsubseteq> s}"
          using fin_partial_points_fun by fastforce
        show "\<And>z. z \<in> {r\<bullet>(x\<bullet>top) \<sqinter> 1' |x. is_partial_point x \<and> x \<sqsubseteq> s} \<Longrightarrow> |z| \<le> k"
          proof -
          fix z
          assume h: "z \<in> {r\<bullet>(x\<bullet>top) \<sqinter> 1' |x. is_partial_point x \<and> x \<sqsubseteq> s}"
          show "|z| \<le> k"
          proof -
              have  "|z| \<le> Max { |r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x . is_partial_point x \<and> x \<sqsubseteq> s}"
                proof (rule Max_ge)
                  show "finite {|r \<bullet> (x \<bullet> top) \<sqinter> 1'| |x::'a. is_partial_point x \<and> x \<sqsubseteq> s}"
                    by (simp add: local.fin_partial_points_fun)
                  show "|z| \<in> {|r \<bullet> (x \<bullet> top) \<sqinter> 1'| |x::'a. is_partial_point x \<and> x \<sqsubseteq> s}"
                    using h by blast
                qed
              also have "\<dots> \<le> Max { |r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x . is_partial_point x \<and> x \<sqsubseteq> top}"
                 proof (rule Max_mono)
                  show "{ |r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x . is_partial_point x \<and> x \<sqsubseteq> s} \<subseteq> { |r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x . is_partial_point x \<and> x \<sqsubseteq> top}"
                    by auto
                  show "{|r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x. is_partial_point x \<and> x \<sqsubseteq> s} \<noteq> {}"
                    using h by blast
                  show "finite {|r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x. is_partial_point x \<and> x \<sqsubseteq> top}"
                    using local.fin_partial_points_fun by fastforce
                qed
              also have "\<dots> = Max { |r\<bullet>(x\<bullet>top) \<sqinter> 1'| |x . is_partial_point x}"
                by simp
              also have "\<dots> = max_deg r"
                by (simp add: local.comp_assoc max_deg_def)
              also have "\<dots> = k"
                using hinv local.inv_def pre_def by auto
              finally show ?thesis
                by blast
            qed
          qed
        qed
      thus ?thesis
        by simp
      qed
    also have "\<dots> \<le> card {r\<bullet>(x\<bullet>top) \<sqinter> 1'|x. is_partial_point x \<and> x \<sqsubseteq> s} * k + |s|"
      by simp
    also have "\<dots> \<le> |s| * k + |s|"
      using card_test_fun inv_def hinv by fastforce
    finally show ?thesis
      by simp
  qed
qed
qed
qed
qed

end