section \<open>Operational Semantics\<close>

theory OG_Tran imports OG_Com begin

type_synonym 'a ann_com_op = "('a ann_com) option"
type_synonym 'a ann_triple_op = "('a ann_com_op \<times> 'a assn)"

primrec com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op" where
  "com (c, q) = c"

primrec post :: "'a ann_triple_op \<Rightarrow> 'a assn" where
  "post (c, q) = q"

definition All_None :: "'a ann_triple_op list \<Rightarrow> bool" where
  "All_None Ts \<equiv> \<forall>(c, q) \<in> set Ts. c = None"

subsection \<open>The Transition Relation\<close>

inductive_set
  ann_transition :: "(('a ann_com_op \<times> 'a) \<times> ('a ann_com_op \<times> 'a)) set"
  and transition :: "(('a com \<times> 'a) \<times> ('a com \<times> 'a)) set"
  and ann_transition' :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
    ("_ -1\<rightarrow> _"[81,81] 100)
  and transition' :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
    ("_ -P1\<rightarrow> _"[81,81] 100)
  and transitions :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
    ("_ -P*\<rightarrow> _"[81,81] 100)
where
  "con_0 -1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition"
| "con_0 -P1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition"
| "con_0 -P*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition\<^sup>*"

| AnnBasic:  "s' \<in> f s \<Longrightarrow> (Some (AnnBasic r f), s) -1\<rightarrow> (None, s')"

| AnnSeq1: "(Some c0, s) -1\<rightarrow> (None, t) \<Longrightarrow>
               (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some c1, t)"
| AnnSeq2: "(Some c0, s) -1\<rightarrow> (Some c2, t) \<Longrightarrow>
               (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some (AnnSeq c2 c1), t)"

| AnnCond1T: "s \<in> b  \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c1, s)"
| AnnCond1F: "s \<notin> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c2, s)"

| AnnCond2T: "s \<in> b  \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (Some c, s)"
| AnnCond2F: "s \<notin> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (None, s)"

| AnnWhileF: "s \<notin> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow> (None, s)"
| AnnWhileT: "s \<in> b  \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow>
                         (Some (AnnSeq c (AnnWhile i b i c)), s)"

| AnnAwait: "\<lbrakk> s \<in> b; atom_com c; (c, s) -P*\<rightarrow> (Parallel [], t) \<rbrakk> \<Longrightarrow>
                   (Some (AnnAwait r b c), s) -1\<rightarrow> (None, t)"

| Parallel: "\<lbrakk> i<length Ts; Ts!i = (Some c, q); (Some c, s) -1\<rightarrow> (r, t) \<rbrakk>
              \<Longrightarrow> (Parallel Ts, s) -P1\<rightarrow> (Parallel (Ts [i:=(r, q)]), t)"

| Basic:  "s' \<in> f s \<Longrightarrow> (Basic f, s) -P1\<rightarrow> (Parallel [], s')"

| Seq1:   "All_None Ts \<Longrightarrow> (Seq (Parallel Ts) c, s) -P1\<rightarrow> (c, s)"
| Seq2:   "(c0, s) -P1\<rightarrow> (c2, t) \<Longrightarrow> (Seq c0 c1, s) -P1\<rightarrow> (Seq c2 c1, t)"

| CondT: "s \<in> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c1, s)"
| CondF: "s \<notin> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c2, s)"

| WhileF: "s \<notin> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Parallel [], s)"
| WhileT: "s \<in> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Seq c (While b i c), s)"

monos "rtrancl_mono"

text \<open>The corresponding abbreviations are:\<close>

abbreviation
  ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
                           \<Rightarrow> bool"  ("_ -_\<rightarrow> _"[81,81] 100)  where
  "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"

abbreviation
  ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
                           ("_ -*\<rightarrow> _"[81,81] 100)  where
  "con_0 -*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition\<^sup>*"

abbreviation
  transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
                          ("_ -P_\<rightarrow> _"[81,81,81] 100)  where
  "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"

subsection \<open>Definition of Semantics\<close>

definition ann_sem :: "'a ann_com \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "ann_sem c \<equiv> \<lambda>s. {t. (Some c, s) -*\<rightarrow> (None, t)}"

definition ann_SEM :: "'a ann_com \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "ann_SEM c S \<equiv> \<Union>(ann_sem c ` S)"

definition sem :: "'a com \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "sem c \<equiv> \<lambda>s. {t. \<exists>Ts. (c, s) -P*\<rightarrow> (Parallel Ts, t) \<and> All_None Ts}"

definition SEM :: "'a com \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "SEM c S \<equiv> \<Union>(sem c ` S)"

abbreviation (input) ID :: "'a \<Rightarrow> 'a set" where
  "ID \<equiv> \<lambda>s. {s}"

abbreviation Omega :: "'a com"    ("\<Omega>" 63)
  where "\<Omega> \<equiv> While UNIV UNIV (Basic ID)"

primrec fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com" where
    "fwhile b c 0 = \<Omega>"
  | "fwhile b c (Suc n) = Cond b (Seq c (fwhile b c n)) (Basic ID)"

subsubsection \<open>Proofs\<close>

declare ann_transition_transition.intros [intro]
inductive_cases transition_cases:
    "(Parallel T,s) -P1\<rightarrow> t"
    "(Basic R, s) -P1\<rightarrow> t"
    "(Seq c1 c2, s) -P1\<rightarrow> t"
    "(Cond b c1 c2, s) -P1\<rightarrow> t"
    "(While b i c, s) -P1\<rightarrow> t"

lemma Parallel_empty_lemma [rule_format (no_asm)]:
  "(Parallel [],s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=[] \<and> n=0 \<and> s=t"
apply(induct n)
 apply(simp (no_asm))
apply clarify
apply(drule relpow_Suc_D2)
apply(force elim:transition_cases)
done

lemma Parallel_AllNone_lemma [rule_format (no_asm)]:
 "All_None Ss \<longrightarrow> (Parallel Ss,s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=Ss \<and> n=0 \<and> s=t"
apply(induct "n")
 apply(simp (no_asm))
apply clarify
apply(drule relpow_Suc_D2)
apply clarify
apply(erule transition_cases,simp_all)
apply(force dest:nth_mem simp add:All_None_def)
done

lemma Parallel_AllNone: "All_None Ts \<Longrightarrow> (SEM (Parallel Ts) X) = X"
apply (unfold SEM_def sem_def)
apply auto
apply(drule rtrancl_imp_UN_relpow)
apply clarify
apply(drule Parallel_AllNone_lemma)
apply auto
done

lemma Parallel_empty: "Ts=[] \<Longrightarrow> (SEM (Parallel Ts) X) = X"
apply(rule Parallel_AllNone)
apply(simp add:All_None_def)
done

text \<open>Set of lemmas from Apt and Olderog "Verification of sequential
and concurrent programs", page 63.\<close>

lemma L3_5i: "X\<subseteq>Y \<Longrightarrow> SEM c X \<subseteq> SEM c Y"
apply (unfold SEM_def)
apply force
done

lemma L3_5ii_lemma1:
 "\<lbrakk> (c1, s1) -P*\<rightarrow> (Parallel Ts, s2); All_None Ts;
  (c2, s2) -P*\<rightarrow> (Parallel Ss, s3); All_None Ss \<rbrakk>
 \<Longrightarrow> (Seq c1 c2, s1) -P*\<rightarrow> (Parallel Ss, s3)"
apply(erule converse_rtrancl_induct2)
apply(force intro:converse_rtrancl_into_rtrancl)+
done

lemma L3_5ii_lemma2 [rule_format (no_asm)]:
 "\<forall>c1 c2 s t. (Seq c1 c2, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow>
  (All_None Ts) \<longrightarrow> (\<exists>y m Rs. (c1,s) -P*\<rightarrow> (Parallel Rs, y) \<and>
  (All_None Rs) \<and> (c2, y) -Pm\<rightarrow> (Parallel Ts, t) \<and>  m \<le> n)"
apply(induct "n")
 apply(force)
apply(safe dest!: relpow_Suc_D2)
apply(erule transition_cases,simp_all)
 apply (fast intro!: le_SucI)
apply (fast intro!: le_SucI elim!: relpow_imp_rtrancl converse_rtrancl_into_rtrancl)
done

lemma L3_5ii_lemma3:
 "\<lbrakk>(Seq c1 c2,s) -P*\<rightarrow> (Parallel Ts,t); All_None Ts\<rbrakk> \<Longrightarrow>
    (\<exists>y Rs. (c1,s) -P*\<rightarrow> (Parallel Rs,y) \<and> All_None Rs
   \<and> (c2,y) -P*\<rightarrow> (Parallel Ts,t))"
apply(drule rtrancl_imp_UN_relpow)
apply(fast dest: L3_5ii_lemma2 relpow_imp_rtrancl)
done

lemma L3_5ii: "SEM (Seq c1 c2) X = SEM c2 (SEM c1 X)"
apply (unfold SEM_def sem_def)
apply auto
 apply(fast dest: L3_5ii_lemma3)
apply(fast elim: L3_5ii_lemma1)
done

lemma L3_5iii: "SEM (Seq (Seq c1 c2) c3) X = SEM (Seq c1 (Seq c2 c3)) X"
apply (simp (no_asm) add: L3_5ii)
done

lemma L3_5iv:
 "SEM (Cond b c1 c2) X = (SEM c1 (X \<inter> b)) Un (SEM c2 (X \<inter> (-b)))"
apply (unfold SEM_def sem_def)
apply auto
apply(erule converse_rtranclE)
 prefer 2
 apply (erule transition_cases,simp_all)
  apply(fast intro: converse_rtrancl_into_rtrancl elim: transition_cases)+
done

lemma  L3_5v_lemma1[rule_format]:
 "(S,s) -Pn\<rightarrow> (T,t) \<longrightarrow> S=\<Omega> \<longrightarrow> (\<not>(\<exists>Rs. T=(Parallel Rs) \<and> All_None Rs))"
apply (unfold UNIV_def)
apply(rule nat_less_induct)
apply safe
apply(erule relpow_E2)
 apply simp_all
apply(erule transition_cases)
 apply simp_all
apply(erule relpow_E2)
 apply(simp add: Id_def)
apply(erule transition_cases,simp_all)
apply clarify
apply(erule transition_cases,simp_all)
apply(erule relpow_E2,simp)
apply clarify
apply(erule transition_cases)
 apply simp+
    apply clarify
    apply(erule transition_cases)
apply simp_all
done

lemma L3_5v_lemma2: "\<lbrakk>(\<Omega>, s) -P*\<rightarrow> (Parallel Ts, t); All_None Ts \<rbrakk> \<Longrightarrow> False"
apply(fast dest: rtrancl_imp_UN_relpow L3_5v_lemma1)
done

lemma L3_5v_lemma3: "SEM (\<Omega>) S = {}"
apply (unfold SEM_def sem_def)
apply(fast dest: L3_5v_lemma2)
done

lemma L3_5v_lemma4 [rule_format]:
 "\<forall>s. (While b i c, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
  (\<exists>k. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t))"
apply(rule nat_less_induct)
apply safe
apply(erule relpow_E2)
 apply safe
apply(erule transition_cases,simp_all)
 apply (rule_tac x = "1" in exI)
 apply(force dest: Parallel_empty_lemma intro: converse_rtrancl_into_rtrancl simp add: Id_def)
apply safe
apply(drule L3_5ii_lemma2)
 apply safe
apply(drule le_imp_less_Suc)
apply (erule allE , erule impE,assumption)
apply (erule allE , erule impE, assumption)
apply safe
apply (rule_tac x = "k+1" in exI)
apply(simp (no_asm))
apply(rule converse_rtrancl_into_rtrancl)
 apply fast
apply(fast elim: L3_5ii_lemma1)
done

lemma L3_5v_lemma5 [rule_format]:
 "\<forall>s. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
  (While b i c, s) -P*\<rightarrow> (Parallel Ts,t)"
apply(induct "k")
 apply(force dest: L3_5v_lemma2)
apply safe
apply(erule converse_rtranclE)
 apply simp_all
apply(erule transition_cases,simp_all)
 apply(rule converse_rtrancl_into_rtrancl)
  apply(fast)
 apply(fast elim!: L3_5ii_lemma1 dest: L3_5ii_lemma3)
apply(drule rtrancl_imp_UN_relpow)
apply clarify
apply(erule relpow_E2)
 apply simp_all
apply(erule transition_cases,simp_all)
apply(fast dest: Parallel_empty_lemma)
done

lemma L3_5v: "SEM (While b i c) = (\<lambda>x. (\<Union>k. SEM (fwhile b c k) x))"
apply(rule ext)
apply (simp add: SEM_def sem_def)
apply safe
 apply(drule rtrancl_imp_UN_relpow,simp)
 apply clarify
 apply(fast dest:L3_5v_lemma4)
apply(fast intro: L3_5v_lemma5)
done

section \<open>Validity of Correctness Formulas\<close>

definition com_validity :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>= _// _//_)" [90,55,90] 50) where
  "\<parallel>= p c q \<equiv> SEM c p \<subseteq> q"

definition ann_com_validity :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> _ _" [60,90] 45) where
  "\<Turnstile> c q \<equiv> ann_SEM c (pre c) \<subseteq> q"

end


theory Gen_Scheduler_Refine
imports "../RefPoint/Gen_Scheduler"
begin

  locale Gen_Scheduler' = cs: LTS cstep
    for cstep :: "'c \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool" +
    fixes en :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> bool"
    fixes ex :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> ('ls\<times>'gs)"
  begin

    definition gstep_succ
      :: "('c,'ls,'gs)global_config \<Rightarrow> ('c,'ls,'gs)global_config set"
      where
      "gstep_succ gc \<equiv> do {
        \<comment> \<open> Select process \<close>
        let lcs = global_config.processes gc;
        (lc,lcs') \<leftarrow> {(lc,lcs'). lcs = {#lc#} + lcs'};
        \<comment> \<open> Focus state \<close>
        let gs = global_config.state gc;
        let ls = local_config.state lc;

        \<comment> \<open> Select action \<close>
        let cmd = local_config.command lc;
        (a,cmd') \<leftarrow> {(a,cmd'). cstep cmd a cmd'};

        case en (ls,gs) a of
          False \<Rightarrow> {} \<comment> \<open> Not enabled \<close>
        | True \<Rightarrow> {do { \<comment> \<open> Enabled \<close>
            \<comment> \<open> Execute \<close>
            let (ls,gs) = ex (ls,gs) a;
            \<comment> \<open> Unfocus state. \<close>
            \<lparr>
              global_config.processes = {#
                \<lparr> local_config.command = cmd', local_config.state = ls\<rparr>
              #} + lcs',
              global_config.state = gs
            \<rparr>
          }}
      }"

    abbreviation "gstep \<equiv> rel_of_succ gstep_succ"

    text \<open>For the final step function, we apply stutter extension\<close>
    definition "step \<equiv> stutter_extend_edges UNIV gstep"

    lemma gstep_succE[cases set: gstep_succ, case_names succ]:
      assumes "gc' \<in> gstep_succ gc"
      obtains lc lcs c' a ls' gs'
        where
        "processes gc = {#lc#} + lcs"
        "cstep (command lc) a c'"
        "en (local_config.state lc, global_config.state gc) a"
        "ex (local_config.state lc, global_config.state gc) a = (ls',gs')"
        "gc' = \<lparr>
          global_config.processes
            = {#\<lparr> local_config.command = c', local_config.state = ls' \<rparr>#} + lcs,
          global_config.state
            = gs'
        \<rparr>"
      using assms
      unfolding gstep_succ_def
      by (auto
        split: option.splits bool.splits Option.bind_splits prod.splits
        simp: all_conj_distrib
        elim!: neq_Some_bool_cases)

    lemma gstep_succI:
      assumes "processes gc = {#lc#} + lcs"
      assumes "cstep (command lc) a c'"
      assumes "en (local_config.state lc, global_config.state gc) a"
      assumes "ex (local_config.state lc, global_config.state gc) a = (ls',gs')"
      shows "\<lparr>
          global_config.processes
            = {#\<lparr> local_config.command = c', local_config.state = ls' \<rparr>#} + lcs,
          global_config.state
            = gs'
        \<rparr> \<in> gstep_succ gc"
      using assms unfolding gstep_succ_def
      by (fastforce)

  end

  locale Gen_Scheduler'_linit =
    Gen_Scheduler' cstep en ex
    for cstep :: "'c \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool"
    and en :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> bool"
    and ex :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> ('ls\<times>'gs)" +
    fixes init :: "('c,'ls,'gs) global_config set"
    fixes label :: "('c,'ls,'gs) global_config \<Rightarrow> 'l"
  begin

    definition system_automaton' :: "(('c,'ls,'gs) global_config, 'l) sa_rec"
      where "system_automaton' \<equiv> \<lparr> g_V = UNIV, g_E = gstep, g_V0 = init, sa_L = label \<rparr>"

    lemma system_automaton'_simps[simp]:
      "g_V system_automaton' = UNIV"
      "g_E system_automaton' = gstep"
      "g_V0 system_automaton' = init"
      "sa_L system_automaton' = label"
      unfolding system_automaton'_def by simp+

    definition system_automaton :: "(('c,'ls,'gs) global_config, 'l) sa_rec"
      where "system_automaton \<equiv> \<lparr> g_V = UNIV, g_E = step, g_V0 = init, sa_L = label \<rparr>"

    lemma system_automaton_simps[simp]:
      "g_V system_automaton = UNIV"
      "g_E system_automaton = step"
      "g_V0 system_automaton = init"
      "sa_L system_automaton = label"
      unfolding system_automaton_def by simp+

    lemma system_automaton_alt_def: "system_automaton = stutter_extend system_automaton'"
      unfolding step_def system_automaton'_def system_automaton_def stutter_extend_def by simp

    sublocale sa': sa system_automaton' by unfold_locales auto
    sublocale sa: sa system_automaton unfolding system_automaton_alt_def by (rule sa'.stutter_extend_sa)

  end

  locale sched_typing =
    s1: Gen_Scheduler cstep1 en1 ex1 +
    s2: Gen_Scheduler' cstep2 en2 ex2
    for cstep1 :: "'c \<Rightarrow> 'a+'b \<Rightarrow> 'c \<Rightarrow> bool"
    and en1 :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> bool"
    and ex1 :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> ('ls\<times>'gs)"

    and cstep2 :: "'c \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool"
    and en2 :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> bool"
    and ex2 :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> ('ls\<times>'gs)"

    +
    fixes wf_local :: "'c \<Rightarrow> 'ls \<Rightarrow> 'gs \<Rightarrow> bool"

    assumes wf_cstep: "wf_local c ls gs
      \<Longrightarrow> cstep1 c aa c' \<longleftrightarrow> (\<exists>a. aa=Inl a \<and> cstep2 c a c')"
    assumes wf_en: "\<lbrakk>wf_local c ls gs; cstep1 c (Inl a) c'\<rbrakk>
      \<Longrightarrow> en1 (ls,gs) a = Some (en2 (ls,gs) a)"
    assumes wf_ex: "\<lbrakk>wf_local c ls gs; cstep1 c (Inl a) c'; en1 (ls,gs) a = Some True\<rbrakk>
      \<Longrightarrow> ex1 (ls,gs) a = Some (ex2 (ls,gs) a)"

    assumes wf_pres_this: "\<lbrakk>
      wf_local c ls gs; cstep1 c (Inl a) c';
      en1 (ls,gs) a = Some True; ex1 (ls,gs) a = Some (ls',gs') \<rbrakk>
      \<Longrightarrow> wf_local c' ls' gs'"
    assumes wf_pres_other: "\<lbrakk>
      wf_local c ls gs; cstep1 c (Inl a) c';
      en1 (ls,gs) a = Some True; ex1 (ls,gs) a = Some (ls',gs');
      wf_local co lso gs
    \<rbrakk>
      \<Longrightarrow> wf_local co lso gs'"

  begin
    definition wf_gglobal :: "('c,'ls,'gs) global_config \<Rightarrow> bool" where
      "wf_gglobal gc \<equiv> \<forall>lc. lc\<in>#global_config.processes gc
        \<longrightarrow> wf_local
              (local_config.command lc)
              (local_config.state lc)
              (global_config.state gc)"

    primrec wf_global where
      "wf_global None = False"
    | "wf_global (Some gc) = wf_gglobal gc"

    lemma wf_cstep_revI:
      "\<lbrakk>wf_local c ls gs; cstep2 c a c'\<rbrakk> \<Longrightarrow> cstep1 c (Inl a) c'"
      using wf_cstep by auto

    lemma wf_en_revI:
      "\<lbrakk>wf_local c ls gs; cstep1 c (Inl a) c'; en2 (ls,gs) a \<rbrakk> \<Longrightarrow> en1 (ls,gs) a = Some True"
      using wf_en by auto

    lemma wf_ex_revI:
      "\<lbrakk>wf_local c ls gs; cstep1 c (Inl a) c'; en2 (ls,gs) a; ex2 (ls,gs) a = fs' \<rbrakk>
      \<Longrightarrow> ex1 (ls,gs) a = Some fs'"
      using wf_en wf_ex by auto

    lemma wf_pres_step: "\<lbrakk>wf_global gc; (gc, gc') \<in> s1.step\<rbrakk> \<Longrightarrow> wf_global gc'"
      apply (cases gc, simp_all)
      unfolding s1.step_def s1.gstep_def
      apply (erule stutter_extend_edgesE)
        apply (clarsimp)
        apply (erule s1.gstep_succE)
        apply (auto
          simp: wf_gglobal_def all_conj_distrib
          simp: wf_cstep
          ) []
        apply (auto
          simp: wf_gglobal_def all_conj_distrib
          simp: wf_en wf_cstep
          ) []
        apply (auto
          simp: wf_gglobal_def all_conj_distrib
          simp: wf_en wf_ex wf_cstep
          ) []
        apply (auto
          simp: wf_gglobal_def all_conj_distrib
          intro: wf_pres_this wf_pres_other
          ) []

        apply clarsimp
      done

    lemma wf_gstep_eq: "wf_gglobal gc \<Longrightarrow>
      s1.gstep_succ gc = Some`s2.gstep_succ gc"
      apply safe
        apply (erule s1.gstep_succE, simp_all add: inj_image_mem_iff) []
        apply (auto
          simp: wf_gglobal_def all_conj_distrib
          simp: wf_en wf_ex wf_cstep
          ) [3]
        apply (clarsimp
          simp: wf_gglobal_def all_conj_distrib
          simp: wf_en wf_ex wf_cstep
          ) []
        apply (auto intro!: s2.gstep_succI)
        apply (erule s2.gstep_succE,
          clarsimp_all simp: wf_gglobal_def all_conj_distrib) []
        apply (rule s1.gstep_succ_succ, assumption)
        apply (rule wf_cstep_revI, assumption+)
        apply (rule wf_en_revI, assumption+, auto simp: wf_cstep) []
        apply (rule wf_ex_revI, assumption+, auto simp: wf_cstep) []
      done

    lemma wf_gstep_revI:
      "\<lbrakk>wf_gglobal gc; gc'\<in>s2.gstep_succ gc\<rbrakk>
      \<Longrightarrow> Some gc' \<in> s1.gstep_succ gc"
      by (auto simp: wf_gstep_eq)

    lemma wf_step_eq: "wf_global gco \<Longrightarrow>
      (gco, gco') \<in> s1.step
      \<longleftrightarrow> (\<exists>gc gc'. gco=Some gc \<and> gco'=Some gc' \<and> (gc, gc') \<in> s2.step)"
      apply (cases gco, simp_all)
      unfolding s1.step_def s2.step_def s1.gstep_def
      apply safe
      apply (erule stutter_extend_edgesE)
        apply (auto simp: wf_gstep_eq intro!: stutter_extend_edgesI_edge) []

        apply clarsimp
        apply (rule stutter_extend_edgesI_stutter, clarsimp)
        apply (auto dest!: wf_gstep_revI) []

      apply (erule stutter_extend_edgesE)
        apply (auto simp: wf_gstep_eq intro!: stutter_extend_edgesI_edge) []

        apply clarsimp
        apply (rule stutter_extend_edgesI_stutter, clarsimp)
        apply (force simp: wf_gstep_eq) []
      done

    lemma wf_pres_step2: "\<lbrakk> wf_gglobal gc; (gc, gc') \<in> s2.step \<rbrakk> \<Longrightarrow> wf_gglobal gc'"
      using wf_pres_step[of "Some gc" "Some gc'"]
      by (simp add: wf_step_eq)

  end

  locale sched_typing_init =
    sched_typing cstep1 en1 ex1 cstep2 en2 ex2 wf_local +
    s1: Gen_Scheduler_linit cstep1 en1 ex1 ginit glabel +
    s2: Gen_Scheduler'_linit cstep2 en2 ex2 ginit glabel
    for cstep1 :: "'c \<Rightarrow> 'a+'b \<Rightarrow> 'c \<Rightarrow> bool"
    and en1 :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> bool"
    and ex1 :: "('ls\<times>'gs) \<Rightarrow> 'a \<rightharpoonup> ('ls\<times>'gs)"

    and cstep2 :: "'c \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool"
    and en2 :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> bool"
    and ex2 :: "('ls\<times>'gs) \<Rightarrow> 'a \<Rightarrow> ('ls\<times>'gs)"

    and ginit :: "('c,'ls,'gs) global_config set"
    and glabel :: "('c,'ls,'gs) global_config \<Rightarrow> 'l"
    and wf_local :: "'c \<Rightarrow> 'ls \<Rightarrow> 'gs \<Rightarrow> bool" +
    assumes wf_init: "gc \<in> ginit \<Longrightarrow> wf_gglobal gc"
  begin

    sublocale bisim: lbisimulation "br Some wf_gglobal"
      s2.system_automaton
      s1.system_automaton
      apply unfold_locales
      apply (auto simp: build_rel_def wf_init wf_step_eq wf_pres_step2 simp: s1.init_conv)
      done

    lemma accept_eq: "s2.sa.accept = s1.sa.accept"
      using bisim.accept_bisim .

    lemma is_run_conv: "s1.sa.g.is_run r \<longleftrightarrow> (\<exists>r'. r=Some o r' \<and> s2.sa.g.is_run r')"
      using bisim.br_run_conv[OF refl] .

  end

end


(*  Title:      HOL/HOLCF/ex/Domain_Proofs.thy
    Author:     Brian Huffman
*)

section {* Internal domain package proofs done manually *}

theory Domain_Proofs
imports HOLCF
begin

(*

The definitions and proofs below are for the following recursive
datatypes:

domain 'a foo = Foo1 | Foo2 (lazy 'a) (lazy "'a bar")
   and 'a bar = Bar (lazy "'a baz \<rightarrow> tr")
   and 'a baz = Baz (lazy "'a foo convex_pd \<rightarrow> tr")

*)

(********************************************************************)

subsection {* Step 1: Define the new type combinators *}

text {* Start with the one-step non-recursive version *}

definition
  foo_bar_baz_deflF ::
    "udom defl \<rightarrow> udom defl \<times> udom defl \<times> udom defl \<rightarrow> udom defl \<times> udom defl \<times> udom defl"
where
  "foo_bar_baz_deflF = (\<Lambda> a. Abs_cfun (\<lambda>(t1, t2, t3).
    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>t2))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>t3)\<cdot>DEFL(tr))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>t1))\<cdot>DEFL(tr)))))"

lemma foo_bar_baz_deflF_beta:
  "foo_bar_baz_deflF\<cdot>a\<cdot>t =
    ( ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(fst (snd t))))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(snd (snd t)))\<cdot>DEFL(tr))
    , u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(fst t)))\<cdot>DEFL(tr)))"
unfolding foo_bar_baz_deflF_def
by (simp add: split_def)

text {* Individual type combinators are projected from the fixed point. *}

definition foo_defl :: "udom defl \<rightarrow> udom defl"
where "foo_defl = (\<Lambda> a. fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"

definition bar_defl :: "udom defl \<rightarrow> udom defl"
where "bar_defl = (\<Lambda> a. fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"

definition baz_defl :: "udom defl \<rightarrow> udom defl"
where "baz_defl = (\<Lambda> a. snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))))"

lemma defl_apply_thms:
  "foo_defl\<cdot>a = fst (fix\<cdot>(foo_bar_baz_deflF\<cdot>a))"
  "bar_defl\<cdot>a = fst (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
  "baz_defl\<cdot>a = snd (snd (fix\<cdot>(foo_bar_baz_deflF\<cdot>a)))"
unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all

text {* Unfold rules for each combinator. *}

lemma foo_defl_unfold:
  "foo_defl\<cdot>a = ssum_defl\<cdot>DEFL(one)\<cdot>(sprod_defl\<cdot>(u_defl\<cdot>a)\<cdot>(u_defl\<cdot>(bar_defl\<cdot>a)))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

lemma bar_defl_unfold: "bar_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(baz_defl\<cdot>a))\<cdot>DEFL(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

lemma baz_defl_unfold: "baz_defl\<cdot>a = u_defl\<cdot>(sfun_defl\<cdot>(u_defl\<cdot>(convex_defl\<cdot>(foo_defl\<cdot>a)))\<cdot>DEFL(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)

text "The automation for the previous steps will be quite similar to
how the fixrec package works."

(********************************************************************)

subsection {* Step 2: Define types, prove class instances *}

text {* Use @{text pcpodef} with the appropriate type combinator. *}

pcpodef 'a foo = "defl_set (foo_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

pcpodef 'a bar = "defl_set (bar_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

pcpodef 'a baz = "defl_set (baz_defl\<cdot>DEFL('a))"
by (rule defl_set_bottom, rule adm_defl_set)

text {* Prove rep instance using lemma @{text typedef_rep_class}. *}

instantiation foo :: ("domain") "domain"
begin

definition emb_foo :: "'a foo \<rightarrow> udom"
where "emb_foo \<equiv> (\<Lambda> x. Rep_foo x)"

definition prj_foo :: "udom \<rightarrow> 'a foo"
where "prj_foo \<equiv> (\<Lambda> y. Abs_foo (cast\<cdot>(foo_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_foo :: "'a foo itself \<Rightarrow> udom defl"
where "defl_foo \<equiv> \<lambda>a. foo_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a foo u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a foo u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a foo itself). liftdefl_of\<cdot>DEFL('a foo)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_foo)
apply (rule below_foo_def)
apply (rule emb_foo_def)
apply (rule prj_foo_def)
apply (rule defl_foo_def)
apply (rule liftemb_foo_def)
apply (rule liftprj_foo_def)
apply (rule liftdefl_foo_def)
done

end

instantiation bar :: ("domain") "domain"
begin

definition emb_bar :: "'a bar \<rightarrow> udom"
where "emb_bar \<equiv> (\<Lambda> x. Rep_bar x)"

definition prj_bar :: "udom \<rightarrow> 'a bar"
where "prj_bar \<equiv> (\<Lambda> y. Abs_bar (cast\<cdot>(bar_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_bar :: "'a bar itself \<Rightarrow> udom defl"
where "defl_bar \<equiv> \<lambda>a. bar_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a bar u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a bar u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a bar itself). liftdefl_of\<cdot>DEFL('a bar)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_bar)
apply (rule below_bar_def)
apply (rule emb_bar_def)
apply (rule prj_bar_def)
apply (rule defl_bar_def)
apply (rule liftemb_bar_def)
apply (rule liftprj_bar_def)
apply (rule liftdefl_bar_def)
done

end

instantiation baz :: ("domain") "domain"
begin

definition emb_baz :: "'a baz \<rightarrow> udom"
where "emb_baz \<equiv> (\<Lambda> x. Rep_baz x)"

definition prj_baz :: "udom \<rightarrow> 'a baz"
where "prj_baz \<equiv> (\<Lambda> y. Abs_baz (cast\<cdot>(baz_defl\<cdot>DEFL('a))\<cdot>y))"

definition defl_baz :: "'a baz itself \<Rightarrow> udom defl"
where "defl_baz \<equiv> \<lambda>a. baz_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a baz u \<rightarrow> udom u) \<equiv> u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a baz u) \<equiv> u_map\<cdot>prj"

definition
  "liftdefl \<equiv> \<lambda>(t::'a baz itself). liftdefl_of\<cdot>DEFL('a baz)"

instance
apply (rule typedef_domain_class)
apply (rule type_definition_baz)
apply (rule below_baz_def)
apply (rule emb_baz_def)
apply (rule prj_baz_def)
apply (rule defl_baz_def)
apply (rule liftemb_baz_def)
apply (rule liftprj_baz_def)
apply (rule liftdefl_baz_def)
done

end

text {* Prove DEFL rules using lemma @{text typedef_DEFL}. *}

lemma DEFL_foo: "DEFL('a foo) = foo_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_foo_def)
done

lemma DEFL_bar: "DEFL('a bar) = bar_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_bar_def)
done

lemma DEFL_baz: "DEFL('a baz) = baz_defl\<cdot>DEFL('a)"
apply (rule typedef_DEFL)
apply (rule defl_baz_def)
done

text {* Prove DEFL equations using type combinator unfold lemmas. *}

lemma DEFL_foo': "DEFL('a foo) = DEFL(one \<oplus> 'a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule foo_defl_unfold)

lemma DEFL_bar': "DEFL('a bar) = DEFL(('a baz \<rightarrow> tr)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule bar_defl_unfold)

lemma DEFL_baz': "DEFL('a baz) = DEFL(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
unfolding DEFL_foo DEFL_bar DEFL_baz domain_defl_simps
by (rule baz_defl_unfold)

(********************************************************************)

subsection {* Step 3: Define rep and abs functions *}

text {* Define them all using @{text prj} and @{text emb}! *}

definition foo_rep :: "'a foo \<rightarrow> one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>)"
where "foo_rep \<equiv> prj oo emb"

definition foo_abs :: "one \<oplus> ('a\<^sub>\<bottom> \<otimes> ('a bar)\<^sub>\<bottom>) \<rightarrow> 'a foo"
where "foo_abs \<equiv> prj oo emb"

definition bar_rep :: "'a bar \<rightarrow> ('a baz \<rightarrow> tr)\<^sub>\<bottom>"
where "bar_rep \<equiv> prj oo emb"

definition bar_abs :: "('a baz \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a bar"
where "bar_abs \<equiv> prj oo emb"

definition baz_rep :: "'a baz \<rightarrow> ('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>"
where "baz_rep \<equiv> prj oo emb"

definition baz_abs :: "('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom> \<rightarrow> 'a baz"
where "baz_abs \<equiv> prj oo emb"

text {* Prove isomorphism rules. *}

lemma foo_abs_iso: "foo_rep\<cdot>(foo_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma foo_rep_iso: "foo_abs\<cdot>(foo_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma bar_abs_iso: "bar_rep\<cdot>(bar_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma bar_rep_iso: "bar_abs\<cdot>(bar_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma baz_abs_iso: "baz_rep\<cdot>(baz_abs\<cdot>x) = x"
by (rule domain_abs_iso [OF DEFL_baz' baz_abs_def baz_rep_def])

lemma baz_rep_iso: "baz_abs\<cdot>(baz_rep\<cdot>x) = x"
by (rule domain_rep_iso [OF DEFL_baz' baz_abs_def baz_rep_def])

text {* Prove isodefl rules using @{text isodefl_coerce}. *}

lemma isodefl_foo_abs:
  "isodefl d t \<Longrightarrow> isodefl (foo_abs oo d oo foo_rep) t"
by (rule isodefl_abs_rep [OF DEFL_foo' foo_abs_def foo_rep_def])

lemma isodefl_bar_abs:
  "isodefl d t \<Longrightarrow> isodefl (bar_abs oo d oo bar_rep) t"
by (rule isodefl_abs_rep [OF DEFL_bar' bar_abs_def bar_rep_def])

lemma isodefl_baz_abs:
  "isodefl d t \<Longrightarrow> isodefl (baz_abs oo d oo baz_rep) t"
by (rule isodefl_abs_rep [OF DEFL_baz' baz_abs_def baz_rep_def])

(********************************************************************)

subsection {* Step 4: Define map functions, prove isodefl property *}

text {* Start with the one-step non-recursive version. *}

text {* Note that the type of the map function depends on which
variables are used in positive and negative positions. *}

definition
  foo_bar_baz_mapF ::
    "('a \<rightarrow> 'b) \<rightarrow>
     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz) \<rightarrow>
     ('a foo \<rightarrow> 'b foo) \<times> ('a bar \<rightarrow> 'b bar) \<times> ('b baz \<rightarrow> 'a baz)"
where
  "foo_bar_baz_mapF = (\<Lambda> f. Abs_cfun (\<lambda>(d1, d2, d3).
    (
      foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>d2))
          oo foo_rep
    ,
      bar_abs oo u_map\<cdot>(cfun_map\<cdot>d3\<cdot>ID) oo bar_rep
    ,
      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>d1)\<cdot>ID) oo baz_rep
    )))"

lemma foo_bar_baz_mapF_beta:
  "foo_bar_baz_mapF\<cdot>f\<cdot>d =
    (
      foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>(u_map\<cdot>(fst (snd d))))
          oo foo_rep
    ,
      bar_abs oo u_map\<cdot>(cfun_map\<cdot>(snd (snd d))\<cdot>ID) oo bar_rep
    ,
      baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst d))\<cdot>ID) oo baz_rep
    )"
unfolding foo_bar_baz_mapF_def
by (simp add: split_def)

text {* Individual map functions are projected from the fixed point. *}

definition foo_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a foo \<rightarrow> 'b foo)"
where "foo_map = (\<Lambda> f. fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"

definition bar_map :: "('a \<rightarrow> 'b) \<rightarrow> ('a bar \<rightarrow> 'b bar)"
where "bar_map = (\<Lambda> f. fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"

definition baz_map :: "('a \<rightarrow> 'b) \<rightarrow> ('b baz \<rightarrow> 'a baz)"
where "baz_map = (\<Lambda> f. snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))))"

lemma map_apply_thms:
  "foo_map\<cdot>f = fst (fix\<cdot>(foo_bar_baz_mapF\<cdot>f))"
  "bar_map\<cdot>f = fst (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
  "baz_map\<cdot>f = snd (snd (fix\<cdot>(foo_bar_baz_mapF\<cdot>f)))"
unfolding foo_map_def bar_map_def baz_map_def by simp_all

text {* Prove isodefl rules for all map functions simultaneously. *}

lemma isodefl_foo_bar_baz:
  assumes isodefl_d: "isodefl d t"
  shows
  "isodefl (foo_map\<cdot>d) (foo_defl\<cdot>t) \<and>
  isodefl (bar_map\<cdot>d) (bar_defl\<cdot>t) \<and>
  isodefl (baz_map\<cdot>d) (baz_defl\<cdot>t)"
unfolding map_apply_thms defl_apply_thms
 apply (rule parallel_fix_ind)
   apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
  apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
 apply (simp only: foo_bar_baz_mapF_beta
                   foo_bar_baz_deflF_beta
                   fst_conv snd_conv)
 apply (elim conjE)
 apply (intro
  conjI
  isodefl_foo_abs
  isodefl_bar_abs
  isodefl_baz_abs
  domain_isodefl
  isodefl_ID_DEFL isodefl_LIFTDEFL
  isodefl_d
 )
 apply assumption+
done

lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]

text {* Prove map ID lemmas, using isodefl_DEFL_imp_ID *}

lemma foo_map_ID: "foo_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_foo)
apply (rule isodefl_foo)
apply (rule isodefl_ID_DEFL)
done

lemma bar_map_ID: "bar_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_bar)
apply (rule isodefl_bar)
apply (rule isodefl_ID_DEFL)
done

lemma baz_map_ID: "baz_map\<cdot>ID = ID"
apply (rule isodefl_DEFL_imp_ID)
apply (subst DEFL_baz)
apply (rule isodefl_baz)
apply (rule isodefl_ID_DEFL)
done

(********************************************************************)

subsection {* Step 5: Define take functions, prove lub-take lemmas *}

definition
  foo_bar_baz_takeF ::
    "('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz) \<rightarrow>
     ('a foo \<rightarrow> 'a foo) \<times> ('a bar \<rightarrow> 'a bar) \<times> ('a baz \<rightarrow> 'a baz)"
where
  "foo_bar_baz_takeF = (\<Lambda> p.
    ( foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
          oo foo_rep
    , bar_abs oo
        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
    , baz_abs oo
        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
    ))"

lemma foo_bar_baz_takeF_beta:
  "foo_bar_baz_takeF\<cdot>p =
    ( foo_abs oo
        ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(fst (snd p))))
          oo foo_rep
    , bar_abs oo
        u_map\<cdot>(cfun_map\<cdot>(snd (snd p))\<cdot>ID) oo bar_rep
    , baz_abs oo
        u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(fst p))\<cdot>ID) oo baz_rep
    )"
unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)

definition
  foo_take :: "nat \<Rightarrow> 'a foo \<rightarrow> 'a foo"
where
  "foo_take = (\<lambda>n. fst (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>))"

definition
  bar_take :: "nat \<Rightarrow> 'a bar \<rightarrow> 'a bar"
where
  "bar_take = (\<lambda>n. fst (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"

definition
  baz_take :: "nat \<Rightarrow> 'a baz \<rightarrow> 'a baz"
where
  "baz_take = (\<lambda>n. snd (snd (iterate n\<cdot>foo_bar_baz_takeF\<cdot>\<bottom>)))"

lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
unfolding foo_take_def bar_take_def baz_take_def
by (intro ch2ch_fst ch2ch_snd chain_iterate)+

lemma take_0_thms: "foo_take 0 = \<bottom>" "bar_take 0 = \<bottom>" "baz_take 0 = \<bottom>"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_0 fst_strict snd_strict)+

lemma take_Suc_thms:
  "foo_take (Suc n) =
    foo_abs oo ssum_map\<cdot>ID\<cdot>(sprod_map\<cdot>(u_map\<cdot>ID)\<cdot>(u_map\<cdot>(bar_take n))) oo foo_rep"
  "bar_take (Suc n) =
    bar_abs oo u_map\<cdot>(cfun_map\<cdot>(baz_take n)\<cdot>ID) oo bar_rep"
  "baz_take (Suc n) =
    baz_abs oo u_map\<cdot>(cfun_map\<cdot>(convex_map\<cdot>(foo_take n))\<cdot>ID) oo baz_rep"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+

lemma lub_take_lemma:
  "(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
    = (foo_map\<cdot>(ID::'a \<rightarrow> 'a), bar_map\<cdot>(ID::'a \<rightarrow> 'a), baz_map\<cdot>(ID::'a \<rightarrow> 'a))"
apply (simp only: lub_Pair [symmetric] ch2ch_Pair chain_take_thms)
apply (simp only: map_apply_thms pair_collapse)
apply (simp only: fix_def2)
apply (rule lub_eq)
apply (rule nat.induct)
apply (simp only: iterate_0 Pair_strict take_0_thms)
apply (simp only: iterate_Suc prod_eq_iff fst_conv snd_conv
                  foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
done

lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
apply (rule trans [OF _ foo_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
apply (rule trans [OF _ bar_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
apply (rule trans [OF _ baz_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done

end


(*
    File:        dBeta.thy
    Time-stamp:  <2020-06-22T04:37:29Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory dBeta imports dLambda begin

consts
  dBeta1Rel :: i
inductive
  domains "dBeta1Rel" <= "dTerm * dTerm"
  intros
    baseI: "[| M: dTerm; N: dTerm |] ==>
               <dApp(dLam(M), N), dSubst(M, 0, N)>: dBeta1Rel"
    dLamI: "<M, M'>: dBeta1Rel ==> <dLam(M), dLam(M')>: dBeta1Rel"

    dAppI1: "[| <M, M'>: dBeta1Rel; N: dTerm |] ==>
                 <dApp(M, N), dApp(M', N)>: dBeta1Rel"

    dAppI2: "[| M: dTerm; <N, N'>: dBeta1Rel |] ==>
             <dApp(M, N), dApp(M, N')>: dBeta1Rel"
  type_intros dTerm.intros SigmaI nat_0I dSubst_type
  type_elims SigmaE2

definition dBeta1 :: "[i, i]=>o" where
"dBeta1(M, N) == <M, N>: dBeta1Rel"

lemma dBeta1Rel_induct:
  assumes major: "<M, N>: dBeta1Rel"
  and
   "!!M N. [| M : dTerm; N : dTerm |] ==>
           P(dApp(dLam(M), N), dSubst(M, 0, N))"
  and
   "!!M M'. [| <M, M'> : dBeta1Rel; P(M, M') |] ==>
           P(dLam(M), dLam(M'))"
  and
   "!!M M' N.  [| <M, M'> : dBeta1Rel; P(M, M'); N : dTerm |] ==>
           P(dApp(M, N), dApp(M', N))"
  and
   "!!M N N'. [| M : dTerm; <N, N'> : dBeta1Rel; P(N, N') |] ==>
           P(dApp(M, N), dApp(M, N'))"
  shows "P(M, N)"
apply (rule_tac P="%x. P(x, N)" and b1="N" in fst_conv [THEN subst])
apply (rule_tac P="%x. P(fst(<M, N>), x)" and a1="M" in snd_conv [THEN subst])
apply (rule major [THEN dBeta1Rel.induct])
apply simp_all
apply (blast intro: assms)+
done

lemma dBeta1_type1:
  "dBeta1(M, N) ==> M: dTerm"
apply (unfold dBeta1_def)
apply (erule subsetD [OF dBeta1Rel.dom_subset, THEN SigmaD1])
done

lemma dBeta1_type2:
  "dBeta1(M, N) ==> N: dTerm"
apply (unfold dBeta1_def)
apply (erule subsetD [OF dBeta1Rel.dom_subset, THEN SigmaD2])
done

lemma dBeta1_baseI:
  "[| A: dTerm; B: dTerm |] ==>
        dBeta1(dApp(dLam(A), B), dSubst(A, 0, B))"
apply (unfold dBeta1_def)
apply (blast intro: dBeta1Rel.intros)
done

lemma dBeta1_dLamI:
  "dBeta1(M, M') ==> dBeta1(dLam(M), dLam(M'))"
apply (unfold dBeta1_def)
apply (blast intro: dBeta1Rel.intros)
done

lemma dBeta1_dAppI1:
  "[| dBeta1(M, M'); N: dTerm |] ==>
         dBeta1(dApp(M, N), dApp(M', N))"
apply (unfold dBeta1_def)
apply (blast intro: dBeta1Rel.intros)
done

lemma dBeta1_dAppI2:
  "[| M: dTerm; dBeta1(N, N') |] ==>
         dBeta1(dApp(M, N), dApp(M, N'))"
apply (unfold dBeta1_def)
apply (blast intro: dBeta1Rel.intros)
done

lemmas dBeta1_dTermIs = dBeta1_baseI dBeta1_dLamI
                        dBeta1_dAppI1 dBeta1_dAppI2

lemma dBeta1_dVarE:
  "dBeta1(dVar(x), N) ==> R"
apply (unfold dBeta1_def)
apply (erule dBeta1Rel.cases)
apply (safe elim!: dTerm.free_elims)
done

lemma dBeta1_dBoundE:
  "dBeta1(dBound(n), N) ==> R"
apply (unfold dBeta1_def)
apply (erule dBeta1Rel.cases)
apply (safe elim!: dTerm.free_elims)
done

lemma dBeta1_dLamE:
  "[| dBeta1(dLam(M), N);
      !!N'. [| dBeta1(M, N'); N = dLam(N')|] ==> R
   |] ==> R"
apply (unfold dBeta1_def)
apply (erule dBeta1Rel.cases)
apply (blast elim!: dTerm.free_elims)+
done

lemma dBeta1_dAppE:
  assumes major: "dBeta1(dApp(A, B), N)"
  and prem1:
     "!!x N'. [| N': dTerm; B: dTerm;
         A = dLam(N'); N = dSubst(N', 0, B) |] ==> R"
  and prem2:
     "!!A'. [| dBeta1(A, A'); B: dTerm; N = dApp(A', B) |] ==> R"
  and prem3:
     "!!B'. [| A: dTerm; dBeta1(B, B'); N = dApp(A, B') |] ==> R"
  shows "R"
apply (rule major [unfolded dBeta1_def, THEN dBeta1Rel.cases])
apply (rule_tac [4] prem3)
apply (rule_tac [3] prem2)
apply (rule_tac [1] prem1)
apply (unfold dBeta1_def)
apply (safe elim!: dTerm.free_elims)
prefer 2
prefer 3
prefer 5
prefer 7
apply (rule refl)+
apply assumption+
done

lemmas  dBeta1_dTermEs = dBeta1_dVarE dBeta1_dBoundE
                         dBeta1_dLamE dBeta1_dAppE

lemma dBeta1_dAbst:
  assumes major: "dBeta1(M, M')"
  and prem: "n: nat"
  shows "dBeta1(dAbst(M, x, n), dAbst(M', x, n))"
apply (rule major [THEN rev_mp])
apply (rule prem [THEN [2] bspec])
apply (rule major [THEN dBeta1_type2, THEN [2] bspec])
apply (rule major [THEN dBeta1_type1, THEN dTerm.induct])
apply (simp_all del: ball_simps)
apply (safe elim!: dBeta1_dTermEs dTerm_typeEs dTerm.free_elims)
apply (rotate_tac [2] 7)
apply (simp_all del: ball_simps add: dAbst_dSubst_lemma2)
apply (rule_tac [4] dBeta1_dAppI2)
apply (rule_tac [3] dBeta1_dAppI1)
apply (rule_tac [2] dBeta1_baseI)
apply (rule_tac [1] dBeta1_dLamI)
apply (erule_tac [7] bspec [THEN bspec, THEN mp])
apply (erule_tac [4] bspec [THEN bspec, THEN mp])
apply (erule_tac [1] bspec [THEN bspec, THEN mp])
apply (assumption | rule dAbst_type nat_succI)+
done

lemma dBeta1_dSubst:
  assumes major: "dBeta1(M, M')"
  and prem1: "N: dProp"
  and prem2: "n: nat"
  shows "dBeta1(dSubst(M, n, N), dSubst(M', n, N))"
apply (rule prem1 [THEN dPropE])
apply (rule major [THEN rev_mp])
apply (rule prem2 [THEN [2] bspec])
apply (rule major [THEN dBeta1_type2, THEN [2] bspec])
apply (rule major [THEN dBeta1_type1, THEN dTerm.induct])
apply (simp_all del: ball_simps)
apply (safe elim!: dBeta1_dTermEs dTerm_typeEs dTerm.free_elims)
apply (rotate_tac [2] 8)
apply (simp_all del: ball_simps add: dDeg_dLift_lemma1
         dSubst_dSubst_lemma2)
apply (rule_tac [4] dBeta1_dAppI2)
apply (rule_tac [3] dBeta1_dAppI1)
apply (rule_tac [2] dBeta1_baseI)
apply (rule_tac [1] dBeta1_dLamI)
apply (erule_tac [7] bspec [THEN bspec, THEN mp])
apply (erule_tac [4] bspec [THEN bspec, THEN mp])
apply (erule_tac [1] bspec [THEN bspec, THEN mp])
apply (assumption | rule dSubst_type nat_succI)+
done

lemma dBeta1_dDeg_lemma:
  assumes major: "dBeta1(M, N)"
  shows "dDeg(N) \<le> dDeg(M)"
apply (rule major [THEN rev_mp])
apply (rule major [THEN dBeta1_type2, THEN [2] bspec])
apply (rule major [THEN dBeta1_type1, THEN dTerm.induct])
apply (safe elim!: dBeta1_dTermEs dTerm_typeEs)
apply (simp_all del: ball_simps)
apply (rule_tac [2] M1="N'" in dDeg_type [THEN natE])
prefer 3
apply (simp del: ball_simps add: dDeg_dSubst_lemma1)
apply (rule_tac [3] dDeg_dSubst_lemma2)
prefer 4 apply simp
apply (erule_tac [2] asm_rl | rule_tac [2] nat_0I)+
apply (drule_tac [3] bspec [THEN mp], erule_tac [3] dBeta1_type2,
       erule_tac [3] asm_rl)
apply (drule_tac [2] bspec [THEN mp], erule_tac [2] dBeta1_type2,
       erule_tac [2] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] dBeta1_type2,
       erule_tac [1] asm_rl)
apply (rule_tac M1="M" in dDeg_type [THEN natE])
apply (rotate_tac [2] 4)
apply (rotate_tac [3] 4)
prefer 2 apply simp
prefer 2 apply simp
apply safe
apply (erule_tac [1] le_trans)
apply (erule_tac [4] le_trans)
apply (assumption | rule Un_upper1_le Un_upper2_le
         nat_into_Ord dDeg_type)+
done

lemma dBeta1_dProp_lemma:
  assumes major: "dBeta1(M, N)"
  and prem: "M: dProp"
  shows "N: dProp"
apply (rule dPropI)
apply (rule major [THEN dBeta1_type2])
apply (insert prem [THEN dPropD2] major [THEN dBeta1_dDeg_lemma])
apply simp
done

lemma dBeta1_dFV_lemma:
  assumes major: "dBeta1(M, N)"
  shows "dFV(N) <= dFV(M)"
apply (rule major [THEN rev_mp])
apply (rule major [THEN dBeta1_type2, THEN [2] bspec])
apply (rule major [THEN dBeta1_type1, THEN dTerm.induct])
apply (safe elim!: dBeta1_dTermEs dTerm_typeEs)
apply (rotate_tac [3] 7)
apply (rotate_tac [4] 7)
apply simp_all
apply (drule_tac [4] bspec [THEN mp], erule_tac [5] asm_rl)
apply (drule_tac [3] bspec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [2] asm_rl)
apply (erule_tac [3] dFV_dSubst_lemma)
prefer 3
prefer 4
prefer 5
prefer 6
prefer 8
apply (erule dBeta1_type2 | assumption | rule nat_0I)+
apply safe
apply (drule_tac [3] subsetD, erule_tac [3] asm_rl)
apply (drule_tac [2] subsetD, erule_tac [2] asm_rl)
apply (drule_tac [1] subsetD, erule_tac [1] asm_rl)
apply safe
done

end


(*
 * Copyright 2023, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Lemmas about the no_fail predicate. *)

theory No_Fail
  imports
    In_Monad
    NonDetMonadVCG
    WPSimp
begin

subsection "Non-Failure"

text \<open>
  With the failure flag, we can formulate non-failure separately from validity.
  A monad @{text m} does not fail under precondition @{text P}, if for no start
  state that satisfies the precondition it sets the failure flag.
\<close>
definition no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> bool" where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> \<not>snd (m s)"

subsection \<open>@{method wpc} setup\<close>

lemma no_fail_pre[wp_pre]:
  "\<lbrakk> no_fail P f; \<And>s. Q s \<Longrightarrow> P s\<rbrakk> \<Longrightarrow> no_fail Q f"
  by (simp add: no_fail_def)

lemma wpc_helper_no_fail_final:
  "no_fail Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (no_fail P f)"
  by (clarsimp simp: wpc_helper_def elim!: no_fail_pre)

wpc_setup "\<lambda>m. no_fail P m" wpc_helper_no_fail_final

subsection \<open>Bundles\<close>

bundle no_pre = hoare_pre [wp_pre del] no_fail_pre [wp_pre del]

bundle classic_wp_pre =
  hoare_pre [wp_pre del]
  all_classic_wp_combs[wp_comb del]
  all_classic_wp_combs[wp_comb]

subsection \<open>Lemmas\<close>

lemma no_failD:
  "\<lbrakk> no_fail P m; P s \<rbrakk> \<Longrightarrow> \<not>(snd (m s))"
  by (simp add: no_fail_def)

lemma no_fail_modify[wp,simp]:
  "no_fail \<top> (modify f)"
  by (simp add: no_fail_def modify_def get_def put_def bind_def)

lemma no_fail_gets_simp[simp]:
  "no_fail P (gets f)"
  unfolding no_fail_def gets_def get_def return_def bind_def
  by simp

lemma no_fail_gets[wp]:
  "no_fail \<top> (gets f)"
  by simp

lemma no_fail_select[simp]:
  "no_fail \<top> (select S)"
  by (simp add: no_fail_def select_def)

lemma no_fail_alt[wp]:
  "\<lbrakk> no_fail P f; no_fail Q g \<rbrakk> \<Longrightarrow> no_fail (P and Q) (f \<sqinter> g)"
  by (simp add: no_fail_def alternative_def)

lemma no_fail_return[simp, wp]:
  "no_fail \<top> (return x)"
  by (simp add: return_def no_fail_def)

lemma no_fail_get[simp, wp]:
  "no_fail \<top> get"
  by (simp add: get_def no_fail_def)

lemma no_fail_put[simp, wp]:
  "no_fail \<top> (put s)"
  by (simp add: put_def no_fail_def)

lemma no_fail_when[wp]:
  "(P \<Longrightarrow> no_fail Q f) \<Longrightarrow> no_fail (if P then Q else \<top>) (when P f)"
  by (simp add: when_def)

lemma no_fail_unless[wp]:
  "(\<not>P \<Longrightarrow> no_fail Q f) \<Longrightarrow> no_fail (if P then \<top> else Q) (unless P f)"
  by (simp add: unless_def when_def)

lemma no_fail_fail[simp, wp]:
  "no_fail \<bottom> fail"
  by (simp add: fail_def no_fail_def)

lemma no_fail_assert[simp, wp]:
  "no_fail (\<lambda>_. P) (assert P)"
  by (simp add: assert_def)

lemma no_fail_assert_opt[simp, wp]:
  "no_fail (\<lambda>_. P \<noteq> None) (assert_opt P)"
  by (simp add: assert_opt_def split: option.splits)

lemma no_fail_case_option[wp]:
  assumes f: "no_fail P f"
  assumes g: "\<And>x. no_fail (Q x) (g x)"
  shows "no_fail (if x = None then P else Q (the x)) (case_option f g x)"
  by (clarsimp simp add: f g)

lemma no_fail_if[wp]:
  "\<lbrakk> P \<Longrightarrow> no_fail Q f; \<not>P \<Longrightarrow> no_fail R g \<rbrakk> \<Longrightarrow> no_fail (if P then Q else R) (if P then f else g)"
  by simp

lemma no_fail_apply[wp]:
  "no_fail P (f (g x)) \<Longrightarrow> no_fail P (f $ g x)"
  by simp

lemma no_fail_undefined[simp, wp]:
  "no_fail \<bottom> undefined"
  by (simp add: no_fail_def)

lemma no_fail_returnOK[simp, wp]:
  "no_fail \<top> (returnOk x)"
  by (simp add: returnOk_def)

lemma no_fail_bind[wp]:
  "\<lbrakk> no_fail P f; \<And>rv. no_fail (R rv) (g rv); \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> no_fail (P and Q) (f >>= (\<lambda>rv. g rv))"
  unfolding no_fail_def bind_def
  using post_by_hoare by fastforce

lemma no_fail_assume_pre:
  "(\<And>s. P s \<Longrightarrow> no_fail P f) \<Longrightarrow> no_fail P f"
  by (simp add: no_fail_def)

lemma no_fail_liftM_eq[simp]:
  "no_fail P (liftM f m) = no_fail P m"
  by (auto simp: liftM_def no_fail_def bind_def return_def)

lemma no_fail_select_f[wp]:
  "no_fail (\<lambda>s. \<not>snd S) (select_f S)"
  by (simp add: select_f_def no_fail_def)

lemma no_fail_liftM[wp]:
  "no_fail P m \<Longrightarrow> no_fail P (liftM f m)"
  by simp

lemma no_fail_pre_and:
  "no_fail P f \<Longrightarrow> no_fail (P and Q) f"
  by (erule no_fail_pre) simp

lemma no_fail_spec:
  "\<lbrakk> \<And>s. no_fail (((=) s) and P) f \<rbrakk> \<Longrightarrow> no_fail P f"
  by (simp add: no_fail_def)

lemma no_fail_assertE[wp]:
  "no_fail (\<lambda>_. P) (assertE P)"
  by (simp add: assertE_def split: if_split)

lemma no_fail_spec_pre:
  "\<lbrakk> no_fail (((=) s) and P') f; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> no_fail (((=) s) and P) f"
  by (erule no_fail_pre, simp)

lemma no_fail_whenE[wp]:
  "\<lbrakk> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. G \<longrightarrow> P s) (whenE G f)"
  by (simp add: whenE_def split: if_split)

lemma no_fail_unlessE[wp]:
  "\<lbrakk> \<not> G \<Longrightarrow> no_fail P f \<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. \<not> G \<longrightarrow> P s) (unlessE G f)"
  by (simp add: unlessE_def split: if_split)

lemma no_fail_throwError[wp]:
  "no_fail \<top> (throwError e)"
  by (simp add: throwError_def)

lemma no_fail_liftE[wp]:
  "no_fail P f \<Longrightarrow> no_fail P (liftE f)"
  unfolding liftE_def by wpsimp

lemma no_fail_gets_the[wp]:
  "no_fail (\<lambda>s. f s \<noteq> None) (gets_the f)"
  unfolding gets_the_def
  by wpsimp

lemma no_fail_lift:
  "(\<And>y. x = Inr y \<Longrightarrow> no_fail P (f y)) \<Longrightarrow> no_fail (\<lambda>s. \<not>isl x \<longrightarrow> P s) (lift f x)"
  unfolding lift_def
  by (wpsimp wp: no_fail_throwError split: sum.splits | assumption)+

lemma validE_R_valid_eq:
  "\<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, - = \<lbrace>Q\<rbrace> f \<lbrace>\<lambda>rv s. \<not> isl rv \<longrightarrow> R (projr rv) s\<rbrace>"
  unfolding validE_R_def validE_def valid_def
  by (fastforce split: sum.splits prod.split)

lemma no_fail_bindE[wp]:
  "\<lbrakk> no_fail P f; \<And>rv. no_fail (R rv) (g rv); \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>,- \<rbrakk>
     \<Longrightarrow> no_fail (P and Q) (f >>=E g)"
  unfolding bindE_def
  by (wpsimp wp: no_fail_lift simp: validE_R_valid_eq | assumption)+

lemma no_fail_False[simp]:
  "no_fail (\<lambda>_. False) X"
  by (clarsimp simp: no_fail_def)

lemma no_fail_gets_map[wp]:
  "no_fail (\<lambda>s. f s p \<noteq> None) (gets_map f p)"
  unfolding gets_map_def by wpsimp

lemma no_fail_or:
  "\<lbrakk>no_fail P a; no_fail Q a\<rbrakk> \<Longrightarrow> no_fail (P or Q) a"
  by (clarsimp simp: no_fail_def)

lemma no_fail_state_assert[wp]:
  "no_fail P (state_assert P)"
  unfolding state_assert_def
  by wpsimp

lemma no_fail_condition:
  "\<lbrakk>no_fail Q A; no_fail R B\<rbrakk> \<Longrightarrow> no_fail (\<lambda>s. (C s \<longrightarrow> Q s) \<and> (\<not> C s \<longrightarrow> R s)) (condition C A B)"
  unfolding condition_def no_fail_def
  by clarsimp

end


theory PiersonNew      (*Benzmüller, Fuenmayor & Lomfeld, 2020*)
  imports GeneralKnowledgeNew
begin (*** Pierson v. Post "wild animal" case **)

consts \<alpha>::"e" (*appropriated animal (fox in this case) *)

(*case-specific 'world-vocabulary'*)
consts Pursue::"c\<Rightarrow>e\<Rightarrow>\<sigma>"
consts Capture::"c\<Rightarrow>e\<Rightarrow>\<sigma>"

(*case-specific taxonomic (legal domain) knowledge*)
axiomatization where
 CW1: "\<lfloor>(\<^bold>\<exists>c. Capture c \<alpha> \<^bold>\<and> \<^bold>\<not>Domestic \<alpha>) \<^bold>\<rightarrow> appWildAnimal\<rfloor>" and
 CW2: "\<lfloor>\<^bold>\<forall>c. Pursue c \<alpha> \<^bold>\<rightarrow> Intent c\<rfloor>" and
 CW3: "\<lfloor>\<^bold>\<forall>c. Capture c \<alpha> \<^bold>\<rightarrow> Poss c\<rfloor>"

lemma True nitpick[satisfy,card i=4] oops (*satisfiable*)

(****************** pro-Pierson's argument ****************)
abbreviation "Pierson_facts \<equiv> \<lfloor>Fox \<alpha> \<^bold>\<and> (FreeRoaming \<alpha>) \<^bold>\<and> (\<^bold>\<not>Pet \<alpha>) \<^bold>\<and>
                        Pursue p \<alpha> \<^bold>\<and> (\<^bold>\<not>Pursue d \<alpha>) \<^bold>\<and> Capture d \<alpha>\<rfloor>"

(* a decision for defendant (Pierson) is compatible with premises*)
lemma "Pierson_facts \<and> \<lfloor>For p \<^bold>\<prec> For d\<rfloor>"
  nitpick[satisfy,card i=4] oops (*non-trivial model*)

(* a decision for plaintiff (Post) is compatible with premises*)
lemma "Pierson_facts \<and> \<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  nitpick[satisfy,card i=4] oops (* non-trivial model?*)

(* a decision for defendant (Pierson) is provable*)
lemma assumes Pierson_facts shows "\<lfloor>For p \<^bold>\<prec> For d\<rfloor>"
  using assms by (metis CW1 CW2 W6 W8 ForAx L2 R1 other.simps(2) rBR)
(*  while a decision for the plaintiff is countersatisfiable*)
lemma assumes Pierson_facts shows "\<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  nitpick oops (*counterexample found*)

(****************** pro-Post's argument ****************)

(*theory amendment: plaintiff claims to be a professional hunter*)
consts Prof::"c\<Rightarrow>\<sigma>"
axiomatization where (*case-specific legal rule*)
 CL1: "\<lfloor>(Pursue x \<alpha> \<^bold>\<and> Prof x \<^bold>\<and> Poss x\<inverse>)  \<^bold>\<rightarrow> (STAB\<^sup>x\<inverse> \<^bold>\<prec>\<^sub>v EFFI\<^sup>x)\<rfloor>"

abbreviation "Post_facts \<equiv> \<lfloor>Fox \<alpha> \<^bold>\<and> (\<^bold>\<not>Pet \<alpha>) \<^bold>\<and> Prof p \<^bold>\<and>
                        Pursue p \<alpha> \<^bold>\<and> (\<^bold>\<not>Pursue d \<alpha>) \<^bold>\<and> Capture d \<alpha>\<rfloor>"

(* a decision for plaintiff (Post) is compatible with premises*)
lemma "Post_facts \<and> \<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  nitpick[satisfy,card i=4] oops (*non-trivial model*)

(* a decision for plaintiff (Post) becomes provable*)
lemma assumes Post_facts shows "\<lfloor>For d \<^bold>\<prec> For p\<rfloor>"
  using assms by (metis CW3 ForAx CL1 R3 other.simps rBR)
(*  while a decision for the defendant is countersatisfiable*)
lemma assumes Post_facts shows "\<lfloor>For p \<^bold>\<prec> For d\<rfloor>"
  nitpick oops (* counterexample *)

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section \<open>Sublinearity\<close>

theory Sublinearity imports Embedding Healthiness LoopInduction begin

subsection \<open>Nonrecursive Primitives\<close>

text \<open>Sublinearity of non-recursive programs is generally straightforward, and follows from the
alebraic properties of the underlying operations, together with healthiness.\<close>

lemma sublinear_wp_Skip:
  "sublinear (wp Skip)"
  by(auto simp:wp_eval)

lemma sublinear_wp_Abort:
  "sublinear (wp Abort)"
  by(auto simp:wp_eval)

lemma sublinear_wp_Apply:
  "sublinear (wp (Apply f))"
  by(auto simp:wp_eval)

lemma sublinear_wp_Seq:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
      and hx:  "healthy (wp x)"   and hy:  "healthy (wp y)"
  shows "sublinear (wp (x ;; y))"
proof(rule sublinearI, simp add:wp_eval)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sP: "sound P" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  with slx hy have "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                    wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s"
    by(blast intro:sublinearD)
  also {
    from sP sQ nna nnb nnc sly
    have "\<And>s. a * wp y P s + b * wp y Q s \<ominus> c \<le>
              wp y (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
      by(blast intro:sublinearD)
    moreover from sP sQ hy
    have "sound (wp y P)" and "sound (wp y Q)" by(auto)
    moreover with nna nnb nnc
    have "sound (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c)"
      by(auto intro!:sound_intros tminus_sound)
    moreover from sP sQ nna nnb nnc
    have "sound (\<lambda>s. a * P s + b * Q s \<ominus> c)"
      by(auto intro!:sound_intros tminus_sound)
    moreover with hy have "sound (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c))"
      by(blast)
    ultimately
    have "wp x (\<lambda>s. a * wp y P s + b * wp y Q s \<ominus> c) s \<le>
          wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s"
      by(blast intro!:le_funD[OF mono_transD[OF healthy_monoD[OF hx]]])
  }
  finally show "a * wp x (wp y P) s + b * wp x (wp y Q) s \<ominus> c \<le>
                wp x (wp y (\<lambda>s. a * P s + b * Q s \<ominus> c)) s" .
qed

lemma sublinear_wp_PC:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
      and uP: "unitary P"
  shows "sublinear (wp (x \<^bsub>P\<^esub>\<oplus> y))"
proof(rule sublinearI, simp add:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  have "a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
        b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c =
        (P s * a * wp x Q s + (1 - P s) * a * wp y Q s) +
        (P s * b * wp x R s + (1 - P s) * b * wp y R s) \<ominus> c"
    by(simp add:field_simps)
  also
  have "... = (P s * a * wp x Q s + P s * b * wp x R s) +
              ((1 - P s) * a * wp y Q s + (1 - P s) * b * wp y R s) \<ominus> c"
    by(simp add:ac_simps)
  also
  have "... = P s * (a * wp x Q s + b * wp x R s) +
              (1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus>
              (P s * c + (1 - P s) * c)"
    by(simp add:field_simps)
  also
  have "... \<le> (P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
              ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c)"
    by(rule tminus_add_mono)
  also {
      from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
        by auto
      hence "(P s * (a * wp x Q s + b * wp x R s) \<ominus> P s * c) +
             ((1 - P s) * (a * wp y Q s + b * wp y R s) \<ominus> (1 - P s) * c) =
             P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
             (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c)"
        by(simp add:tminus_left_distrib)
  }
  also {
    from sQ sR nna nnb nnc slx
    have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
          wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from sQ sR nna nnb nnc sly
    have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
          wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from uP have "0 \<le> P s" and "0 \<le> 1 - P s"
      by auto
    ultimately
    have "P s * (a * wp x Q s + b * wp x R s \<ominus> c) +
          (1 - P s) * (a * wp y Q s + b * wp y R s  \<ominus> c) \<le>
          P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
          (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast intro:add_mono mult_left_mono)
  }
  finally
  show " a * (P s * wp x Q s + (1 - P s) * wp y Q s) +
         b * (P s * wp x R s + (1 - P s) * wp y R s) \<ominus> c \<le>
         P s * wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s +
         (1 - P s) * wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s" .
qed

lemma sublinear_wp_DC:
  fixes x::"'s prog"
  assumes slx: "sublinear (wp x)" and sly: "sublinear (wp y)"
  shows "sublinear (wp (x \<Sqinter> y))"
proof(rule sublinearI, simp only:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  from nna nnb
  have "a * min (wp x Q s) (wp y Q s) +
        b * min (wp x R s) (wp y R s) \<ominus> c =
        min (a * wp x Q s) (a * wp y Q s) +
        min (b * wp x R s) (b * wp y R s) \<ominus> c"
    by(simp add:min_distrib)
  also
  have "... \<le> min (a * wp x Q s + b * wp x R s)
                  (a * wp y Q s + b * wp y R s) \<ominus> c"
    by(auto intro!:tminus_left_mono)
  also
  have "... = min (a * wp x Q s + b * wp x R s \<ominus> c)
                  (a * wp y Q s + b * wp y R s \<ominus> c)"
    by(rule min_tminus_distrib)
  also {
    from slx sQ sR nna nnb nnc
    have "a * wp x Q s + b * wp x R s \<ominus> c \<le>
          wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    moreover
    from sly sQ sR nna nnb nnc
    have "a * wp y Q s + b * wp y R s \<ominus> c \<le>
          wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    ultimately
    have "min (a * wp x Q s + b * wp x R s \<ominus> c)
              (a * wp y Q s + b * wp y R s \<ominus> c) \<le>
          min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
              (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
      by(auto)
  }
  finally show "a * min (wp x Q s) (wp y Q s) +
                b * min (wp x R s) (wp y R s) \<ominus> c \<le>
               min (wp x (\<lambda>s. a * Q s + b * R s \<ominus> c) s)
                   (wp y (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
qed

text \<open>As for continuity, we insist on a finite support.\<close>
lemma sublinear_wp_SetPC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes slp: "\<And>s a. a \<in> supp (P s) \<Longrightarrow> sublinear (wp (p a))"
      and sum: "\<And>s. (\<Sum>a\<in>supp (P s). P s a) \<le> 1"
      and nnP: "\<And>s a. 0 \<le> P s a"
      and fin: "\<And>s. finite (supp (P s))"
  shows "sublinear (wp (SetPC p P))"
proof(rule sublinearI, simp add:wp_eval)
  fix R::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s
  and a::real and b::real and c::real
  assume sR: "sound R" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"
  have "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
        b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c =
        (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus> c"
    by(simp add:field_simps sum_distrib_left sum.distrib)
  also have "... \<le>
             (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s)) \<ominus>
             (\<Sum>a'\<in>supp (P s). P s a' * c)"
  proof(rule tminus_right_antimono)
    have "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> (\<Sum>a'\<in>supp (P s). P s a') * c"
      by(simp add:sum_distrib_right)
    also from sum and nnc have "... \<le> 1 * c"
      by(rule mult_right_mono)
    finally show "(\<Sum>a'\<in>supp (P s). P s a' * c) \<le> c" by(simp)
  qed
  also from fin
  have "... \<le> (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s) \<ominus> P s a' * c)"
    by(blast intro:tminus_sum_mono)
  also have "... = (\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c))"
    by(simp add:nnP tminus_left_distrib)
  also {
    from slp sQ sR nna nnb nnc
    have "\<And>a'. a' \<in> supp (P s) \<Longrightarrow> a * wp (p a') Q s + b * wp (p a') R s \<ominus> c \<le>
                                    wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s"
      by(blast)
    with nnP
    have "(\<Sum>a'\<in>supp (P s). P s a' * (a * wp (p a') Q s + b * wp (p a') R s \<ominus> c)) \<le>
          (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)"
      by(blast intro:sum_mono mult_left_mono)
  }
  finally
  show "a * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') Q s) +
        b * (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') R s) \<ominus> c \<le>
        (\<Sum>a'\<in>supp (P s). P s a' * wp (p a') (\<lambda>s. a * Q s + b * R s \<ominus> c) s)" .
qed

lemma sublinear_wp_SetDC:
  fixes p::"'a \<Rightarrow> 's prog"
  assumes slp: "\<And>s a. a \<in> S s \<Longrightarrow> sublinear (wp (p a))"
      and hp:  "\<And>s a. a \<in> S s \<Longrightarrow> healthy (wp (p a))"
      and ne:  "\<And>s. S s \<noteq> {}"
  shows "sublinear (wp (SetDC p S))"
proof(rule sublinearI, simp add:wp_eval, rule cInf_greatest)
  fix P::"'s \<Rightarrow> real" and Q::"'s \<Rightarrow> real" and s::'s and x y
  and a::real and b::real and c::real
  assume sP: "sound P" and sQ: "sound Q"
     and nna: "0 \<le> a" and nnb: "0 \<le> b" and nnc: "0 \<le> c"

  from ne show "(\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s \<noteq> {}" by(auto)

  assume yin: "y \<in> (\<lambda>pr. wp (p pr) (\<lambda>s. a * P s + b * Q s \<ominus> c) s) ` S s"
  then obtain x where xin: "x \<in> S s" and rwy: "y = wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
    by(auto)

  from xin hp sP nna
  have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) \<le> a * wp (p x) P s"
    by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
  moreover from xin hp sQ nnb
  have "b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<le> b * wp (p x) Q s"
    by(intro mult_left_mono[OF cInf_lower] bdd_belowI[where m=0], blast+)
  ultimately
  have "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) +
        b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le>
        a * wp (p x) P s + b * wp (p x) Q s \<ominus> c"
    by(blast intro:tminus_left_mono add_mono)

  also from xin slp sP sQ nna nnb nnc
  have "... \<le> wp (p x) (\<lambda>s. a * P s + b * Q s \<ominus> c) s"
    by(blast)

  finally show "a * Inf ((\<lambda>a. wp (p a) P s) ` S s) + b * Inf ((\<lambda>a. wp (p a) Q s) ` S s) \<ominus> c \<le> y"
    by(simp add:rwy)
qed

lemma sublinear_wp_Embed:
  "sublinear t \<Longrightarrow> sublinear (wp (Embed t))"
  by(simp add:wp_eval)

lemma sublinear_wp_repeat:
  "\<lbrakk> sublinear (wp p); healthy (wp p) \<rbrakk> \<Longrightarrow> sublinear (wp (repeat n p))"
  by(induct n, simp_all add:sublinear_wp_Seq sublinear_wp_Skip healthy_wp_repeat)

lemma sublinear_wp_Bind:
  "\<lbrakk> \<And>s. sublinear (wp (a (f s))) \<rbrakk> \<Longrightarrow> sublinear (wp (Bind f a))"
  by(rule sublinearI, simp add:wp_eval, auto)

subsection \<open>Sublinearity for Loops\<close>

text \<open>We break the proof of sublinearity loops into separate proofs of sub-distributivity and
sub-additivity.  The first follows by transfinite induction.\<close>
lemma sub_distrib_wp_loop:
  fixes body::"'s prog"
  assumes sdb: "sub_distrib (wp body)"
      and hb:  "healthy (wp body)"
      and nhb: "nearly_healthy (wlp body)"
  shows "sub_distrib (wp (do G \<longrightarrow> body od))"
proof -
  have "\<forall>P s. sound P \<longrightarrow> wp (do G \<longrightarrow> body od) P s \<ominus> 1 \<le>
                          wp (do G \<longrightarrow> body od) (\<lambda>s. P s \<ominus> 1) s"
  proof(rule loop_induct[OF hb nhb], safe)
    fix S::"('s trans \<times> 's trans) set" and P::"'s expect" and s::'s
    assume saS: "\<forall>x\<in>S. \<forall>P s. sound P \<longrightarrow> fst x P s \<ominus> 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s"
       and sP: "sound P"
       and fS: "\<forall>x\<in>S. feasible (fst x)"

    from sP have sPm: "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)

    have nnSup: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
    proof(cases "S={}", simp add:Sup_trans_def Sup_exp_def)
      fix s
      assume "S \<noteq> {}"
      then obtain x where xin: "x\<in>S" by(auto)
      with fS sPm have "0 \<le> fst x (\<lambda>s. P s \<ominus> 1) s" by(auto)
      also from xin fS sPm have "... \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
        by(auto intro!: le_funD[OF Sup_trans_upper2])
      finally show "?thesis s" .
    qed

    have "\<And>x s. fst x P s \<le> (fst x P s \<ominus> 1) + 1" by(simp add:tminus_def)
    also from saS sP
    have "\<And>x s. x\<in>S \<Longrightarrow> (fst x P s \<ominus> 1) + 1 \<le> fst x (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto intro:add_right_mono)
    also {
      from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
      with fS have "\<And>x s. x\<in>S \<Longrightarrow> fst x (\<lambda>s. P s \<ominus> 1) s + 1 \<le>
                                   Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
        by(blast intro!: add_right_mono le_funD[OF Sup_trans_upper2])
    }
    finally have le: "\<And>s. \<forall>x\<in>S. fst x P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto)
    moreover from nnSup have nn: "\<And>s. 0 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      by(auto intro:add_nonneg_nonneg)
    ultimately
    have leSup: "Sup_trans (fst ` S) P s \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1"
      unfolding Sup_trans_def
      by(intro le_funD[OF Sup_exp_least], auto)

    show "Sup_trans (fst ` S) P s \<ominus> 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s"
    proof(cases "Sup_trans (fst ` S) P s \<le> 1", simp_all add:nnSup)
      from leSup have "Sup_trans (fst ` S) P s - 1 \<le>
                       Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s + 1 - 1"
        by(auto)
      thus "Sup_trans (fst ` S) P s - 1 \<le> Sup_trans (fst ` S) (\<lambda>s. P s \<ominus> 1) s" by(simp)
    qed
  next
    fix t::"'s trans" and P::"'s expect" and s::'s
    assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
       and ft: "feasible t"
       and sP: "sound P"

     from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(auto intro:tminus_sound)
     with ft have s2: "sound (t (\<lambda>s. P s \<ominus> 1))" by(auto)
     from sP ft have "sound (t P)" by(auto)
     hence s3: "sound (\<lambda>s. t P s \<ominus> 1)" by(auto intro!:tminus_sound)

    show "wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) P s \<ominus> 1 \<le>
          wp (body ;; Embed t \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) (\<lambda>a. P a \<ominus> 1) s"
    proof(simp add:wp_eval)
      have "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 =
            \<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (\<guillemotleft>G\<guillemotright> s + (1 - \<guillemotleft>G\<guillemotright> s))"
        by(simp)
      also have "... \<le> (\<guillemotleft>G\<guillemotright> s * wp body (t P) s \<ominus> \<guillemotleft>G\<guillemotright> s) +
                        ((1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> (1 - \<guillemotleft>G\<guillemotright> s))"
        by(rule tminus_add_mono)
      also have "... = \<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
        by(simp add:tminus_left_distrib)
      also {
        from ft sP have "wp body (t P) s \<ominus> 1 \<le> wp body (\<lambda>s. t P s \<ominus> 1) s"
          by(auto intro:sub_distribD[OF sdb])
        also {
          from IH sP have "\<lambda>s. t P s \<ominus> 1 \<tturnstile> t (\<lambda>s. P s \<ominus> 1)" by(auto)
          with sP ft s2 s3 have "wp body (\<lambda>s. t P s \<ominus> 1) s \<le> wp body (t (\<lambda>s. P s \<ominus> 1)) s"
            by(blast intro:le_funD[OF mono_transD, OF healthy_monoD, OF hb])
        }
        finally have "\<guillemotleft>G\<guillemotright> s * (wp body (t P) s \<ominus> 1) + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1) \<le>
                      \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)"
          by(auto intro:add_right_mono mult_left_mono)
      }
      finally show "\<guillemotleft>G\<guillemotright> s * wp body (t P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s \<ominus> 1 \<le>
                    \<guillemotleft>G\<guillemotright> s * wp body (t (\<lambda>s. P s \<ominus> 1)) s + (1 - \<guillemotleft>G\<guillemotright> s) * (P s \<ominus> 1)" .
    qed
  next
    fix t t'::"'s trans" and P::"'s expect" and s::'s
    assume IH: "\<forall>P s. sound P \<longrightarrow> t P s \<ominus> 1 \<le> t (\<lambda>a. P a \<ominus> 1) s"
       and eq: "equiv_trans t t'" and sP: "sound P"

    from sP have "t' P s \<ominus> 1 = t P s \<ominus> 1" by(simp add:equiv_transD[OF eq])
    also from sP IH have "... \<le> t (\<lambda>s. P s \<ominus> 1) s" by(auto)
    also {
      from sP have "sound (\<lambda>s. P s \<ominus> 1)" by(simp add:tminus_sound)
      hence "t (\<lambda>s. P s \<ominus> 1) s = t' (\<lambda>s. P s \<ominus> 1) s" by(simp add:equiv_transD[OF eq])
    }
    finally show "t' P s \<ominus> 1 \<le> t' (\<lambda>s. P s \<ominus> 1) s" .
  qed
  thus ?thesis by(auto intro!:sub_distribI)
qed

text \<open>For sub-additivity, we again use the limit-of-iterates characterisation.  Firstly, all
iterates are sublinear:\<close>
lemma sublinear_iterates:
  assumes hb: "healthy (wp body)"
      and sb: "sublinear (wp body)"
  shows "sublinear (iterates body G i)"
  by(induct i, auto intro!:sublinear_wp_PC sublinear_wp_Seq sublinear_wp_Skip sublinear_wp_Embed
                           assms healthy_intros iterates_healthy)

text \<open>From this, sub-additivity follows for the limit (i.e. the loop), by appealing to the
property at all steps.\<close>
lemma sub_add_wp_loop:
  fixes body::"'s prog"
  assumes sb: "sublinear (wp body)"
      and cb:  "bd_cts (wp body)"
      and hwp:  "healthy (wp body)"
  shows "sub_add (wp (do G \<longrightarrow> body od))"
proof
  fix P Q::"'s expect" and s::'s
  assume sP: "sound P" and sQ: "sound Q"

  from hwp cb sP have "(\<lambda>i. iterates body G i P s) \<longlonglongrightarrow> wp do G \<longrightarrow> body od P s"
    by(rule loop_iterates)
  moreover
  from hwp cb sQ have "(\<lambda>i. iterates body G i Q s) \<longlonglongrightarrow> wp do G \<longrightarrow> body od Q s"
    by(rule loop_iterates)
  ultimately
  have "(\<lambda>i. iterates body G i P s + iterates body G i Q s) \<longlonglongrightarrow>
        wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s"
    by(rule tendsto_add)
  moreover {
    from sublinear_subadd[OF sublinear_iterates, OF hwp sb,
                          OF healthy_feasibleD[OF iterates_healthy, OF hwp]] sP sQ
    have "\<And>i. iterates body G i P s + iterates body G i Q s \<le> iterates body G i (\<lambda>s. P s + Q s) s"
      by(rule sub_addD)
  }
  moreover {
    from sP sQ have "sound (\<lambda>s. P s + Q s)" by(blast intro:sound_intros)
    with hwp cb have "(\<lambda>i. iterates body G i (\<lambda>s. P s + Q s) s) \<longlonglongrightarrow>
                           wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
      by(blast intro:loop_iterates)
  }
  ultimately
  show "wp do G \<longrightarrow> body od P s + wp do G \<longrightarrow> body od Q s \<le> wp do G \<longrightarrow> body od (\<lambda>s. P s + Q s) s"
    by(blast intro:LIMSEQ_le)
qed

lemmas sublinear_intros =
  sublinear_wp_Abort
  sublinear_wp_Skip
  sublinear_wp_Apply
  sublinear_wp_Seq
  sublinear_wp_PC
  sublinear_wp_DC
  sublinear_wp_SetPC
  sublinear_wp_SetDC
  sublinear_wp_Embed
  sublinear_wp_repeat
  sublinear_wp_Bind
  sublinear_wp_loop

end