(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Kripke
imports Main "Eval_Base.Eval_Base"
begin
(*>*)

section \<open>A modal logic of knowledge\<close>

text\<open>

\label{sec:kbps-logic-of-knowledge}

We begin with the standard syntax and semantics of the propositional
logic of knowledge based on \emph{Kripke structures}. More extensive
treatments can be found in \citet{Lenzen:1978}, \citet{Chellas:1980},
\citet{Hintikka:1962} and \citet[Chapter~2]{FHMV:1995}.

The syntax includes one knowledge modality per agent, and one for
\emph{common knowledge} amongst a set of agents. It is parameterised
by the type @{typ "'a"} of agents and @{typ "'p"} of propositions.

\<close>

datatype ('a, 'p) Kform
  = Kprop "'p"
  | Knot "('a, 'p) Kform"
  | Kand "('a, 'p) Kform" "('a, 'p) Kform"
  | Kknows "'a" "('a, 'p) Kform"  ("\<^bold>K\<^sub>_ _")
  | Kcknows "'a list" "('a, 'p) Kform" ("\<^bold>C\<^bsub>_\<^esub> _")

text\<open>

A Kripke structure consists of a set of \emph{worlds} of type @{typ
"'w"}, one \emph{accessibility relation} between worlds for each agent
and a \emph{valuation function} that indicates the truth of a
proposition at a world. This is a very general story that we will
quickly specialise.

\<close>

type_synonym 'w Relation = "('w \<times> 'w) set"

record ('a, 'p, 'w) KripkeStructure =
  worlds :: "'w set"
  relations :: "'a \<Rightarrow> 'w Relation"
  valuation :: "'w \<Rightarrow> 'p \<Rightarrow> bool"

definition kripke :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> bool" where
  "kripke M \<equiv> \<forall>a. relations M a \<subseteq> worlds M \<times> worlds M"

definition
  mkKripke :: "'w set \<Rightarrow> ('a \<Rightarrow> 'w Relation) \<Rightarrow> ('w \<Rightarrow> 'p \<Rightarrow> bool)
            \<Rightarrow> ('a, 'p, 'w) KripkeStructure"
where
  "mkKripke ws rels val \<equiv>
     \<lparr> worlds = ws, relations = \<lambda>a. rels a \<inter> ws \<times> ws, valuation = val \<rparr>"
(*<*)

lemma kripkeI[intro]:
  assumes "\<And>a. relations M a \<subseteq> worlds M \<times> worlds M"
  shows "kripke M"
  using assms unfolding kripke_def by simp

lemma kripke_rels_worlds[dest]:
  assumes "(w, w') \<in> relations M a"
  assumes M: "kripke M"
  shows "w \<in> worlds M \<and> w' \<in> worlds M"
  using assms unfolding kripke_def by auto

lemma kripke_tc_rels_worlds[dest]:
  assumes R: "(w, w') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
  assumes M: "kripke M"
  shows "w \<in> worlds M \<and> w' \<in> worlds M"
  using assms apply2 (induct rule: trancl_induct) by auto

lemma kripke_rels_trc_worlds:
  assumes R: "(w, w') \<in> (\<Union>a. relations M a)\<^sup>*"
  assumes w: "w \<in> worlds M"
  assumes M: "kripke M"
  assumes W: "W = worlds M"
  shows "w' \<in> W"
  using assms apply2 (induct rule: rtrancl_induct) by auto

lemma mkKripke_kripke[intro, simp]:
  "kripke (mkKripke ws rels val)"
  unfolding kripke_def mkKripke_def by clarsimp

lemma mkKripke_simps[simp]:
  "worlds (mkKripke ws rels val) = ws"
  "relations (mkKripke ws rels val) = (\<lambda>a. rels a \<inter> ws \<times> ws)"
  "valuation (mkKripke ws rels val) = val"
  unfolding mkKripke_def by simp_all
(*>*)

text \<open>

The standard semantics for knowledge is given by taking the
accessibility relations to be equivalence relations, yielding the
S$5_n$ structures, so-called due to their axiomatisation.

\<close>

definition S5n :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> bool" where
  "S5n M \<equiv> \<forall>a. equiv (worlds M) (relations M a)"
(*<*)

lemma S5nI[intro]: "\<lbrakk> \<And>a. equiv (worlds M) (relations M a) \<rbrakk> \<Longrightarrow> S5n M"
  by (simp add: S5n_def)

lemma S5nD[dest]: "S5n M \<Longrightarrow> equiv (worlds M) (relations M a)"
  by (simp add: S5n_def)

lemma S5n_kripke[intro]: "S5n M \<Longrightarrow> kripke M"
  by (rule kripkeI, erule equivE[OF S5nD], auto simp add: refl_on_def)

lemma S5n_rels_closed:
  "S5n M \<Longrightarrow> relations M a `` (relations M a `` X) \<subseteq> relations M a `` X"
  apply (drule S5nD[where a=a])
  apply (erule equivE)
  apply (auto dest: refl_onD symD transD)
  done

(*>*)

text\<open>

Intuitively an agent considers two worlds to be equivalent if it
cannot distinguish between them.

\<close>

subsection\<open>Satisfaction\<close>

text\<open>

A formula $\phi$ is satisfied at a world $w$ in Kripke structure $M$
in the following way:\<close>

fun models :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> ('a, 'p) Kform
           \<Rightarrow> bool" ("(_, _ \<Turnstile> _)" [80,0,80] 80) where
  "M, w \<Turnstile> (Kprop p) = valuation M w p"
| "M, w \<Turnstile> (Knot \<phi>) = (\<not> M, w \<Turnstile> \<phi>)"
| "M, w \<Turnstile> (Kand \<phi> \<psi>) = (M, w \<Turnstile> \<phi> \<and> M, w \<Turnstile> \<psi>)"
| "M, w \<Turnstile> (\<^bold>K\<^sub>a \<phi>) = (\<forall>w' \<in> relations M a `` {w}. M, w' \<Turnstile> \<phi>)"
| "M, w \<Turnstile> (\<^bold>C\<^bsub>as\<^esub> \<phi>) = (\<forall>w' \<in> (\<Union>a \<in> set as. relations M a)\<^sup>+ `` {w}. M, w' \<Turnstile> \<phi>)"

text\<open>

The first three clauses are standard.

The clause for @{term "Kknows a \<phi>"} expresses the idea that an agent
knows @{term "\<phi>"} at world @{term "w"} in structure @{term "M"} iff
@{term "\<phi>"} is true at all worlds it considers possible.

The clause for @{term "Kcknows as \<phi>"} captures what it means for the
set of agents @{term "as"} to commonly know @{term "\<phi>"}; roughly,
everyone knows @{term "\<phi>"} and knows that everyone knows it, and so
forth. Note that the transitive closure and the reflexive-transitive
closure generate the same relation due to the reflexivity of the
agents' accessibility relations; we use the former as it has a more
pleasant induction principle.

\<close>
(*<*)

lemma S5n_rels_eq:
  assumes S5n: "S5n M"
      and ww': "(w, w') \<in> relations M a"
  shows "relations M a `` {w} = relations M a `` {w'}"
  using S5nD[OF S5n] ww' by - (rule equiv_class_eq, blast+)

text\<open>

A key property of the semantics for common knowledge is that it forms
an equivalence class itself.

\<close>

lemma tc_equiv:
  assumes E: "\<And>i. i \<in> is \<Longrightarrow> equiv A (f i)"
      and is_nempty: "is \<noteq> {}"
  shows "equiv A ((\<Union>i\<in>is. f i)\<^sup>+)"
proof(rule equivI)
  from E is_nempty show "refl_on A ((\<Union>i\<in>is. f i)\<^sup>+)"
    unfolding equiv_def
    apply -
    apply (rule refl_onI)
    apply (rule trancl_Int_subset)
    apply (auto dest: refl_onD refl_onD1 refl_onD2)
    done
  from E show "sym ((\<Union>i\<in>is. f i)\<^sup>+)"
    apply -
    apply (rule sym_trancl)
    unfolding equiv_def sym_def by blast
  show "trans  ((\<Union>i\<in>is. f i)\<^sup>+)" by (rule trans_trancl)
qed

lemma S5n_tc_rels_eq:
  assumes S5n: "S5n M"
      and ww': "(w, w') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
  shows "(\<Union>a \<in> as. relations M a)\<^sup>+ `` {w} = (\<Union>a \<in> as. relations M a)\<^sup>+ `` {w'}"
  apply (cases "as = {}")
   apply fastforce
  apply (rule equiv_class_eq[OF _ ww'])
  apply (erule tc_equiv[OF S5nD[OF S5n]])
  done

text\<open>We can show that the standard S5 properties hold of this semantics:\<close>

lemma S5n_knowledge_generalisation:
  "\<lbrakk> S5n M; \<forall>w \<in> worlds M. M, w \<Turnstile> \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> Kknows a \<phi>"
  unfolding S5n_def equiv_def refl_on_def by auto

lemma S5n_knowledge:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Kknows a \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> \<phi>"
  unfolding S5n_def equiv_def refl_on_def by auto

lemma S5n_positive_introspection:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Kknows a \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> Kknows a (Kknows a \<phi>)"
  unfolding S5n_def equiv_def by simp (blast dest: transD)

lemma S5n_negative_introspection:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Knot (Kknows a \<phi>) \<rbrakk>
     \<Longrightarrow> M, w \<Turnstile> Kknows a (Knot (Kknows a \<phi>))"
  unfolding S5n_def equiv_def by simp (blast dest: symD transD)
(*>*)

text\<open>

The relation between knowledge and common knowledge can be understood
as follows, following \citet[\S2.4]{FHMV:1995}. Firstly, that $\phi$
is common knowledge to a set of agents $as$ can be seen as asserting
that everyone in $as$ knows $\phi$ and moreover knows that it is
common knowledge amongst $as$.

\<close>

lemma S5n_common_knowledge_fixed_point:
  assumes S5n: "S5n M"
  assumes w: "w \<in> worlds M"
  assumes a: "a \<in> set as"
  shows "M, w \<Turnstile> Kcknows as \<phi>
     \<longleftrightarrow> M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
(*<*)
proof
  assume CK: "M, w \<Turnstile> Kcknows as \<phi>"
  from S5n a w CK
  have "M, w \<Turnstile> Kknows a \<phi>"
   and "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
    by (auto intro: trancl_into_trancl2)
  then show "M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
    by simp
next
  assume "M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
  hence "M, w \<Turnstile> (Kknows a (Kcknows as \<phi>))" by simp
  with S5n w show "M, w \<Turnstile> (Kcknows as \<phi>)" by (rule S5n_knowledge)
qed

(*>*)
text\<open>

Secondly we can provide an induction schema for the introduction of
common knowledge: from everyone in $as$ knows that $\phi$ implies
$\phi \land \psi$, and that $\phi$ is satisfied at world $w$, infer
that $\psi$ is common knowledge amongst $as$ at $w$.

\<close>

lemma S5n_common_knowledge_induct:
  assumes S5n: "S5n M"
  assumes w: "w \<in> worlds M"
  assumes E: "\<forall>a \<in> set as. \<forall>w \<in> worlds M.
                 M, w \<Turnstile> \<phi> \<longrightarrow> M, w \<Turnstile> \<^bold>K\<^sub>a (Kand \<phi> \<psi>)"
  assumes p: "M, w \<Turnstile> \<phi>"
  shows "M, w \<Turnstile> \<^bold>C\<^bsub>as\<^esub> \<psi>"
(*<*)
proof -
  { fix w' assume ww': "(w, w') \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
    from ww' S5n E p w have "M, w' \<Turnstile> Kand \<phi> \<psi>"
      apply2 ( induct rule: trancl_induct)
      by( simp_all, blast+) }
  thus ?thesis by simp
qed

(* We actually use a simpler variant. *)

lemma S5n_common_knowledge_fixed_point_simpler:
  assumes S5n: "S5n M"
      and w: "w \<in> worlds M"
      and a: "a \<in> set as"
  shows "M, w \<Turnstile> Kcknows as \<phi> \<longleftrightarrow> M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
proof
  assume CK: "M, w \<Turnstile> Kcknows as \<phi>"
  from S5n a w CK show "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
    by (auto intro: trancl_into_trancl2)
next
  assume "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
  with S5n w show "M, w \<Turnstile> (Kcknows as \<phi>)" by (rule S5n_knowledge)
qed

(*>*)

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

subsection \<open>Generated models\<close>

text\<open>

\label{sec:generated_models}

The rest of this section introduces the technical machinery we use to
relate Kripke structures.

Intuitively the truth of a formula at a world depends only on the
worlds that are reachable from it in zero or more steps, using any of
the accessibility relations at each step. Traditionally this result is
called the \emph{generated model property}
\citep[\S3.4]{Chellas:1980}.

Given the model generated by @{term "w"} in @{term "M"}:

\<close>

definition
  gen_model :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> ('a, 'p, 'w) KripkeStructure"
where
  "gen_model M w \<equiv>
    let ws' = worlds M \<inter> (\<Union>a. relations M a)\<^sup>* `` {w}
     in \<lparr> worlds = ws',
          relations = \<lambda>a. relations M a \<inter> (ws' \<times> ws'),
          valuation = valuation M \<rparr>"
(*<*)

lemma gen_model_worldsD[dest]:
  "w' \<in> worlds (gen_model M w) \<Longrightarrow> w' \<in> worlds M"
  unfolding gen_model_def by simp

lemma gen_model_world_refl:
  "w \<in> worlds M \<Longrightarrow> w \<in> worlds (gen_model M w)"
  unfolding gen_model_def by simp

lemma gen_model_rels_worlds[dest]:
  assumes "(w', w'') \<in> relations (gen_model M w) a"
  shows "w' \<in> worlds (gen_model M w) \<and> w'' \<in> worlds (gen_model M w)"
  using assms unfolding gen_model_def by simp

lemma gen_model_rels_tc_worlds[dest]:
  assumes "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
  shows "w'' \<in> worlds (gen_model M w)"
  using assms apply2 (induct rule: trancl_induct) by auto

lemma gen_model_rels[dest]:
  assumes "(w', w'') \<in> relations (gen_model M w) a"
  shows "(w', w'') \<in> relations M a"
  using assms unfolding gen_model_def by simp

lemma gen_model_worlds:
  "worlds (gen_model M w) = worlds M \<inter> (\<Union>a. relations M a)\<^sup>* `` {w}"
  unfolding gen_model_def by simp

lemma gen_model_tc_rels[dest]:
  assumes M: "kripke M"
      and R: "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
  shows "(w', w'') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
using R
proof2(induct rule: trancl_induct)
  case (base y) with M show ?case by auto
next
  case (step y z)
  with M have "y \<in> worlds (gen_model M w)"
          and "z \<in> worlds (gen_model M w)" by auto
  with M step show ?case by (auto intro: trancl_into_trancl)
qed

lemma gen_model_rels_rev[dest]:
  assumes M: "kripke M"
      and "w' \<in> worlds (gen_model M w)"
      and "(w', w'') \<in> relations M a"
  shows "(w', w'') \<in> relations (gen_model M w) a"
  using assms
  unfolding gen_model_def by (auto intro: rtrancl_into_rtrancl)

lemma gen_model_tc_rels_rev[dest]:
  assumes M: "kripke M"
      and R: "(w', w'') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
      and W: "w' \<in> worlds (gen_model M w)"
  shows "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
using R W
proof2(induct rule: trancl_induct)
  case (base y) with M show ?case by auto
next
  case (step y z)
  with M have "y \<in> worlds (gen_model M w)"
          and "z \<in> worlds (gen_model M w)" by auto
  with M step show ?case by (auto intro: trancl_into_trancl)
qed

lemma gen_model_kripke:
  shows "kripke (gen_model M w)"
  unfolding gen_model_def by auto

(*>*)

text\<open>

where we take the image of @{term "w"} under the reflexive transitive
closure of the agents' relations, we can show that the satisfaction of
a formula @{term "\<phi>"} at a world @{term "w'"} is preserved, provided
@{term "w'"} is relevant to the world @{term "w"} that the sub-model
is based upon:

\<close>

lemma gen_model_semantic_equivalence:
  assumes M: "kripke M"
  assumes w': "w' \<in> worlds (gen_model M w)"
  shows "M, w' \<Turnstile> \<phi> \<longleftrightarrow> (gen_model M w), w' \<Turnstile> \<phi>"
(*<*)
proof -
  { fix w w' assume "w' \<in> worlds (gen_model M w)"
    hence "M, w' \<Turnstile> \<phi> \<longleftrightarrow> (gen_model M w), w' \<Turnstile> \<phi>"
    proof2(induct \<phi> arbitrary: w')
      case (Kknows a f w') show ?case
      proof
        assume lhs: "M, w' \<Turnstile> Kknows a f"
        with Kknows show "gen_model M w, w' \<Turnstile> Kknows a f" by auto
      next
        assume rhs: "gen_model M w, w' \<Turnstile> Kknows a f"
        with M Kknows show "M, w' \<Turnstile> Kknows a f"
          by (simp, blast)
      qed
    next
      case (Kcknows as f w') show ?case
      proof
        assume lhs: "M, w' \<Turnstile> Kcknows as f"
        with M Kcknows show "gen_model M w, w' \<Turnstile> Kcknows as f"
          by (simp, blast)
      next
        assume rhs: "gen_model M w, w' \<Turnstile> Kcknows as f"
        with M Kcknows show "M, w' \<Turnstile> Kcknows as f"
          by (simp, blast)
      qed
    qed (simp_all add: gen_model_def) }
  with w' show ?thesis by simp
qed
(*>*)

text\<open>

This is shown by a straightforward structural induction over the
formula @{term "\<phi>"}.

\<close>
(*<*)

lemma gen_model_S5n:
  assumes S5n: "S5n M"
  shows "S5n (gen_model M w)"
proof(intro S5nI equivI)
  show "\<And>n. refl_on (worlds (gen_model M w)) (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by - (rule refl_onI, auto simp add: refl_on_def gen_model_def)
  show "\<And>n. sym (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by (unfold gen_model_def sym_def, auto)
  show "\<And>n. trans (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by - (rule transI, simp add: gen_model_def, unfold trans_def, blast)
qed

text\<open>

If two models generate the same sub-model for a world, they satisfy
the same formulas at that world.

\<close>

lemma gen_model_eq:
  assumes M: "kripke M"
      and M': "kripke M'"
      and "gen_model M w = gen_model M' w"
      and "w' \<in> worlds (gen_model M' w)"
  shows "M, w' \<Turnstile> \<phi> \<longleftrightarrow> M', w' \<Turnstile> \<phi>"
  using assms gen_model_semantic_equivalence[OF M, where w=w]
              gen_model_semantic_equivalence[OF M', where w=w]
  by auto

text \<open>

Our final lemma in this section is technical: it allows us to move
between two Kripke structures that have the same relevant worlds.

\<close>

lemma gen_model_subset_aux:
  assumes R: "\<And>a. relations M a \<inter> T \<times> T = relations M' a \<inter> T \<times> T"
      and T: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> T"
  shows "(\<Union>x. relations M x)\<^sup>* `` {t} \<subseteq> (\<Union>x. relations M' x)\<^sup>* `` {t}"
proof -
  { fix x assume "(t, x) \<in> (\<Union>x. relations M x)\<^sup>*"
    hence "(t, x) \<in> (\<Union>x. relations M' x)\<^sup>*"
    proof2(induct rule: rtrancl_induct)
      case (step y z)
      with R T have "(y, z) \<in> (\<Union>a. relations M' a)"
        by auto (blast dest: rtrancl_trans)
      with step show ?case by (blast intro: rtrancl_trans)
    qed simp }
  thus ?thesis by blast
qed

lemma gen_model_subset:
  assumes M: "kripke M"
      and M': "kripke M'"
      and R: "\<And>a. relations M a \<inter> T \<times> T = relations M' a \<inter> T \<times> T"
      and tMT: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> T"
      and tM'T: "(\<Union>a. relations M' a)\<^sup>* `` {t} \<subseteq> T"
      and tM: "t \<in> worlds M"
      and tM': "t \<in> worlds M'"
      and V: "valuation M = valuation M'"
  shows "gen_model M t = gen_model M' t"
proof -
  from tMT tM'T gen_model_subset_aux[OF R] gen_model_subset_aux[OF R[symmetric]]
  have F: "(\<Union>a. relations M a)\<^sup>* `` {t} = (\<Union>a. relations M' a)\<^sup>* `` {t}"
    by - (rule, simp_all)

  from M tMT tM have G: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> worlds M"
    by (auto dest: kripke_rels_trc_worlds)
  from M' tM'T tM' have H: "(\<Union>a. relations M' a)\<^sup>* `` {t} \<subseteq> worlds M'"
    by (auto dest: kripke_rels_trc_worlds)

  from F G H have WORLDS: "worlds (gen_model M t) = worlds (gen_model M' t)"
    unfolding gen_model_def by (auto iff: Int_absorb1)

  have RELATIONS: "\<And>a. relations (gen_model M t) a = relations (gen_model M' t) a"
  proof (simp add: Int_absorb1 G H gen_model_def)
    fix a
    { fix a x y
      assume XY: "(x, y) \<in> relations M a \<inter> (\<Union>x. relations M x)\<^sup>* `` {t} \<times> (\<Union>x. relations M x)\<^sup>* `` {t}"
      from XY tMT
      have "(x, y) \<in> relations M a \<inter> T \<times> T" by blast
      with R
      have "(x, y) \<in> relations M' a \<inter> T \<times> T" by blast
      with F XY tM'T
      have "(x, y) \<in> relations M' a \<inter> (\<Union>x. relations M' x)\<^sup>* `` {t} \<times> (\<Union>x. relations M' x)\<^sup>* `` {t}"
        by blast }
    moreover
    { fix a x y
      assume XY: "(x, y) \<in> relations M' a \<inter> (\<Union>x. relations M' x)\<^sup>* `` {t} \<times> (\<Union>x. relations M' x)\<^sup>* `` {t}"
      from XY tM'T
      have "(x, y) \<in> relations M' a \<inter> T \<times> T" by blast
      with R
      have "(x, y) \<in> relations M a \<inter> T \<times> T" by blast
      with F XY tMT
      have "(x, y) \<in> relations M a \<inter> (\<Union>x. relations M x)\<^sup>* `` {t} \<times> (\<Union>x. relations M x)\<^sup>* `` {t}"
        by blast }
    ultimately show "Restr (relations M a) ((\<Union>x. relations M x)\<^sup>* `` {t}) =
      Restr (relations M' a) ((\<Union>x. relations M' x)\<^sup>* `` {t})"
    apply -
    apply rule
     apply rule
     apply auto[1]
    apply rule
    apply (case_tac x)
    apply (simp (no_asm_use))
    apply (metis Image_singleton_iff mem_Sigma_iff)
    done
  qed
  from WORLDS RELATIONS V show ?thesis
    unfolding gen_model_def by simp
qed

(*>*)

subsection \<open>Simulations\<close>

text\<open>

\label{sec:kripke-theory-simulations}

A \emph{simulation}, or \emph{p-morphism}, is a mapping from the
worlds of one Kripke structure to another that preserves the truth of
all formulas at related worlds \citep[\S3.4, Ex. 3.60]{Chellas:1980}.
Such a function @{term "f"} must satisfy four properties. Firstly, the
image of the set of worlds of @{term "M"} under @{term "f"} should
equal the set of worlds of @{term "M'"}.

\<close>

definition
  sim_range :: "('a, 'p, 'w1) KripkeStructure
              \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_range M M' f \<equiv> worlds M' = f ` worlds M
                    \<and> (\<forall>a. relations M' a \<subseteq> worlds M' \<times> worlds M')"

text\<open>The value of a proposition should be the same at corresponding
worlds:\<close>

definition
  sim_val :: "('a, 'p, 'w1) KripkeStructure
           \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_val M M' f \<equiv> \<forall>u \<in> worlds M. valuation M u = valuation M' (f u)"

text\<open>

If two worlds are related in @{term "M"}, then the simulation
maps them to related worlds in @{term "M'"}; intuitively the
simulation relates enough worlds. We term this the \emph{forward}
property.

\<close>

definition
  sim_f :: "('a, 'p, 'w1) KripkeStructure
         \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_f M M' f \<equiv>
     \<forall>a u v. (u, v) \<in> relations M a \<longrightarrow> (f u, f v) \<in> relations M' a"

text\<open>

Conversely, if two worlds @{term "f u"} and @{term "v'"} are related
in @{term "M'"}, then there is a pair of related worlds @{term "u"}
and @{term "v"} in @{term "M"} where @{term "f v = v'"}. Intuitively
the simulation makes enough distinctions. We term this the
\emph{reverse} property.

\<close>

definition
  sim_r :: "('a, 'p, 'w1) KripkeStructure
         \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_r M M' f \<equiv> \<forall>a. \<forall>u \<in> worlds M. \<forall>v'.
              (f u, v') \<in> relations M' a
           \<longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v')"

definition "sim M M' f \<equiv> sim_range M M' f \<and> sim_val M M' f
                       \<and> sim_f M M' f \<and> sim_r M M' f"
(*<*)

lemma sim_rangeI[intro]:
  "\<lbrakk> worlds M' = f ` worlds M; (\<And>a. relations M' a \<subseteq> worlds M' \<times> worlds M') \<rbrakk>
     \<Longrightarrow> sim_range M M' f"
  unfolding sim_range_def by simp

lemma sim_valI[intro]:
  "(\<And>u. u \<in> worlds M \<Longrightarrow> valuation M u = valuation M' (f u))
   \<Longrightarrow> sim_val M M' f"
  unfolding sim_val_def by simp

lemma sim_fI[intro]:
  "(\<And>a u v. (u, v) \<in> relations M a \<Longrightarrow> (f u, f v) \<in> relations M' a)
   \<Longrightarrow> sim_f M M' f"
  unfolding sim_f_def by simp

lemma sim_fD:
  "\<lbrakk> (u, v) \<in> relations M a; sim M M' f \<rbrakk>
     \<Longrightarrow> (f u, f v) \<in> relations M' a"
  unfolding sim_def sim_f_def by blast

lemma sim_rI[intro]:
  "(\<And>a u v'.
    \<lbrakk>u \<in> worlds M; (f u, v') \<in> relations M' a\<rbrakk>
    \<Longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v'))
  \<Longrightarrow> sim_r M M' f"
  unfolding sim_r_def by simp

lemma sim_rD:
  "\<lbrakk> (f u, v') \<in> relations M' a; sim M M' f; u \<in> worlds M \<rbrakk>
     \<Longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v')"
  unfolding sim_def sim_r_def by blast

lemma simI[intro]:
  "\<lbrakk> sim_range M M' f; sim_val M M' f; sim_f M M' f; sim_r M M' f \<rbrakk>
     \<Longrightarrow> sim M M' f"
  unfolding sim_def by simp

text\<open>The identity is a simulation:\<close>

lemma sim_id: "kripke M \<Longrightarrow> sim M M id"
(*<*)
  unfolding sim_def sim_r_def sim_f_def sim_range_def sim_val_def
  by auto
(*>*)

(*>*)

text\<open>

Due to the common knowledge modality, we need to show the simulation
properties lift through the transitive closure. In particular we can
show that forward simulation is preserved:

\<close>

Reverse simulation also:

\<close>

lemma sim_r_tc:
  assumes M: "kripke M"
  assumes s: "sim M M' f"
  assumes u: "u \<in> worlds M"
  assumes fuv': "(f u, v') \<in> (\<Union>a\<in>as. relations M' a)\<^sup>+"
  obtains v where "f v = v'" and "(u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
(*<*)
proof -
  assume E: "\<And>v. \<lbrakk>f v = v'; (u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+\<rbrakk> \<Longrightarrow> thesis"

  from fuv' have as_nempty: "as \<noteq> {}" by auto
  from fuv' have "\<exists>v. f v = v' \<and> (u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
  proof2(induct rule: trancl_induct)
    case (base v') with u s as_nempty show ?case
      by (blast dest: sim_rD)
  next
    case (step v' w')
    hence fuv': "(f u, v') \<in> (\<Union>a\<in>as. relations M' a)\<^sup>+"
      and v'w': "(v', w') \<in> (\<Union>a\<in>as. relations M' a)" by fast+
    from step
    obtain v where vv': "f v = v'"
               and uv: "(u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
      by blast
    from s v'w' vv' kripke_tc_rels_worlds[OF uv M]
    obtain w where ww': "f w = w'"
               and vw: "(v, w) \<in> (\<Union>a\<in>as. relations M a)"
      by (blast dest: sim_rD)
    from uv vw ww' show ?case by (blast intro: trancl_trans)
  qed
  with E show thesis by blast
qed

lemma sim_f_trc:
  assumes uv': "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
      and s: "sim M M' f"
  shows "(f u, f v) \<in> (\<Union>a. relations M' a)\<^sup>*"
  using assms
  apply - apply2( induct rule: rtrancl_induct[OF uv'])
  by( auto dest: sim_fD intro: rtrancl_into_rtrancl )

lemma sim_r_trc:
  assumes s: "sim M M' f"
      and fuv': "(f u, v') \<in> (\<Union>a. relations M' a)\<^sup>*"
      and M: "kripke M"
      and u: "u \<in> worlds M"
  obtains v
    where "f v = v'"
      and "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
proof -
  assume E: "\<And>v. \<lbrakk>f v = v'; (u, v) \<in> (\<Union>a. relations M a)\<^sup>*\<rbrakk> \<Longrightarrow> thesis"
  from fuv' have "\<exists>v. f v = v' \<and> (u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
  proof2(induct rule: rtrancl_induct)
    case base show ?case by blast
  next
    case (step v' w')
    hence fuv': "(f u, v') \<in> (\<Union>a. relations M' a)\<^sup>*"
      and v'w': "(v', w') \<in> (\<Union>a. relations M' a)" by fast+
    from step
    obtain v where vv': "f v = v'"
               and uv: "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
      by blast
    from s v'w' vv' kripke_rels_trc_worlds[OF uv u M]
    obtain w where ww': "f w = w'"
               and vw: "(v, w) \<in> (\<Union>a. relations M a)"
      by (blast dest: sim_rD)
    from uv vw ww' show ?case by (blast intro: rtrancl_trans)
  qed
  with E show thesis by blast
qed

lemma sim_kripke: "\<lbrakk> sim M M' f; kripke M \<rbrakk> \<Longrightarrow> kripke M'"
  unfolding sim_def sim_range_def by (rule kripkeI, blast)

lemma sim_S5n:
  assumes S5n: "S5n M"
      and sim: "sim M M' f"
  shows "S5n M'"
proof(intro S5nI equivI)
  fix a from S5n sim show "refl_on (worlds M') (relations M' a)"
     using sim_kripke S5n_kripke
     unfolding S5n_def equiv_def sim_def sim_f_def sim_range_def
     by - (rule refl_onI, (simp, blast dest: refl_onD)+)
next
  fix a
  { fix u v assume uv: "(u, v) \<in> relations M' a"
    from sim uv
    obtain u' where uw: "u' \<in> worlds M"
                and fu: "u = f u'"
      unfolding sim_def sim_range_def by bestsimp
    from sim uv fu uw
    obtain v' where u'v': "(u', v') \<in> relations M a"
                and fv: "v = f v'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n u'v' have "(v', u') \<in> relations M a"
      unfolding S5n_def equiv_def by (blast dest: symD)
    with sim fu fv have "(v, u) \<in> relations M' a"
      unfolding sim_def sim_f_def by simp }
  thus "sym (relations M' a)" by (blast intro: symI)
next
  fix a
  { fix x y z
    assume xy: "(x, y) \<in> relations M' a"
       and yz: "(y, z) \<in> relations M' a"
    from sim xy
    obtain x' where xw: "x' \<in> worlds M"
                and fx: "x = f x'"
      unfolding sim_def sim_range_def by bestsimp
    from sim xy fx xw
    obtain y' where x'y': "(x', y') \<in> relations M a"
                and fy: "y = f y'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n sim yz fy x'y'
    obtain z' where y'z': "(y', z') \<in> relations M a"
                and fz: "z = f z'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n x'y' y'z' have "(x', z') \<in> relations M a"
      unfolding S5n_def equiv_def by (blast dest: transD)
    with sim fx fy fz have "(x, z) \<in> relations M' a"
      unfolding sim_def sim_f_def by simp }
  thus "trans (relations M' a)" by (blast intro: transI)
qed

(*>*)
text\<open>

Finally we establish the key property of simulations, that they
preserve the satisfaction of all formulas in the following way:

\<close>

lemma sim_semantic_equivalence:
  assumes M: "kripke M"
  assumes s: "sim M M' f"
  assumes u: "u \<in> worlds M"
  shows "M, u \<Turnstile> \<phi> \<longleftrightarrow> M', f u \<Turnstile> \<phi>"
(*<*)
using u
proof2(induct \<phi> arbitrary: u)
  case (Kknows a \<psi> u)
  hence u: "u \<in> worlds M" by fast
  show ?case
  proof
    assume lhs: "M, u \<Turnstile> Kknows a \<psi>"
    { fix v' assume "(f u, v') \<in> relations M' a"
      with s u obtain v where uv:  "(u, v) \<in> relations M a"
                          and vv': "f v = v'"
        by (blast dest: sim_rD)
      from lhs uv have "M, v \<Turnstile> \<psi>" by simp
      with kripke_rels_worlds[OF uv M] vv' Kknows
      have "M', v' \<Turnstile> \<psi>" by auto }
    thus "M', f u \<Turnstile> Kknows a \<psi>" by simp
  next
    assume rhs: "M', f u \<Turnstile> Kknows a \<psi>"
    { fix v assume uv: "(u, v) \<in> relations M a"
      with s have "(f u, f v) \<in> relations M' a"
        by (blast dest: sim_fD)
      with rhs have "M', f v \<Turnstile> \<psi>" by simp
      with kripke_rels_worlds[OF uv M] Kknows s
      have "M, v \<Turnstile> \<psi>" by auto }
    thus "M, u \<Turnstile> Kknows a \<psi>" by simp
  qed
next
  case (Kcknows as \<psi>)
  hence u: "u \<in> worlds M" by fast
  show ?case
  proof
    assume lhs: "M, u \<Turnstile> Kcknows as \<psi>"
    { fix v' assume "(f u, v') \<in> (\<Union>x\<in>set as. relations M' x)\<^sup>+"
      with M s u
      obtain v where uv:  "(u, v) \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
                and vv': "f v = v'"
        by (blast intro: sim_r_tc)
      from uv lhs have "M, v \<Turnstile> \<psi>" by simp
      with kripke_tc_rels_worlds[OF uv M] vv' Kcknows
      have "M', v' \<Turnstile> \<psi>" by auto }
    thus "M', f u \<Turnstile> Kcknows as \<psi>" by simp
  next
    assume rhs: "M', f u \<Turnstile> Kcknows as \<psi>"
    { fix v assume uv: "(u, v) \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
      with s have "(f u, f v) \<in> (\<Union>x\<in>set as. relations M' x)\<^sup>+"
        by (blast dest: sim_f_tc)
      with rhs have "M', f v \<Turnstile> \<psi>" by simp
      with kripke_tc_rels_worlds[OF uv M] Kcknows s
      have "M, v \<Turnstile> \<psi>" by auto }
    thus "M, u \<Turnstile> Kcknows as \<psi>" by simp
  qed
qed (insert s,
     auto simp add: sim_range_def sim_def sim_val_def)
(*>*)

text\<open>

The proof is by structural induction over the formula @{term "\<phi>"}. The
knowledge cases appeal to our two simulation preservation lemmas.

\citet{DBLP:journals/toplas/Sangiorgi09} surveys the history of
p-morphisms and the related concept of \emph{bisimulation}.

This is all we need to know about Kripke structures.

\<close>

(*<*)
end
(*>*)


theory nat_acc_alt_mul_same
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun mult :: "Nat => Nat => Nat" where
"mult (Z) y = Z"
| "mult (S n) y = plus y (mult n y)"

fun accplus :: "Nat => Nat => Nat" where
"accplus (Z) y = y"
| "accplus (S z) y = accplus z (S y)"

fun accaltmul :: "Nat => Nat => Nat" where
"accaltmul (Z) y = Z"
| "accaltmul (S z) (Z) = Z"
| "accaltmul (S z) (S x2) =
     S (accplus z (accplus x2 (accaltmul z x2)))"

(*hipster plus mult accplus accaltmul *)

theorem x0 :
  "!! (x :: Nat) . !! (y :: Nat) . (accaltmul x y) = (mult x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Surprise_Paradox
imports
  Incompleteness.Goedel_I
  Incompleteness.Pseudo_Coding
begin

text \<open>
The Surprise Paradox comes in a few variations, one being the following:

\begin{quote}
A judge sentences a felon to death by hanging, to be executed at noon the next week, Monday to
Friday. As an extra punishment, the judge does not disclose the day of the hanging and promises the
felon that it will come at a surprise.

The felon, probably a logician, then concludes that he cannot be hanged on Friday, as by then it would
not longer be a surprise. Using this fact and similar reasoning, he cannot be hanged on Thursday, and so
on. He reaches the conclusion that he cannot be hanged at all, and contently returns to his cell.

Wednesday, at noon, the hangman comes to the very surprised felon, and executes him.
\end{quote}

Obviously, something is wrong here: Does the felon reason wrongly? It looks about right.
Or is the judge lying? But his prediction became true!

It is an interesting exercise to try to phrase the Surprise Paradox in a rigorous manner, and
see this might clarify things.

In 1964, Frederic Fitch suggested a formulation that refines the notion of ``surprise'' as
``cannot be proven from the given assumptions'' @{cite Fitch}. To formulate that, we need propositions that
reference their own provability, so just as Fitch builds on Gödel's work, we build on Paulson's
formalisation of Gödel's incompleteness theorems in Isabelle @{cite Incompleteness}.
\<close>

section \<open>Excluded or\<close>

text \<open>Although the proof goes through with regular disjunction, Fitch phrases the judge's
proposition using exclusive or, so we add syntax for that.\<close>

abbreviation Xor :: "fm \<Rightarrow> fm \<Rightarrow> fm" (infix "XOR" 120)
 where "Xor A B \<equiv> (A OR B) AND ((Neg A) OR (Neg B))"

section \<open>Formulas with variables\<close>

text \<open>
In Paulson's formalisation of terms and formulas, only terms carry variables. This is sufficient for
his purposes, because the proposition that is being diagonalised needs itself as a parameter to
@{term_type PfP}, which does take a term (which happens to be a quoted formula).

In order to stay close to Fitch, we need the diagonalised proposition to occur deeper in a quotation
of a few logical conjunctions. Therefore, we build a small theory of formulas with variables (``holed''
formulas). These support substituting a formula for a variable, this substitution commutes with
quotation, and closed holed formulas can be converted to regular formulas.

In our application, we do not need holes under an quantifier, which greatly simplifies things here.
In particular, we can use @{command datatype} and @{command fun}.
\<close>

datatype hfm =
   HVar name
 | HFm fm
 | HDisj hfm hfm (infixr "HOR" 130)
 | HNeg  hfm

abbreviation HImp :: "hfm \<Rightarrow> hfm \<Rightarrow> hfm"  (infixr "HIMP" 125)
  where "HImp A B \<equiv> HDisj (HNeg A) B"

definition HConj :: "hfm \<Rightarrow> hfm \<Rightarrow> hfm"   (infixr "HAND" 135)
  where "HConj A B \<equiv> HNeg (HDisj (HNeg A) (HNeg B))"

abbreviation HXor :: "hfm \<Rightarrow> hfm \<Rightarrow> hfm" (infix "HXOR" 120)
 where "HXor A B \<equiv> (A HOR B) HAND (HNeg A HOR HNeg B)"

fun  subst_hfm :: "hfm \<Rightarrow> name \<Rightarrow> fm \<Rightarrow> hfm" ("_'(_:::=_')" [1000, 0, 0] 200)
  where
    "(HVar name)(i:::=x) = (if i = name then HFm x else HVar name)"
  | "(HDisj A B)(i:::=x) = HDisj (A(i:::=x)) (B(i:::=x))"
  | "(HNeg A)(i:::=x) = HNeg (A(i:::=x))"
  | "(HFm A)(i:::=x) = HFm A"

lemma subst_hfml_Conj[simp]:
  "(HConj A B)(i:::=x) = HConj (A(i:::=x)) (B(i:::=x))"
 unfolding HConj_def by simp

instantiation hfm :: quot
begin
fun quot_hfm :: "hfm \<Rightarrow> tm"
  where
   "quot_hfm (HVar name) = (Var name)"
 | "quot_hfm (HFm A) = \<guillemotleft>A\<guillemotright>"
 | "quot_hfm (HDisj A B) = HPair (HTuple 3) (HPair (quot_hfm A) (quot_hfm B))"
 | "quot_hfm (HNeg A) = HPair (HTuple 4) (quot_hfm A)"

instance ..
end

lemma subst_quot_hfm[simp]: "subst i \<guillemotleft>P\<guillemotright> \<guillemotleft>A\<guillemotright> = \<guillemotleft>A(i:::=P)\<guillemotright>"
  by (induction A) auto

fun hfm_to_fm :: "hfm \<Rightarrow> fm"
  where
   "hfm_to_fm (HVar name) = undefined"
 | "hfm_to_fm (HFm A) = A"
 | "hfm_to_fm (HDisj A B) = Disj (hfm_to_fm A) (hfm_to_fm B)"
 | "hfm_to_fm (HNeg A) = Neg (hfm_to_fm A)"

lemma hfm_to_fm_Conj[simp]:
  "hfm_to_fm (HConj A B) = Conj (hfm_to_fm A) (hfm_to_fm B)"
unfolding HConj_def Conj_def by simp

fun closed_hfm  :: "hfm \<Rightarrow> bool"
  where
   "closed_hfm (HVar name) \<longleftrightarrow> False"
 | "closed_hfm (HFm A) \<longleftrightarrow> True"
 | "closed_hfm (HDisj A B) \<longleftrightarrow> closed_hfm A \<and> closed_hfm B"
 | "closed_hfm (HNeg A) \<longleftrightarrow> closed_hfm A"

lemma closed_hfm_Conj[simp]:
  "closed_hfm (HConj A B) \<longleftrightarrow> closed_hfm A \<and> closed_hfm B"
unfolding HConj_def by simp

lemma quot_closed_hfm[simp]: "closed_hfm A \<Longrightarrow> \<guillemotleft>A\<guillemotright> = \<guillemotleft>hfm_to_fm A\<guillemotright>"
  by (induction A) (auto simp add: quot_fm_def)

declare quot_hfm.simps[simp del]

section \<open>Fitch's proof\<close>

text \<open>
For simplicity, Fitch (and we) restrict the week to two days. Propositions \<open>Q\<^sub>1\<close> and \<open>Q\<^sub>2\<close>
represent the propositions that the hanging occurs on the first resp.\@ the second day, but
these can obviously be any propositions.
\<close>

context
  fixes Q\<^sub>1 :: fm and Q\<^sub>2 :: fm
  assumes Q_closed: "supp Q\<^sub>1 = {}" "supp Q\<^sub>2 = {}"
begin

  text \<open>
  In order to define the judge's proposition, which is self-referential, we apply the usual trick
  of defining a proposition with a variable, and then using Gödel's diagonalisation lemma.
  \<close>

  definition H :: fm where
    "H = Q\<^sub>1 AND Neg (PfP \<guillemotleft>HVar X0 HIMP HFm Q\<^sub>1\<guillemotright>) XOR
     Q\<^sub>2 AND Neg (PfP \<guillemotleft>HVar X0 HAND HNeg (HFm Q\<^sub>1) HIMP (HFm Q\<^sub>2)\<guillemotright>)"

  definition P where "P = (SOME P. {} \<turnstile> P IFF H(X0 ::= \<guillemotleft>P\<guillemotright>))"

  lemma P': "{} \<turnstile> P IFF H(X0 ::= \<guillemotleft>P\<guillemotright>)"
  proof-
    from diagonal[where \<alpha> = "H" and i = X0]
    obtain \<delta> where "{} \<turnstile> \<delta> IFF H(X0 ::= \<guillemotleft>\<delta>\<guillemotright>)".
    thus ?thesis  unfolding P_def by (rule someI)
  qed

  text \<open>
  From now on, the lemmas are named after their number in Fitch's paper, and correspond to his
  statements pleasingly closely.
  \<close>

  lemma 7: "{} \<turnstile> P IFF
     (Q\<^sub>1 AND Neg (PfP \<guillemotleft>P IMP Q\<^sub>1\<guillemotright>) XOR
      Q\<^sub>2 AND Neg (PfP \<guillemotleft>P AND Neg Q\<^sub>1 IMP Q\<^sub>2\<guillemotright>))"
    using P' unfolding H_def
    by (simp add: Q_closed forget_subst_fm[unfolded fresh_def])
  lemmas "7_E" = 7[THEN thin0, THEN Iff_MP_left', OF Conj_E, OF thin2]

  lemmas propositional_calculus =
    AssumeH Neg_I Imp_I Conj_E Disj_E ExFalso[OF Neg_E]
    ExFalso[OF rotate2, OF Neg_E] ExFalso[OF rotate3, OF Neg_E]

  lemma 8: "{} \<turnstile> (P AND Neg Q\<^sub>1) IMP Q\<^sub>2"
    by (intro propositional_calculus "7_E")

  lemma 10: "{} \<turnstile> PfP \<guillemotleft>(P AND Neg Q\<^sub>1) IMP Q\<^sub>2\<guillemotright>"
    using 8 by (rule proved_imp_proved_PfP)
  lemmas "10_I" = 10[THEN thin0]

  lemma 11: "{} \<turnstile> P IMP Q\<^sub>1"
    by (intro propositional_calculus "7_E" "10_I")

  lemma 12: "{} \<turnstile> PfP \<guillemotleft>P IMP Q\<^sub>1\<guillemotright>"
    using 11 by (rule proved_imp_proved_PfP)
  lemmas "12_I" = 12[THEN thin0]

  lemma 13: "{} \<turnstile> Neg P"
    by (intro propositional_calculus "7_E" "10_I" "12_I")
end

section \<open>Substitution, quoting and V-quoting\<close>

text \<open>In the end, we did not need the lemma at the end of this section, but it may be useful to
others.\<close>

lemma trans_tm_forgets: "atom ` set is \<sharp>* t \<Longrightarrow> trans_tm is t = trans_tm [] t"
  by (induct t rule: tm.induct)
     (auto simp: lookup_notin fresh_star_def fresh_at_base)

lemma vquot_dbtm_fresh: "atom ` V \<sharp>* t \<Longrightarrow> vquot_dbtm V t = quot_dbtm t"
  by (nominal_induct t rule: dbtm.strong_induct)
     (auto simp add: fresh_star_def fresh_at_base)

lemma subst_vquot_dbtm_trans_tm[simp]:
  "atom i \<sharp> is \<Longrightarrow> atom ` set is \<sharp>* t \<Longrightarrow>
   subst i \<guillemotleft>t\<guillemotright> (vquot_dbtm {i} (trans_tm is t')) =
   quot_dbtm (trans_tm is (subst i t t'))"
  by (nominal_induct t' avoiding: "is" i t rule: tm.strong_induct)
     (auto simp add:  quot_tm_def lookup_notin fresh_imp_notin_env
                      vquot_dbtm_fresh lookup_fresh
           intro: trans_tm_forgets[symmetric])

lemma subst_vquot_dbtm_trans_fm[simp]:
  "atom i \<sharp> is \<Longrightarrow> atom ` set is \<sharp>* t \<Longrightarrow>
   subst i \<guillemotleft>t\<guillemotright> (vquot_dbfm {i} (trans_fm is A)) =
   quot_dbfm (trans_fm is (subst_fm A i t))"
  by (nominal_induct A avoiding: "is" i t rule: fm.strong_induct)
     (auto simp add: quot_fm_def fresh_Cons)

lemma subst_vquot[simp]:
  "subst i \<guillemotleft>t\<guillemotright> \<lfloor>A\<rfloor>{i} = \<guillemotleft>A(i ::= t)\<guillemotright>"
  by (nominal_induct A avoiding: i t rule: fm.strong_induct)
     (auto simp add: vquot_fm_def quot_fm_def fresh_Cons)

end


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

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

section \<open>Continuity\<close>

theory Continuity imports Healthiness begin

text \<open>We rely on one additional healthiness property, continuity, which is shown here seperately,
as its proof relies, in general, on healthiness.  It is only relevant when a program appears
in an inductive context i.e.~inside a loop.\<close>

text \<open>A continuous transformer preserves limits (or the suprema of ascending chains).\<close>
definition bd_cts :: "'s trans \<Rightarrow> bool"
where "bd_cts t = (\<forall>M. (\<forall>i. (M i \<tturnstile> M (Suc i)) \<and> sound (M i)) \<longrightarrow>
                       (\<exists>b. \<forall>i. bounded_by b (M i)) \<longrightarrow>
                       t (Sup_exp (range M)) = Sup_exp (range (t o M)))"

lemma bd_ctsD:
  "\<lbrakk> bd_cts t; \<And>i. M i \<tturnstile> M (Suc i); \<And>i. sound (M i); \<And>i. bounded_by b (M i) \<rbrakk> \<Longrightarrow>
   t (Sup_exp (range M)) = Sup_exp (range (t o M))"
  unfolding bd_cts_def by(auto)

lemma bd_ctsI:
  "(\<And>b M. (\<And>i. M i \<tturnstile> M (Suc i)) \<Longrightarrow> (\<And>i. sound (M i)) \<Longrightarrow> (\<And>i. bounded_by b (M i)) \<Longrightarrow>
         t (Sup_exp (range M)) = Sup_exp (range (t o M))) \<Longrightarrow> bd_cts t"
  unfolding bd_cts_def by(auto)

text \<open>A generalised property for transformers of transformers.\<close>
definition bd_cts_tr :: "('s trans \<Rightarrow> 's trans) \<Rightarrow> bool"
where "bd_cts_tr T = (\<forall>M. (\<forall>i. le_trans (M i) (M (Suc i)) \<and> feasible (M i)) \<longrightarrow>
                          equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV)))"

lemma bd_cts_trD:
  "\<lbrakk> bd_cts_tr T; \<And>i. le_trans (M i) (M (Suc i)); \<And>i. feasible (M i) \<rbrakk> \<Longrightarrow>
   equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV))"
  by(simp add:bd_cts_tr_def)

lemma bd_cts_trI:
  "(\<And>M. (\<And>i. le_trans (M i) (M (Suc i))) \<Longrightarrow> (\<And>i. feasible (M i)) \<Longrightarrow>
         equiv_trans (T (Sup_trans (M ` UNIV))) (Sup_trans ((T o M) ` UNIV))) \<Longrightarrow> bd_cts_tr T"
  by(simp add:bd_cts_tr_def)

subsection \<open>Continuity of Primitives\<close>

lemma cts_wp_Abort:
  "bd_cts (wp (Abort::'s prog))"
proof -
  have X: "range (\<lambda>(i::nat) (s::'s). 0) = {\<lambda>s. 0}" by(auto)
  show ?thesis by(intro bd_ctsI, simp add:wp_eval o_def Sup_exp_def X)
qed

lemma cts_wp_Skip:
  "bd_cts (wp Skip)"
  by(rule bd_ctsI, simp add:wp_def Skip_def o_def)

lemma cts_wp_Apply:
  "bd_cts (wp (Apply f))"
proof -
  have X: "\<And>M s. {P (f s) |P. P \<in> range M} = {P s |P. P \<in> range (\<lambda>i s. M i (f s))}" by(auto)
  show ?thesis by(intro bd_ctsI ext, simp add:wp_eval o_def Sup_exp_def X)
qed

lemma cts_wp_Bind:
  fixes a::"'a \<Rightarrow> 's prog"
  assumes ca: "\<And>s. bd_cts (wp (a (f s)))"
  shows "bd_cts (wp (Bind f a))"
proof(rule bd_ctsI)
  fix M::"nat \<Rightarrow> 's expect" and c::real
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by c (M i)"
  with bd_ctsD[OF ca]
  have "\<And>s. wp (a (f s)) (Sup_exp (range M)) =
            Sup_exp (range (wp (a (f s)) o M))"
    by(auto)
  moreover have "\<And>s. {fa s |fa. fa \<in> range (\<lambda>x. wp (a (f s)) (M x))} =
                      {fa s |fa. fa \<in> range (\<lambda>x s. wp (a (f s)) (M x) s)}"
    by(auto)
  ultimately show "wp (Bind f a) (Sup_exp (range M)) =
                   Sup_exp (range (wp (Bind f a) \<circ> M))"
    by(simp add:wp_eval o_def Sup_exp_def)
qed

text \<open>The first nontrivial proof.  We transform the suprema into limits, and appeal to the
continuity of the underlying operation (here infimum).  This is typical of the remainder of the
nonrecursive elements.\<close>
lemma cts_wp_DC:
  fixes a b::"'s prog"
  assumes ca: "bd_cts (wp a)"
      and cb: "bd_cts (wp b)"
      and ha: "healthy (wp a)"
      and hb: "healthy (wp b)"
  shows "bd_cts (wp (a \<Sqinter> b))"
proof(rule bd_ctsI, rule antisym)
  fix M::"nat \<Rightarrow> 's expect" and c::real
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by c (M i)"

  from ha hb have hab: "healthy (wp (a \<Sqinter> b))" by(rule healthy_intros)
  from bM have leSup: "\<And>i. M i \<tturnstile> Sup_exp (range M)" by(auto intro:Sup_exp_upper)
  from sM bM have sSup: "sound (Sup_exp (range M))" by(auto intro:Sup_exp_sound)

  show "Sup_exp (range (wp (a \<Sqinter> b) \<circ> M)) \<tturnstile> wp (a \<Sqinter> b) (Sup_exp (range M))"
  proof(rule Sup_exp_least, clarsimp, rule le_funI)
    fix i s
    from mono_transD[OF healthy_monoD[OF hab]] leSup sM sSup
    have "wp (a \<Sqinter> b) (M i) \<tturnstile> wp (a \<Sqinter> b) (Sup_exp (range M))" by(auto)
    thus "wp (a \<Sqinter> b) (M i) s \<le> wp (a \<Sqinter> b) (Sup_exp (range M)) s" by(auto)

    from hab sSup have "sound (wp (a \<Sqinter> b) (Sup_exp (range M)))" by(auto)
    thus "nneg (wp (a \<Sqinter> b) (Sup_exp (range M)))" by(auto)
  qed

  from sM bM ha have "\<And>i. bounded_by c (wp a (M i))" by(auto)
  hence baM: "\<And>i s. wp a (M i) s \<le> c" by(auto)
  from sM bM hb have "\<And>i. bounded_by c (wp b (M i))" by(auto)
  hence bbM: "\<And>i s. wp b (M i) s \<le> c" by(auto)

  show "wp (a \<Sqinter> b) (Sup_exp (range M)) \<tturnstile> Sup_exp (range (wp (a \<Sqinter> b) \<circ> M))"
  proof(simp add:wp_eval o_def, rule le_funI)
    fix s::'s
    from bd_ctsD[OF ca, of M, OF chain sM bM] bd_ctsD[OF cb, of M, OF chain sM bM]
    have "min (wp a (Sup_exp (range M)) s) (wp b (Sup_exp (range M)) s) =
          min (Sup_exp (range (wp a o M)) s) (Sup_exp (range (wp b o M)) s)" by(simp)
    also {
      have "{f s |f. f \<in> range (\<lambda>x. wp a (M x))} = range (\<lambda>i. wp a (M i) s)"
           "{f s |f. f \<in> range (\<lambda>x. wp b (M x))} = range (\<lambda>i. wp b (M i) s)"
        by(auto)
      hence "min (Sup_exp (range (wp a o M)) s) (Sup_exp (range (wp b o M)) s) =
            min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s)))"
        by(simp add:Sup_exp_def o_def)
    }
    also {
      have "(\<lambda>i. wp a (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. wp a (M i) s))"
      proof(rule increasing_LIMSEQ)
        fix n
        from mono_transD[OF healthy_monoD, OF ha] sM chain
        show "wp a (M n) s \<le> wp a (M (Suc n)) s" by(auto intro:le_funD)
        from baM show "wp a (M n) s \<le> Sup (range (\<lambda>i. wp a (M i) s))"
          by(intro cSup_upper bdd_aboveI, auto)

        fix e::real assume pe: "0 < e"
        from baM have cSup: "Sup (range (\<lambda>i. wp a (M i) s)) \<in> closure (range (\<lambda>i. wp a (M i) s))"
          by(blast intro:closure_contains_Sup)
        with pe obtain y where yin: "y \<in> (range (\<lambda>i. wp a (M i) s))"
                          and dy: "dist y (Sup (range (\<lambda>i. wp a (M i) s))) < e"
          by(blast dest:iffD1[OF closure_approachable])
        from yin obtain i where "y = wp a (M i) s" by(auto)
        with dy have "dist (wp a (M i) s) (Sup (range (\<lambda>i. wp a (M i) s))) < e"
          by(simp)
        moreover from baM have "wp a (M i) s \<le> Sup (range (\<lambda>i. wp a (M i) s))"
          by(intro cSup_upper bdd_aboveI, auto)
        ultimately have "Sup (range (\<lambda>i. wp a (M i) s)) \<le> wp a (M i) s + e"
          by(simp add:dist_real_def)
        thus "\<exists>i. Sup (range (\<lambda>i. wp a (M i) s)) \<le> wp a (M i) s + e" by(auto)
      qed
      moreover
      have "(\<lambda>i. wp b (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. wp b (M i) s))"
      proof(rule increasing_LIMSEQ)
        fix n
        from mono_transD[OF healthy_monoD, OF hb] sM chain
        show "wp b (M n) s \<le> wp b (M (Suc n)) s" by(auto intro:le_funD)
        from bbM show "wp b (M n) s \<le> Sup (range (\<lambda>i. wp b (M i) s))"
          by(intro cSup_upper bdd_aboveI, auto)

        fix e::real assume pe: "0 < e"
        from bbM have cSup: "Sup (range (\<lambda>i. wp b (M i) s)) \<in> closure (range (\<lambda>i. wp b (M i) s))"
          by(blast intro:closure_contains_Sup)
        with pe obtain y where yin: "y \<in> (range (\<lambda>i. wp b (M i) s))"
                          and dy: "dist y (Sup (range (\<lambda>i. wp b (M i) s))) < e"
          by(blast dest:iffD1[OF closure_approachable])
        from yin obtain i where "y = wp b (M i) s" by(auto)
        with dy have "dist (wp b (M i) s) (Sup (range (\<lambda>i. wp b (M i) s))) < e"
          by(simp)
        moreover from bbM have "wp b (M i) s \<le> Sup (range (\<lambda>i. wp b (M i) s))"
          by(intro cSup_upper bdd_aboveI, auto)
        ultimately have "Sup (range (\<lambda>i. wp b (M i) s)) \<le> wp b (M i) s + e"
          by(simp add:dist_real_def)
        thus "\<exists>i. Sup (range (\<lambda>i. wp b (M i) s)) \<le> wp b (M i) s + e" by(auto)
      qed
      ultimately have "(\<lambda>i. min (wp a (M i) s) (wp b (M i) s)) \<longlonglongrightarrow>
                       min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s)))"
        by(rule tendsto_min)
      moreover have "bdd_above (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)))"
      proof(intro bdd_aboveI, clarsimp)
        fix i
        have "min (wp a (M i) s) (wp b (M i) s) \<le> wp a (M i) s" by(auto)
        also {
          from ha sM bM have "bounded_by c (wp a (M i))" by(auto)
          hence "wp a (M i) s \<le>  c" by(auto)
        }
        finally show "min (wp a (M i) s) (wp b (M i) s) \<le> c" .
      qed
      ultimately
      have "min (Sup (range (\<lambda>i. wp a (M i) s))) (Sup (range (\<lambda>i. wp b (M i) s))) \<le>
            Sup (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)))"
        by(blast intro:LIMSEQ_le_const2 cSup_upper min.mono[OF baM bbM])
    }
    also {
      have "range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s)) =
            {f s |f. f \<in> range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))}"
        by(auto)
      hence "Sup (range (\<lambda>i. min (wp a (M i) s) (wp b (M i) s))) =
           Sup_exp (range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))) s"
        by (simp add: Sup_exp_def cong del: SUP_cong_simp)
    }
    finally show "min (wp a (Sup_exp (range M)) s) (wp b (Sup_exp (range M)) s) \<le>
                  Sup_exp (range (\<lambda>i s. min (wp a (M i) s) (wp b (M i) s))) s" .
  qed
qed

lemma cts_wp_Seq:
  fixes a b::"'s prog"
  assumes ca: "bd_cts (wp a)"
      and cb: "bd_cts (wp b)"
      and hb: "healthy (wp b)"
  shows "bd_cts (wp (a ;; b))"
proof(rule bd_ctsI, simp add:o_def wp_eval)
  fix M::"nat \<Rightarrow> 's expect" and c::real
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by c (M i)"
  hence "wp a (wp b (Sup_exp (range M))) = wp a (Sup_exp (range (wp b o M)))"
    by(subst bd_ctsD[OF cb], auto)
  also {
    from sM hb have "\<And>i. sound ((wp b o M) i)" by(auto)
    moreover from chain sM
    have "\<And>i. (wp b o M) i \<tturnstile> (wp b o M) (Suc i)"
      by(auto intro:mono_transD[OF healthy_monoD, OF hb])
    moreover from sM bM hb have "\<And>i. bounded_by c ((wp b o M) i)" by(auto)
    ultimately have "wp a (Sup_exp (range (wp b o M))) =
                     Sup_exp (range (wp a o (wp b o M)))"
      by(subst bd_ctsD[OF ca], auto)
  }
  also have "Sup_exp (range (wp a o (wp b o M))) =
             Sup_exp (range (\<lambda>i. wp a (wp b (M i))))"
    by(simp add:o_def)
  finally show "wp a (wp b (Sup_exp (range M))) =
                Sup_exp (range (\<lambda>i. wp a (wp b (M i))))" .
qed

lemma cts_wp_PC:
  fixes a b::"'s prog"
  assumes ca: "bd_cts (wp a)"
      and cb: "bd_cts (wp b)"
      and ha: "healthy (wp a)"
      and hb: "healthy (wp b)"
      and up: "unitary p"
  shows "bd_cts (wp (PC a p b))"
proof(rule bd_ctsI, rule ext, simp add:o_def wp_eval)
  fix M::"nat \<Rightarrow> 's expect" and c::real and s::'s
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by c (M i)"

  from sM have "\<And>i. nneg (M i)" by(auto)
  with bM have nc: "0 \<le> c" by(auto)

  from chain sM bM have "wp a (Sup_exp (range M)) = Sup_exp (range (wp a o M))"
    by(rule bd_ctsD[OF ca])
  hence "wp a (Sup_exp (range M)) s = Sup_exp (range (wp a o M)) s"
    by(simp)
  also {
    have "{f s |f. f \<in> range (\<lambda>x. wp a (M x))} = range (\<lambda>i. wp a (M i) s)"
      by(auto)
    hence "Sup_exp (range (wp a o M)) s = Sup (range (\<lambda>i. wp a (M i) s))"
      by(simp add:Sup_exp_def o_def)
  }
  finally have "p s * wp a (Sup_exp (range M)) s =
                p s * Sup (range (\<lambda>i. wp a (M i) s))" by(simp)
  also have "... = Sup {p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)}"
  proof(rule cSup_mult, blast, clarsimp)
    from up show "0 \<le> p s" by(auto)
    fix i
    from sM bM ha have "bounded_by c (wp a (M i))" by(auto)
    thus "wp a (M i) s \<le> c" by(auto)
  qed
  also {
    have "{p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)} = range (\<lambda>i. p s * wp a (M i) s)"
      by(auto)
    hence "Sup {p s * x |x. x \<in> range (\<lambda>i. wp a (M i) s)} =
           Sup (range (\<lambda>i. p s * wp a (M i) s))" by(simp)
  }
  finally have "p s * wp a (Sup_exp (range M)) s = Sup (range (\<lambda>i. p s * wp a (M i) s))" .
  moreover {
    from chain sM bM have "wp b (Sup_exp (range M)) = Sup_exp (range (wp b o M))"
      by(rule bd_ctsD[OF cb])
    hence "wp b (Sup_exp (range M)) s = Sup_exp (range (wp b o M)) s"
      by(simp)
    also {
      have "{f s |f. f \<in> range (\<lambda>x. wp b (M x))} = range (\<lambda>i. wp b (M i) s)"
        by(auto)
      hence "Sup_exp (range (wp b o M)) s = Sup (range (\<lambda>i. wp b (M i) s))"
        by(simp add:Sup_exp_def o_def)
    }
    finally have "(1 - p s) * wp b (Sup_exp (range M)) s =
                  (1 - p s) * Sup (range (\<lambda>i. wp b (M i) s))" by(simp)
    also have "... = Sup {(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)}"
    proof(rule cSup_mult, blast, clarsimp)
      from up show "0 \<le> 1 - p s"
        by auto
      fix i
      from sM bM hb have "bounded_by c (wp b (M i))" by(auto)
      thus "wp b (M i) s \<le> c" by(auto)
    qed
    also {
      have "{(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)} =
            range (\<lambda>i. (1 - p s) * wp b (M i) s)"
        by(auto)
      hence "Sup {(1 - p s) * x |x. x \<in> range (\<lambda>i. wp b (M i) s)} =
             Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))" by(simp)
    }
    finally have "(1 - p s) * wp b (Sup_exp (range M)) s =
                  Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))" .
  }
  ultimately
  have "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s =
        Sup (range (\<lambda>i. p s * wp a (M i) s)) + Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
    by(simp)
  also {
    from bM sM ha have "\<And>i. bounded_by c (wp a (M i))" by(auto)
    hence "\<And>i. wp a (M i) s \<le> c" by(auto)
    moreover from up have "0 \<le> p s" by(auto)
    ultimately have "\<And>i. p s * wp a (M i) s \<le> p s * c" by(auto intro:mult_left_mono)
    also from up nc have "p s * c \<le> 1 * c" by(blast intro:mult_right_mono)
    also have "... = c" by(simp)
    finally have baM: "\<And>i. p s * wp a (M i) s \<le> c" .

    have lima: "(\<lambda>i. p s * wp a (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. p s * wp a (M i) s))"
    proof(rule increasing_LIMSEQ)
      fix n
      from sM chain healthy_monoD[OF ha] have "wp a (M n) \<tturnstile> wp a (M (Suc n))"
        by(auto)
      with up show "p s * wp a (M n) s \<le> p s * wp a (M (Suc n)) s"
        by(blast intro:mult_left_mono)
      from baM show "p s * wp a (M n) s \<le> Sup (range (\<lambda>i. p s * wp a (M i) s))"
        by(intro cSup_upper bdd_aboveI, auto)
    next
      fix e::real
      assume pe: "0 < e"
      from baM have "Sup (range (\<lambda>i. p s * wp a (M i) s)) \<in>
                     closure (range (\<lambda>i. p s * wp a (M i) s))"
        by(blast intro:closure_contains_Sup)
      thm closure_approachable
      with pe obtain y where yin: "y \<in> range (\<lambda>i. p s * wp a (M i) s)"
                         and dy: "dist y (Sup (range (\<lambda>i. p s * wp a (M i) s))) < e"
        by(blast dest:iffD1[OF closure_approachable])
      from yin obtain i where "y = p s * wp a (M i) s" by(auto)
      with dy have "dist (p s * wp a (M i) s) (Sup (range (\<lambda>i. p s * wp a (M i) s))) < e"
        by(simp)
      moreover from baM have "p s * wp a (M i) s \<le> Sup (range (\<lambda>i. p s * wp a (M i) s))"
        by(intro cSup_upper bdd_aboveI, auto)
      ultimately have "Sup (range (\<lambda>i. p s * wp a (M i) s)) \<le> p s * wp a (M i) s + e"
        by(simp add:dist_real_def)
      thus "\<exists>i. Sup (range (\<lambda>i. p s * wp a (M i) s)) \<le> p s * wp a (M i) s + e" by(auto)
    qed

    from bM sM hb have "\<And>i. bounded_by c (wp b (M i))" by(auto)
    hence "\<And>i. wp b (M i) s \<le> c" by(auto)
    moreover from up have "0 \<le> (1 - p s)"
      by auto
    ultimately have "\<And>i. (1 - p s) * wp b (M i) s \<le> (1 - p s) * c" by(auto intro:mult_left_mono)
    also {
      from up have "1 - p s \<le> 1" by(auto)
      with nc have "(1 - p s) * c \<le> 1 * c" by(blast intro:mult_right_mono)
    }
    also have "1 * c = c" by(simp)
    finally have bbM: "\<And>i. (1 - p s) * wp b (M i) s \<le> c" .

    have limb: "(\<lambda>i. (1 - p s) * wp b (M i) s) \<longlonglongrightarrow> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
    proof(rule increasing_LIMSEQ)
      fix n
      from sM chain healthy_monoD[OF hb] have "wp b (M n) \<tturnstile> wp b (M (Suc n))"
        by(auto)
      moreover from up have "0 \<le> 1 - p s"
        by auto
      ultimately show "(1 - p s) * wp b (M n) s \<le> (1 - p s) * wp b (M (Suc n)) s"
        by(blast intro:mult_left_mono)
      from bbM show "(1 - p s) * wp b (M n) s \<le> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
        by(intro cSup_upper bdd_aboveI, auto)
    next
      fix e::real
      assume pe: "0 < e"
      from bbM have "Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<in>
                     closure (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
        by(blast intro:closure_contains_Sup)
      with pe obtain y where yin: "y \<in> range (\<lambda>i. (1 - p s) * wp b (M i) s)"
                         and dy: "dist y (Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))) < e"
        by(blast dest:iffD1[OF closure_approachable])
      from yin obtain i where "y = (1 - p s) * wp b (M i) s" by(auto)
      with dy have "dist ((1 - p s) * wp b (M i) s)
                         (Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))) < e"
        by(simp)
      moreover from bbM
      have "(1 - p s) * wp b (M i) s \<le> Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
        by(intro cSup_upper bdd_aboveI, auto)
      ultimately have "Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le> (1 - p s) * wp b (M i) s + e"
        by(simp add:dist_real_def)
      thus "\<exists>i. Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le> (1 - p s) * wp b (M i) s + e" by(auto)
    qed

    from lima limb have "(\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s) \<longlonglongrightarrow>
      Sup (range (\<lambda>i. p s * wp a (M i) s)) + Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s))"
      by(rule tendsto_add)
    moreover from add_mono[OF baM bbM]
    have "\<And>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s \<le>
                       Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s))"
      by(intro cSup_upper bdd_aboveI, auto)
    ultimately have "Sup (range (\<lambda>i. p s * wp a (M i) s)) +
                     Sup (range (\<lambda>i. (1 - p s) * wp b (M i) s)) \<le>
                     Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s))"
      by(blast intro: LIMSEQ_le_const2)
  }
  also {
    have "range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s) =
          {f s |f. f \<in> range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)}"
      by(auto)
    hence "Sup (range (\<lambda>i. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) =
           Sup_exp (range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)) s"
      by (simp add: Sup_exp_def cong del: SUP_cong_simp)
  }
  finally
  have "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s \<le>
        Sup_exp (range (\<lambda>i s. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) s" .
  moreover
  have "Sup_exp (range (\<lambda>i s. p s * wp a (M i) s + (1 - p s) * wp b (M i) s)) s \<le>
        p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s"
  proof(rule le_funD[OF Sup_exp_least], clarsimp, rule le_funI)
    fix i::nat and s::'s
    from bM have leSup: "M i \<tturnstile> Sup_exp (range M)"
      by(blast intro: Sup_exp_upper)
    moreover from sM bM have sSup: "sound (Sup_exp (range M))"
      by(auto intro:Sup_exp_sound)
    moreover note healthy_monoD[OF ha] sM
    ultimately have "wp a (M i) \<tturnstile> wp a (Sup_exp (range M))" by(auto)
    hence "wp a (M i) s \<le> wp a (Sup_exp (range M)) s" by(auto)
    moreover {
      from leSup sSup healthy_monoD[OF hb] sM
      have "wp b (M i) \<tturnstile> wp b (Sup_exp (range M))" by(auto)
      hence "wp b (M i) s \<le> wp b (Sup_exp (range M)) s" by(auto)
    }
    moreover from up have "0 \<le> p s" "0 \<le> 1 - p s"
      by auto
    ultimately
    show "p s * wp a (M i) s + (1 - p s) * wp b (M i) s \<le>
          p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s"
      by(blast intro:add_mono mult_left_mono)

    from sSup ha hb have "sound (wp a (Sup_exp (range M)))"
                         "sound (wp b (Sup_exp (range M)))"
      by(auto)
    hence "\<And>s. 0 \<le> wp a (Sup_exp (range M)) s" "\<And>s. 0 \<le> wp b (Sup_exp (range M)) s"
      by(auto)
    moreover from up have "\<And>s. 0 \<le> p s" "\<And>s. 0 \<le> 1 - p s"
      by auto
    ultimately show "nneg (\<lambda>c. p c * wp a (Sup_exp (range M)) c +
                          (1 - p c) * wp b (Sup_exp (range M)) c)"
      by(blast intro:add_nonneg_nonneg mult_nonneg_nonneg)
  qed
  ultimately show "p s * wp a (Sup_exp (range M)) s + (1 - p s) * wp b (Sup_exp (range M)) s =
                  Sup_exp (range (\<lambda>x s. p s * wp a (M x) s + (1 - p s) * wp b (M x) s)) s"
    by(auto)
qed

text \<open>Both set-based choice operators are only continuous for finite sets (probabilistic choice
\emph{can} be extended infinitely, but we have not done so).  The proofs for both are inductive,
and rely on the above results on binary operators.\<close>

lemma SetPC_Bind:
  "SetPC a p = Bind p (\<lambda>p. SetPC a (\<lambda>_. p))"
  by(intro ext, simp add:SetPC_def Bind_def Let_def)

lemma SetPC_remove:
  assumes nz: "p x \<noteq> 0" and n1: "p x \<noteq> 1"
      and fsupp: "finite (supp p)"
  shows "SetPC a (\<lambda>_. p) = PC (a x) (\<lambda>_. p x) (SetPC a (\<lambda>_. dist_remove p x))"
proof(intro ext, simp add:SetPC_def PC_def)
  fix ab P s
  from nz have "x \<in> supp p" by(simp add:supp_def)
  hence "supp p = insert x (supp p - {x})" by(auto)
  hence "(\<Sum>x\<in>supp p. p x * a x ab P s) =
         (\<Sum>x\<in>insert x (supp p - {x}). p x * a x ab P s)"
    by(simp)
  also from fsupp
  have "... = p x * a x ab P s + (\<Sum>x\<in>supp p - {x}. p x * a x ab P s)"
    by(blast intro:sum.insert)
  also from n1
  have "... = p x * a x ab P s + (1 - p x) * ((\<Sum>x\<in>supp p - {x}. p x * a x ab P s) / (1 - p x))"
    by(simp add:field_simps)
  also have "... = p x * a x ab P s +
                   (1 - p x) * ((\<Sum>y\<in>supp p - {x}. (p y / (1 - p x)) * a y ab P s))"
    by(simp add:sum_divide_distrib)
  also have "... = p x * a x ab P s +
                   (1 - p x) * ((\<Sum>y\<in>supp p - {x}. dist_remove p x y * a y ab P s))"
    by(simp add:dist_remove_def)
  also from nz n1
  have "... = p x * a x ab P s +
              (1 - p x) * ((\<Sum>y\<in>supp (dist_remove p x). dist_remove p x y * a y ab P s))"
    by(simp add:supp_dist_remove)
  finally show "(\<Sum>x\<in>supp p. p x * a x ab P s) =
                 p x * a x ab P s +
                 (1 - p x) * (\<Sum>y\<in>supp (dist_remove p x). dist_remove p x y * a y ab P s)" .
qed

lemma cts_bot:
  "bd_cts (\<lambda>(P::'s expect) (s::'s). 0::real)"
proof -
  have X: "\<And>s::'s. {(P::'s expect) s |P. P \<in> range (\<lambda>P s. 0)} = {0}" by(auto)
  show ?thesis by(intro bd_ctsI, simp add:Sup_exp_def o_def X)
qed

lemma wp_SetPC_nil:
  "wp (SetPC a (\<lambda>s a. 0)) = (\<lambda>P s. 0)"
  by(intro ext, simp add:wp_eval)

lemma SetPC_sgl:
  "supp p = {x} \<Longrightarrow> SetPC a (\<lambda>_. p) = (\<lambda>ab P s. p x * a x ab P s)"
  by(simp add:SetPC_def)

lemma bd_cts_scale:
  fixes a::"'s trans"
  assumes ca: "bd_cts a"
      and ha: "healthy a"
      and nnc: "0 \<le> c"
  shows "bd_cts (\<lambda>P s. c * a P s)"
proof(intro bd_ctsI ext, simp add:o_def)
  fix M::"nat \<Rightarrow> 's expect" and d::real and s::'s
  assume chain: "\<And>i. M i \<tturnstile> M (Suc i)" and sM: "\<And>i. sound (M i)"
     and bM: "\<And>i. bounded_by d (M i)"

  from sM have "\<And>i. nneg (M i)" by(auto)
  with bM have nnd: "0 \<le> d" by(auto)

  from sM bM have sSup: "sound (Sup_exp (range M))" by(auto intro:Sup_exp_sound)
  with healthy_scalingD[OF ha] nnc
  have "c * a (Sup_exp (range M)) s = a (\<lambda>s. c * Sup_exp (range M) s) s"
    by(auto intro:scalingD)
  also {
    have "\<And>s. {f s |f. f \<in> range M} = range (\<lambda>i. M i s)" by(auto)
    hence "a (\<lambda>s. c * Sup_exp (range M) s) s =
           a (\<lambda>s. c * Sup (range (\<lambda>i. M i s))) s"
      by(simp add:Sup_exp_def)
  }
  also {
    from bM have "\<And>x s. x \<in> range (\<lambda>i. M i s) \<Longrightarrow> x \<le> d" by(auto)
    with nnc have "a (\<lambda>s. c * Sup (range (\<lambda>i. M i s))) s =
                   a (\<lambda>s. Sup {c*x |x. x \<in> range (\<lambda>i. M i s)}) s"
      by(subst cSup_mult, blast+)
  }
  also {
    have X: "\<And>s. {c * x |x. x \<in> range (\<lambda>i. M i s)} = range (\<lambda>i. c * M i s)" by(auto)
    have "a (\<lambda>s. Sup {c * x |x. x \<in> range (\<lambda>i. M i s)}) s =
          a (\<lambda>s. Sup (range (\<lambda>i. c * M i s))) s" by(simp add:X)
  }
  also {
    have "\<And>s. range (\<lambda>i. c * M i s) = {f s |f. f \<in> range (\<lambda>i s. c * M i s)}"
      by(auto)
    hence "(\<lambda>s. Sup (range (\<lambda>i. c * M i s))) = Sup_exp (range (\<lambda>i s. c * M i s))"
      by (simp add: Sup_exp_def cong del: SUP_cong_simp)
    hence "a (\<lambda>s. Sup (range (\<lambda>i. c * M i s))) s =
           a (Sup_exp (range (\<lambda>i s. c * M i s))) s" by(simp)
  }
  also {
    from le_funD[OF chain] nnc
    have "\<And>i. (\<lambda>s. c * M i s) \<tturnstile> (\<lambda>s. c * M (Suc i) s)"
      by(auto intro:le_funI[OF mult_left_mono])
    moreover from sM nnc
    have "\<And>i. sound (\<lambda>s. c * M i s)"
      by(auto intro:sound_intros)
    moreover from bM nnc
    have "\<And>i. bounded_by (c * d) (\<lambda>s. c * M i s)"
      by(auto intro:mult_left_mono)
    ultimately
    have "a (Sup_exp (range (\<lambda>i s. c * M i s))) =
          Sup_exp (range (a o (\<lambda>i s. c * M i s)))"
      by(rule bd_ctsD[OF ca])
    hence "a (Sup_exp (range (\<lambda>i s. c * M i s))) s =
          Sup_exp (range (a o (\<lambda>i s. c * M i s))) s"
      by(auto)
  }
  also have "Sup_exp (range (a o (\<lambda>i s. c * M i s))) s =
             Sup_exp (range (\<lambda>x. a (\<lambda>s. c * M x s))) s"
    by(simp add:o_def)
  also {
    from nnc sM
    have "\<And>x. a (\<lambda>s. c * M x s) = (\<lambda>s. c * a (M x) s)"
      by(auto intro:scalingD[OF healthy_scalingD, OF ha, symmetric])
    hence "Sup_exp (range (\<lambda>x. a (\<lambda>s. c * M x s))) s =
           Sup_exp (range (\<lambda>x s. c * a (M x) s)) s"
      by(simp)
  }
  finally show "c * a (Sup_exp (range M)) s = Sup_exp (range (\<lambda>x s. c * a (M x) s)) s" .
qed

lemma cts_wp_SetPC_const:
  fixes a::"'a \<Rightarrow> 's prog"
  assumes ca: "\<And>x. x \<in> (supp p) \<Longrightarrow> bd_cts (wp (a x))"
      and ha: "\<And>x. x \<in> (supp p) \<Longrightarrow> healthy (wp (a x))"
      and up: "unitary p"
      and sump: "sum p (supp p) \<le> 1"
      and fsupp: "finite (supp p)"
  shows "bd_cts (wp (SetPC a (\<lambda>_. p)))"
proof(cases "supp p = {}", simp add:supp_empty SetPC_def wp_def cts_bot)
  assume nesupp: "supp p \<noteq> {}"
  from fsupp have "unitary p \<longrightarrow> sum p (supp p) \<le> 1 \<longrightarrow>
                   (\<forall>x\<in>supp p. bd_cts (wp (a x))) \<longrightarrow>
                   (\<forall>x\<in>supp p. healthy (wp (a x))) \<longrightarrow>
                   bd_cts (wp (SetPC a (\<lambda>_. p)))"
  proof(induct "supp p" arbitrary:p, simp add:supp_empty wp_SetPC_nil cts_bot, clarify)
    fix x::'a and F::"'a set" and p::"'a \<Rightarrow> real"
    assume fF: "finite F"
    assume "insert x F = supp p"
    hence pstep: "supp p = insert x F" by(simp)
    hence xin: "x \<in> supp p" by(auto)
    assume up: "unitary p" and ca: "\<forall>x\<in>supp p. bd_cts (wp (a x))"
       and ha: "\<forall>x\<in>supp p. healthy (wp (a x))"
       and sump: "sum p (supp p) \<le> 1"
       and xni: "x \<notin> F"
    assume IH: "\<And>p. F = supp p \<Longrightarrow>
                     unitary p \<longrightarrow> sum p (supp p) \<le> 1 \<longrightarrow>
                     (\<forall>x\<in>supp p. bd_cts (wp (a x))) \<longrightarrow>
                     (\<forall>x\<in>supp p. healthy (wp (a x))) \<longrightarrow>
                     bd_cts (wp (SetPC a (\<lambda>_. p)))"

    from fF pstep have fsupp: "finite (supp p)" by(auto)

    from xin have nzp: "p x \<noteq> 0" by(simp add:supp_def)

    have xy_le_sum:
      "\<And>y. y \<in> supp p \<Longrightarrow> y \<noteq> x \<Longrightarrow> p x + p y \<le> sum p (supp p)"
    proof -
      fix y assume yin: "y \<in> supp p" and yne: "y \<noteq> x"
      from up have "0 \<le> sum p (supp p - {x,y})"
        by(auto intro:sum_nonneg)
      hence "p x + p y \<le> p x + p y + sum p (supp p - {x,y})"
        by(auto)
    also {
      from yin yne fsupp
      have "p y + sum p (supp p - {x,y}) = sum p (supp p - {x})"
        by(subst sum.insert[symmetric], (blast intro!:sum.cong)+)
      moreover
      from xin fsupp
      have "p x + sum p (supp p - {x}) = sum p (supp p)"
        by(subst sum.insert[symmetric], (blast intro!:sum.cong)+)
      ultimately
      have "p x + p y + sum p (supp p - {x, y}) = sum p (supp p)" by(simp)
    }
    finally show "p x + p y \<le> sum p (supp p)" .
    qed

    have n1p: "\<And>y. y \<in> supp p \<Longrightarrow> y \<noteq> x \<Longrightarrow> p x \<noteq> 1"
    proof(rule ccontr, simp)
      assume px1: "p x = 1"
      fix y assume yin: "y \<in> supp p" and yne: "y \<noteq> x"
      from up have "0 \<le> p y" by(auto)
      with yin have "0 < p y" by(auto simp:supp_def)
      hence "0 + p x < p y + p x" by(rule add_strict_right_mono)
      with px1 have "1 < p x + p y" by(simp)
      also from yin yne have "p x + p y \<le> sum p (supp p)"
        by(rule xy_le_sum)
      finally show False using sump by(simp)
    qed

    show "bd_cts (wp (SetPC a (\<lambda>_. p)))"
    proof(cases "F = {}")
      case True with pstep have "supp p = {x}" by(simp)
      hence "wp (SetPC a (\<lambda>_. p)) = (\<lambda>P s. p x * wp (a x) P s)"
        by(simp add:SetPC_sgl wp_def)
      moreover {
        from up ca ha xin have "bd_cts (wp (a x))" "healthy (wp (a x))" "0 \<le> p x"
          by(auto)
        hence "bd_cts (\<lambda>P s. p x * wp (a x) P s)"
          by(rule bd_cts_scale)
      }
      ultimately show ?thesis by(simp)
    next
      assume neF: "F \<noteq> {}"
      then obtain y where yinF: "y \<in> F" by(auto)
      with xni have yne: "y \<noteq> x" by(auto)
      from yinF pstep have yin: "y \<in> supp p" by(auto)

      from supp_dist_remove[of p x, OF nzp n1p, OF yin yne]
      have supp_sub: "supp (dist_remove p x) \<subseteq> supp p" by(auto)

      from xin ca have cax: "bd_cts (wp (a x))" by(auto)
      from xin ha have hax: "healthy (wp (a x))" by(auto)

      from supp_sub ha have hra: "\<forall>x\<in>supp (dist_remove p x). healthy (wp (a x))"
        by(auto)
      from supp_sub ca have cra: "\<forall>x\<in>supp (dist_remove p x). bd_cts (wp (a x))"
        by(auto)

      from supp_dist_remove[of p x, OF nzp n1p, OF yin yne] pstep xni
      have Fsupp: "F = supp (dist_remove p x)"
        by(simp)

      have udp: "unitary (dist_remove p x)"
      proof(intro unitaryI2 nnegI bounded_byI)
        fix y
        show "0 \<le> dist_remove p x y"
        proof(cases "y=x", simp_all add:dist_remove_def)
          from up have "0 \<le> p y" "0 \<le> 1 - p x"
            by auto
          thus "0 \<le> p y / (1 - p x)"
            by(rule divide_nonneg_nonneg)
        qed
        show "dist_remove p x y \<le> 1"
        proof(cases "y=x", simp_all add:dist_remove_def,
              cases "y\<in>supp p", simp_all add:nsupp_zero)
          assume yne: "y \<noteq> x" and yin: "y \<in> supp p"
          hence "p x + p y \<le> sum p (supp p)"
            by(auto intro:xy_le_sum)
          also note sump
          finally have "p y \<le> 1 - p x" by(auto)
          moreover from up have "p x \<le> 1" by(auto)
          moreover from yin yne have "p x \<noteq> 1" by(rule n1p)
          ultimately show "p y / (1 - p x) \<le> 1" by(auto)
        qed
      qed

      from xin have pxn0: "p x \<noteq> 0" by(auto simp:supp_def)
      from yin yne have pxn1: "p x \<noteq> 1" by(rule n1p)

      from pxn0 pxn1 have "sum (dist_remove p x) (supp (dist_remove p x)) =
                           sum (dist_remove p x) (supp p - {x})"
        by(simp add:supp_dist_remove)
      also have "... = (\<Sum>y\<in>supp p - {x}. p y / (1 - p x))"
        by(simp add:dist_remove_def)
      also have "... = (\<Sum>y\<in>supp p - {x}. p y) / (1 - p x)"
        by(simp add:sum_divide_distrib)
      also {
        from xin have "insert x (supp p) = supp p" by(auto)
        with fsupp have "p x + (\<Sum>y\<in>supp p - {x}. p y) = sum p (supp p)"
          by(simp add:sum.insert[symmetric])
        also note sump
        finally have "sum p (supp p - {x}) \<le> 1 - p x" by(auto)
        moreover {
          from up have "p x \<le> 1" by(auto)
          with pxn1 have "p x < 1" by(auto)
          hence "0 < 1 - p x" by(auto)
        }
        ultimately have "sum p (supp p - {x}) / (1 - p x) \<le> 1"
          by(auto)
      }
      finally have sdp: "sum (dist_remove p x) (supp (dist_remove p x)) \<le> 1" .

      from Fsupp udp sdp hra cra IH
      have cts_dr: "bd_cts (wp (SetPC a (\<lambda>_. dist_remove p x)))"
        by(auto)

      from up have upx: "unitary (\<lambda>_. p x)" by(auto)

      from pxn0 pxn1 fsupp hra show ?thesis
        by(simp add:SetPC_remove,
           blast intro:cts_wp_PC cax cts_dr hax healthy_intros
                       unitary_sound[OF udp] sdp upx)
    qed
  qed
  with assms show ?thesis by(auto)
qed

lemma cts_wp_SetPC:
  fixes a::"'a \<Rightarrow> 's prog"
  assumes ca: "\<And>x s. x \<in> (supp (p s)) \<Longrightarrow> bd_cts (wp (a x))"
      and ha: "\<And>x s. x \<in> (supp (p s)) \<Longrightarrow> healthy (wp (a x))"
      and up: "\<And>s. unitary (p s)"
      and sump: "\<And>s. sum (p s) (supp (p s)) \<le> 1"
      and fsupp: "\<And>s. finite (supp (p s))"
  shows "bd_cts (wp (SetPC a p))"
proof -
  from assms have "bd_cts (wp (Bind p (\<lambda>p. SetPC a (\<lambda>_. p))))"
    by(iprover intro!:cts_wp_Bind cts_wp_SetPC_const)
  thus ?thesis by(simp add:SetPC_Bind[symmetric])
qed

lemma wp_SetDC_Bind:
  "SetDC a S = Bind S (\<lambda>S. SetDC a (\<lambda>_. S))"
  by(intro ext, simp add:SetDC_def Bind_def)

lemma SetDC_finite_insert:
  assumes fS: "finite S"
      and neS: "S \<noteq> {}"
  shows "SetDC a (\<lambda>_. insert x S) = a x \<Sqinter> SetDC a (\<lambda>_. S)"
proof (intro ext, simp add: SetDC_def DC_def cong del: image_cong_simp cong add: INF_cong_simp)
  fix ab P s
  from fS have A: "finite (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S))"
           and B: "finite (((\<lambda>x. a x ab P s) ` S))" by(auto)
  from neS have C: "insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S) \<noteq> {}"
            and D: "(\<lambda>x. a x ab P s) ` S \<noteq> {}" by(auto)
  from A C have "Inf (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S)) =
                 Min (insert (a x ab P s) ((\<lambda>x. a x ab P s) ` S))"
    by(auto intro:cInf_eq_Min)
  also from B D have "... = min (a x ab P s) (Min ((\<lambda>x. a x ab P s) ` S))"
    by(auto intro:Min_insert)
  also from B D have "... = min (a x ab P s) (Inf ((\<lambda>x. a x ab P s) ` S))"
    by(simp add:cInf_eq_Min)
  finally show "(INF x\<in>insert x S. a x ab P s) =
    min (a x ab P s) (INF x\<in>S. a x ab P s)"
    by (simp cong del: INF_cong_simp)
qed

lemma SetDC_singleton:
  "SetDC a (\<lambda>_. {x}) = a x"
  by (simp add: SetDC_def cong del: INF_cong_simp)

lemma cts_wp_SetDC_const:
  fixes a::"'a \<Rightarrow> 's prog"
  assumes ca: "\<And>x. x \<in> S \<Longrightarrow> bd_cts (wp (a x))"
      and ha: "\<And>x. x \<in> S \<Longrightarrow> healthy (wp (a x))"
      and fS: "finite S"
      and neS: "S \<noteq> {}"
  shows "bd_cts (wp (SetDC a (\<lambda>_. S)))"
proof -
  have "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow>
        (\<forall>x\<in>S. bd_cts (wp (a x))) \<longrightarrow>
        (\<forall>x\<in>S. healthy (wp (a x))) \<longrightarrow>
        bd_cts (wp (SetDC a (\<lambda>_. S)))"
  proof(induct S rule:finite_induct, simp, clarsimp)
    fix x::'a and F::"'a set"
    assume fF: "finite F"
       and IH: "F \<noteq> {} \<Longrightarrow> bd_cts (wp (SetDC a (\<lambda>_. F)))"
       and cax: "bd_cts (wp (a x))"
       and hax: "healthy (wp (a x))"
       and haF: "\<forall>x\<in>F. healthy (wp (a x))"
    show "bd_cts (wp (SetDC a (\<lambda>_. insert x F)))"
    proof(cases "F = {}", simp add:SetDC_singleton cax)
      assume "F \<noteq> {}"
      with fF cax hax haF IH show "bd_cts (wp (SetDC a (\<lambda>_. insert x F)))"
       by(auto intro!:cts_wp_DC healthy_intros simp:SetDC_finite_insert)
    qed
  qed
  with assms show ?thesis by(auto)
qed

lemma cts_wp_SetDC:
  fixes a::"'a \<Rightarrow> 's prog"
  assumes ca: "\<And>x s. x \<in> S s \<Longrightarrow> bd_cts (wp (a x))"
      and ha: "\<And>x s. x \<in> S s \<Longrightarrow> healthy (wp (a x))"
      and fS: "\<And>s. finite (S s)"
      and neS: "\<And>s. S s \<noteq> {}"
  shows "bd_cts (wp (SetDC a S))"
proof -
  from assms have "bd_cts (wp (Bind S (\<lambda>S. SetDC a (\<lambda>_. S))))"
    by(iprover intro!:cts_wp_Bind cts_wp_SetDC_const)
  thus ?thesis by(simp add:wp_SetDC_Bind[symmetric])
qed

lemma cts_wp_repeat:
  "bd_cts (wp a) \<Longrightarrow> healthy (wp a) \<Longrightarrow> bd_cts (wp (repeat n a))"
  by(induct n, auto intro:cts_wp_Skip cts_wp_Seq healthy_intros)

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

subsection \<open>Continuity of a Single Loop Step\<close>

text \<open>A single loop iteration is continuous, in the more general sense defined above for
transformer transformers.\<close>
lemma cts_wp_loopstep:
  fixes body::"'s prog"
  assumes hb: "healthy (wp body)"
      and cb: "bd_cts (wp body)"
  shows "bd_cts_tr (\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip))" (is "bd_cts_tr ?F")
proof(rule bd_cts_trI, rule le_trans_antisym)
  fix M::"nat \<Rightarrow> 's trans" and b::real
  assume chain: "\<And>i. le_trans (M i) (M (Suc i))"
     and fM:    "\<And>i. feasible (M i)"
  show fw: "le_trans (Sup_trans (range (?F o M))) (?F (Sup_trans (range M)))"
  proof(rule le_transI[OF Sup_trans_least2], clarsimp)
    fix P Q::"'s expect" and t
    assume sP: "sound P"
    assume nQ: "nneg Q" and bP: "bounded_by (bound_of P) Q"
    hence sQ: "sound Q" by(auto)

    from fM have fSup: "feasible (Sup_trans (range M))"
      by(auto intro:feasible_Sup_trans)

    from sQ fM have "M t Q \<tturnstile> Sup_trans (range M) Q"
      by(auto intro:Sup_trans_upper2)
    moreover from sQ fM fSup
      have sMtP: "sound (M t Q)" "sound (Sup_trans (range M) Q)" by(auto)
    ultimately have "wp body (M t Q) \<tturnstile> wp body (Sup_trans (range M) Q)"
      using healthy_monoD[OF hb] by(auto)
    hence "\<And>s. wp body (M t Q) s \<le> wp body (Sup_trans (range M) Q) s"
      by(rule le_funD)
    thus "?F (M t) Q \<tturnstile> ?F (Sup_trans (range M)) Q"
      by(intro le_funI, simp add:wp_eval mult_left_mono)

    show "nneg (wp (body ;; Embed (Sup_trans (range M)) \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip) Q)"
    proof(rule nnegI, simp add:wp_eval)
      fix s::'s
        from fSup sQ have "sound (Sup_trans (range M) Q)" by(auto)
        with hb have "sound (wp body (Sup_trans (range M) Q))" by(auto)
        hence "0 \<le> wp body (Sup_trans (range M) Q) s" by(auto)
        moreover from sQ have "0 \<le> Q s" by(auto)
        ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) Q) s + (1 - \<guillemotleft>G\<guillemotright> s) * Q s"
          by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)
    qed
  next
    fix P::"'s expect" assume sP: "sound P"
    thus "nneg P" "bounded_by (bound_of P) P" by(auto)
    show "\<forall>u\<in>range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M).
            \<forall>R. nneg R \<and> bounded_by (bound_of P) R \<longrightarrow>
                nneg (u R) \<and> bounded_by (bound_of P) (u R)"
    proof(clarsimp, intro conjI nnegI bounded_byI, simp_all add:wp_eval)
      fix u::nat and R::"'s expect" and s::'s
      assume nR: "nneg R" and bR: "bounded_by (bound_of P) R"
      hence sR: "sound R" by(auto)
      with fM have sMuR: "sound (M u R)" by(auto)
      with hb have "sound (wp body (M u R))" by(auto)
      hence "0 \<le> wp body (M u R) s" by(auto)
      moreover from nR have "0 \<le> R s" by(auto)
      ultimately show "0 \<le> \<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s"
        by(auto intro:add_nonneg_nonneg mult_nonneg_nonneg)

      from sR bR fM have "bounded_by (bound_of P) (M u R)" by(auto)
      with sMuR hb have "bounded_by (bound_of P) (wp body (M u R))" by(auto)
      hence "wp body (M u R) s \<le> bound_of P" by(auto)
      moreover from bR have "R s \<le> bound_of P" by(auto)
      ultimately have "\<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s \<le>
                       \<guillemotleft>G\<guillemotright> s * bound_of P + (1 - \<guillemotleft>G\<guillemotright> s) * bound_of P"
        by(auto intro:add_mono mult_left_mono)
      also have "... = bound_of P" by(simp add:algebra_simps)
      finally show "\<guillemotleft>G\<guillemotright> s * wp body (M u R) s + (1 - \<guillemotleft>G\<guillemotright> s) * R s \<le> bound_of P" .
    qed
  qed

  show "le_trans (?F (Sup_trans (range M))) (Sup_trans (range (?F o M)))"
   proof(rule le_transI, rule le_funI, simp add: wp_eval cong del: image_cong_simp)
    fix P::"'s expect" and s::'s
    assume sP: "sound P"
    have "{t P |t. t \<in> range M} = range (\<lambda>i. M i P)"
      by(blast)
    hence "wp body (Sup_trans (range M) P) s = wp body (Sup_exp (range (\<lambda>i. M i P))) s"
      by(simp add:Sup_trans_def)
    also {
      from sP fM have "\<And>i. sound (M i P)" by(auto)
      moreover from sP chain have "\<And>i. M i P \<tturnstile> M (Suc i) P" by(auto)
      moreover {
        from sP have "bounded_by (bound_of P) P" by(auto)
        with sP fM have "\<And>i. bounded_by (bound_of P) (M i P)" by(auto)
      }
      ultimately have "wp body (Sup_exp (range (\<lambda>i. M i P))) s =
                       Sup_exp (range (\<lambda>i. wp body (M i P))) s"
        by(subst bd_ctsD[OF cb], auto simp:o_def)
    }
    also have "Sup_exp (range (\<lambda>i. wp body (M i P))) s =
               Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
      by(simp add:Sup_exp_def)
    finally have "\<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) P) s + (1 - \<guillemotleft>G\<guillemotright> s) * P s =
                  \<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1 - \<guillemotleft>G\<guillemotright> s) * P s"
      by(simp)
    also {
      from sP fM have "\<And>i. sound (M i P)" by(auto)
      moreover from sP fM have "\<And>i. bounded_by (bound_of P) (M i P)" by(auto)
      ultimately have "\<And>i. bounded_by (bound_of P) (wp body (M i P))" using hb by(auto)
      hence bound: "\<And>i. wp body (M i P) s \<le> bound_of P" by(auto)
      moreover
      have "{\<guillemotleft> G \<guillemotright> s * x |x. x \<in> {f s |f. f \<in> range (\<lambda>i. wp body (M i P))}} =
            {\<guillemotleft> G \<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
        by(blast)
      ultimately
      have "\<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} =
            Sup {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
        by(subst cSup_mult, auto)
      moreover {
        have "{x + (1-\<guillemotleft>G\<guillemotright> s) * P s |x.
               x \<in> {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))}} =
              {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
          by(blast)
        moreover from bound sP have "\<And>i. \<guillemotleft>G\<guillemotright> s * wp body (M i P) s \<le> bound_of P"
          by(cases "G s", auto)
        ultimately
        have "Sup {\<guillemotleft>G\<guillemotright> s * f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1-\<guillemotleft>G\<guillemotright> s) * P s =
              Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
          by(subst cSup_add, auto)
      }
      ultimately
      have "\<guillemotleft>G\<guillemotright> s * Sup {f s |f. f \<in> range (\<lambda>i. wp body (M i P))} + (1-\<guillemotleft>G\<guillemotright> s) * P s =
            Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))}"
        by(simp)
    }
    also {
      have "\<And>i. \<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s =
                 ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M) i P s"
        by(simp add:wp_eval)
      also have "\<And>i. ... i \<le>
                 Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}}"
      proof(intro cSup_upper bdd_aboveI, blast, clarsimp simp:wp_eval)
        fix i
        from sP have bP: "bounded_by (bound_of P) P" by(auto)
        with sP fM have "sound (M i P)" "bounded_by (bound_of P) (M i P)" by(auto)
        with hb have "bounded_by (bound_of P) (wp body (M i P))" by(auto)
        with bP have "wp body (M i P) s \<le> bound_of P" "P s \<le> bound_of P" by(auto)
        hence "\<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le>
               \<guillemotleft>G\<guillemotright> s * (bound_of P) + (1-\<guillemotleft>G\<guillemotright> s) * (bound_of P)"
          by(auto intro:add_mono mult_left_mono)
        also have "... = bound_of P" by(simp add:algebra_simps)
        finally show "\<guillemotleft>G\<guillemotright> s * wp body (M i P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le> bound_of P" .
      qed
      finally
      have "Sup {\<guillemotleft>G\<guillemotright> s * f s + (1-\<guillemotleft>G\<guillemotright> s) * P s |f. f \<in> range (\<lambda>i. wp body (M i P))} \<le>
            Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}}"
        by(blast intro:cSup_least)
    }
    also have "Sup {f s |f. f \<in> {t P |t. t \<in> range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)}} =
               Sup_trans (range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)) P s"
      by(simp add:Sup_trans_def Sup_exp_def)
    finally show "\<guillemotleft>G\<guillemotright> s * wp body (Sup_trans (range M) P) s + (1-\<guillemotleft>G\<guillemotright> s) * P s \<le>
                  Sup_trans (range ((\<lambda>x. wp (body ;; Embed x \<^bsub>\<guillemotleft> G \<guillemotright>\<^esub>\<oplus> Skip)) \<circ> M)) P s" .
  qed
qed

end


theory Srecurse_siterate
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Stream" "types/Twople"
    "~~/src/HOL/Library/BNF_Corec"
    Hinze_Streams
begin
setup Tactic_Data.set_sledgehammer_coinduct
setup Misc_Data.set_noisy

lemma recurse_simps[simp]:
      "stl (srecurse f a) = monomap f (srecurse f a)"
  by - (subst srecurse.code,simp)+
(*cohipster srecurse siterate*)
lemma lemma_az [thy_expl]: "SCons (y z) (monomap y x2) = monomap y (SCons z x2)"
  by (metis Stream.sel(1) Stream.sel(2) monomap.friend.code)

lemma lemma_ba [thy_expl]: "shd (srecurse y z) = z"
  by (metis Stream.sel(1) srecurse.code)

lemma lemma_bb [thy_expl]: "stl (srecurse y z) = srecurse y (y z)"
  by(coinduction rule: Hinze_Streams.srecurse.coinduct)
    (simp add: lemma_ba srecurse.cong_base srecurse.cong_monomap)

lemma lemma_bc [thy_expl]: "monomap y (srecurse y z) = srecurse y (y z)"
  using lemma_bb
  by (force simp add: lemma_bb)

lemma lemma_bd [thy_expl]: "SCons z (srecurse y (y z)) = srecurse y z"
  by (metis lemma_bc srecurse.code)

lemma lemma_be [thy_expl]: "monomap z (SCons y (srecurse z x2)) = SCons (z y) (srecurse z (z x2))"
  by (metis lemma_az lemma_bc)

lemma lemma_bf [thy_expl]: "srecurse y z = siterate y z"
proof(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
  case Eq_Stream thus ?case
    using lemma_ba lemma_bb
    by (force simp add: lemma_ba lemma_bb)
qed

lemma lemma_bg [thy_expl]: "monomap y (siterate y z) = siterate y (y z)"
 using lemma_bc lemma_bf
 by (force simp add: lemma_bc lemma_bf)

lemma lemma_bh [thy_expl]: "monomap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
 by (metis lemma_az lemma_bg)
end