(*
bounded stack using List as its implementation
*)
theory BoundedStack
imports Main
begin

section {* implementation by list *}

record 'a stack = stk :: "'a list"
                  maxsize :: nat

locale bstack_list
begin

fun push :: "'a \<Rightarrow> 'a stack \<Rightarrow> 'a stack"
where "push v s = (if length (stk s) < maxsize s then
                  s\<lparr>stk := v # stk s\<rparr>
               else s)"

fun pop :: "'a stack \<Rightarrow> ('a \<times> 'a stack)"
where "pop s = (case stk s of x # xs \<Rightarrow> (x, s\<lparr>stk := xs\<rparr>))"

definition top :: "'a stack \<Rightarrow> 'a"
  where "top s \<equiv> hd (stk s)"

definition "emp s \<equiv> stk s = []"

definition "full s \<equiv> length (stk s) = maxsize s"

definition "notfull s \<equiv> length (stk s) < maxsize s"

definition "valid s \<equiv> notfull s \<or> full s"

lemma "notfull s \<Longrightarrow> top (push v s) = v"
  by(simp add:top_def notfull_def)

lemma "notfull s \<Longrightarrow> pop (push x s) = (x, s)"
  by (simp add:notfull_def)

lemma "full s \<Longrightarrow> push x s = s"
  by (simp add:full_def)

lemma "\<not> emp s \<Longrightarrow> top s = fst (pop s)"
  by (simp add: emp_def list.case_eq_if top_def)

lemma "\<lbrakk>\<not> emp s; (v, s0) = pop s; valid s \<rbrakk> \<Longrightarrow> push v s0 = s"
  apply(simp add: emp_def valid_def full_def notfull_def)
  apply(case_tac "stk s") apply simp
  by auto

end

section {* implementation by type *}

typedef (overloaded) 'a bstack =
  "{xs :: ('a list \<times> nat). length (fst xs) \<le> snd xs}"
  morphisms alist_of Abs_bstack
proof -
  have "([],0) \<in> {xs. length (fst xs) \<le> snd xs}" by simp
  thus ?thesis by blast
qed

thm alist_of_inverse
thm alist_of
thm Abs_bstack_inverse
thm Abs_bstack_inject

locale bstack_type
begin

definition capacity :: "'a bstack \<Rightarrow> nat"
where "capacity s \<equiv> snd (alist_of s)"

definition size :: "'a bstack \<Rightarrow> nat"
where "size s \<equiv> length (fst (alist_of s))"

definition isfull :: "'a bstack \<Rightarrow> bool"
where "isfull s \<equiv> size s = capacity s"

definition isempty :: "'a bstack \<Rightarrow> bool"
where "isempty s \<equiv> fst (alist_of s) = []"

lemma Abs_bstack: "length (fst xs) \<le> snd xs \<Longrightarrow> alist_of (Abs_bstack xs) = xs"
  apply (rule Abs_bstack_inverse) by simp

lemma [code abstype]: "Abs_bstack (alist_of bs) = bs"
  by (simp add:alist_of_inverse)

lemma "xs = alist_of bs \<Longrightarrow> length (fst xs) \<le> snd xs"
  using alist_of by auto

lemma bstack_valid: "size s \<le> capacity s"
  apply(simp add:capacity_def size_def)
  using alist_of by blast

definition newstack :: "nat \<Rightarrow> 'a bstack"
where "newstack n \<equiv> Abs_bstack ([],n)"

definition push :: "'a \<Rightarrow> 'a bstack \<Rightarrow> 'a bstack"
where "push v s \<equiv> (if \<not>isfull s then
                      Abs_bstack (v # fst (alist_of s), snd (alist_of s))
                   else s)"

definition pop :: "'a bstack \<Rightarrow> ('a option \<times> 'a bstack)"
where "pop s \<equiv> (if \<not> isempty s then
                  (Some (hd (fst (alist_of s))), Abs_bstack (tl (fst (alist_of s)), snd (alist_of s)))
                else (None, s))"

definition top :: "'a bstack \<Rightarrow> 'a option"
where "top s \<equiv> (if \<not> isempty s then
                  (Some (hd (fst (alist_of s))))
                else None)"

lemma "\<not> isfull s \<Longrightarrow> top (push v s) = Some v"
  apply(simp add:top_def isfull_def capacity_def isempty_def size_def push_def)
  by (metis Abs_bstack bstack_valid capacity_def fst_conv length_Cons
        less_Suc_eq list.distinct(1) list.sel(1) not_less size_def snd_conv)

lemma "\<not> isfull s \<Longrightarrow> pop (push x s) = (Some x, s)"
  apply(simp add:pop_def isfull_def capacity_def isempty_def size_def push_def)
  by (metis (no_types, lifting) Abs_bstack alist_of alist_of_inverse fst_conv length_Cons
      less_Suc_eq list.distinct(1) list.sel(1) list.sel(3) mem_Collect_eq not_less prod_eq_iff snd_conv)

lemma "isfull s \<Longrightarrow> push x s = s"
  by (simp add:isfull_def size_def capacity_def push_def)

lemma "\<not> isempty s \<Longrightarrow> top s = fst (pop s)"
  by (simp add: isempty_def top_def pop_def)

lemma "\<lbrakk>\<not> isempty s; (v, s0) = pop s \<rbrakk> \<Longrightarrow> push (the v) s0 = s"
  apply(simp add: pop_def isempty_def isfull_def size_def capacity_def push_def)
  by (metis alist_of_inverse Abs_bstack bstack_valid capacity_def size_def fst_conv
        length_Cons less_Suc_eq list.exhaust_sel not_less prod.exhaust_sel snd_conv)

end

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>Convert between $\omega$-Words and Streams\<close>

theory Omega_Words_Fun_Stream
imports
  "HOL-Library.Omega_Words_Fun" "HOL-Library.Stream"
begin

(* TODO add to HOL-Library.Omega_Words_Fun *)

definition to_omega :: "'a stream \<Rightarrow> 'a word" where
  "to_omega \<equiv> snth"

definition to_stream :: "'a word \<Rightarrow> 'a stream" where
  "to_stream w \<equiv> smap w nats"

lemma to_omega_to_stream[simp]:
  "to_omega (to_stream w) = w"
  unfolding to_omega_def to_stream_def
  by auto

lemma to_stream_to_omega[simp]:
  "to_stream (to_omega s) = s"
  unfolding to_omega_def to_stream_def
  by (metis stream_smap_nats)

lemma bij_to_omega:
  "bij to_omega"
  by (metis bijI' to_omega_to_stream to_stream_to_omega)

lemma bij_to_stream:
  "bij to_stream"
  by (metis bijI' to_omega_to_stream to_stream_to_omega)

lemma image_intersection[simp]:
  "to_omega ` (A \<inter> B) = to_omega ` A \<inter> to_omega ` B"
  "to_stream ` (C \<inter> D) = to_stream ` C \<inter> to_stream ` D"
  by (simp_all add: bij_is_inj bij_to_omega bij_to_stream image_Int)

lemma to_stream_snth[simp]:
  "(to_stream w) !! k = w k"
  by (simp add: to_stream_def)

lemma to_omega_index[simp]:
  "(to_omega s) k = s !! k"
  by (metis to_stream_snth to_stream_to_omega)

lemma to_stream_stake[simp]:
  "stake k (to_stream w) = prefix k w"
  by (induction k) (simp add: to_stream_def)+

lemma to_omega_prefix[simp]:
  "prefix k (to_omega s) = stake k s"
  by (metis to_stream_stake to_stream_to_omega)

lemma in_image[simp]:
  "x \<in> to_omega ` X \<longleftrightarrow> to_stream x \<in> X"
  "y \<in> to_stream ` Y \<longleftrightarrow> to_omega y \<in> Y"
  by force+

end


section \<open>Sets and Extended Natural Numbers\<close>

theory ESet_Extensions
imports
  "../Basics/Functions"
  Basic_Extensions
  CCPO_Extensions
begin

  lemma card_lessThan_enat[simp]: "card {..< enat k} = card {..< k}"
  proof -
    have 1: "{..< enat k} = enat ` {..< k}"
      unfolding lessThan_def image_Collect using enat_iless by force
    have "card {..< enat k} = card (enat ` {..< k})" unfolding 1 by rule
    also have "\<dots> = card {..< k}" using card_image inj_enat by metis
    finally show ?thesis by this
  qed
  lemma card_atMost_enat[simp]: "card {.. enat k} = card {.. k}"
  proof -
    have 1: "{.. enat k} = enat ` {.. k}"
      unfolding atMost_def image_Collect using enat_ile by force
    have "card {.. enat k} = card (enat ` {.. k})" unfolding 1 by rule
    also have "\<dots> = card {.. k}" using card_image inj_enat by metis
    finally show ?thesis by this
  qed

  lemma enat_Collect:
    assumes "\<infinity> \<notin> A"
    shows "{i. enat i \<in> A} = the_enat ` A"
    using assms by (safe, force) (metis enat_the_enat)

  lemma Collect_lessThan: "{i. enat i < n} = the_enat ` {..< n}"
  proof -
    have 1: "\<infinity> \<notin> {..< n}" by simp
    have "{i. enat i < n} = {i. enat i \<in> {..< n}}" by simp
    also have "\<dots> = the_enat ` {..< n}" using enat_Collect 1 by this
    finally show ?thesis by this
  qed

  instantiation set :: (type) esize_ccpo
  begin

    function esize_set where "finite A \<Longrightarrow> esize A = enat (card A)" | "infinite A \<Longrightarrow> esize A = \<infinity>"
      by auto termination by lexicographic_order

    lemma esize_iff_empty[iff]: "esize A = 0 \<longleftrightarrow> A = {}" by (cases "finite A", auto)
    lemma esize_iff_infinite[iff]: "esize A = \<infinity> \<longleftrightarrow> infinite A" by force
    lemma esize_singleton[simp]: "esize {a} = eSuc 0" by simp

    instance
    proof
      fix A :: "'a set"
      assume 1: "esize A \<noteq> \<infinity>"
      show "finite {B. B \<subseteq> A}" using 1 by simp
    next
      fix A B :: "'a set"
      assume 1: "A \<subseteq> B"
      show "esize A \<le> esize B"
      proof (cases "finite B")
        case False
        show ?thesis using False by auto
      next
        case True
        have 2: "finite A" using True 1 by auto
        show ?thesis using card_mono True 1 2 by auto
      qed
    next
      fix A B :: "'a set"
      assume 1: "esize A \<noteq> \<infinity>" "A \<subset> B"
      show "esize A < esize B" using psubset_card_mono 1 by (cases "finite B", auto)
    qed

  end

  lemma esize_image[simp, intro]:
    assumes "inj_on f A"
    shows "esize (f ` A) = esize A"
    using card_image finite_imageD assms by (cases "finite A", auto)
  lemma esize_insert1[simp]: "a \<notin> A \<Longrightarrow> esize (insert a A) = eSuc (esize A)"
    by (cases "finite A", force+)
  lemma esize_insert2[simp]: "a \<in> A \<Longrightarrow> esize (insert a A) = esize A"
    using insert_absorb by metis
  lemma esize_remove1[simp]: "a \<notin> A \<Longrightarrow> esize (A - {a}) = esize A"
    by (cases "finite A", force+)
  lemma esize_remove2[simp]: "a \<in> A \<Longrightarrow> esize (A - {a}) = epred (esize A)"
    by (cases "finite A", force+)
  lemma esize_union_disjoint[simp]:
    assumes "A \<inter> B = {}"
    shows "esize (A \<union> B) = esize A + esize B"
  proof (cases "finite (A \<union> B)")
    case True
    show ?thesis using card_Un_disjoint assms True by auto
  next
    case False
    show ?thesis using False by (cases "finite A", auto)
  qed
  lemma esize_lessThan[simp]: "esize {..< n} = n"
  proof (cases n)
    case (enat k)
    have 1: "finite {..< n}" unfolding enat by (metis finite_lessThan_enat_iff not_enat_eq)
    show ?thesis using 1 unfolding enat by simp
  next
    case (infinity)
    have 1: "infinite {..< n}" unfolding infinity using infinite_lessThan_infty by simp
    show ?thesis using 1 unfolding infinity by simp
  qed
  lemma esize_atMost[simp]: "esize {.. n} = eSuc n"
  proof (cases n)
    case (enat k)
    have 1: "finite {.. n}" unfolding enat by (metis atMost_iff finite_enat_bounded)
    show ?thesis using 1 unfolding enat by simp
  next
    case (infinity)
    have 1: "infinite {.. n}"
      unfolding infinity
      by (metis atMost_iff enat_ord_code(3) infinite_lessThan_infty infinite_super subsetI)
    show ?thesis using 1 unfolding infinity by simp
  qed

  lemma least_eSuc[simp]:
    assumes "A \<noteq> {}"
    shows "least (eSuc ` A) = eSuc (least A)"
  proof (rule antisym)
    obtain k where 10: "k \<in> A" using assms by blast
    have 11: "eSuc k \<in> eSuc ` A" using 10 by auto
    have 20: "least A \<in> A" using 10 LeastI by metis
    have 21: "least (eSuc ` A) \<in> eSuc ` A" using 11 LeastI by metis
    have 30: "\<And> l. l \<in> A \<Longrightarrow> least A \<le> l" using 10 Least_le by metis
    have 31: "\<And> l. l \<in> eSuc ` A \<Longrightarrow> least (eSuc ` A) \<le> l" using 11 Least_le by metis
    show "least (eSuc ` A) \<le> eSuc (least A)" using 20 31 by auto
    show "eSuc (least A) \<le> least (eSuc ` A)" using 21 30 by auto
  qed

  lemma Inf_enat_eSuc[simp]: "\<Sqinter> (eSuc ` A) = eSuc (\<Sqinter> A)" unfolding Inf_enat_def by simp

  definition lift :: "nat set \<Rightarrow> nat set"
    where "lift A \<equiv> insert 0 (Suc ` A)"

  lemma liftI_0[intro, simp]: "0 \<in> lift A" unfolding lift_def by auto
  lemma liftI_Suc[intro]: "a \<in> A \<Longrightarrow> Suc a \<in> lift A" unfolding lift_def by auto
  lemma liftE[elim]:
    assumes "b \<in> lift A"
    obtains (0) "b = 0" | (Suc) a where "b = Suc a" "a \<in> A"
    using assms unfolding lift_def by auto

  lemma lift_esize[simp]: "esize (lift A) = eSuc (esize A)" unfolding lift_def by auto
  lemma lift_least[simp]: "least (lift A) = 0" unfolding lift_def by auto

  primrec nth_least :: "'a set \<Rightarrow> nat \<Rightarrow> 'a :: wellorder"
    where "nth_least A 0 = least A" | "nth_least A (Suc n) = nth_least (A - {least A}) n"

  lemma nth_least_wellformed[intro?, simp]:
    assumes "enat n < esize A"
    shows "nth_least A n \<in> A"
  using assms
  proof (induct n arbitrary: A)
    case 0
    show ?case using 0 by simp
  next
    case (Suc n)
    have 1: "A \<noteq> {}" using Suc(2) by auto
    have 2: "enat n < esize (A - {least A})" using Suc(2) 1 by simp
    have 3: "nth_least (A - {least A}) n \<in> A - {least A}" using Suc(1) 2 by this
    show ?case using 3 by simp
  qed

  lemma card_wellformed[intro?, simp]:
    fixes k :: "'a :: wellorder"
    assumes "k \<in> A"
    shows "enat (card {i \<in> A. i < k}) < esize A"
  proof (cases "finite A")
    case False
    show ?thesis using False by simp
  next
    case True
    have 1: "esize {i \<in> A. i < k} < esize A" using True assms by fastforce
    show ?thesis using True 1 by simp
  qed

  lemma card_nth_least[simp]:
    assumes "enat n < esize A"
    shows "card {k \<in> A. k < nth_least A n} = n"
  using assms
  proof (induct n arbitrary: A)
    case 0
    have 1: "{k \<in> A. k < least A} = {}" using least_not_less by auto
    show ?case using nth_least.simps(1) card_empty 1 by metis
  next
    case (Suc n)
    have 1: "A \<noteq> {}" using Suc(2) by auto
    have 2: "enat n < esize (A - {least A})" using Suc(2) 1 by simp
    have 3: "nth_least A 0 < nth_least A (Suc n)" using nth_least_strict_mono Suc(2) by blast
    have 4: "{k \<in> A. k < nth_least A (Suc n)} =
      {least A} \<union> {k \<in> A - {least A}. k < nth_least (A - {least A}) n}" using 1 3 by auto
    have 5: "card {k \<in> A - {least A}. k < nth_least (A - {least A}) n} = n" using Suc(1) 2 by this
    have 6: "finite {k \<in> A - {least A}. k < nth_least (A - {least A}) n}"
      using 5 Collect_empty_eq card_infinite infinite_imp_nonempty least_not_less nth_least.simps(1)
      by (metis (no_types, lifting))
    have "card {k \<in> A. k < nth_least A (Suc n)} =
      card ({least A} \<union> {k \<in> A - {least A}. k < nth_least (A - {least A}) n})" using 4 by simp
    also have "\<dots> = card {least A} + card {k \<in> A - {least A}. k < nth_least (A - {least A}) n}"
      using 6 by simp
    also have "\<dots> = Suc n" using 5 by simp
    finally show ?case by this
  qed

  lemma card_nth_least_le[simp]:
    assumes "enat n < esize A"
    shows "card {k \<in> A. k \<le> nth_least A n} = Suc n"
  proof -
    have 1: "{k \<in> A. k \<le> nth_least A n} = {nth_least A n} \<union> {k \<in> A. k < nth_least A n}"
      using assms by auto
    have 2: "card {k \<in> A. k < nth_least A n} = n" using assms by simp
    have 3: "finite {k \<in> A. k < nth_least A n}"
      using 2 Collect_empty_eq card_infinite infinite_imp_nonempty least_not_less nth_least.simps(1)
      by (metis (no_types, lifting))
    have "card {k \<in> A. k \<le> nth_least A n} = card ({nth_least A n} \<union> {k \<in> A. k < nth_least A n})"
      unfolding 1 by rule
    also have "\<dots> = card {nth_least A n} + card {k \<in> A. k < nth_least A n}" using 3 by simp
    also have "\<dots> = Suc n" using assms by simp
    finally show ?thesis by this
  qed

  lemma nth_least_card:
    fixes k :: nat
    assumes "k \<in> A"
    shows "nth_least A (card {i \<in> A. i < k}) = k"
  proof (rule nat_set_card_equality_less)
    have 1: "enat (card {l \<in> A. l < k}) < esize A"
    proof (cases "finite A")
      case False
      show ?thesis using False by simp
    next
      case True
      have 1: "{l \<in> A. l < k} \<subset> A" using assms by blast
      have 2: "card {l \<in> A. l < k} < card A" using psubset_card_mono True 1 by this
      show ?thesis using True 2 by simp
    qed
    show "nth_least A (card {l \<in> A. l < k}) \<in> A" using 1 by rule
    show "k \<in> A" using assms by this
    show "card {z \<in> A. z < nth_least A (card {i \<in> A. i < k})} = card {z \<in> A. z < k}" using 1 by simp
  qed

  interpretation nth_least:
    bounded_function_pair "{i. enat i < esize A}" "A" "nth_least A" "\<lambda> k. card {i \<in> A. i < k}"
    using nth_least_wellformed card_wellformed by (unfold_locales, blast+)

  interpretation nth_least:
    injection "{i. enat i < esize A}" "A" "nth_least A" "\<lambda> k. card {i \<in> A. i < k}"
    using card_nth_least by (unfold_locales, blast)

  interpretation nth_least:
    surjection "{i. enat i < esize A}" "A" "nth_least A" "\<lambda> k. card {i \<in> A. i < k}"
    for A :: "nat set"
    using nth_least_card by (unfold_locales, blast)

  interpretation nth_least:
    bijection "{i. enat i < esize A}" "A" "nth_least A" "\<lambda> k. card {i \<in> A. i < k}"
    for A :: "nat set"
    by unfold_locales

  lemma nth_least_strict_mono_inverse:
    fixes A :: "nat set"
    assumes "enat k < esize A" "enat l < esize A" "nth_least A k < nth_least A l"
    shows "k < l"
    using assms by (metis not_less_iff_gr_or_eq nth_least_strict_mono)

  lemma nth_least_less_card_less:
    fixes k :: nat
    shows "enat n < esize A \<and> nth_least A n < k \<longleftrightarrow> n < card {i \<in> A. i < k}"
  proof safe
    assume 1: "enat n < esize A" "nth_least A n < k"
    have 2: "nth_least A n \<in> A" using 1(1) by rule
    have "n = card {i \<in> A. i < nth_least A n}" using 1 by simp
    also have "\<dots> < card {i \<in> A. i < k}" using 1(2) 2 by simp
    finally show "n < card {i \<in> A. i < k}" by this
  next
    assume 1: "n < card {i \<in> A. i < k}"
    have "enat n < enat (card {i \<in> A. i < k})" using 1 by simp
    also have "\<dots> = esize {i \<in> A. i < k}" by simp
    also have "\<dots> \<le> esize A" by blast
    finally show 2: "enat n < esize A" by this
    have 3: "n = card {i \<in> A. i < nth_least A n}" using 2 by simp
    have 4: "card {i \<in> A. i < nth_least A n} < card {i \<in> A. i < k}" using 1 2 by simp
    have 5: "nth_least A n \<in> A" using 2 by rule
    show "nth_least A n < k" using 4 5 by simp
  qed

  lemma nth_least_less_esize_less:
    "enat n < esize A \<and> enat (nth_least A n) < k \<longleftrightarrow> enat n < esize {i \<in> A. enat i < k}"
    using nth_least_less_card_less by (cases k, simp+)

  lemma nth_least_le:
    assumes "enat n < esize A"
    shows "n \<le> nth_least A n"
  using assms
  proof (induct n)
    case 0
    show ?case using 0 by simp
  next
    case (Suc n)
    have "n \<le> nth_least A n" using Suc by (metis Suc_ile_eq less_imp_le)
    also have "\<dots> < nth_least A (Suc n)" using nth_least_strict_mono Suc(2) by blast
    finally show ?case by simp
  qed

  lemma nth_least_eq:
    assumes "enat n < esize A" "enat n < esize B"
    assumes "\<And> i. i \<le> nth_least A n \<Longrightarrow> i \<le> nth_least B n \<Longrightarrow> i \<in> A \<longleftrightarrow> i \<in> B"
    shows "nth_least A n = nth_least B n"
  using assms
  proof (induct n arbitrary: A B)
    case 0
    have 1: "least A = least B"
    proof (rule least_eq)
      show "A \<noteq> {}" using 0(1) by simp
      show "B \<noteq> {}" using 0(2) by simp
    next
      fix i
      assume 2: "i \<le> least A" "i \<le> least B"
      show "i \<in> A \<longleftrightarrow> i \<in> B" using 0(3) 2 unfolding nth_least.simps by this
    qed
    show ?case using 1 by simp
  next
    case (Suc n)
    have 1: "A \<noteq> {}" "B \<noteq> {}" using Suc(2, 3) by auto
    have 2: "least A = least B"
    proof (rule least_eq)
      show "A \<noteq> {}" using 1(1) by this
      show "B \<noteq> {}" using 1(2) by this
    next
      fix i
      assume 3: "i \<le> least A" "i \<le> least B"
      have 4: "nth_least A 0 \<le> nth_least A (Suc n)" using Suc(2) by blast
      have 5: "nth_least B 0 \<le> nth_least B (Suc n)" using Suc(3) by blast
      have 6: "i \<le> nth_least A (Suc n)" "i \<le> nth_least B (Suc n)" using 3 4 5 by auto
      show "i \<in> A \<longleftrightarrow> i \<in> B" using Suc(4) 6 by this
    qed
    have 3: "nth_least (A - {least A}) n = nth_least (B - {least B}) n"
    proof (rule Suc(1))
      show "enat n < esize (A - {least A})" using Suc(2) 1(1) by simp
      show "enat n < esize (B - {least B})" using Suc(3) 1(2) by simp
    next
      fix i
      assume 3: "i \<le> nth_least (A - {least A}) n" "i \<le> nth_least (B - {least B}) n"
      have 4: "i \<le> nth_least A (Suc n)" "i \<le> nth_least B (Suc n)" using 3 by simp+
      have 5: "i \<in> A \<longleftrightarrow> i \<in> B" using Suc(4) 4 by this
      show "i \<in> A - {least A} \<longleftrightarrow> i \<in> B - {least B}" using 2 5 by auto
    qed
    show ?case using 3 by simp
  qed

  lemma nth_least_restrict[simp]:
    assumes "enat i < esize {i \<in> s. enat i < k}"
    shows "nth_least {i \<in> s. enat i < k} i = nth_least s i"
  proof (rule nth_least_eq)
    show "enat i < esize {i \<in> s. enat i < k}" using assms by this
    show "enat i < esize s" using nth_least_less_esize_less assms by auto
  next
    fix l
    assume 1: "l \<le> nth_least {i \<in> s. enat i < k} i"
    have 2: "nth_least {i \<in> s. enat i < k} i \<in> {i \<in> s. enat i < k}" using assms by rule
    have "enat l \<le> enat (nth_least {i \<in> s. enat i < k} i)" using 1 by simp
    also have "\<dots> < k" using 2 by simp
    finally show "l \<in> {i \<in> s. enat i < k} \<longleftrightarrow> l \<in> s" by auto
  qed

  lemma least_nth_least[simp]:
    assumes "A \<noteq> {}" "\<And> i. i \<in> A \<Longrightarrow> enat i < esize B"
    shows "least (nth_least B ` A) = nth_least B (least A)"
    using assms by simp

  lemma nth_least_nth_least[simp]:
    assumes "enat n < esize A" "\<And> i. i \<in> A \<Longrightarrow> enat i < esize B"
    shows "nth_least B (nth_least A n) = nth_least (nth_least B ` A) n"
  using assms
  proof (induct n arbitrary: A)
    case 0
    show ?case using 0 by simp
  next
    case (Suc n)
    have 1: "A \<noteq> {}" using Suc(2) by auto
    have 2: "nth_least B ` (A - {least A}) = nth_least B ` A - nth_least B ` {least A}"
    proof (rule inj_on_image_set_diff)
      show "inj_on (nth_least B) {i. enat i < esize B}" using nth_least.inj_on by this
      show "A - {least A} \<subseteq> {i. enat i < esize B}" using Suc(3) by blast
      show "{least A} \<subseteq> {i. enat i < esize B}" using Suc(3) 1 by force
    qed
    have "nth_least B (nth_least A (Suc n)) = nth_least B (nth_least (A - {least A}) n)" by simp
    also have "\<dots> = nth_least (nth_least B ` (A - {least A})) n" using Suc 1 by force
    also have "\<dots> = nth_least (nth_least B ` A - nth_least B ` {least A}) n" unfolding 2 by rule
    also have "\<dots> = nth_least (nth_least B ` A - {nth_least B (least A)}) n" by simp
    also have "\<dots> = nth_least (nth_least B ` A - {least (nth_least B ` A)}) n" using Suc(3) 1 by auto
    also have "\<dots> = nth_least (nth_least B ` A) (Suc n)" by simp
    finally show ?case by this
  qed

  lemma nth_least_Max[simp]:
    assumes "finite A" "A \<noteq> {}"
    shows "nth_least A (card A - 1) = Max A"
  using assms
  proof (induct "card A - 1" arbitrary: A)
    case 0
    have 1: "card A = 1" using 0 by (metis One_nat_def Suc_diff_1 card_gt_0_iff)
    obtain a where 2: "A = {a}" using 1 by rule
    show ?case unfolding 2 by (simp del: insert_iff)
  next
    case (Suc n)
    have 1: "least A \<in> A" using Suc(4) by rule
    have 2: "card (A - {least A}) = Suc n" using Suc(2, 3) 1 by simp
    have 3: "A - {least A} \<noteq> {}" using 2 Suc(3) by fastforce
    have "nth_least A (card A - 1) = nth_least A (Suc n)" unfolding Suc(2) by rule
    also have "\<dots> = nth_least (A - {least A}) n" by simp
    also have "\<dots> = nth_least (A - {least A}) (card (A - {least A}) - 1)" unfolding 2 by simp
    also have "\<dots> = Max (A - {least A})"
    proof (rule Suc(1))
      show "n = card (A - {least A}) - 1" unfolding 2 by simp
      show "finite (A - {least A})" using Suc(3) by simp
      show "A - {least A} \<noteq> {}" using 3 by this
    qed
    also have "\<dots> = Max A" using Suc(3) 3 by simp
    finally show ?case by this
  qed

  lemma nth_least_le_Max:
    assumes "finite A" "A \<noteq> {}" "enat n < esize A"
    shows "nth_least A n \<le> Max A"
  proof -
    have "nth_least A n \<le> nth_least A (card A - 1)"
    proof (rule nth_least_mono)
      show "enat (card A - 1) < esize A" by (metis Suc_diff_1 Suc_ile_eq assms(1) assms(2)
        card_eq_0_iff esize_set.simps(1) not_gr0 order_refl)
      show "n \<le> card A - 1" by (metis Suc_diff_1 Suc_leI antisym_conv assms(1) assms(3)
        enat_ord_simps(2) esize_set.simps(1) le_less neq_iff not_gr0)
    qed
    also have "\<dots> = Max A" using nth_least_Max assms(1, 2) by this
    finally show ?thesis by this
  qed

  lemma nth_least_not_contains:
    fixes k :: nat
    assumes "enat (Suc n) < esize A" "nth_least A n < k" "k < nth_least A (Suc n)"
    shows "k \<notin> A"
  proof
    assume 1: "k \<in> A"
    have 2: "nth_least A (card {i \<in> A. i < k}) = k" using nth_least.right_inverse 1 by this
    have 3: "n < card {i \<in> A. i < k}"
    proof (rule nth_least_strict_mono_inverse)
      show "enat n < esize A" using assms(1) by auto
      show "enat (card {i \<in> A. i < k}) < esize A" using nth_least.g.wellformed 1 by simp
      show "nth_least A n < nth_least A (card {i \<in> A. i < k})" using assms(2) 2 by simp
    qed
    have 4: "card {i \<in> A. i < k} < Suc n"
    proof (rule nth_least_strict_mono_inverse)
      show "enat (card {i \<in> A. i < k}) < esize A" using nth_least.g.wellformed 1 by simp
      show "enat (Suc n) < esize A" using assms(1) by this
      show "nth_least A (card {i \<in> A. i < k}) < nth_least A (Suc n)" using assms(3) 2 by simp
    qed
    show "False" using 3 4 by auto
  qed

  lemma nth_least_Suc[simp]:
    assumes "enat n < esize A"
    shows "nth_least (Suc ` A) n = Suc (nth_least A n)"
  using assms
  proof (induct n arbitrary: A)
    case (0)
    have 1: "A \<noteq> {}" using 0 by auto
    show ?case using 1 by simp
  next
    case (Suc n)
    have 1: "enat n < esize (A - {least A})"
    proof -
      have 2: "A \<noteq> {}" using Suc(2) by auto
      have 3: "least A \<in> A" using LeastI 2 by fast
      have 4: "A = insert (least A) A" using 3 by auto
      have "eSuc (enat n) = enat (Suc n)" by simp
      also have "\<dots> < esize A" using Suc(2) by this
      also have "\<dots> = esize (insert (least A) A)" using 4 by simp
      also have "\<dots> = eSuc (esize (A - {least A}))" using 3 2 by simp
      finally show ?thesis using Extended_Nat.eSuc_mono by metis
    qed
    have "nth_least (Suc ` A) (Suc n) = nth_least (Suc ` A - {least (Suc ` A)}) n" by simp
    also have "\<dots> = nth_least (Suc ` (A - {least A})) n" by simp
    also have "\<dots> = Suc (nth_least (A - {least A}) n)" using Suc(1) 1 by this
    also have "\<dots> = Suc (nth_least A (Suc n))" by simp
    finally show ?case by this
  qed

  lemma nth_least_list_card[simp]:
    assumes "enat n \<le> esize A"
    shows "card {k \<in> A. k < nth_least (lift A) n} = n"
    using less_Suc_eq_le assms by (cases n, auto simp del: nth_least.simps)

end


theory Submission
  imports Defs
begin

lemma disjE':
  assumes major: "P \<or> Q"
    and minorP: "P \<Longrightarrow> R"
    and minorQ: "Q \<Longrightarrow> \<not>P \<Longrightarrow> R"
  shows R
  using assms by auto

(* The append lemma - gives 30% of the points.
   Note: While this lemma gives less points, it's actually harder to prove! *)

lemma takeWhile_other:
  assumes "hd ys \<noteq> a"
  shows "takeWhile (\<lambda>y. y = a) ys = []"
  by (metis (mono_tags, lifting) assms hd_Cons_tl takeWhile.simps(1) takeWhile.simps(2))

lemma rle_append: "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons a as)
  from `a # as = [] \<or> ys = [] \<or> last (a # as) \<noteq> hd ys`
  show ?case
  proof (elim disjE')
    assume "a # as = []"
    thus ?thesis by simp
  next
    assume "ys = []"
    thus ?thesis
      by simp
  next
    assume "last (a # as) \<noteq> hd ys"
      and "ys \<noteq> []"

    show "rle ((a # as) @ ys) = rle (a # as) @ rle ys"
    proof (cases "as")
      case Nil
      then show ?thesis
        by auto
         (metis \<open>last (a # as) \<noteq> hd ys\<close> last_ConsL takeWhile_other,
           metis (full_types) \<open>last (a # as) \<noteq> hd ys\<close> \<open>ys \<noteq> []\<close> dropWhile.simps(2) hd_Cons_tl last_ConsL)
    next
      case (Cons b bs)

      have "rle ((a # as) @ ys) = (case rle (as@ys) of
                (r,n)#rs \<Rightarrow> if r=a then (r,n+1)#rs else (a,1)#(r,n)#rs)"
        by (auto simp add: local.Cons split: list.splits)
      also have "... = (case rle as @ rle ys of
                (r,n)#rs \<Rightarrow> if r=a then (r,n+1)#rs else (a,1)#(r,n)#rs)"
        using Cons.hyps \<open>last (a # as) \<noteq> hd ys\<close> by fastforce
      also have "... = rle (a # as) @ rle ys"
        by (auto simp add: local.Cons split: list.splits)

      finally show ?thesis
        by blast
    qed
  qed
qed

text \<open>Note: Proofs for the second part were finished after the deadline.\<close>

lemma split_replicate:
  assumes "xs = a #as"
  shows "\<exists>n. xs = replicate n a @ drop n xs \<and> 0 < n \<and> n \<le> length xs \<and> (n = length xs \<or> a \<noteq> xs ! n)"
  using assms proof (induct xs arbitrary: a as)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  show ?case
  proof (cases bs)
    case Nil
    then show ?thesis
      using Cons.prems by (auto intro!: exI[where x=1])
  next
    case (Cons c cs)
    show ?thesis
    proof (cases "b = c")
      case True

      from `\<And>a as. bs = a # as \<Longrightarrow> \<exists>n. bs = replicate n a @ drop n bs \<and> 0 < n \<and> n \<le> length bs \<and> (n = length bs \<or> a \<noteq> bs ! n)`[OF `bs = c # cs`]

      obtain n where "bs = replicate n c @ drop n bs"
        and "0 < n" and "n \<le> length bs"
        and "n = length bs \<or> c \<noteq> bs ! n"
        by blast
      then show ?thesis
        using Cons.prems True by (auto simp add: intro!: exI[where x="n+1"])
    next
      case False
      then show ?thesis
        using Cons.prems local.Cons by (auto intro!: exI[where x=1])
    qed
  qed
qed

lemma append_diff_induct:
  assumes "P []"
    and "\<And>n x xs. P xs \<Longrightarrow> xs = [] \<or> x \<noteq> hd xs  \<Longrightarrow> P (replicate n x @ xs)"
  shows "P xs"
proof (induct "length xs" arbitrary: xs rule: less_induct)
  case less

  show ?case
  proof (cases xs)
    case Nil
    then show ?thesis
      by (simp add: assms(1))
  next
    case (Cons a list)

    obtain n where "xs = replicate n a @ drop n xs" and "n > 0" and "n\<le>length xs" and "n = length xs \<or> a \<noteq> xs!n"
      using split_replicate
      by (metis local.Cons)

    have "P (replicate n a @ drop n xs)"
    proof (rule assms(2))

      show "P (drop n xs)"
      proof (rule less.hyps)
        show "length (drop n xs) < length xs"
          by (simp add: \<open>0 < n\<close> local.Cons)
      qed
      show "drop n xs = [] \<or> a \<noteq> hd (drop n xs)"
        using \<open>n = length xs \<or> a \<noteq> xs ! n\<close> \<open>n \<le> length xs\<close> drop_eq_Nil hd_drop_conv_nth le_neq_implies_less by blast
    qed
    then show ?thesis
      using \<open>xs = replicate n a @ drop n xs\<close> by auto
  qed
qed

lemma dropWhile_replicate:
  "dropWhile (\<lambda>y. y = x) (replicate n x) = []"
  by (induct n) auto

lemma rle_replicate: "rle (replicate n x) = (if n = 0 then []else [(x,n)])"
  by (induct n)
    (auto simp add: dropWhile_replicate split: if_splits,
      metis (mono_tags, lifting) le_neq_implies_less length_replicate length_takeWhile_le nth_length_takeWhile nth_replicate)

(* Given the append lemma show the reverse lemma - gives 70% of the points.
   Note: While this lemma gives more points, it might actually be easier to prove *)
lemma rle_rev_if_rle_append1: " rle (rev xs) = rev (rle xs)"
proof (induct xs rule: append_diff_induct)
  case 1
  then show ?case
    by simp
next
  case (2 n x xs)

  show ?case
  proof (subst rev_append)
    show "rle (rev xs @ rev (replicate n x)) = rev (rle (replicate n x @ xs))"
    proof (subst rle_append)
      show "rev xs = [] \<or> rev (replicate n x) = [] \<or> last (rev xs) \<noteq> hd (rev (replicate n x))"
        using "2.hyps"(2) last_rev by force
      show "rle (rev xs) @ rle (rev (replicate n x)) = rev (rle (replicate n x @ xs))"
      proof (subst rle_append)
        show "replicate n x = [] \<or> xs = [] \<or> last (replicate n x) \<noteq> hd xs"
          using "2.hyps"(2) by auto
        show "rle (rev xs) @ rle (rev (replicate n x)) = rev (rle (replicate n x) @ rle xs)"
          by (subst rev_append)  (auto simp add: "2.hyps"(1) rle_replicate)
      qed
    qed
  qed
qed

lemma rle_rev_if_rle_append:
"(xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys \<Longrightarrow> rle (xs @ ys) = rle xs @ rle ys)
       \<Longrightarrow> rle (rev xs) = rev (rle xs)"
  by (rule rle_rev_if_rle_append1)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Natural number ranges\<close>
theory Nat_Ranges
  imports Nat_Base
begin

subsection \<open>Ranges\<close>

definition "range_incl_excl l u \<equiv> {i \<in> \<nat> | l \<le> i \<and> i < u}"

bundle isa_set_range_incl_excl_syntax
begin notation range_incl_excl ("[_,\<dots>,_[") end
bundle no_isa_set_range_incl_excl_syntax
begin no_notation range_incl_excl ("[_,\<dots>,_[") end
unbundle isa_set_range_incl_excl_syntax

abbreviation "range_incl_incl l u \<equiv> [l,\<dots>,succ u["

bundle isa_set_range_incl_incl_syntax
begin notation range_incl_incl ("[_,\<dots>,_]") end
bundle no_isa_set_range_incl_incl_syntax
begin no_notation range_incl_incl ("[_,\<dots>,_]") end
unbundle isa_set_range_incl_incl_syntax

abbreviation "range_excl_incl l u \<equiv> [succ l,\<dots>,u]"

bundle isa_set_range_excl_incl_syntax
begin notation range_excl_incl ("]_,\<dots>,_]") end
bundle no_isa_set_range_excl_incl_syntax
begin no_notation range_excl_incl ("]_,\<dots>,_]") end
unbundle isa_set_range_excl_incl_syntax

abbreviation "range_excl_excl l u \<equiv> [succ l,\<dots>,u["

bundle isa_set_range_excl_excl_syntax
begin notation range_excl_excl ("]_,\<dots>,_[") end
bundle no_isa_set_range_excl_excl_syntax
begin no_notation range_excl_excl ("]_,\<dots>,_[") end
unbundle isa_set_range_excl_excl_syntax

bundle isa_set_range_syntax
begin
unbundle
  isa_set_range_incl_excl_syntax
  isa_set_range_incl_incl_syntax
  isa_set_range_excl_incl_syntax
  isa_set_range_excl_excl_syntax
end
bundle no_isa_set_range_syntax
begin
unbundle
  no_isa_set_range_incl_excl_syntax
  no_isa_set_range_incl_incl_syntax
  no_isa_set_range_excl_incl_syntax
  no_isa_set_range_excl_excl_syntax
end

lemma range_incl_excl_type [type]: "range_incl_excl : Nat \<Rightarrow> Nat \<Rightarrow> Subset \<nat>"
  unfolding range_incl_excl_def by unfold_types auto

lemma Nat_mem_rangeI [intro]:
  assumes "u : Nat"
  and "l \<le> n" "n \<le> u"
  shows "n \<in> [l,\<dots>,u]"
  using assms unfolding range_incl_excl_def
  by (auto intro: Nat_lt_succ_if_le Nat_if_le_Nat dest: Nat_if_le_Nat)

lemma mem_rangeE:
  assumes "n \<in> [l,\<dots>,u]"
  obtains "n \<in> \<nat>" "l \<le> n" "n \<le> u"
  using assms unfolding range_incl_excl_def by (auto dest: le_if_lt_succ)

lemma
  assumes "n \<in> [l,\<dots>,u]"
  (*TODO: automatically derive a corresponding type checking rule?*)
  shows mem_nat_if_mem_range: "n \<in> [l,\<dots>,u] \<Longrightarrow> n \<in> \<nat>"
  and ge_if_mem_range: "n \<in> [l,\<dots>,u] \<Longrightarrow> l \<le> n"
  and le_if_mem_range: "n \<in> [l,\<dots>,u] \<Longrightarrow> n \<le> u"
  by (auto elim: mem_rangeE)

lemma Nat_mem_range_zeroI [intro]: "u : Nat \<Longrightarrow> n \<le> u \<Longrightarrow> n \<in> [0,\<dots>,u]"
  by (rule Nat_mem_rangeI) (auto dest: Nat_if_le_Nat)

lemma Nat_mem_range_if_le [intro]: "u : Nat \<Longrightarrow> l \<le> u \<Longrightarrow> l \<in> [l,\<dots>,u]"
  by (rule Nat_mem_rangeI) auto

lemma Nat_mem_range_if_ge [intro]: "u : Nat \<Longrightarrow> l \<le> u \<Longrightarrow> u \<in> [l,\<dots>,u]"
  by (rule Nat_mem_rangeI) auto

lemma Nat_range_subset_if_le_if_le [intro]:
  "u' : Nat \<Longrightarrow> l' \<le> l \<Longrightarrow> u \<le> u' \<Longrightarrow> [l,\<dots>,u] \<subseteq> [l',\<dots>,u']"
  by (intro subsetI Nat_mem_rangeI) (auto elim!: mem_rangeE intro: Nat_le_trans)

lemma Nat_succ_eq_range_zero:
  assumes "n : Nat"
  shows "succ n = [0,\<dots>,n]"
proof -
  have "[0,\<dots>,n] = {i \<in> \<nat> | i \<le> n}"
    unfolding range_incl_excl_def
    by (rule eqI) (auto intro: Nat_lt_succ_if_le le_if_lt_succ)
  then show ?thesis
    using assms unfolding le_def lt_def nat_def
    by (auto 7 0 dest: ElementD mem_omega_if_mem_if_mem_omega)
qed

(*Note Kevin: should this be intro? should this be backward_derive? what should
it be? If it's intro, it will not be picked when we, for example, want to beta
reduce M `i `j with "M" a matrix. *)
lemma Nat_mem_range_incl_exclI [intro]:
  assumes "n : Nat" "l \<le> n" "n < u"
  shows "n \<in> [l,\<dots>,u["
  using assms unfolding range_incl_excl_def by auto

lemma mem_range_incl_exclE:
  assumes "n \<in> [l,\<dots>,u["
  obtains "n \<in> \<nat>" "n < u" "l \<le> n"
  using assms unfolding range_incl_excl_def by auto

lemma assumes "n \<in> [l,\<dots>,u["
  shows mem_nat_if_mem_range_incl_excl: "n \<in> \<nat>"
  and lt_if_mem_range_incl_excl: "n < u"
  and ge_if_mem_range_incl_excl: "l \<le> n"
  using assms by (auto elim: mem_range_incl_exclE)

(*Note Kevin: maybe a good test for set and type conversion*)
(*lemma
  assumes "l : Nat" "u : Nat" "n : Element [l,\<dots>,u]"
  shows "pred n : Element [pred l,\<dots>,u["
  oops*)

end


section \<open> Probabilistic Designs \<close>

theory utp_prob_des
  imports "UTP-Calculi.utp_wprespec" "UTP-Designs.utp_designs" "HOL-Probability.Probability_Mass_Function"
begin recall_syntax

purge_notation inner (infix "\<bullet>" 70)
declare [[coercion pmf]]

alphabet 's prss =
  prob :: "'s pmf"

text \<open> If the probabilities of two disjoint sample sets sums up to 1, then the probability of the
  first set is equal to 1 minus the probability of the second set. \<close>

lemma prob_lemma1:
  assumes "X \<inter> Y = {}"
  shows "((\<Sum>\<^sub>a i\<in>(X \<union> Y). pmf M i) = 1) = ((\<Sum>\<^sub>a i\<in>X. pmf M i) = 1 - (\<Sum>\<^sub>a i\<in>Y. pmf M i))"
  by (metis assms diff_eq_eq infsetsum_Un_disjoint pmf_abs_summable)

no_utp_lift ndesign wprespec uwp

type_synonym ('a, 'b) rel_pdes = "('a, 'b prss) rel_des"
type_synonym 's hrel_pdes = "('s, 's) rel_pdes"

translations
  (type) "('a, 'b) rel_pdes" <= (type) "('a, 'b prss) rel_des"

definition forget_prob :: "('s prss, 's) rel_des" ("\<^bold>f\<^bold>p") where
[upred_defs]: "forget_prob = U(true \<turnstile>\<^sub>n ($prob($\<^bold>v\<acute>) > 0))"

definition pemb :: "('a, 'b) rel_des \<Rightarrow> ('a, 'b) rel_pdes" ("\<K>")
  where [upred_defs]: "pemb D = \<^bold>f\<^bold>p \\ D"

lemma pemb_mono: "P \<sqsubseteq> Q \<Longrightarrow> \<K>(P) \<sqsubseteq> \<K>(Q)"
  by (metis (mono_tags, lifting) dual_order.trans order_refl pemb_def wprespec)

text \<open> Can this law be generalised for normal or arbitrary designs? \<close>

lemma wdprespec: "(true \<turnstile>\<^sub>n R) \\ (p \<turnstile>\<^sub>n Q) = (p \<turnstile>\<^sub>n (R \\ Q))"
  by (rel_auto)

lemma "R wp (&\<^bold>v =\<^sub>u \<guillemotleft>s'\<guillemotright>) = Pre(R\<lbrakk>\<guillemotleft>s'\<guillemotright>/$\<^bold>v\<acute>\<rbrakk>)"
  by (rel_auto)

lemma pemb_form:
  fixes R :: "('a, 'b) urel"
  shows "\<^U>(($prob($\<^bold>v\<acute>) > 0) \\ R) = \<^U>((\<Sum>\<^sub>a i\<in>{s'.(R wp (&\<^bold>v = s'))\<^sup><}. $prob\<acute> i) = 1)" (is "?lhs = ?rhs")
proof -
  have "?lhs = \<^U>((\<not> (\<not> R) ;; (0 < $prob\<acute>$\<^bold>v)))"
    by (rel_auto)
  also have "... = \<^U>((\<Sum>\<^sub>a i\<in>{s'.(R wp (&\<^bold>v = s'))\<^sup><}. $prob\<acute> i) = 1)"
    apply (rel_auto)
    apply (metis (no_types, lifting) infsetsum_pmf_eq_1 mem_Collect_eq pmf_positive subset_eq)
    apply (metis AE_measure_pmf_iff UNIV_I measure_pmf.prob_eq_1 measure_pmf_conv_infsetsum mem_Collect_eq set_pmf_eq' sets_measure_pmf)
    done
  finally show ?thesis .
qed

lemma prob_lift:
  fixes R :: "('a, 'b) urel" and p :: "'a upred"
  shows "\<K>(p \<turnstile>\<^sub>n R) = \<^U>(p \<turnstile>\<^sub>n ((\<Sum>\<^sub>a i\<in>{s'.(R wp (&\<^bold>v = s'))\<^sup><}. $prob\<acute> i) = 1))"
proof -
  have 1:"\<K>(p \<turnstile>\<^sub>n R) = \<^U>(p \<turnstile>\<^sub>n (($prob($\<^bold>v\<acute>) > 0) \\ R))"
    by (rel_auto)
  have 2:"\<^U>(($prob($\<^bold>v\<acute>) > 0) \\ R) = \<^U>((\<Sum>\<^sub>a i\<in>{s'.(R wp (&\<^bold>v = s'))\<^sup><}. $prob\<acute> i) = 1)"
    by (simp add: pemb_form)
  show ?thesis
    by (simp add: "1" "2")
qed

no_utp_lift usubst (0) subst (1)

lemma prob_assigns: "\<K>(\<langle>\<sigma>\<rangle>\<^sub>D) = \<^U>(true \<turnstile>\<^sub>n ($prob\<acute>((\<sigma> \<dagger> &\<^bold>v)\<^sup><) = 1))"
  by (simp add: assigns_d_ndes_def prob_lift wp usubst, rel_auto)

lemma prob_skip: "\<K>(II\<^sub>D) = \<^U>(true \<turnstile>\<^sub>n ($prob\<acute>($\<^bold>v) = 1))"
  by (simp only: assigns_d_id[THEN sym] prob_assigns usubst, rel_auto)

lemma prob_assign:
  fixes e :: "(_, _) uexpr"
  shows "\<K>(x :=\<^sub>D e) = \<^U>(true \<turnstile>\<^sub>n ($prob\<acute>($\<^bold>v\<lbrakk>e\<^sup></$x\<rbrakk>) = 1))"
  by (simp add: prob_assigns wp usubst, rel_auto)

definition wplus :: "'a pmf \<Rightarrow> real \<Rightarrow> 'a pmf \<Rightarrow> 'a pmf" ("(_ +\<^bsub>_\<^esub> _)" [64, 0, 65] 64) where
"wplus P w Q = join_pmf (pmf_of_list [(P, w), (Q, 1 - w)])"

lemma pmf_wplus:
  assumes "w \<in> {0..1}"
  shows "pmf (P +\<^bsub>w\<^esub> Q) i = pmf P i * w + pmf Q i * (1 - w)"
proof -
  from assms have pmf_wf_list: "pmf_of_list_wf [(P, w), (Q, 1 - w)]"
    by (auto intro!: pmf_of_list_wfI)
  show ?thesis
  proof (cases "w \<in> {0<..<1}")
    case True
    hence set_pmf:"set_pmf (pmf_of_list [(P, w), (Q, 1 - w)]) = {P, Q}"
      by (subst set_pmf_of_list_eq, auto simp add: pmf_wf_list)
    thus ?thesis
    proof (cases "P = Q")
      case True
      from assms show ?thesis
        apply (auto simp add: wplus_def join_pmf_def pmf_bind)
        apply (subst integral_measure_pmf[of "{P, Q}"])
          apply (auto simp add: set_pmf_of_list pmf_wf_list set_pmf pmf_pmf_of_list)
        apply (simp add: True)
        apply (metis distrib_right eq_iff_diff_eq_0 le_add_diff_inverse mult.commute mult_cancel_left1)
        done
    next
      case False
      then show ?thesis
        apply (auto simp add: wplus_def join_pmf_def pmf_bind)
        apply (subst integral_measure_pmf[of "{P, Q}"])
          apply (auto simp add: set_pmf_of_list pmf_wf_list set_pmf pmf_pmf_of_list)
        done
    qed
  next
    case False
    thm disjE
    with assms have "w = 0 \<or> w = 1"
      by (auto)
    with assms show ?thesis
    proof (erule_tac disjE, simp_all)
      assume w: "w = 0"
      with pmf_wf_list have "set_pmf (pmf_of_list [(P, w), (Q, 1 - w)]) = {Q}"
        apply (simp add: pmf_of_list_remove_zeros(2)[THEN sym])
        apply (subst set_pmf_of_list_eq, auto simp add: pmf_of_list_wf_def)
        done
      with w show "pmf (P +\<^bsub>0\<^esub> Q) i = pmf Q i"
        apply (auto simp add: wplus_def join_pmf_def pmf_bind pmf_wf_list pmf_of_list_remove_zeros(2)[THEN sym])
        apply (subst integral_measure_pmf[of "{Q}"])
          apply (simp_all add: set_pmf_of_list_eq pmf_pmf_of_list pmf_of_list_wf_def)
        done
    next
      assume w: "w = 1"
      with pmf_wf_list have "set_pmf (pmf_of_list [(P, w), (Q, 1 - w)]) = {P}"
        apply (simp add: pmf_of_list_remove_zeros(2)[THEN sym])
        apply (subst set_pmf_of_list_eq, auto simp add: pmf_of_list_wf_def)
        done
      with w show "pmf (P +\<^bsub>1\<^esub> Q) i = pmf P i"
        apply (auto simp add: wplus_def join_pmf_def pmf_bind pmf_wf_list pmf_of_list_remove_zeros(2)[THEN sym])
        apply (subst integral_measure_pmf[of "{P}"])
          apply (simp_all add: set_pmf_of_list_eq pmf_pmf_of_list pmf_of_list_wf_def)
        done
    qed
  qed
qed

lemma wplus_commute:
  assumes "w \<in>{0..1}"
  shows "P +\<^bsub>w\<^esub> Q = Q +\<^bsub>(1 - w)\<^esub> P"
  using assms by (auto intro: pmf_eqI simp add: pmf_wplus)

lemma wplus_zero: "P +\<^bsub>0\<^esub> Q = Q"
  by (auto intro: pmf_eqI simp add: pmf_wplus)

lemma wplus_one: "P +\<^bsub>1\<^esub> Q = P"
  by (auto intro: pmf_eqI simp add: pmf_wplus)

lemma wplus_assoc:
  assumes "w\<^sub>1 \<in> {0..1}" "w\<^sub>2 \<in> {0..1}"
  defines "w\<^sub>2' \<equiv> w\<^sub>1+w\<^sub>2 - w\<^sub>1\<cdot>w\<^sub>2" and "w\<^sub>1' \<equiv> w\<^sub>1 / w\<^sub>1+w\<^sub>2 - w\<^sub>1\<cdot>w\<^sub>2"
  shows "P +\<^bsub>w\<^sub>1\<^esub> (Q +\<^bsub>w\<^sub>2\<^esub> R) = (P +\<^bsub>w\<^sub>1'\<^esub> Q) +\<^bsub>w\<^sub>2'\<^esub> R"
proof (rule pmf_eqI)
  fix i
  from assms(1-2) have "w\<^sub>1+w\<^sub>2 - w\<^sub>1\<cdot>w\<^sub>2 \<in> {0..1}"
    using mult_right_le_one_le sum_le_prod1 by fastforce
  with assms show "pmf (P +\<^bsub>w\<^sub>1\<^esub> (Q +\<^bsub>w\<^sub>2\<^esub> R)) i = pmf (P +\<^bsub>w\<^sub>1'\<^esub> Q +\<^bsub>w\<^sub>2'\<^esub> R) i"
    apply (simp add: pmf_wplus add.assoc)
    apply (subst pmf_wplus)
    apply (auto)
    oops

definition prob_merge :: "real \<Rightarrow> (('s, 's prss, 's prss) mrg, 's prss) urel" ("\<^bold>P\<^bold>M\<^bsub>_\<^esub>") where
[upred_defs]: "prob_merge r = \<^U>($prob\<acute> = $0:prob +\<^bsub>r\<^esub> $1:prob)"

lemma swap_prob_merge:
  assumes "r \<in> {0..1}"
  shows "swap\<^sub>m ;; \<^bold>P\<^bold>M\<^bsub>r\<^esub> = \<^bold>P\<^bold>M\<^bsub>1 - r\<^esub>"
  by (rel_auto, (metis assms wplus_commute)+)

abbreviation prob_des_merge :: "real \<Rightarrow> (('s des, 's prss des, 's prss des) mrg, 's prss des) urel" ("\<^bold>P\<^bold>D\<^bold>M\<^bsub>_\<^esub>") where
"\<^bold>P\<^bold>D\<^bold>M\<^bsub>r\<^esub> \<equiv> \<^bold>D\<^bold>M(\<^bold>P\<^bold>M\<^bsub>r\<^esub>)"

lemma swap_prob_des_merge:
  assumes "r \<in> {0..1}"
  shows "swap\<^sub>m ;; \<^bold>P\<^bold>D\<^bold>M\<^bsub>r\<^esub> = \<^bold>P\<^bold>D\<^bold>M\<^bsub>1 - r\<^esub>"
  by (metis assms swap_des_merge swap_prob_merge)

abbreviation prob_choice :: "'s hrel_pdes \<Rightarrow> real \<Rightarrow> 's hrel_pdes \<Rightarrow> 's hrel_pdes" ("(_ \<oplus>\<^bsub>_\<^esub> _)" [164, 0, 165] 164) where
"prob_choice P r Q \<equiv> P \<parallel>\<^sup>D\<^bsub>\<^bold>P\<^bold>M\<^bsub>r\<^esub>\<^esub> Q"

lemma prob_choice_commute: "r \<in> {0..1} \<Longrightarrow> P \<oplus>\<^bsub>r\<^esub> Q = Q \<oplus>\<^bsub>1 - r\<^esub> P"
  by (simp add: swap_prob_des_merge[THEN sym], metis par_by_merge_commute_swap)

end