           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               Februaru 2006               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_hide
imports FNF_F_sf_induct FNF_F_sf_ext
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)

declare split_if  [split del]

(*****************************************************************

         1. full sequentialization for Hiding (P -- X)
         2.
         3.

 *****************************************************************)

(*============================================================*
 |                                                            |
 |                     Hiding P -- X                          |
 |                                                            |
 *============================================================*)

definition
  Pfun_Hiding :: "'a set => (('p,'a) proc => ('p,'a) proc)"
  where
  Pfun_Hiding_def :
    "Pfun_Hiding X == (%P1. P1 -- X)"

definition
  SP_step_Hiding ::
   "'a set => ('a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
    ('a => ('p,'a) proc) => ('p,'a) proc)"
  where
  SP_step_Hiding_def :
    "SP_step_Hiding X == (%A1 Pf1 Q1 SPf.
     (if (Q1 = STOP)
      then if (A1 Int X = {})
           then ((? :A1 -> SPf) [+] Q1)
           else (((? :(A1-X) -> SPf) [+] Q1)
                 [>seq
                (! :(A1 Int X) ..seq SPf))
      else (((? :(A1-X) -> SPf) [+] Q1) |~|seq
            (! :(A1 Int X) ..seq SPf))))"

definition
  fsfF_Hiding :: "('p,'a) proc => 'a set => ('p,'a) proc"
                          ("(1_ /--seq _)" [84,85] 84)
  where
  fsfF_Hiding_def :
    "P1 --seq X ==
       (fsfF_induct1 (Pfun_Hiding X) (SP_step_Hiding X) P1)"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Hiding_in:
    "P1 : fsfF_proc ==> P1 --seq X : fsfF_proc"
apply (simp add: fsfF_Hiding_def)
apply (rule fsfF_induct1_in)
apply (simp_all add: SP_step_Hiding_def)
apply (simp split: split_if)
apply (intro conjI impI)
apply (simp_all add: fsfF_proc.intros)
apply (rule fsfF_Int_choice_in)
apply (simp_all add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
apply (rule fsfF_Timeout_in)
apply (simp_all add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
apply (rule fsfF_Int_choice_in)
apply (simp add: fsfF_proc.intros)
apply (simp add: fsfF_Rep_int_choice_com_in)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Hiding_eqF: "P1 -- X =F P1 --seq X"
apply (simp add: fsfF_Hiding_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct1_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Hiding_def
                     SP_step_Hiding_def)

apply (case_tac "Q1 = STOP")
apply (rule cspF_rw_left)
apply (rule cspF_decompo)
apply (simp)
apply (simp)
apply (rule cspF_unit)

apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (simp)

apply (simp split: split_if)
apply (intro conjI impI)
apply (rule cspF_rw_left)
apply (rule cspF_IF)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (rule cspF_reflex)

apply (rule cspF_rw_left)
apply (rule cspF_IF)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Timeout_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (rule cspF_rw_right)
apply (rule cspF_unit)
apply (simp)
apply (simp)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym])
apply (simp)

(* Q1 ~= STOP *)
apply (simp)

apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV)
apply (simp)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_reflex)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym])
apply (rule cspF_reflex)

(* congruence *)
apply (simp split: split_if)
apply (intro conjI impI)
apply (rule cspF_rw_left,
     (simp
     | rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Timeout_eqF[THEN cspF_sym]
     | rule cspF_decompo
     | rule cspF_reflex)+ ,
       rule cspF_rw_right,
     (simp
     | rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Rep_int_choice_com_eqF[THEN cspF_sym]
     | rule cspF_fsfF_Timeout_eqF[THEN cspF_sym]
     | rule cspF_decompo
     | rule cspF_reflex)+)+
done

(****************** to add them again ******************)

declare split_if    [split]
declare disj_not1   [simp]

end


(*  Title:      JinjaThreads/Execute/Round_Robin.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{Round robin scheduler} *}

theory Round_Robin
imports
  Scheduler
begin

text {*
  A concrete scheduler must pick one possible reduction step from the small-step semantics for invidivual threads.
  Currently, this is only possible if there is only one such by using @{term Predicate.the}.
*}

section {* Concrete schedulers *}

subsection {* Round-robin schedulers *}

type_synonym 'queue round_robin = "'queue \<times> nat"
  -- "Waiting queue of threads and remaining number of steps of the first thread until it has to return resources"

primrec enqueue_new_thread :: "'t list \<Rightarrow> ('t,'x,'m) new_thread_action \<Rightarrow> 't list"
where
  "enqueue_new_thread queue (NewThread t x m) = queue @ [t]"
| "enqueue_new_thread queue (ThreadExists t b) = queue"

definition enqueue_new_threads :: "'t list \<Rightarrow> ('t,'x,'m) new_thread_action list \<Rightarrow> 't list"
where
  "enqueue_new_threads = foldl enqueue_new_thread"

primrec round_robin_update_state :: "nat \<Rightarrow> 't list round_robin \<Rightarrow> 't \<Rightarrow> ('l,'t,'x,'m,'w,'o) thread_action \<Rightarrow> 't list round_robin"
where
  "round_robin_update_state n0 (queue, n) t ta =
   (let queue' = enqueue_new_threads queue \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>
    in if n = 0 \<or> Yield \<in> set \<lbrace>ta\<rbrace>\<^bsub>c\<^esub> then (rotate1 queue', n0) else (queue', n - 1))"

context multithreaded_base begin

abbreviation round_robin_step :: "nat \<Rightarrow> 't list round_robin \<Rightarrow> ('l,'t,'x,'m,'w) state \<Rightarrow> 't \<Rightarrow> ('t \<times> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) option \<times> 't list round_robin) option"
where
  "round_robin_step n0 \<sigma> s t \<equiv> step_thread (round_robin_update_state n0 \<sigma> t) s t"

partial_function (option) round_robin_reschedule :: "'t \<Rightarrow>
    't list \<Rightarrow> nat \<Rightarrow> ('l,'t,'x,'m,'w) state \<Rightarrow> ('t \<times> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) option \<times> 't list round_robin) option"
where
  "round_robin_reschedule t0 queue n0 s =
   (let
      t = hd queue;
      queue' = tl queue
    in
      if t = t0 then
        None
      else
        case round_robin_step n0 (t # queue', n0) s t of
          None \<Rightarrow> round_robin_reschedule t0 (queue' @ [t]) n0 s
        | \<lfloor>ttaxm\<sigma>\<rfloor> \<Rightarrow> \<lfloor>ttaxm\<sigma>\<rfloor>)"

fun round_robin :: "nat \<Rightarrow> 't list round_robin \<Rightarrow> ('l,'t,'x,'m,'w) state \<Rightarrow> ('t \<times> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) option \<times> 't list round_robin) option"
where
  "round_robin n0 ([], n) s = None"
| "round_robin n0 (t # queue, n) s =
   (case round_robin_step n0 (t # queue, n) s t of
      \<lfloor>ttaxm\<sigma>\<rfloor> \<Rightarrow> \<lfloor>ttaxm\<sigma>\<rfloor>
    | None \<Rightarrow> round_robin_reschedule t (queue @ [t]) n0 s)"

end

primrec round_robin_invar :: "'t list round_robin \<Rightarrow> 't set \<Rightarrow> bool"
where "round_robin_invar (queue, n) T \<longleftrightarrow> set queue = T \<and> distinct queue"

lemma set_enqueue_new_thread:
  "set (enqueue_new_thread queue nta) = set queue \<union> {t. \<exists>x m. nta = NewThread t x m}"
by(cases nta) auto

lemma set_enqueue_new_threads:
  "set (enqueue_new_threads queue ntas) = set queue \<union> {t. \<exists>x m. NewThread t x m \<in> set ntas}"
apply(induct ntas arbitrary: queue)
apply(auto simp add: enqueue_new_threads_def set_enqueue_new_thread)
done

lemma enqueue_new_thread_eq_Nil [simp]:
  "enqueue_new_thread queue nta = [] \<longleftrightarrow> queue = [] \<and> (\<exists>t b. nta = ThreadExists t b)"
by(cases nta) simp_all

lemma enqueue_new_threads_eq_Nil [simp]:
  "enqueue_new_threads queue ntas = [] \<longleftrightarrow> queue = [] \<and> set ntas \<subseteq> {ThreadExists t b|t b. True}"
apply(induct ntas arbitrary: queue)
apply(auto simp add: enqueue_new_threads_def)
done

lemma distinct_enqueue_new_threads:
  fixes ts :: "('l,'t,'x) thread_info"
  and ntas :: "('t,'x,'m) new_thread_action list"
  assumes "thread_oks ts ntas" "set queue = dom ts" "distinct queue"
  shows "distinct (enqueue_new_threads queue ntas)"
using assms
proof(induct ntas arbitrary: ts queue)
  case Nil thus ?case by(simp add: enqueue_new_threads_def)
next
  case (Cons nt ntas)
  from `thread_oks ts (nt # ntas)`
  have "thread_ok ts nt" and "thread_oks (redT_updT ts nt) ntas" by simp_all
  from `thread_ok ts nt` `set queue = dom ts` `distinct queue`
  have "set (enqueue_new_thread queue nt) = dom (redT_updT ts nt) \<and> distinct (enqueue_new_thread queue nt)"
    by(cases nt)(auto)
  with `thread_oks (redT_updT ts nt) ntas`
  have "distinct (enqueue_new_threads (enqueue_new_thread queue nt) ntas)"
    by(blast intro: Cons.hyps)
  thus ?case by(simp add: enqueue_new_threads_def)
qed

lemma round_robin_reschedule_induct [consumes 1, case_names head rotate]:
  assumes major: "t0 \<in> set queue"
  and head: "\<And>queue. P (t0 # queue)"
  and rotate: "\<And>queue t. \<lbrakk> t \<noteq> t0; t0 \<in> set queue; P (queue @ [t]) \<rbrakk> \<Longrightarrow> P (t # queue)"
  shows "P queue"
using major
proof(induct n\<equiv>"length (takeWhile (\<lambda>x. x\<noteq>t0) queue)" arbitrary: queue)
  case 0
  then obtain queue' where "queue = t0 # queue'"
    by(cases queue)(auto split: split_if_asm)
  thus ?case by(simp add: head)
next
  case (Suc n)
  then obtain t queue' where [simp]: "queue = t # queue'"
    and t: "t \<noteq> t0" and n: "n = length (takeWhile (\<lambda>x. x \<noteq> t0) queue')"
    and t0: "t0 \<in> set queue'"
    by(cases queue)(auto split: split_if_asm)
  from n t0 have "n = length (takeWhile (\<lambda>x. x \<noteq> t0) (queue' @ [t]))" by(simp)
  moreover from t0 have "t0 \<in> set (queue' @ [t])" by simp
  ultimately have "P (queue' @ [t])" by(rule Suc.hyps)
  with t t0 show ?case by(simp add: rotate)
qed

context multithreaded_base begin

declare actions_ok_iff [simp del]
declare actions_ok.cases [rule del]

lemma round_robin_step_invar_None:
  "\<lbrakk> round_robin_step n0 \<sigma> s t' = \<lfloor>(t, None, \<sigma>')\<rfloor>; round_robin_invar \<sigma> (dom (thr s)) \<rbrakk>
  \<Longrightarrow> round_robin_invar \<sigma>' (dom (thr s))"
by(cases \<sigma>)(auto dest: step_thread_Some_NoneD simp add: set_enqueue_new_threads distinct_enqueue_new_threads)

lemma round_robin_step_invar_Some:
  "\<lbrakk> deterministic I; round_robin_step n0 \<sigma> s t' = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>; round_robin_invar \<sigma> (dom (thr s)); s \<in> I \<rbrakk>
  \<Longrightarrow> round_robin_invar \<sigma>' (dom (thr s) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})"
apply(cases \<sigma>)
apply clarsimp
apply(frule (1) step_thread_Some_SomeD)
apply(auto split: split_if_asm simp add: split_beta set_enqueue_new_threads deterministic_THE)
apply(auto simp add: actions_ok_iff distinct_enqueue_new_threads)
done

lemma round_robin_reschedule_Cons:
  "round_robin_reschedule t0 (t0 # queue) n0 s = None"
  "t \<noteq> t0 \<Longrightarrow> round_robin_reschedule t0 (t # queue) n0 s =
   (case round_robin_step n0 (t # queue, n0) s t of
      None \<Rightarrow> round_robin_reschedule t0 (queue @ [t]) n0 s
    | Some ttaxm\<sigma> \<Rightarrow> Some ttaxm\<sigma>)"
by(simp_all add: round_robin_reschedule.simps)

lemma round_robin_reschedule_NoneD:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = None"
  and t0: "t0 \<in> set queue"
  shows "set (takeWhile (\<lambda>t'. t' \<noteq> t0) queue) \<inter> active_threads s = {}"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case (head queue)
  thus ?case by simp
next
  case (rotate queue t)
  from `round_robin_reschedule t0 (t # queue) n0 s = None` `t \<noteq> t0`
  have "round_robin_step n0 (t # queue, n0) s t = None"
    and "round_robin_reschedule t0 (queue @ [t]) n0 s = None"
    by(simp_all add: round_robin_reschedule_Cons)
  from this(1) have "t \<notin> active_threads s" by(rule step_thread_NoneD)
  moreover from `round_robin_reschedule t0 (queue @ [t]) n0 s = None`
  have "set (takeWhile (\<lambda>t'. t' \<noteq> t0) (queue @ [t])) \<inter> active_threads s = {}"
    by(rule rotate.hyps)
  moreover have "takeWhile (\<lambda>t'. t' \<noteq> t0) (queue @ [t]) = takeWhile (\<lambda>t'. t' \<noteq> t0) queue"
    using `t0 \<in> set queue` by simp
  ultimately show ?case using `t \<noteq> t0` by simp
qed

lemma round_robin_reschedule_Some_NoneD:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
  and t0: "t0 \<in> set queue"
  shows "\<exists>x ln n. thr s t = \<lfloor>(x, ln)\<rfloor> \<and> ln $ n > 0 \<and> \<not> waiting (wset s t) \<and> may_acquire_all (locks s) t ln"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_step n0 (t' # queue, n0) s t' = \<lfloor>(t, None, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(blast dest: step_thread_Some_NoneD)
  qed
qed

lemma round_robin_reschedule_Some_SomeD:
  assumes "deterministic I"
  and rrr: "round_robin_reschedule t0 queue n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
  and t0: "t0 \<in> set queue"
  and I: "s \<in> I"
  shows "\<exists>x. thr s t = \<lfloor>(x, no_wait_locks)\<rfloor> \<and> t \<turnstile> \<langle>x, shr s\<rangle> -ta\<rightarrow> \<langle>x', m'\<rangle> \<and> actions_ok s t ta"
using t0 rrr
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_step n0 (t' # queue, n0) s t' = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using I by(blast dest: step_thread_Some_SomeD[OF `deterministic I`])
  qed
qed

lemma round_robin_reschedule_invar_None:
  assumes rrr: "round_robin_reschedule t0 queue n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
  and invar: "round_robin_invar (queue, n0) (dom (thr s))"
  and t0: "t0 \<in> set queue"
  shows "round_robin_invar \<sigma>' (dom (thr s))"
using t0 rrr invar
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    moreover from `round_robin_invar (t' # queue, n0) (dom (thr s))`
    have "round_robin_invar (queue @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_step n0 (t' # queue, n0) s t' = \<lfloor>(t, None, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using `round_robin_invar (t' # queue, n0) (dom (thr s))`
      by(rule round_robin_step_invar_None)
  qed
qed

lemma round_robin_reschedule_invar_Some:
  assumes "deterministic I"
  and rrr: "round_robin_reschedule t0 queue n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
  and invar: "round_robin_invar (queue, n0) (dom (thr s))"
  and t0: "t0 \<in> set queue"
  and "s \<in> I"
  shows "round_robin_invar \<sigma>' (dom (thr s) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})"
using t0 rrr invar
proof(induct queue rule: round_robin_reschedule_induct)
  case head thus ?case by(simp add: round_robin_reschedule_Cons)
next
  case (rotate queue t')
  show ?case
  proof(cases "round_robin_step n0 (t' # queue, n0) s t'")
    case None
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_reschedule t0 (queue @ [t']) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    moreover from `round_robin_invar (t' # queue, n0) (dom (thr s))`
    have "round_robin_invar (queue @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule rotate.hyps)
  next
    case (Some a)
    with `round_robin_reschedule t0 (t' # queue) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>` `t' \<noteq> t0`
    have "round_robin_step n0 (t' # queue, n0) s t' = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
      by(simp add: round_robin_reschedule_Cons)
    thus ?thesis using `round_robin_invar (t' # queue, n0) (dom (thr s))` `s \<in> I`
      by(rule round_robin_step_invar_Some[OF `deterministic I`])
  qed
qed

lemma round_robin_NoneD:
  assumes rr: "round_robin n0 \<sigma> s = None"
  and invar: "round_robin_invar \<sigma> (dom (thr s))"
  shows "active_threads s = {}"
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  show ?thesis
  proof(cases queue)
    case Nil
    thus ?thesis using invar \<sigma> by(fastforce elim: active_threads.cases)
  next
    case (Cons t queue')
    with rr \<sigma> have "round_robin_step n0 (t # queue', n) s t = None"
      and "round_robin_reschedule t (queue' @ [t]) n0 s = None" by simp_all
    from `round_robin_step n0 (t # queue', n) s t = None`
    have "t \<notin> active_threads s" by(rule step_thread_NoneD)
    moreover from `round_robin_reschedule t (queue' @ [t]) n0 s = None`
    have "set (takeWhile (\<lambda>x. x \<noteq> t) (queue' @ [t])) \<inter> active_threads s = {}"
      by(rule round_robin_reschedule_NoneD) simp
    moreover from invar \<sigma> Cons
    have "takeWhile (\<lambda>x. x \<noteq> t) (queue' @ [t]) = queue'"
      by(subst takeWhile_append2) auto
    moreover from invar have "active_threads s \<subseteq> set queue"
      using \<sigma> by(auto elim: active_threads.cases)
    ultimately show ?thesis using Cons by auto
  qed
qed

lemma round_robin_Some_NoneD:
  assumes rr: "round_robin n0 \<sigma> s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
  shows "\<exists>x ln n. thr s t = \<lfloor>(x, ln)\<rfloor> \<and> ln $ n > 0 \<and> \<not> waiting (wset s t) \<and> may_acquire_all (locks s) t ln"
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  with rr have "queue \<noteq> []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue \<sigma> have "round_robin_step n0 (t' # queue', n) s t' = \<lfloor>(t, None, \<sigma>')\<rfloor>" by simp
    thus ?thesis by(blast dest: step_thread_Some_NoneD)
  next
    case None
    with rr queue \<sigma> have "round_robin_reschedule t' (queue' @ [t']) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>" by simp
    thus ?thesis by(rule round_robin_reschedule_Some_NoneD)simp
  qed
qed

lemma round_robin_Some_SomeD:
  assumes "deterministic I"
  and rr: "round_robin n0 \<sigma> s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
  and "s \<in> I"
  shows "\<exists>x. thr s t = \<lfloor>(x, no_wait_locks)\<rfloor> \<and> t \<turnstile> \<langle>x, shr s\<rangle> -ta\<rightarrow> \<langle>x', m'\<rangle> \<and> actions_ok s t ta"
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  with rr have "queue \<noteq> []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue \<sigma> have "round_robin_step n0 (t' # queue', n) s t' = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>" by simp
    thus ?thesis using `s \<in> I` by(blast dest: step_thread_Some_SomeD[OF `deterministic I`])
  next
    case None
    with rr queue \<sigma> have "round_robin_reschedule t' (queue' @ [t']) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>" by simp
    thus ?thesis by(rule round_robin_reschedule_Some_SomeD[OF `deterministic I`])(simp_all add: `s \<in> I`)
  qed
qed

lemma round_robin_invar_None:
  assumes rr: "round_robin n0 \<sigma> s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
  and invar: "round_robin_invar \<sigma> (dom (thr s))"
  shows "round_robin_invar \<sigma>' (dom (thr s))"
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  with rr have "queue \<noteq> []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue \<sigma> have "round_robin_step n0 (t' # queue', n) s t' = \<lfloor>(t, None, \<sigma>')\<rfloor>" by simp
    thus ?thesis using invar unfolding \<sigma> queue by(rule round_robin_step_invar_None)
  next
    case None
    with rr queue \<sigma> have "round_robin_reschedule t' (queue' @ [t']) n0 s = \<lfloor>(t, None, \<sigma>')\<rfloor>" by simp
    moreover from invar queue \<sigma> have "round_robin_invar (queue' @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule round_robin_reschedule_invar_None) simp
  qed
qed

lemma round_robin_invar_Some:
  assumes "deterministic I"
  and rr: "round_robin n0 \<sigma> s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
  and invar: "round_robin_invar \<sigma> (dom (thr s))" "s \<in> I"
  shows "round_robin_invar \<sigma>' (dom (thr s) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})"
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  with rr have "queue \<noteq> []" by clarsimp
  then obtain t' queue' where queue: "queue = t' # queue'"
    by(auto simp add: neq_Nil_conv)
  show ?thesis
  proof(cases "round_robin_step n0 (t' # queue', n) s t'")
    case (Some a)
    with rr queue \<sigma> have "round_robin_step n0 (t' # queue', n) s t' = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>" by simp
    thus ?thesis using invar unfolding \<sigma> queue by(rule round_robin_step_invar_Some[OF `deterministic I`])
  next
    case None
    with rr queue \<sigma> have "round_robin_reschedule t' (queue' @ [t']) n0 s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>" by simp
    moreover from invar queue \<sigma>
    have "round_robin_invar (queue' @ [t'], n0) (dom (thr s))" by simp
    ultimately show ?thesis by(rule round_robin_reschedule_invar_Some[OF `deterministic I`])(simp_all add: `s \<in> I`)
  qed
qed

end

locale round_robin_base =
  scheduler_base_aux
    final r convert_RA
    thr_\<alpha> thr_invar thr_lookup thr_update
    ws_\<alpha> ws_invar ws_lookup
    is_\<alpha> is_invar is_memb is_ins is_delete
  for final :: "'x \<Rightarrow> bool"
  and r :: "'t \<Rightarrow> ('x \<times> 'm) \<Rightarrow> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) Predicate.pred"
  and convert_RA :: "'l released_locks \<Rightarrow> 'o list"
  and "output" :: "'queue round_robin \<Rightarrow> 't \<Rightarrow> ('l,'t,'x,'m,'w,'o) thread_action \<Rightarrow> 'q option"
  and thr_\<alpha> :: "'m_t \<Rightarrow> ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t \<Rightarrow> bool"
  and thr_lookup :: "'t \<Rightarrow> 'm_t \<rightharpoonup> ('x \<times> 'l released_locks)"
  and thr_update :: "'t \<Rightarrow> 'x \<times> 'l released_locks \<Rightarrow> 'm_t \<Rightarrow> 'm_t"
  and ws_\<alpha> :: "'m_w \<Rightarrow> ('w,'t) wait_sets"
  and ws_invar :: "'m_w \<Rightarrow> bool"
  and ws_lookup :: "'t \<Rightarrow> 'm_w \<rightharpoonup> 'w wait_set_status"
  and ws_update :: "'t \<Rightarrow> 'w wait_set_status \<Rightarrow> 'm_w \<Rightarrow> 'm_w"
  and ws_delete :: "'t \<Rightarrow> 'm_w \<Rightarrow> 'm_w"
  and ws_iterate :: "'m_w \<Rightarrow> ('t \<times> 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w \<Rightarrow> ('t \<times> 'w wait_set_status \<Rightarrow> bool) \<rightharpoonup> ('t \<times> 'w wait_set_status)"
  and is_\<alpha> :: "'s_i \<Rightarrow> 't interrupts"
  and is_invar :: "'s_i \<Rightarrow> bool"
  and is_memb :: "'t \<Rightarrow> 's_i \<Rightarrow> bool"
  and is_ins :: "'t \<Rightarrow> 's_i \<Rightarrow> 's_i"
  and is_delete :: "'t \<Rightarrow> 's_i \<Rightarrow> 's_i"
  +
  fixes queue_\<alpha> :: "'queue \<Rightarrow> 't list"
  and queue_invar :: "'queue \<Rightarrow> bool"
  and queue_empty :: "unit \<Rightarrow> 'queue"
  and queue_isEmpty :: "'queue \<Rightarrow> bool"
  and queue_enqueue :: "'t \<Rightarrow> 'queue \<Rightarrow> 'queue"
  and queue_dequeue :: "'queue \<Rightarrow> 't \<times> 'queue"
  and queue_push :: "'t \<Rightarrow> 'queue \<Rightarrow> 'queue"
begin

definition queue_rotate1 :: "'queue \<Rightarrow> 'queue"
where "queue_rotate1 = split queue_enqueue \<circ> queue_dequeue"

primrec enqueue_new_thread :: "'queue \<Rightarrow> ('t,'x,'m) new_thread_action \<Rightarrow> 'queue"
where
  "enqueue_new_thread ts (NewThread t x m) = queue_enqueue t ts"
| "enqueue_new_thread ts (ThreadExists t b) = ts"

definition enqueue_new_threads :: "'queue \<Rightarrow> ('t,'x,'m) new_thread_action list \<Rightarrow> 'queue"
where
  "enqueue_new_threads = foldl enqueue_new_thread"

primrec round_robin_update_state :: "nat \<Rightarrow> 'queue round_robin \<Rightarrow> 't \<Rightarrow> ('l,'t,'x,'m,'w,'o) thread_action \<Rightarrow> 'queue round_robin"
where
  "round_robin_update_state n0 (queue, n) t ta =
   (let queue' = enqueue_new_threads queue \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>
    in if n = 0 \<or> Yield \<in> set \<lbrace>ta\<rbrace>\<^bsub>c\<^esub> then (queue_rotate1 queue', n0) else (queue', n - 1))"

abbreviation round_robin_step ::
  "nat \<Rightarrow> 'queue round_robin \<Rightarrow> ('l,'t,'m,'m_t,'m_w,'s_i) state_refine \<Rightarrow> 't
  \<Rightarrow> ('t \<times> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) option \<times> 'queue round_robin) option"
where
  "round_robin_step n0 \<sigma> s t \<equiv> step_thread (round_robin_update_state n0 \<sigma> t) s t"

partial_function (option) round_robin_reschedule ::
  "'t \<Rightarrow> 'queue \<Rightarrow> nat \<Rightarrow> ('l,'t,'m,'m_t,'m_w,'s_i) state_refine
  \<Rightarrow> ('t \<times> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) option \<times> 'queue round_robin) option"
where
  "round_robin_reschedule t0 queue n0 s =
   (let
      (t, queue') = queue_dequeue queue
    in
      if t = t0 then
        None
      else
        case round_robin_step n0 (queue_push t queue', n0) s t of
          None \<Rightarrow> round_robin_reschedule t0 (queue_enqueue t queue') n0 s
        | \<lfloor>ttaxm\<sigma>\<rfloor> \<Rightarrow> \<lfloor>ttaxm\<sigma>\<rfloor>)"

primrec round_robin :: "nat \<Rightarrow> ('l,'t,'x,'m,'w,'o,'m_t,'m_w,'s_i,'queue round_robin) scheduler"
where
  "round_robin n0 (queue, n) s =
   (if queue_isEmpty queue then None
    else
      let
        (t, queue') = queue_dequeue queue
      in
        (case round_robin_step n0 (queue_push t queue', n) s t of
           \<lfloor>ttaxm\<sigma>\<rfloor> \<Rightarrow> \<lfloor>ttaxm\<sigma>\<rfloor>
         | None \<Rightarrow> round_robin_reschedule t (queue_enqueue t queue') n0 s))"

primrec round_robin_invar :: "'queue round_robin \<Rightarrow> 't set \<Rightarrow> bool"
where "round_robin_invar (queue, n) T \<longleftrightarrow> queue_invar queue \<and> Round_Robin.round_robin_invar (queue_\<alpha> queue, n) T"

definition round_robin_\<alpha> :: "'queue round_robin \<Rightarrow> 't list round_robin"
where "round_robin_\<alpha> = apfst queue_\<alpha>"

definition round_robin_start :: "nat \<Rightarrow> 't \<Rightarrow> 'queue round_robin"
where "round_robin_start n0 t = (queue_enqueue t (queue_empty ()), n0)"

lemma round_robin_invar_correct:
  "round_robin_invar \<sigma> T \<Longrightarrow> Round_Robin.round_robin_invar (round_robin_\<alpha> \<sigma>) T"
by(cases \<sigma>)(simp add: round_robin_\<alpha>_def)

end

locale round_robin =
  round_robin_base
    final r convert_RA "output"
    thr_\<alpha> thr_invar thr_lookup thr_update
    ws_\<alpha> ws_invar ws_lookup ws_update ws_delete ws_iterate ws_sel
    is_\<alpha> is_invar is_memb is_ins is_delete
    queue_\<alpha> queue_invar queue_empty queue_isEmpty queue_enqueue queue_dequeue queue_push
  +
  scheduler_aux
    final r convert_RA
    thr_\<alpha> thr_invar thr_lookup thr_update
    ws_\<alpha> ws_invar ws_lookup
    is_\<alpha> is_invar is_memb is_ins is_delete
  +
  ws!: map_update ws_\<alpha> ws_invar ws_update +
  ws!: map_delete ws_\<alpha> ws_invar ws_delete +
  ws!: map_iteratei ws_\<alpha> ws_invar ws_iterate +
  ws!: map_sel' ws_\<alpha> ws_invar ws_sel +
  queue!: list queue_\<alpha> queue_invar +
  queue!: list_empty queue_\<alpha> queue_invar queue_empty +
  queue!: list_isEmpty queue_\<alpha> queue_invar queue_isEmpty +
  queue!: list_enqueue queue_\<alpha> queue_invar queue_enqueue +
  queue!: list_dequeue queue_\<alpha> queue_invar queue_dequeue +
  queue!: list_push queue_\<alpha> queue_invar queue_push
  for final :: "'x \<Rightarrow> bool"
  and r :: "'t \<Rightarrow> ('x \<times> 'm) \<Rightarrow> (('l,'t,'x,'m,'w,'o) thread_action \<times> 'x \<times> 'm) Predicate.pred"
  and convert_RA :: "'l released_locks \<Rightarrow> 'o list"
  and "output" :: "'queue round_robin \<Rightarrow> 't \<Rightarrow> ('l,'t,'x,'m,'w,'o) thread_action \<Rightarrow> 'q option"
  and thr_\<alpha> :: "'m_t \<Rightarrow> ('l,'t,'x) thread_info"
  and thr_invar :: "'m_t \<Rightarrow> bool"
  and thr_lookup :: "'t \<Rightarrow> 'm_t \<rightharpoonup> ('x \<times> 'l released_locks)"
  and thr_update :: "'t \<Rightarrow> 'x \<times> 'l released_locks \<Rightarrow> 'm_t \<Rightarrow> 'm_t"
  and ws_\<alpha> :: "'m_w \<Rightarrow> ('w,'t) wait_sets"
  and ws_invar :: "'m_w \<Rightarrow> bool"
  and ws_lookup :: "'t \<Rightarrow> 'm_w \<rightharpoonup> 'w wait_set_status"
  and ws_update :: "'t \<Rightarrow> 'w wait_set_status \<Rightarrow> 'm_w \<Rightarrow> 'm_w"
  and ws_delete :: "'t \<Rightarrow> 'm_w \<Rightarrow> 'm_w"
  and ws_iterate :: "'m_w \<Rightarrow> ('t \<times> 'w wait_set_status, 'm_w) set_iterator"
  and ws_sel :: "'m_w \<Rightarrow> ('t \<times> 'w wait_set_status \<Rightarrow> bool) \<rightharpoonup> ('t \<times> 'w wait_set_status)"
  and is_\<alpha> :: "'s_i \<Rightarrow> 't interrupts"
  and is_invar :: "'s_i \<Rightarrow> bool"
  and is_memb :: "'t \<Rightarrow> 's_i \<Rightarrow> bool"
  and is_ins :: "'t \<Rightarrow> 's_i \<Rightarrow> 's_i"
  and is_delete :: "'t \<Rightarrow> 's_i \<Rightarrow> 's_i"
  and queue_\<alpha> :: "'queue \<Rightarrow> 't list"
  and queue_invar :: "'queue \<Rightarrow> bool"
  and queue_empty :: "unit \<Rightarrow> 'queue"
  and queue_isEmpty :: "'queue \<Rightarrow> bool"
  and queue_enqueue :: "'t \<Rightarrow> 'queue \<Rightarrow> 'queue"
  and queue_dequeue :: "'queue \<Rightarrow> 't \<times> 'queue"
  and queue_push :: "'t \<Rightarrow> 'queue \<Rightarrow> 'queue"
begin

lemma queue_rotate1_correct:
  assumes "queue_invar queue" "queue_\<alpha> queue \<noteq> []"
  shows "queue_\<alpha> (queue_rotate1 queue) = rotate1 (queue_\<alpha> queue)"
  and "queue_invar (queue_rotate1 queue)"
using assms
apply(auto simp add: queue_rotate1_def split_beta queue.dequeue_correct queue.enqueue_correct)
by(cases "queue_\<alpha> queue") simp_all

lemma enqueue_thread_correct:
  assumes "queue_invar queue"
  shows "queue_\<alpha> (enqueue_new_thread queue nta) = Round_Robin.enqueue_new_thread (queue_\<alpha> queue) nta"
  and "queue_invar (enqueue_new_thread queue nta)"
using assms
by(case_tac [!] nta)(simp_all add: queue.enqueue_correct)

lemma enqueue_threads_correct:
  assumes "queue_invar queue"
  shows "queue_\<alpha> (enqueue_new_threads queue ntas) = Round_Robin.enqueue_new_threads (queue_\<alpha> queue) ntas"
  and "queue_invar (enqueue_new_threads queue ntas)"
using assms
apply(induct ntas arbitrary: queue)
apply(simp_all add: enqueue_new_threads_def Round_Robin.enqueue_new_threads_def enqueue_thread_correct)
done

lemma round_robin_update_thread_correct:
  assumes "round_robin_invar \<sigma> T" "t' \<in> T"
  shows "round_robin_\<alpha> (round_robin_update_state n0 \<sigma> t ta) = Round_Robin.round_robin_update_state n0 (round_robin_\<alpha> \<sigma>) t ta"
using assms
apply(cases \<sigma>)
apply(auto simp add: round_robin_\<alpha>_def queue_rotate1_correct enqueue_threads_correct del: conjI)
apply(subst (1 2) queue_rotate1_correct)
apply(auto simp add: enqueue_threads_correct)
done

lemma round_robin_step_correct:
  assumes det: "\<alpha>.deterministic I"
  and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  shows
  "map_option (apsnd (apsnd round_robin_\<alpha>)) (round_robin_step n0 \<sigma> s t) =
   \<alpha>.round_robin_step n0 (round_robin_\<alpha> \<sigma>) (state_\<alpha> s) t" (is ?thesis1)
  and "case_option True (\<lambda>(t, taxm, \<sigma>). round_robin_invar \<sigma> (case taxm of None \<Rightarrow> dom (thr_\<alpha> (thr s)) | Some (ta, x', m') \<Rightarrow> dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})) (round_robin_step n0 \<sigma> s t)"
  (is ?thesis2)
proof -
  have "?thesis1 \<and> ?thesis2"
  proof(cases "dom (thr_\<alpha> (thr s)) = {}")
    case True
    thus ?thesis using invar
      apply(cases \<sigma>)
      apply(auto dest: step_thread_Some_NoneD[OF det] step_thread_Some_SomeD[OF det])
      apply(fastforce simp add: \<alpha>.step_thread_eq_None_conv elim: \<alpha>.active_threads.cases intro: sym)
      done
  next
    case False
    then obtain t' where t': "t' \<in> dom (thr_\<alpha> (thr s))" by blast
    hence ?thesis1
      using step_thread_correct(1)[of I round_robin_invar \<sigma> s round_robin_\<alpha> "round_robin_update_state n0 \<sigma> t" t, OF det invar]
      unfolding o_def using invar
      by(subst (asm) round_robin_update_thread_correct) auto
    moreover
    { fix ta :: "('l, 't, 'x, 'm, 'w, 'o) thread_action"
      assume "FWThread.thread_oks (thr_\<alpha> (thr s)) \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>"
      moreover from t' invar have "queue_\<alpha> (fst \<sigma>) \<noteq> []" by(cases \<sigma>) auto
      ultimately have "round_robin_invar (round_robin_update_state n0 \<sigma> t ta) (dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})"
        using invar t' by(cases \<sigma>)(auto simp add: queue_rotate1_correct enqueue_threads_correct set_enqueue_new_threads iff del: domIff intro: distinct_enqueue_new_threads) }
    from step_thread_correct(2)[OF det, of round_robin_invar \<sigma> s "round_robin_update_state n0 \<sigma> t" t, OF invar this]
    have ?thesis2 using t' invar by simp
    ultimately show ?thesis by blast
  qed
  thus ?thesis1 ?thesis2 by blast+
qed

lemma round_robin_reschedule_correct:
  assumes det: "\<alpha>.deterministic I"
  and invar: "round_robin_invar (queue, n) (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  and t0: "t0 \<in> set (queue_\<alpha> queue)"
  shows "map_option (apsnd (apsnd round_robin_\<alpha>)) (round_robin_reschedule t0 queue n0 s) =
     \<alpha>.round_robin_reschedule t0 (queue_\<alpha> queue) n0 (state_\<alpha> s)"
  and "case_option True (\<lambda>(t, taxm, \<sigma>). round_robin_invar \<sigma> (case taxm of None \<Rightarrow> dom (thr_\<alpha> (thr s)) | Some (ta, x', m') \<Rightarrow> dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})) (round_robin_reschedule t0 queue n0 s)"
using t0 invar
proof(induct "queue_\<alpha> queue" arbitrary: queue n rule: round_robin_reschedule_induct)
  case head
  { case 1 thus ?case using head[symmetric]
      by(subst round_robin_reschedule.simps)(subst \<alpha>.round_robin_reschedule.simps, clarsimp simp add: split_beta queue.dequeue_correct)
  next
    case 2 thus ?case using head[symmetric]
      by(subst round_robin_reschedule.simps)(clarsimp simp add: split_beta queue.dequeue_correct) }
next
  case (rotate \<alpha>queue' t)
  obtain t' queue' where queue': "queue_dequeue queue = (t', queue')" by(cases "queue_dequeue queue")
  note [simp] = `t # \<alpha>queue' = queue_\<alpha> queue`[symmetric]
  { case 1
    with queue' have [simp]: "t' = t" "\<alpha>queue' = queue_\<alpha> queue'" "queue_invar queue'" by(auto elim: queue.removelE)
    from 1 queue' have invar': "round_robin_invar (queue_push t queue', n0) (dom (thr_\<alpha> (thr s)))"
      by(auto simp add: queue.push_correct)
    show ?case
    proof(cases "round_robin_step n0 (queue_push t queue', n0) s t")
      case Some thus ?thesis
        using queue' `t \<noteq> t0` round_robin_step_correct[OF det invar' `state_invar s`, of n0 t] invar' `state_\<alpha> s \<in> I`
        by(subst round_robin_reschedule.simps)(subst \<alpha>.round_robin_reschedule.simps, auto simp add: round_robin_\<alpha>_def queue.push_correct)
    next
      case None
      hence \<alpha>None: "\<alpha>.round_robin_step n0 (queue_\<alpha> (queue_push t queue'), n0) (state_\<alpha> s) t = None"
        using round_robin_step_correct[OF det invar' `state_invar s`, of n0 t] invar' `state_\<alpha> s \<in> I`
        by(auto simp add: queue.push_correct round_robin_\<alpha>_def)
      have "\<alpha>queue' @ [t] = queue_\<alpha> (queue_enqueue t queue')" by(simp add: queue.enqueue_correct)
      moreover from invar'
      have "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_\<alpha> (thr s)))"
        by(auto simp add: queue.enqueue_correct queue.push_correct)
      ultimately
      have "map_option (apsnd (apsnd round_robin_\<alpha>)) (round_robin_reschedule t0 (queue_enqueue t queue') n0 s) =
            \<alpha>.round_robin_reschedule t0 (queue_\<alpha> (queue_enqueue t queue')) n0 (state_\<alpha> s)"
        using `state_invar s` `state_\<alpha> s \<in> I` by(rule rotate.hyps)
      thus ?thesis using None \<alpha>None `t \<noteq> t0` invar' queue'
        by(subst round_robin_reschedule.simps)(subst \<alpha>.round_robin_reschedule.simps, auto simp add: queue.enqueue_correct queue.push_correct)
    qed
  next
    case 2
    with queue' have [simp]: "t' = t" "\<alpha>queue' = queue_\<alpha> queue'" "queue_invar queue'" by(auto elim: queue.removelE)
    from 2 queue' have invar': "round_robin_invar (queue_push t queue', n0) (dom (thr_\<alpha> (thr s)))"
      by(auto simp add: queue.push_correct)
    show ?case
    proof(cases "round_robin_step n0 (queue_push t queue', n0) s t")
      case Some thus ?thesis
        using queue' `t \<noteq> t0` round_robin_step_correct[OF det invar' `state_invar s`, of n0 t] invar' `state_\<alpha> s \<in> I`
        by(subst round_robin_reschedule.simps)(auto simp add: round_robin_\<alpha>_def queue.push_correct)
    next
      case None
      have "\<alpha>queue' @ [t] = queue_\<alpha> (queue_enqueue t queue')" by(simp add: queue.enqueue_correct)
      moreover from invar'
      have "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_\<alpha> (thr s)))"
        by(auto simp add: queue.enqueue_correct queue.push_correct)
      ultimately
      have "case_option True (\<lambda>(t, taxm, \<sigma>). round_robin_invar \<sigma> (case_option (dom (thr_\<alpha> (thr s))) (\<lambda>(ta, x', m'). dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>}) taxm)) (round_robin_reschedule t0 (queue_enqueue t queue') n0 s)"
        using `state_invar s` `state_\<alpha> s \<in> I` by(rule rotate.hyps)
      thus ?thesis using None `t \<noteq> t0` invar' queue'
        by(subst round_robin_reschedule.simps)(auto simp add: queue.enqueue_correct queue.push_correct)
    qed
  }
qed

lemma round_robin_correct:
  assumes det: "\<alpha>.deterministic I"
  and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  shows "map_option (apsnd (apsnd round_robin_\<alpha>)) (round_robin n0 \<sigma> s) =
         \<alpha>.round_robin n0 (round_robin_\<alpha> \<sigma>) (state_\<alpha> s)"
    (is ?thesis1)
  and "case_option True (\<lambda>(t, taxm, \<sigma>). round_robin_invar \<sigma> (case taxm of None \<Rightarrow> dom (thr_\<alpha> (thr s)) | Some (ta, x', m') \<Rightarrow> dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})) (round_robin n0 \<sigma> s)"
    (is ?thesis2)
proof -
  obtain queue n where \<sigma>: "\<sigma> = (queue, n)" by(cases \<sigma>)
  have "?thesis1 \<and> ?thesis2"
  proof(cases "queue_\<alpha> queue")
    case Nil thus ?thesis using invar \<sigma>
      by(auto simp add: split_beta queue.isEmpty_correct round_robin_\<alpha>_def)
  next
    case (Cons t \<alpha>queue')
    with invar \<sigma> obtain queue'
      where [simp]: "queue_dequeue queue = (t, queue')" "\<alpha>queue' = queue_\<alpha> queue'" "queue_invar queue'"
      by(auto elim: queue.removelE)
    from invar \<sigma> Cons have invar': "round_robin_invar (queue_push t queue', n) (dom (thr_\<alpha> (thr s)))"
      by(auto simp add: queue.push_correct)
    from invar \<sigma> Cons have invar'': "round_robin_invar (queue_enqueue t queue', n0) (dom (thr_\<alpha> (thr s)))"
      by(auto simp add: queue.enqueue_correct)
    show ?thesis
    proof(cases "round_robin_step n0 (queue_push t queue', n) s t")
      case Some
      with \<sigma> Cons invar show ?thesis
        using round_robin_step_correct[OF det invar' `state_invar s`, of n0 t]
        by(auto simp add: queue.isEmpty_correct queue.push_correct round_robin_\<alpha>_def)
    next
      case None
      from invar \<sigma> Cons have "t \<in> set (queue_\<alpha> (queue_enqueue t queue'))"
        by(auto simp add: queue.enqueue_correct)
      from round_robin_reschedule_correct[OF det invar'' `state_invar s`, OF `state_\<alpha> s \<in> I` this, of n0] None \<sigma> Cons invar
        round_robin_step_correct[OF det invar' `state_invar s`, of n0 t]
      show ?thesis by(auto simp add: queue.isEmpty_correct queue.push_correct round_robin_\<alpha>_def queue.enqueue_correct)
    qed
  qed
  thus ?thesis1 ?thesis2 by simp_all
qed

lemma round_robin_scheduler_spec:
  assumes det: "\<alpha>.deterministic I"
  shows "scheduler_spec final r (round_robin n0) round_robin_invar thr_\<alpha> thr_invar ws_\<alpha> ws_invar is_\<alpha> is_invar I"
proof
  fix \<sigma> s
  assume rr: "round_robin n0 \<sigma> s = None"
    and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have "\<alpha>.round_robin n0 (round_robin_\<alpha> \<sigma>) (state_\<alpha> s) = None" by simp
  moreover from invar have "Round_Robin.round_robin_invar (round_robin_\<alpha> \<sigma>) (dom (thr (state_\<alpha> s)))"
    by(simp add: round_robin_invar_correct)
  ultimately show "\<alpha>.active_threads (state_\<alpha> s) = {}" by(rule \<alpha>.round_robin_NoneD)
next
  fix \<sigma> s t \<sigma>'
  assume rr: "round_robin n0 \<sigma> s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
    and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have rr': "\<alpha>.round_robin n0 (round_robin_\<alpha> \<sigma>) (state_\<alpha> s) = \<lfloor>(t, None, round_robin_\<alpha> \<sigma>')\<rfloor>" by simp
  then show "\<exists>x ln n. thr_\<alpha> (thr s) t = \<lfloor>(x, ln)\<rfloor> \<and> 0 < ln $ n \<and> \<not> waiting (ws_\<alpha> (wset s) t) \<and> may_acquire_all (locks s) t ln"
    by(rule \<alpha>.round_robin_Some_NoneD[where s="state_\<alpha> s", unfolded state_\<alpha>_conv])
next
  fix \<sigma> s t ta x' m' \<sigma>'
  assume rr: "round_robin n0 \<sigma> s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
    and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  have rr': "\<alpha>.round_robin n0 (round_robin_\<alpha> \<sigma>) (state_\<alpha> s) = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, round_robin_\<alpha> \<sigma>')\<rfloor>" by simp
  thus "\<exists>x. thr_\<alpha> (thr s) t = \<lfloor>(x, no_wait_locks)\<rfloor> \<and> Predicate.eval (r t (x, shr s)) (ta, x', m') \<and> \<alpha>.actions_ok (state_\<alpha> s) t ta"
    using `state_\<alpha> s \<in> I` by(rule \<alpha>.round_robin_Some_SomeD[OF det, where s="state_\<alpha> s", unfolded state_\<alpha>_conv])
next
  fix \<sigma> s t \<sigma>'
  assume rr: "round_robin n0 \<sigma> s = \<lfloor>(t, None, \<sigma>')\<rfloor>"
    and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  show "round_robin_invar \<sigma>' (dom (thr_\<alpha> (thr s)))" by simp
next
  fix \<sigma> s t ta x' m' \<sigma>'
  assume rr: "round_robin n0 \<sigma> s = \<lfloor>(t, \<lfloor>(ta, x', m')\<rfloor>, \<sigma>')\<rfloor>"
    and invar: "round_robin_invar \<sigma> (dom (thr_\<alpha> (thr s)))" "state_invar s" "state_\<alpha> s \<in> I"
  from round_robin_correct[OF det, OF invar, of n0] rr
  show "round_robin_invar \<sigma>' (dom (thr_\<alpha> (thr s)) \<union> {t. \<exists>x m. NewThread t x m \<in> set \<lbrace>ta\<rbrace>\<^bsub>t\<^esub>})" by simp
qed

lemma round_robin_start_invar:
  "round_robin_invar (round_robin_start n0 t0) {t0}"
by(simp add: round_robin_start_def queue.empty_correct queue.enqueue_correct)

end

sublocale round_robin_base <
  scheduler_base
    final r convert_RA
    "round_robin n0" "output" "pick_wakeup_via_sel (\<lambda>s P. ws_sel s (\<lambda>(k,v). P k v))" round_robin_invar
    thr_\<alpha> thr_invar thr_lookup thr_update
    ws_\<alpha> ws_invar ws_lookup ws_update ws_delete ws_iterate
    is_\<alpha> is_invar is_memb is_ins is_delete
  for n0 .

sublocale round_robin <
  pick_wakeup_spec
    final r convert_RA
    "pick_wakeup_via_sel (\<lambda>s P. ws_sel s (\<lambda>(k,v). P k v))" round_robin_invar
    thr_\<alpha> thr_invar
    ws_\<alpha> ws_invar
    is_\<alpha> is_invar
by(rule pick_wakeup_spec_via_sel)(unfold_locales)

context round_robin begin

lemma round_robin_scheduler:
  assumes det: "\<alpha>.deterministic I"
  shows
  "scheduler
     final r convert_RA
     (round_robin n0) (pick_wakeup_via_sel (\<lambda>s P. ws_sel s (\<lambda>(k,v). P k v))) round_robin_invar
     thr_\<alpha> thr_invar thr_lookup thr_update
     ws_\<alpha> ws_invar ws_lookup ws_update ws_delete ws_iterate
     is_\<alpha> is_invar is_memb is_ins is_delete
     I"
proof -
  interpret scheduler_spec
      final r convert_RA
      "round_robin n0" round_robin_invar
      thr_\<alpha> thr_invar
      ws_\<alpha> ws_invar
      is_\<alpha> is_invar
      I
    using det by(rule round_robin_scheduler_spec)

  show ?thesis by(unfold_locales)(rule \<alpha>.deterministic_invariant3p[OF det])
qed

end

lemmas [code] =
  round_robin_base.queue_rotate1_def
  round_robin_base.enqueue_new_thread.simps
  round_robin_base.enqueue_new_threads_def
  round_robin_base.round_robin_update_state.simps
  round_robin_base.round_robin_reschedule.simps
  round_robin_base.round_robin.simps
  round_robin_base.round_robin_start_def

end


section \<open>Priority Search Trees on top of RBTs\<close>

theory PST_RBT
  imports
  "HOL-Data_Structures.Cmp"
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Lookup2"
  PST_General
  "Eval_Base.Eval_Base"
begin

text \<open>
We obtain a priority search map based on red-black trees via the
general priority search tree augmentation.

This theory has been derived from the standard Isabelle implementation of red
black trees in @{session "HOL-Data_Structures"}.
\<close>

subsection \<open>Definitions\<close>

subsubsection \<open>The Code\<close>

datatype tcolor = Red | Black

type_synonym ('k,'p) rbth = "(('k\<times>'p) \<times> (tcolor \<times> ('k \<times> 'p))) tree"

abbreviation R where "R mkp l a r \<equiv> Node l (a, Red,mkp) r"
abbreviation B where "B mkp l a r \<equiv> Node l (a, Black,mkp) r"

abbreviation "mkR \<equiv> mkNode Red"
abbreviation "mkB \<equiv> mkNode Black"

fun baliL :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
  "baliL (R _ (R _ t1 a1 t2) a2 t3) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL (R _ t1 a1 (R _ t2 a2 t3)) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL t1 a t2 = mkB t1 a t2"

fun baliR :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
"baliR t1 a1 (R _ (R _ t2 a2 t3) a3 t4) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a1 (R _ t2 a2 (R _ t3 a3 t4)) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a t2 = mkB t1 a t2"

fun paint :: "tcolor \<Rightarrow> ('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth" where
"paint c Leaf = Leaf" |
"paint c (Node l (a, (_,mkp)) r) = Node l (a, (c,mkp)) r"

fun baldL :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldL (R _ t1 x t2) y t3 = mkR (mkB t1 x t2) y t3" |
"baldL bl x (B _ t1 y t2) = baliR bl x (mkR t1 y t2)" |
"baldL bl x (R _ (B _ t1 y t2) z t3)
  = mkR (mkB bl x t1) y (baliR t2 z (paint Red t3))" |
"baldL t1 x t2 = mkR t1 x t2"

fun baldR :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldR t1 x (R _ t2 y t3) = mkR t1 x (mkB t2 y t3)" |
"baldR (B _ t1 x t2) y t3 = baliL (mkR t1 x t2) y t3" |
"baldR (R _ t1 x (B _ t2 y t3)) z t4
  = mkR (baliL (paint Red t1) x t2) y (mkB t3 z t4)" |
"baldR t1 x t2 = mkR t1 x t2"

fun combine :: "('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"combine Leaf t = t" |
"combine t Leaf = t" |
"combine (R _ t1 a t2) (R _ t3 c t4) =
  (case combine t2 t3 of
     R _ u2 b u3 \<Rightarrow> (mkR (mkR t1 a u2) b (mkR u3 c t4)) |
     t23 \<Rightarrow> mkR t1 a (mkR t23 c t4))" |
"combine (B _ t1 a t2) (B _ t3 c t4) =
  (case combine t2 t3 of
     R _ t2' b t3' \<Rightarrow> mkR (mkB t1 a t2') b (mkB t3' c t4) |
     t23 \<Rightarrow> baldL t1 a (mkB t23 c t4))" |
"combine t1 (R _ t2 a t3) = mkR (combine t1 t2) a t3" |
"combine (R _ t1 a t2) t3 = mkR t1 a (combine t2 t3)"

fun color :: "('k,'p) rbth \<Rightarrow> tcolor" where
"color Leaf = Black" |
"color (Node _ (_, (c,_)) _) = c"

fun upd :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth" where
"upd x y Leaf = mkR Leaf (x,y) Leaf" |
"upd x y (B _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> baliL (upd x y l) (a,b) r |
  GT \<Rightarrow> baliR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkB l (x,y) r)" |
"upd x y (R _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> mkR (upd x y l) (a,b) r |
  GT \<Rightarrow> mkR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkR l (x,y) r)"

definition update :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth"
where
"update x y t = paint Black (upd x y t)"

fun del :: "'a::linorder \<Rightarrow> ('a,'b::linorder)rbth \<Rightarrow> ('a,'b)rbth" where
"del x Leaf = Leaf" |
"del x (Node l ((a,b), (c,_)) r) = (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) (a,b) r else mkR (del x l) (a,b) r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l (a,b) (del x r) else mkR l (a,b) (del x r) |
  EQ \<Rightarrow> combine l r)"

definition delete :: "'a::linorder \<Rightarrow> ('a,'b::linorder) rbth \<Rightarrow> ('a,'b) rbth" where
"delete x t = paint Black (del x t)"

subsubsection \<open>Invariants\<close>

fun bheight :: "('k,'p) rbth \<Rightarrow> nat" where
"bheight Leaf = 0" |
"bheight (Node l (x, (c,_)) r) = (if c = Black then bheight l + 1 else bheight l)"

fun invc :: "('k,'p) rbth \<Rightarrow> bool" where
"invc Leaf = True" |
"invc (Node l (a, (c,_)) r) =
  (invc l \<and> invc r \<and> (c = Red \<longrightarrow> color l = Black \<and> color r = Black))"

fun invc2 :: "('k,'p) rbth \<Rightarrow> bool" \<comment> \<open>Weaker version\<close> where
"invc2 Leaf = True" |
"invc2 (Node l (a, _) r) = (invc l \<and> invc r)"

fun invh :: "('k,'p) rbth \<Rightarrow> bool" where
"invh Leaf = True" |
"invh (Node l (x, _) r) = (invh l \<and> invh r \<and> bheight l = bheight r)"

definition rbt :: "('k,'p::linorder) rbth \<Rightarrow> bool" where
"rbt t = (invc t \<and> invh t \<and> invpst t \<and> color t = Black)"

subsection \<open>Functional Correctness\<close>

lemma inorder_paint[simp]: "inorder(paint c t) = inorder t"
by(cases t) (auto)

lemma inorder_mkNode[simp]:
  "inorder (mkNode c l a r) = inorder l @ a # inorder r"
by (auto simp: mkNode_def)

lemma inorder_baliL[simp]:
  "inorder(baliL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma inorder_baliR[simp]:
  "inorder(baliR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma inorder_baldL[simp]:
  "inorder(baldL l a r) = inorder l @ a # inorder r"
by (cases "(l,a,r)" rule: baldL.cases) auto

lemma inorder_baldR[simp]:
  "inorder(baldR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldR.cases) auto

lemma inorder_combine[simp]:
  "inorder(combine l r) = inorder l @ inorder r"
  apply2 (induction l r rule: combine.induct) by(auto split: tree.split tcolor.split)

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(upd x y t) = upd_list x y (inorder t)"
apply2(induction x y t rule: upd.induct)
  by(auto simp: upd_list_simps)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd)

lemma inorder_del:
 "sorted1(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
apply2(induction x t rule: del.induct)
  by(auto simp: del_list_simps)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Invariant Preservation\<close>

lemma color_paint_Black: "color (paint Black t) = Black"
by (cases t) auto

theorem rbt_Leaf: "rbt Leaf"
by (simp add: rbt_def)

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
by (cases t rule: invc.cases) simp+

lemma paint_invc2: "invc2 t \<Longrightarrow> invc2 (paint c t)"
by (cases t) auto

lemma invc_paint_Black: "invc2 t \<Longrightarrow> invc (paint Black t)"
by (cases t) auto

lemma invh_paint: "invh t \<Longrightarrow> invh (paint c t)"
by (cases t) auto

lemma invc_mkRB[simp]:
  "invc (mkR l a r) \<longleftrightarrow> invc l \<and> invc r \<and> color l = Black \<and> color r = Black"
  "invc (mkB l a r) \<longleftrightarrow> invc l \<and> invc r"
by (simp_all add: mkNode_def)

lemma color_mkNode[simp]: "color (mkNode c l a r) = c"
by (simp_all add: mkNode_def)

subsubsection \<open>Update\<close>

lemma invc_baliL:
  "\<lbrakk>invc2 l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma invc_baliR:
  "\<lbrakk>invc l; invc2 r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma bheight_mkRB[simp]:
  "bheight (mkR l a r) = bheight l"
  "bheight (mkB l a r) = Suc (bheight l)"
  by (simp_all add: mkNode_def)

lemma bheight_baliL:
  "bheight l = bheight r \<Longrightarrow> bheight (baliL l a r) = Suc (bheight l)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma bheight_baliR:
  "bheight l = bheight r \<Longrightarrow> bheight (baliR l a r) = Suc (bheight l)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma invh_mkNode[simp]:
  "invh (mkNode c l a r) \<longleftrightarrow> invh l \<and> invh r \<and> bheight l = bheight r"
by (simp add: mkNode_def)

lemma invh_baliL:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliL l a r)"
apply2 (induct l a r rule: baliL.induct) by auto

lemma invh_baliR:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliR l a r)"
apply2 (induct l a r rule: baliR.induct) by auto

lemma invc_upd: assumes "invc t"
  shows "color t = Black \<Longrightarrow> invc (upd x y t)" "invc2 (upd x y t)"
using assms
apply2 (induct x y t rule: upd.induct)
  by(auto simp: invc_baliL invc_baliR invc2I mkNode_def)

lemma invh_upd: assumes "invh t"
  shows "invh (upd x y t)" "bheight (upd x y t) = bheight t"
using assms
apply2(induct x y t rule: upd.induct)
  by(auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

lemma invpst_paint[simp]: "invpst (paint c t) = invpst t"
by (cases "(c,t)" rule: paint.cases) auto

lemma invpst_baliR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliR l a r)"
by (cases "(l,a,r)" rule: baliR.cases) auto

lemma invpst_baliL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliL l a r)"
by (cases "(l,a,r)" rule: baliL.cases) auto

lemma invpst_upd: "invpst t \<Longrightarrow> invpst (upd x y t)"
apply2 (induct x y t rule: upd.induct) by(auto simp: invpst_baliR invpst_baliL)

theorem rbt_update: "rbt t \<Longrightarrow> rbt (update x y t)"
by (simp add: invc_upd(2) invh_upd(1) color_paint_Black invc_paint_Black
  invh_paint rbt_def update_def invpst_upd)

subsubsection \<open>Delete\<close>

lemma bheight_paint_Red:
  "color t = Black \<Longrightarrow> bheight (paint Red t) = bheight t - 1"
by (cases t) auto

lemma invh_baldL_invc:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight l + 1"
apply2 (induct l a r rule: baldL.induct)
   by(auto simp: invh_baliR invh_paint bheight_baliR bheight_paint_Red)

lemma invh_baldL_Black:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  color r = Black \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
apply2 (induct l a r rule: baldL.induct) by(auto simp add: invh_baliR bheight_baliR)

lemma invc_baldL: "\<lbrakk>invc2 l; invc r; color r = Black\<rbrakk> \<Longrightarrow> invc (baldL l a r)"
apply2 (induct l a r rule: baldL.induct) by(auto simp: invc_baliR invc2I mkNode_def)

lemma invc2_baldL: "\<lbrakk> invc2 l; invc r \<rbrakk> \<Longrightarrow> invc2 (baldL l a r)"
apply2 (induct l a r rule: baldL.induct)
  by(auto simp: invc_baliR paint_invc2 invc2I mkNode_def)

lemma invh_baldR_invc:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1;  invc l \<rbrakk>
  \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l"
apply2(induct l a r rule: baldR.induct)
  by(auto simp: invh_baliL bheight_baliL invh_paint bheight_paint_Red)

lemma invc_baldR: "\<lbrakk>invc a; invc2 b; color a = Black\<rbrakk> \<Longrightarrow> invc (baldR a x b)"
apply2 (induct a x b rule: baldR.induct) by(simp_all add: invc_baliL mkNode_def)

lemma invc2_baldR: "\<lbrakk> invc l; invc2 r \<rbrakk> \<Longrightarrow>invc2 (baldR l x r)"
apply2 (induct l x r rule: baldR.induct)
  by(auto simp: invc_baliL paint_invc2 invc2I mkNode_def)

lemma invh_combine:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk>
  \<Longrightarrow> invh (combine l r) \<and> bheight (combine l r) = bheight l"
apply2 (induct l r rule: combine.induct)
  by(auto simp: invh_baldL_Black split: tree.splits tcolor.splits)

lemma invc_combine:
  assumes "invc l" "invc r"
  shows "color l = Black \<Longrightarrow> color r = Black \<Longrightarrow> invc (combine l r)"
         "invc2 (combine l r)"
using assms
apply2 (induct l r rule: combine.induct)
  by(auto simp: invc_baldL invc2I mkNode_def split: tree.splits tcolor.splits)

lemma neq_LeafD: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x c r. t = Node l (x,c) r"
by(cases t) auto

lemma del_invc_invh: "invh t \<Longrightarrow> invc t \<Longrightarrow> invh (del x t) \<and>
   (color t = Red \<and> bheight (del x t) = bheight t \<and> invc (del x t) \<or>
    color t = Black \<and> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
proof2 (induct x t rule: del.induct)
case (2 x _ y _ c)
  have "x = y \<or> x < y \<or> x > y" by auto
  thus ?case proof (elim disjE)
    assume "x = y"
    with 2 show ?thesis
    by (cases c) (simp_all add: invh_combine invc_combine)
  next
    assume "x < y"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldL_invc invc_baldL invc2_baldL mkNode_def
          dest: neq_LeafD)
  next
    assume "y < x"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldR_invc invc_baldR invc2_baldR mkNode_def
          dest: neq_LeafD)
  qed
qed auto

lemma invpst_baldR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldR l a r)"
by (cases "(l,a,r)" rule: baldR.cases) (auto simp: invpst_baliL)

lemma invpst_baldL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldL l a r)"
by (cases "(l,a,r)" rule: baldL.cases) (auto simp: invpst_baliR)

lemma invpst_combine: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (combine l r)"
apply2(induction l r rule: combine.induct)
  by(auto split: tree.splits tcolor.splits simp: invpst_baldR invpst_baldL)

lemma invpst_del: "invpst t \<Longrightarrow> invpst (del x t)"
apply2(induct x t rule: del.induct)
  by(auto simp: invpst_baldR invpst_baldL invpst_combine)

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete k t)"
apply (clarsimp simp: delete_def rbt_def)
apply (frule (1) del_invc_invh[where x=k])
apply (auto simp: invc_paint_Black invh_paint color_paint_Black invpst_del)
done

lemma rbt_getmin_ismin:
  "rbt t \<Longrightarrow> t\<noteq>Leaf \<Longrightarrow> is_min2 (pst_getmin t) (set_tree t)"
unfolding rbt_def by (simp add: pst_getmin_ismin)

definition "rbt_is_empty t \<equiv> t = Leaf"

lemma rbt_is_empty: "rbt_is_empty t \<longleftrightarrow> inorder t = []"
by (cases t) (auto simp: rbt_is_empty_def)

definition empty where "empty = Leaf"

subsection \<open>Overall Correctness\<close>

interpretation PM: PrioMap_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "rbt" and is_empty = rbt_is_empty
and getmin = pst_getmin
apply standard
apply (auto simp: lookup_map_of inorder_update inorder_delete rbt_update
                  rbt_delete rbt_Leaf rbt_is_empty empty_def
            dest: rbt_getmin_ismin)
done

end


(*  Title:      Jinja/Common/Type.thy

    Author:     David von Oheimb, Tobias Nipkow
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Jinja types\<close>

theory Type imports Auxiliary begin

type_synonym cname = string \<comment> \<open>class names\<close>
type_synonym mname = string \<comment> \<open>method name\<close>
type_synonym vname = string \<comment> \<open>names for local/field variables\<close>

definition Object :: cname
where
  "Object \<equiv> ''Object''"

definition this :: vname
where
  "this \<equiv> ''this''"

\<comment> \<open>types\<close>
datatype ty
  = Void          \<comment> \<open>type of statements\<close>
  | Boolean
  | Integer
  | NT            \<comment> \<open>null type\<close>
  | Class cname   \<comment> \<open>class type\<close>

definition is_refT :: "ty \<Rightarrow> bool"
where
  "is_refT T  \<equiv>  T = NT \<or> (\<exists>C. T = Class C)"

lemma [iff]: "is_refT(Class C)"
(*<*)by(simp add:is_refT_def)(*>*)

lemma refTE:
  "\<lbrakk>is_refT T; T = NT \<Longrightarrow> P; \<And>C. T = Class C \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
(*<*)by (auto simp add: is_refT_def)(*>*)

lemma not_refTE:
  "\<lbrakk> \<not>is_refT T; T = Void \<or> T = Boolean \<or> T = Integer \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
(*<*)by (cases T, auto simp add: is_refT_def)(*>*)

end


(*  Title:      HOL/Auth/n_germanish.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanish Protocol Case Study*}

theory n_germanish imports n_germanish_lemma_invs_on_rules n_germanish_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


(*
  Theory: PDF_Transformations.thy
  Author: Manuel Eberl

  Provides lemmas for transformations of measure spaces with a density.
*)

section \<open>Measure Space Transformations\<close>

theory PDF_Transformations
imports Density_Predicates
begin

lemma not_top_le_1_ennreal[simp]: "\<not> top \<le> (1::ennreal)"
  by (simp add: top_unique)

lemma range_int: "range int = {n. n \<ge> 0}"
proof (intro equalityI subsetI)
  fix n :: int assume "n \<in> {n. n \<ge> 0}"
  hence "n = int (nat n)" by simp
  thus "n \<in> range int" by blast
qed auto

lemma range_exp: "range (exp :: real \<Rightarrow> real) = {x. x > 0}"
proof (intro equalityI subsetI)
  fix x :: real assume "x \<in> {x. x > 0}"
  hence "x = exp (ln x)" by simp
  thus "x \<in> range exp" by blast
qed auto

lemma Int_stable_Icc: "Int_stable (range (\<lambda>(a, b). {a .. b::real}))"
  by (auto simp: Int_stable_def)

lemma distr_mult_real:
  assumes "c \<noteq> 0" "has_density M lborel (f :: real \<Rightarrow> ennreal)"
  shows "has_density (distr M borel ((*) c)) lborel (\<lambda>x. f (x / c) * inverse (abs c))"
            (is "has_density ?M' _ ?f'")
proof
  from assms(2) have "M = density lborel f" by (rule has_densityD)
  also from assms have Mf[measurable]: "f \<in> borel_measurable borel"
    by (auto dest: has_densityD)
  hence "distr (density lborel f) borel ((*) c) = density lborel ?f'" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X[measurable]: "X \<in> sets (distr (density lborel f) borel ((*) c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c * x) \<partial>lborel"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from assms(1) and X have "... = \<integral>\<^sup>+x. ?f' x * indicator X x \<partial>lborel"
      apply (subst lborel_distr_mult'[of "inverse c"])
      apply simp
      apply (subst nn_integral_density)
      apply (simp_all add: nn_integral_distr field_simps)
      done
    also from X have "... = emeasure ?M2 X"
      by (subst emeasure_density) auto
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M borel ((*) c) = density lborel ?f'" .
qed (insert assms, auto dest: has_densityD)

lemma distr_uminus_real:
  assumes "has_density M lborel (f :: real \<Rightarrow> ennreal)"
  shows "has_density (distr M borel uminus) lborel (\<lambda>x. f (- x))"
proof-
  from assms have "has_density (distr M borel ((*) (- 1))) lborel
                       (\<lambda>x. f (x / -1) * ennreal (inverse (abs (-1))))"
    by (intro distr_mult_real) simp_all
  also have "(*) (-1) = (uminus :: real \<Rightarrow> real)" by (intro ext) simp
  also have "(\<lambda>x. f (x / -1) * ennreal (inverse (abs (-1)))) = (\<lambda>x. f (-x))"
    by (intro ext) (simp add: one_ennreal_def[symmetric])
  finally show ?thesis .
qed

lemma distr_plus_real:
  assumes "has_density M lborel (f :: real \<Rightarrow> ennreal)"
  shows "has_density (distr M borel ((+) c)) lborel (\<lambda>x. f (x - c))"
proof
  from assms have "M = density lborel f" by (rule has_densityD)
  also from assms have Mf[measurable]: "f \<in> borel_measurable borel"
    by (auto dest: has_densityD)
  hence "distr (density lborel f) borel ((+) c) = density lborel (\<lambda>x. f (x - c))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density lborel f) borel ((+) c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c + x) \<partial>lborel"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = \<integral>\<^sup>+x. f (x - c) * indicator X x \<partial>lborel"
      by (subst lborel_distr_plus[where c = "-c", symmetric], subst nn_integral_distr) auto
    also from X have "... = emeasure ?M2 X"
      by (subst emeasure_density)
         (auto simp: emeasure_density intro!: measurable_compose[OF borel_measurable_diff Mf])
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M borel ((+) c) = density lborel (\<lambda>x. f (x - c))" .
qed (insert assms, auto dest: has_densityD)

lemma count_space_uminus:
  "count_space UNIV = distr (count_space UNIV) (count_space UNIV) (uminus :: ('a :: ring \<Rightarrow> _))"
proof (rule distr_bij_count_space[symmetric])
  show "bij (uminus :: 'a \<Rightarrow> 'a)"
    by (auto intro!: o_bij[where g=uminus])
qed

lemma count_space_plus:
  "count_space UNIV = distr (count_space UNIV) (count_space UNIV) ((+) (c :: ('a :: ring)))"
  by (rule distr_bij_count_space [symmetric]) simp

lemma distr_uminus_ring_count_space:
  assumes "has_density M (count_space UNIV) (f :: _ :: ring \<Rightarrow> ennreal)"
  shows "has_density (distr M (count_space UNIV) uminus) (count_space UNIV) (\<lambda>x. f (- x))"
proof
  from assms have "M = density (count_space UNIV) f" by (rule has_densityD)
  also have "distr (density (count_space UNIV) f) (count_space UNIV) uminus =
               density (count_space UNIV)(\<lambda>x. f (- x))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density (count_space UNIV) f) (count_space UNIV) uminus)"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (-x) \<partial>count_space UNIV"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = emeasure ?M2 X"
      by (subst count_space_uminus) (simp_all add: nn_integral_distr emeasure_density)
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M (count_space UNIV) uminus = density (count_space UNIV) (\<lambda>x. f (- x))" .
qed (insert assms, auto dest: has_densityD)

lemma distr_plus_ring_count_space:
  assumes "has_density M (count_space UNIV) (f :: _ :: ring \<Rightarrow> ennreal)"
  shows "has_density (distr M (count_space UNIV) ((+) c)) (count_space UNIV) (\<lambda>x. f (x - c))"
proof
  from assms have "M = density (count_space UNIV) f" by (rule has_densityD)
  also have "distr (density (count_space UNIV) f) (count_space UNIV) ((+) c) =
               density (count_space UNIV)(\<lambda>x. f (x - c))" (is "?M1 = ?M2")
  proof (intro measure_eqI)
    fix X assume X: "X \<in> sets (distr (density (count_space UNIV) f) (count_space UNIV) ((+) c))"
    with assms have "emeasure ?M1 X = \<integral>\<^sup>+x. f x * indicator X (c + x) \<partial>count_space UNIV"
      by (subst emeasure_distr, simp, simp, subst emeasure_density)
         (auto dest: has_densityD intro!: measurable_sets_borel nn_integral_cong
               split: split_indicator)
    also from X have "... = emeasure ?M2 X"
      by (subst count_space_plus[of "-c"]) (simp_all add: nn_integral_distr emeasure_density)
    finally show "emeasure ?M1 X = emeasure ?M2 X" .
  qed simp
  finally show "distr M (count_space UNIV) ((+) c) = density (count_space UNIV) (\<lambda>x. f (x - c))" .
qed (insert assms, auto dest: has_densityD)

lemma subprob_density_distr_real_eq:
  assumes dens: "has_subprob_density M lborel f"
  assumes Mh: "h \<in> borel_measurable borel"
  assumes Mg: "g \<in> borel_measurable borel"
  assumes measure_eq:
    "\<And>a b. a \<le> b \<Longrightarrow> emeasure (distr (density lborel f) lborel h) {a..b} =
                          emeasure (density lborel g) {a..b}"
  shows "has_subprob_density (distr M borel (h :: real \<Rightarrow> real)) lborel g"
proof (rule has_subprob_densityI)
  from dens have sets_M: "sets M = sets borel" by (auto dest: has_subprob_densityD)
  have meas_M[simp]: "measurable M = measurable borel"
    by (intro ext, subst measurable_cong_sets[OF sets_M refl]) auto
  from Mh and dens show subprob_space: "subprob_space (distr M borel h)"
    by (intro subprob_space.subprob_space_distr) (auto dest: has_subprob_densityD)
  show "distr M borel h = density lborel g"
  proof (rule measure_eqI_generator_eq[OF Int_stable_Icc, of UNIV])
    {
      fix x :: real
      obtain n :: nat where "n > abs x" using reals_Archimedean2 by auto
      hence "\<exists>n::nat. x \<in> {-real n..real n}" by (intro exI[of _ n]) auto
    }
    thus "(\<Union>i::nat. {-real i..real i}) = UNIV" by blast
  next
    fix i :: nat
    from subprob_space have "emeasure (distr M borel h) {-real i..real i} \<le> 1"
      by (intro subprob_space.subprob_emeasure_le_1) (auto dest: has_subprob_densityD)
    thus "emeasure (distr M borel h) {- real i..real i} \<noteq> \<infinity>" by auto
  next
    fix X :: "real set" assume "X \<in> range (\<lambda>(a,b). {a..b})"
    then obtain a b where "X = {a..b}" by auto
    with dens have "emeasure (distr M lborel h) X = emeasure (density lborel g) X"
      by (cases "a \<le> b") (auto simp: measure_eq dest: has_subprob_densityD)
    also have "distr M lborel h = distr M borel h"
      by (rule distr_cong) auto
    finally show "emeasure (distr M borel h) X = emeasure (density lborel g) X" .
  qed (auto simp: borel_eq_atLeastAtMost)
qed (insert assms, auto)

lemma subprob_density_distr_real_exp:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M borel exp) lborel
           (\<lambda>x. if x > 0 then f (ln x) * ennreal (inverse x) else 0)"
           (is "has_subprob_density _ _ ?g")
proof (rule subprob_density_distr_real_eq[OF dens])
  from dens have [measurable]: "f \<in> borel_measurable borel"
    by (auto dest: has_subprob_densityD)

  have Mf: "(\<lambda>x. f (ln x) * ennreal (inverse x)) \<in> borel_measurable borel" by simp

  fix a b :: real assume "a \<le> b"

  let ?A = "\<lambda>i. {inverse (Suc i) :: real ..}"
  let ?M1 = "distr (density lborel f) lborel exp" and ?M2 = "density lborel ?g"
  {
    fix x :: real assume "\<forall>i. x < inverse (Suc i)"
    hence "x \<le> 0" by (intro tendsto_lowerbound[OF LIMSEQ_inverse_real_of_nat])
                     (auto intro!: always_eventually less_imp_le)
  }
  hence decomp: "{a..b} = {x\<in>{a..b}. x \<le> 0} \<union> (\<Union>i. ?A i \<inter> {a..b})" (is "_ = ?C \<union> ?D")
    by (auto simp: not_le)
  have inv_le: "\<And>x i. x \<ge> inverse (real (Suc i)) \<Longrightarrow> \<not>(x \<le> 0)"
    by (subst not_le, erule dual_order.strict_trans1, simp)
  hence "emeasure ?M1 {a..b} = emeasure ?M1 ?C + emeasure ?M1 ?D"
    by (subst decomp, intro plus_emeasure[symmetric]) auto
  also have "emeasure ?M1 ?C = 0" by (subst emeasure_distr) auto
  also have "0 = emeasure ?M2 ?C"
    by (subst emeasure_density, simp, simp, rule sym, subst nn_integral_0_iff) auto
  also have "emeasure ?M1 (\<Union>i. ?A i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A i \<inter> {a..b}) = emeasure ?M2 (?A i \<inter> {a..b})"
  proof (case_tac "inverse (Suc i) \<le> b")
    fix i assume True: "inverse (Suc i) \<le> b"
    let ?a = "inverse (Suc i)"
    from \<open>a \<le> b\<close> have A: "?A i \<inter> {a..b} = {max ?a a..b}" (is "?E = ?F") by auto
    hence "emeasure ?M1 ?E = emeasure ?M1 ?F" by simp
    also have "strict_mono_on ln {max (inverse (real (Suc i))) a..b}"
      by (rule strict_mono_onI, subst ln_less_cancel_iff)
         (auto dest: inv_le simp del: of_nat_Suc)
    with \<open>a \<le> b\<close> True dens
      have "emeasure ?M1 ?F = emeasure (density lborel (\<lambda>x. f (ln x) * inverse x)) ?F"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less not_le range_exp dest: has_subprob_densityD dest!: inv_le
               intro!: DERIV_ln continuous_on_inverse continuous_on_id simp del: of_nat_Suc)
    also note A[symmetric]
    also have "emeasure (density lborel (\<lambda>x. f (ln x) * inverse x)) ?E = emeasure ?M2 ?E"
      by (subst (1 2) emeasure_density)
         (auto intro!: nn_integral_cong split: split_indicator dest!: inv_le simp del: of_nat_Suc)
    finally show "emeasure ?M1 (?A i \<inter> {a..b}) = emeasure ?M2 (?A i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M2 ?C + emeasure ?M2 ?D = emeasure ?M2 (?C \<union> ?D)"
    by (rule plus_emeasure) (auto dest: inv_le simp del: of_nat_Suc)
  also note decomp[symmetric]
  finally show "emeasure ?M1 {a..b} = emeasure ?M2 {a..b}" .
qed (insert dens, auto dest!: has_subprob_densityD(1))

lemma subprob_density_distr_real_inverse_aux:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M borel (\<lambda>x. - inverse x)) lborel
              (\<lambda>x. f (-inverse x) * ennreal (inverse (x * x)))"
           (is "has_subprob_density _ _ ?g")
proof (rule subprob_density_distr_real_eq[OF dens])
  from dens have Mf[measurable]: "f \<in> borel_measurable borel" by (auto dest: has_subprob_densityD)
  show Mg: "?g \<in> borel_measurable borel" by measurable

  have surj[simp]: "surj (\<lambda>x. - inverse x :: real)"
    by (intro surjI[of _ "\<lambda>x. - inverse x"]) (simp add: field_simps)
  fix a b :: real assume "a \<le> b"
  let ?A1 = "\<lambda>i. {..-inverse (Suc i) :: real}" and  ?A2 = "\<lambda>i. {inverse (Suc i) :: real ..}"
  let ?C = "if 0 \<in> {a..b} then {0} else {}"
  let ?M1 = "distr (density lborel f) lborel (\<lambda>x. - inverse x)" and ?M2 = "density lborel ?g"
  have inv_le: "\<And>x i. x \<ge> inverse (real (Suc i)) \<Longrightarrow> \<not>(x \<le> 0)"
    by (subst not_le, erule dual_order.strict_trans1, simp)
  have "\<And>x. x > 0 \<Longrightarrow> \<exists>i. x \<ge> inverse (Suc i)"
  proof (rule ccontr)
    fix x :: real assume "x > 0" "\<not>(\<exists>i. x \<ge> inverse (Suc i))"
    hence "x \<le> 0" by (intro tendsto_lowerbound[OF LIMSEQ_inverse_real_of_nat])
                      (auto intro!: always_eventually less_imp_le simp: not_le)
    with \<open>x > 0\<close> show False by simp
  qed
  hence A: "(\<Union>i. ?A2 i) = {0<..}" by (auto dest: inv_le simp del: of_nat_Suc)
  moreover have "\<And>x. x < 0 \<Longrightarrow> \<exists>i. x \<le> -inverse (Suc i)"
  proof (rule ccontr)
    fix x :: real assume "x < 0" "\<not>(\<exists>i. x \<le> -inverse (Suc i))"
    hence "x \<ge> 0"
      by (intro tendsto_upperbound, simp)
         (auto intro!: always_eventually less_imp_le LIMSEQ_inverse_real_of_nat_add_minus simp: not_le)
    with \<open>x < 0\<close> show False by simp
  qed
  hence B: "(\<Union>i. ?A1 i) = {..<0}"
    by (auto simp: le_minus_iff[of _ "inverse x" for x] dest!: inv_le simp del: of_nat_Suc)
  ultimately have C: "UNIV = (\<Union>i. ?A1 i) \<union> (\<Union>i. ?A2 i) \<union> {0}" by (subst A, subst B) force
  have UN_Int_distrib: "\<And>f A. (\<Union>i. f i) \<inter> A = (\<Union>i. f i \<inter> A)" by blast
  have decomp: "{a..b} = (\<Union>i. ?A1 i \<inter> {a..b}) \<union> (\<Union>i. ?A2 i \<inter> {a..b}) \<union> ?C" (is "_ = ?D \<union> ?E \<union> _")
    by (subst Int_UNIV_left[symmetric], simp only: C Int_Un_distrib2 UN_Int_distrib)
       (simp split: if_split)
  have "emeasure ?M1 {a..b} = emeasure ?M1 ?D + emeasure ?M1 ?E + emeasure ?M1 ?C"
    apply (subst decomp)
    apply (subst plus_emeasure[symmetric], simp, simp, simp)
    apply (subst plus_emeasure[symmetric])
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x] simp del: of_nat_Suc)
    done
  also have "(\<lambda>x. - inverse x) -` {0 :: real} = {0}" by (auto simp: field_simps)
  hence "emeasure ?M1 ?C = 0"
    by (subst emeasure_distr)  (auto split: if_split simp: emeasure_density Mf)
  also have "emeasure ?M2 {0} = 0" by (simp add: emeasure_density)
  hence "0 = emeasure ?M2 ?C"
    by (rule_tac sym, rule_tac order.antisym, rule_tac order.trans, rule_tac emeasure_mono[of _ "{0}"]) simp_all
  also have "emeasure ?M1 (\<Union>i. ?A1 i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A1 i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A1 i \<inter> {a..b}) = emeasure ?M2 (?A1 i \<inter> {a..b})"
  proof (case_tac "-inverse (Suc i) \<ge> a")
    fix i assume True: "-inverse (Suc i) \<ge> a"
    let ?a = "-inverse (Suc i)"
    from \<open>a \<le> b\<close> have A: "?A1 i \<inter> {a..b} = {a..min ?a b}" (is "?F = ?G") by auto
    hence "emeasure ?M1 ?F = emeasure ?M1 ?G" by simp
    also have "strict_mono_on (\<lambda>x. -inverse x) {a..min ?a b}"
      by (rule strict_mono_onI)
         (auto simp: le_minus_iff[of _ "inverse x" for x] dest!: inv_le simp del: of_nat_Suc)
    with \<open>a \<le> b\<close> True dens
      have "emeasure ?M1 ?G = emeasure ?M2 ?G"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less dest: has_subprob_densityD inv_le
               intro!: derivative_eq_intros continuous_on_mult continuous_on_inverse continuous_on_id)
    also note A[symmetric]
    finally show "emeasure ?M1 (?A1 i \<inter> {a..b}) = emeasure ?M2 (?A1 i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A1 i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A1 i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A1 i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M1 (\<Union>i. ?A2 i \<inter> {a..b}) = (SUP i. emeasure ?M1 (?A2 i \<inter> {a..b}))"
    by (rule SUP_emeasure_incseq[symmetric])
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "\<And>i. emeasure ?M1 (?A2 i \<inter> {a..b}) = emeasure ?M2 (?A2 i \<inter> {a..b})"
  proof (case_tac "inverse (Suc i) \<le> b")
    fix i assume True: "inverse (Suc i) \<le> b"
    let ?a = "inverse (Suc i)"
    from \<open>a \<le> b\<close> have A: "?A2 i \<inter> {a..b} = {max ?a a..b}" (is "?F = ?G") by auto
    hence "emeasure ?M1 ?F = emeasure ?M1 ?G" by simp
    also have "strict_mono_on (\<lambda>x. -inverse x) {max ?a a..b}"
      by (rule strict_mono_onI) (auto dest!: inv_le simp: not_le simp del: of_nat_Suc)
    with \<open>a \<le> b\<close> True dens
      have "emeasure ?M1 ?G = emeasure ?M2 ?G"
      by (intro emeasure_density_distr_interval)
         (auto simp: Mf not_less dest: has_subprob_densityD inv_le
               intro!: derivative_eq_intros continuous_on_mult continuous_on_inverse continuous_on_id)
    also note A[symmetric]
    finally show "emeasure ?M1 (?A2 i \<inter> {a..b}) = emeasure ?M2 (?A2 i \<inter> {a..b})" .
  qed simp
  hence "(SUP i. emeasure ?M1 (?A2 i \<inter> {a..b})) = (SUP i. emeasure ?M2 (?A2 i \<inter> {a..b}))" by simp
  also have "... = emeasure ?M2 (\<Union>i. ?A2 i \<inter> {a..b})"
    by (rule SUP_emeasure_incseq)
       (auto simp: incseq_def max_def not_le dest: order.strict_trans1)
  also have "emeasure ?M2 ?D + emeasure ?M2 ?E + emeasure ?M2 ?C = emeasure ?M2 {a..b}"
    apply (subst (4) decomp)
    apply (subst plus_emeasure, simp, simp)
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x] simp del: of_nat_Suc)
    apply (subst plus_emeasure)
    apply (auto dest!: inv_le simp: not_le le_minus_iff[of _ "inverse x" for x])
    done
  finally show "emeasure ?M1 {a..b} = emeasure ?M2 {a..b}" .
qed simp

lemma subprob_density_distr_real_inverse:
  assumes dens: "has_subprob_density M lborel f"
  shows "has_subprob_density (distr M borel inverse) lborel (\<lambda>x. f (inverse x) * ennreal (inverse (x * x)))"
proof (unfold has_subprob_density_def, intro conjI)
  let ?g' = "(\<lambda>x. f (-inverse x) * ennreal (inverse (x * x)))"
  have prob: "has_subprob_density (distr M borel (\<lambda>x. -inverse x)) lborel ?g'"
    by (rule subprob_density_distr_real_inverse_aux[OF assms])
  from assms have sets_M: "sets M = sets borel" by (auto dest: has_subprob_densityD)
  have [simp]: "measurable M = measurable borel"
    by (intro ext, subst measurable_cong_sets[OF sets_M refl]) auto
  from prob have dens: "has_density (distr M lborel (\<lambda>x. -inverse x)) lborel
                 (\<lambda>x. f (-inverse x) * ennreal (inverse (x * x)))"
    unfolding has_subprob_density_def by (simp cong: distr_cong)
  from distr_uminus_real[OF this]
    show "has_density (distr M borel inverse) lborel
              (\<lambda>x. f (inverse x) * ennreal (inverse (x * x)))"
    by (simp add: distr_distr o_def cong: distr_cong)
  show "subprob_space (distr M borel inverse)"
    by (intro subprob_space.subprob_space_distr has_subprob_densityD[OF assms]) simp_all
qed

  from assms have sets_M: "sets M = sets borel" by (auto dest: has_densityD)
  hence [simp]: "space M = UNIV" by (subst sets_eq_imp_space_eq[OF sets_M]) simp
  from sets_M have [simp]: "measurable M = measurable borel"
    by (intro ext measurable_cong_sets) simp_all
  have M_add: "case_prod (+) \<in> borel_measurable (borel :: (real \<times> real) measure)"
    by (simp add: borel_prod[symmetric])

  show "distr M borel (case_prod (+)) = density lborel ?f'"
  proof (rule measure_eqI)
    fix X :: "real set" assume X[measurable]: "X \<in> sets (distr M borel (case_prod (+)))"
    hence "emeasure (distr M borel (case_prod (+))) X = emeasure M ((\<lambda>(x, y). x + y) -` X)"
      by (simp_all add: M_add emeasure_distr)
    also from X have "... = \<integral>\<^sup>+z. f z * indicator ((\<lambda>(x, y). x + y) -` X) z \<partial>(lborel \<Otimes>\<^sub>M lborel)"
      by (simp add: emeasure_density has_densityD[OF assms]
                     measurable_sets_borel[OF M_add] lborel_prod)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y) \<partial>lborel \<partial>lborel"
      apply (rule lborel.nn_integral_fst[symmetric])
      apply measurable
      apply (simp_all add: borel_prod)
      done
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y)
                          \<partial>distr lborel borel ((+) (-x)) \<partial>lborel"
      by (rule nn_integral_cong, subst lborel_distr_plus) simp
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator ((\<lambda>(x, y). x + y) -` X) (x, z-x)
                          \<partial>lborel \<partial>lborel"
      apply (rule nn_integral_cong)
      apply (subst nn_integral_distr)
      apply simp_all
      apply measurable
      apply (subst space_count_space)
      apply auto
      done
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator X z \<partial>lborel \<partial>lborel"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also have "... = \<integral>\<^sup>+z. \<integral>\<^sup>+x. f (x, z-x) * indicator X z \<partial>lborel \<partial>lborel" using X
      by (subst lborel_pair.Fubini')
         (simp_all add: pair_sigma_finite_def)
    also have "... = \<integral>\<^sup>+z. (\<integral>\<^sup>+x. f (x, z-x) \<partial>lborel) * indicator X z \<partial>lborel"
      by (rule nn_integral_cong) (simp split: split_indicator)
    also have "... = emeasure (density lborel ?f') X" using X
      by (simp add: emeasure_density)
    finally show "emeasure (distr M borel (case_prod (+))) X = emeasure (density lborel ?f') X" .
  qed (insert assms, auto dest: has_densityD)
qed simp_all

lemma distr_convolution_ring_count_space:
  assumes C: "countable (UNIV :: 'a set)"
  assumes "has_density M (count_space UNIV) (f :: (('a :: ring) \<times> 'a) \<Rightarrow> ennreal)"
  shows "has_density (distr M (count_space UNIV) (case_prod (+))) (count_space UNIV)
             (\<lambda>z. \<integral>\<^sup>+x. f (x, z - x) \<partial>count_space UNIV)"
            (is "has_density ?M' _ ?f'")
proof
  let ?CS = "count_space UNIV :: 'a measure" and ?CSP = "count_space UNIV :: ('a \<times> 'a) measure"
  show Mf': "(\<lambda>z. \<integral>\<^sup>+ x. f (x, z - x) \<partial>count_space UNIV) \<in> borel_measurable ?CS" by simp

  from assms have sets_M: "sets M = UNIV" and [simp]: "space M = UNIV"
    by (auto dest: has_densityD)
  from assms have [simp]: "measurable M = measurable (count_space UNIV)"
    by (intro ext measurable_cong_sets) (simp_all add: sets_M)

  interpret sigma_finite_measure ?CS by (rule sigma_finite_measure_count_space_countable[OF C])
  show "distr M ?CS (case_prod (+)) = density ?CS ?f'"
  proof (rule measure_eqI)
    fix X :: "'a set" assume X: "X \<in> sets (distr M ?CS (case_prod (+)))"
    hence "emeasure (distr M ?CS (case_prod (+))) X = emeasure M ((\<lambda>(x, y). x + y) -` X)"
      by (simp_all add: emeasure_distr)
    also from X have "... = \<integral>\<^sup>+z. f z * indicator ((\<lambda>(x, y). x + y) -` X) z \<partial>(?CS \<Otimes>\<^sub>M ?CS)"
      by (simp add: emeasure_density has_densityD[OF assms(2)]
                     sets_M pair_measure_countable C)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y) \<partial>?CS \<partial>?CS"
      by (rule nn_integral_fst[symmetric]) (simp add: pair_measure_countable C)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x, y) * indicator ((\<lambda>(x, y). x + y) -` X) (x,y)
                          \<partial>distr ?CS ?CS ((+) (-x)) \<partial>?CS"
      by (rule nn_integral_cong, subst count_space_plus) simp
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator ((\<lambda>(x, y). x + y) -` X) (x, z-x) \<partial>?CS \<partial>?CS"
      by (rule nn_integral_cong) (simp_all add: nn_integral_distr)
    also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+z. f (x, z-x) * indicator X z \<partial>?CS \<partial>?CS"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also have "... = \<integral>\<^sup>+z. \<integral>\<^sup>+x. f (x, z-x) * indicator X z \<partial>?CS \<partial>?CS" using X
      by (subst pair_sigma_finite.Fubini')
         (simp_all add: pair_sigma_finite_def sigma_finite_measure_count_space_countable
                        C pair_measure_countable)
    also have "... = \<integral>\<^sup>+z. (\<integral>\<^sup>+x. f (x, z-x) \<partial>?CS) * indicator X z \<partial>?CS"
      by (rule nn_integral_cong) (simp split: split_indicator)
    also have "... = emeasure (density ?CS ?f') X" using X by (simp add: emeasure_density)
    finally show "emeasure (distr M ?CS (case_prod (+))) X = emeasure (density ?CS ?f') X" .
  qed (insert assms, auto dest: has_densityD)
qed simp_all

end