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

theory Kripke
imports Main
begin
(*>*)

section {*A modal logic of knowledge*}

text{*

\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.

*}

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{*

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.

*}

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 by (induct rule: trancl_induct) 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 by (induct rule: rtrancl_induct) 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 {*

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.

*}

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{*

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

*}

subsection{* Satisfaction *}

text{*

A formula $\phi$ is satisfied at a world $w$ in Kripke structure $M$
in the following way: *}

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{*

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.

*}
(*<*)

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{*

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

*}

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{* We can show that the standard S5 properties hold of this semantics: *}

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{*

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$.

*}

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{*

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$.

*}

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>"
      by ( induct rule: trancl_induct
         , 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 {*Generated models*}

text{*

\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"}:

*}

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 by (induct rule: trancl_induct) 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
proof(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
proof(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{*

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:

*}

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>"
    proof(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{*

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

*}
(*<*)

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{*

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

*}

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 {*

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

*}

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>*"
    proof(induct rule: rtrancl_induct)
      case (step y z)
      with R T have "(y, z) \<in> (\<Union>a. relations M' a)"
        by (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)

  { 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
  have RELATIONS: "\<And>a. relations (gen_model M t) a = relations (gen_model M' t) a"
    unfolding gen_model_def
    apply -
    apply (simp (no_asm) add: Int_absorb1 G H)
    apply rule
     apply rule
     apply auto[1]
    apply rule
    apply (case_tac x)
    apply blast
    done

  from WORLDS RELATIONS V show ?thesis
    unfolding gen_model_def by simp
qed

(*>*)

subsection {*Simulations*}

text{*

\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'"}.

*}

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{* The value of a proposition should be the same at corresponding
worlds: *}

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{*

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.

*}

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{*

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.

*}

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{* The identity is a simulation: *}

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{*

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:

*}

Reverse simulation also:

*}

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>+"
  proof(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
  by - ( induct rule: rtrancl_induct[OF uv']
       , 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>*"
  proof(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{*

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

*}

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
proof(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{*

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.

*}

(*<*)
end
(*>*)


(* Authors: F. Maric, M. Spasic, R. Thiemann *)
section \<open>Rational Numbers Extended with Infinitesimal Element\<close>
theory QDelta
  imports
    Abstract_Linear_Poly
    Simplex_Algebra
begin

datatype QDelta = QDelta rat rat

primrec qdfst :: "QDelta \<Rightarrow> rat" where
  "qdfst (QDelta a b) = a"

primrec qdsnd :: "QDelta \<Rightarrow> rat" where
  "qdsnd (QDelta a b) = b"

lemma [simp]: "\<lbrakk>QDelta.qdsnd x = QDelta.qdsnd y; QDelta.qdfst y = QDelta.qdfst x\<rbrakk> \<Longrightarrow> x = y"
  by (cases x) auto

instantiation QDelta :: rational_vector
begin

definition zero_QDelta :: "QDelta"
  where
    "0 = QDelta 0 0"

definition plus_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "qd1 + qd2 = QDelta (qdfst qd1 + qdfst qd2) (qdsnd qd1 + qdsnd qd2)"

definition minus_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "qd1 - qd2 = QDelta (qdfst qd1 - qdfst qd2) (qdsnd qd1 - qdsnd qd2)"

definition uminus_QDelta :: "QDelta \<Rightarrow> QDelta"
  where
    "- qd = QDelta (- (qdfst qd)) (- (qdsnd qd))"

definition scaleRat_QDelta :: "rat \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "r *R qd = QDelta (r*(qdfst qd)) (r*(qdsnd qd))"

instance
proof
qed (auto simp add: plus_QDelta_def zero_QDelta_def uminus_QDelta_def minus_QDelta_def scaleRat_QDelta_def field_simps)
end

instantiation QDelta :: linorder
begin
definition less_eq_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> bool"
  where
    "qd1 \<le> qd2 \<longleftrightarrow> (qdfst qd1 < qdfst qd2) \<or> (qdfst qd1 = qdfst qd2 \<and> qdsnd qd1 \<le> qdsnd qd2)"

definition less_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> bool"
  where
    "qd1 < qd2 \<longleftrightarrow> (qdfst qd1 < qdfst qd2) \<or> (qdfst qd1 = qdfst qd2 \<and> qdsnd qd1 < qdsnd qd2)"

instance proof qed (auto simp add: less_QDelta_def less_eq_QDelta_def)
end

instantiation QDelta:: linordered_rational_vector
begin
instance proof qed (auto simp add: plus_QDelta_def less_QDelta_def scaleRat_QDelta_def mult_strict_left_mono mult_strict_left_mono_neg)
end

instantiation QDelta :: lrv
begin
definition one_QDelta where
  "one_QDelta = QDelta 1 0"
instance proof qed (auto simp add: one_QDelta_def zero_QDelta_def)
end

definition \<delta>0 :: "QDelta \<Rightarrow> QDelta \<Rightarrow> rat"
  where
    "\<delta>0 qd1 qd2 ==
    let c1 = qdfst qd1; c2 = qdfst qd2; k1 = qdsnd qd1; k2 = qdsnd qd2 in
      (if (c1 < c2 \<and> k1 > k2) then
              (c2 - c1) / (k1 - k2)
       else
               1
       )
    "

definition val :: "QDelta \<Rightarrow> rat \<Rightarrow> rat"
  where "val qd \<delta> = (qdfst qd) + \<delta> * (qdsnd qd)"

lemma val_plus:
  "val (qd1 + qd2) \<delta> = val qd1 \<delta> + val qd2 \<delta>"
  by (simp add: field_simps val_def plus_QDelta_def)

lemma val_scaleRat:
  "val (c *R qd) \<delta> = c * val qd \<delta>"
  by (simp add: field_simps val_def scaleRat_QDelta_def)

lemma qdfst_setsum:
  "finite A \<Longrightarrow> qdfst (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. qdfst (f x))"
  by (induct A rule: finite_induct) (auto simp add: zero_QDelta_def plus_QDelta_def)

lemma qdsnd_setsum:
  "finite A \<Longrightarrow> qdsnd (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. qdsnd (f x))"
  by (induct A rule: finite_induct) (auto simp add: zero_QDelta_def plus_QDelta_def)

lemma valuate_valuate_rat:
  "lp \<lbrace>(\<lambda>v. (QDelta (vl v) 0))\<rbrace> = QDelta (lp\<lbrace>vl\<rbrace>) 0"
  using Rep_linear_poly
  by (simp add: valuate_def scaleRat_QDelta_def qdsnd_setsum qdfst_setsum)

lemma valuate_rat_valuate:
  "lp\<lbrace>(\<lambda>v. val (vl v) \<delta>)\<rbrace> = val (lp\<lbrace>vl\<rbrace>) \<delta>"
  unfolding valuate_def val_def
  using rational_vector.scale_sum_right[of \<delta> "\<lambda>x. Rep_linear_poly lp x * qdsnd (vl x)" "{v :: nat. Rep_linear_poly lp v \<noteq> (0 :: rat)}"]
  using Rep_linear_poly
  by (auto simp add: field_simps sum.distrib qdfst_setsum qdsnd_setsum) (auto simp add: scaleRat_QDelta_def)

lemma delta0:
  assumes "qd1 \<le> qd2"
  shows "\<forall> \<epsilon>. \<epsilon> > 0 \<and> \<epsilon> \<le> (\<delta>0 qd1 qd2) \<longrightarrow> val qd1 \<epsilon> \<le> val qd2 \<epsilon>"
proof-
  have "\<And> e c1 c2 k1 k2 :: rat. \<lbrakk>e \<ge> 0; c1 < c2; k1 \<le> k2\<rbrakk> \<Longrightarrow> c1 + e*k1 \<le> c2 + e*k2"
  proof-
    fix e c1 c2 k1 k2 :: rat
    show "\<lbrakk>e \<ge> 0; c1 < c2; k1 \<le> k2\<rbrakk> \<Longrightarrow> c1 + e*k1 \<le> c2 + e*k2"
      using mult_left_mono[of "k1" "k2" "e"]
      using add_less_le_mono[of "c1" "c2" "e*k1" "e*k2"]
      by simp
  qed
  then show ?thesis
    using assms
    by (auto simp add: \<delta>0_def val_def less_eq_QDelta_def Let_def field_simps mult_left_mono)
qed

primrec
  \<delta>_min ::"(QDelta \<times> QDelta) list \<Rightarrow> rat" where
  "\<delta>_min [] = 1" |
  "\<delta>_min (h # t) = min (\<delta>_min t) (\<delta>0 (fst h) (snd h))"

lemma delta_gt_zero:
  "\<delta>_min l > 0"
  by (induct l) (auto simp add: Let_def field_simps \<delta>0_def)

lemma delta_le_one:
  "\<delta>_min l \<le> 1"
  by (induct l, auto)

lemma delta_min_append:
  "\<delta>_min (as @ bs) = min (\<delta>_min as) (\<delta>_min bs)"
  by (induct as, insert delta_le_one[of bs], auto)

lemma delta_min_mono: "set as \<subseteq> set bs \<Longrightarrow> \<delta>_min bs \<le> \<delta>_min as"
proof (induct as)
  case Nil
  then show ?case using delta_le_one by simp
next
  case (Cons a as)
  from Cons(2) have "a \<in> set bs" by auto
  from split_list[OF this]
  obtain bs1 bs2 where bs: "bs = bs1 @ [a] @ bs2" by auto
  have bs: "\<delta>_min bs = \<delta>_min ([a] @ bs)" unfolding bs delta_min_append by auto
  show ?case unfolding bs using Cons(1-2) by auto
qed

lemma delta_min:
  assumes "\<forall> qd1 qd2. (qd1, qd2) \<in> set qd \<longrightarrow> qd1 \<le> qd2"
  shows "\<forall> \<epsilon>. \<epsilon> > 0 \<and> \<epsilon> \<le> \<delta>_min qd \<longrightarrow> (\<forall> qd1 qd2. (qd1, qd2) \<in> set qd \<longrightarrow> val qd1 \<epsilon> \<le> val qd2 \<epsilon>)"
  using assms
  using delta0
  by (induct qd, auto)

lemma QDelta_0_0: "QDelta 0 0 = 0" by code_simp
lemma qdsnd_0: "qdsnd 0 = 0" by code_simp
lemma qdfst_0: "qdfst 0 = 0" by code_simp

end


section \<open>Prisms\<close>

theory Prisms
  imports Lenses
begin

subsection \<open> Signature and Axioms \<close>

text \<open>Prisms are like lenses, but they act on sum types rather than product types~\<^cite>\<open>"Gibbons17"\<close>.
  See \url{https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Prism.html}
  for more information.\<close>

record ('v, 's) prism =
  prism_match :: "'s \<Rightarrow> 'v option" ("match\<index>")
  prism_build :: "'v \<Rightarrow> 's" ("build\<index>")

type_notation
  prism (infixr "\<Longrightarrow>\<^sub>\<triangle>" 0)

locale wb_prism =
  fixes x :: "'v \<Longrightarrow>\<^sub>\<triangle> 's" (structure)
  assumes match_build: "match (build v) = Some v"
  and build_match: "match s = Some v \<Longrightarrow> s = build v"
begin

  lemma build_match_iff: "match s = Some v \<longleftrightarrow> s = build v"
    using build_match match_build by blast

  lemma range_build: "range build = dom match"
    using build_match match_build by fastforce

  lemma inj_build: "inj build"
    by (metis injI match_build option.inject)

end

declare wb_prism.match_build [simp]
declare wb_prism.build_match [simp]

subsection \<open> Co-dependence \<close>

text \<open> The relation states that two prisms construct disjoint elements of the source. This
  can occur, for example, when the two prisms characterise different constructors of an
  algebraic datatype. \<close>

definition prism_diff :: "('a \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> ('b \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> bool" (infix "\<nabla>" 50) where
[lens_defs]: "prism_diff X Y = (range build\<^bsub>X\<^esub> \<inter> range build\<^bsub>Y\<^esub> = {})"

lemma prism_diff_intro:
  "(\<And> s\<^sub>1 s\<^sub>2. build\<^bsub>X\<^esub> s\<^sub>1 = build\<^bsub>Y\<^esub> s\<^sub>2 \<Longrightarrow> False) \<Longrightarrow> X \<nabla> Y"
  by (auto simp add: prism_diff_def)

lemma prism_diff_irrefl: "\<not> X \<nabla> X"
  by (simp add: prism_diff_def)

lemma prism_diff_sym: "X \<nabla> Y \<Longrightarrow> Y \<nabla> X"
  by (auto simp add: prism_diff_def)

lemma prism_diff_build: "X \<nabla> Y \<Longrightarrow> build\<^bsub>X\<^esub> u \<noteq> build\<^bsub>Y\<^esub> v"
  by (simp add: disjoint_iff_not_equal prism_diff_def)

lemma prism_diff_build_match: "\<lbrakk> wb_prism X; X \<nabla> Y \<rbrakk> \<Longrightarrow> match\<^bsub>X\<^esub> (build\<^bsub>Y\<^esub> v) = None"
  using UNIV_I wb_prism.range_build by (fastforce simp add: prism_diff_def)

subsection \<open> Canonical prisms \<close>

definition prism_id :: "('a \<Longrightarrow>\<^sub>\<triangle> 'a)" ("1\<^sub>\<triangle>") where
[lens_defs]: "prism_id = \<lparr> prism_match = Some, prism_build = id \<rparr>"

lemma wb_prism_id: "wb_prism 1\<^sub>\<triangle>"
  unfolding prism_id_def wb_prism_def by simp

lemma prism_id_never_diff: "\<not> 1\<^sub>\<triangle> \<nabla> X"
  by (simp add: prism_diff_def prism_id_def)

subsection \<open> Summation \<close>

definition prism_plus :: "('a \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> ('b \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> 'a + 'b \<Longrightarrow>\<^sub>\<triangle> 's" (infixl "+\<^sub>\<triangle>" 85)
  where
[lens_defs]: "X +\<^sub>\<triangle> Y = \<lparr> prism_match = (\<lambda> s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of
                                 (Some u, _) \<Rightarrow> Some (Inl u) |
                                 (None, Some v) \<Rightarrow> Some (Inr v) |
                                 (None, None) \<Rightarrow> None),
           prism_build = (\<lambda> v. case v of Inl x \<Rightarrow> build\<^bsub>X\<^esub> x | Inr y \<Rightarrow> build\<^bsub>Y\<^esub> y) \<rparr>"

lemma prism_plus_wb [simp]: "\<lbrakk> wb_prism X; wb_prism Y; X \<nabla> Y \<rbrakk> \<Longrightarrow> wb_prism (X +\<^sub>\<triangle> Y)"
  apply (unfold_locales)
   apply (auto simp add: prism_plus_def sum.case_eq_if option.case_eq_if prism_diff_build_match)
  apply (metis map_option_case map_option_eq_Some option.exhaust option.sel sum.disc(2) sum.sel(1) wb_prism.build_match_iff)
  apply (metis (no_types, lifting) isl_def not_None_eq option.case_eq_if option.sel sum.sel(2) wb_prism.build_match)
  done

lemma build_plus_Inl [simp]: "build\<^bsub>c +\<^sub>\<triangle> d\<^esub> (Inl x) = build\<^bsub>c\<^esub> x"
  by (simp add: prism_plus_def)

lemma build_plus_Inr [simp]: "build\<^bsub>c +\<^sub>\<triangle> d\<^esub> (Inr y) = build\<^bsub>d\<^esub> y"
  by (simp add: prism_plus_def)

lemma prism_diff_preserved_1 [simp]: "\<lbrakk> X \<nabla> Y; X \<nabla> Z \<rbrakk> \<Longrightarrow> X \<nabla> Y +\<^sub>\<triangle> Z"
  by (auto simp add: lens_defs sum.case_eq_if)

lemma prism_diff_preserved_2 [simp]: "\<lbrakk> X \<nabla> Z; Y \<nabla> Z \<rbrakk> \<Longrightarrow> X +\<^sub>\<triangle> Y \<nabla> Z"
  by (meson prism_diff_preserved_1 prism_diff_sym)

text \<open> The following two lemmas are useful for reasoning about prism sums \<close>

lemma Bex_Sum_iff: "(\<exists>x\<in>A<+>B. P x) \<longleftrightarrow> (\<exists> x\<in>A. P (Inl x)) \<or> (\<exists> y\<in>B. P (Inr y))"
  by (auto)

lemma Ball_Sum_iff: "(\<forall>x\<in>A<+>B. P x) \<longleftrightarrow> (\<forall> x\<in>A. P (Inl x)) \<and> (\<forall> y\<in>B. P (Inr y))"
  by (auto)

subsection \<open> Instances \<close>

definition prism_suml :: "('a, 'a + 'b) prism" ("Inl\<^sub>\<triangle>") where
[lens_defs]: "prism_suml = \<lparr> prism_match = (\<lambda> v. case v of Inl x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inl \<rparr>"

definition prism_sumr :: "('b, 'a + 'b) prism" ("Inr\<^sub>\<triangle>") where
[lens_defs]: "prism_sumr = \<lparr> prism_match = (\<lambda> v. case v of Inr x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inr \<rparr>"

lemma wb_prim_suml [simp]: "wb_prism Inl\<^sub>\<triangle>"
  apply (unfold_locales)
   apply (simp_all add: prism_suml_def sum.case_eq_if)
  apply (metis option.inject option.simps(3) sum.collapse(1))
  done

lemma wb_prim_sumr [simp]: "wb_prism Inr\<^sub>\<triangle>"
  apply (unfold_locales)
   apply (simp_all add: prism_sumr_def sum.case_eq_if)
  apply (metis option.distinct(1) option.inject sum.collapse(2))
  done

lemma prism_suml_indep_sumr [simp]: "Inl\<^sub>\<triangle> \<nabla> Inr\<^sub>\<triangle>"
  by (auto simp add: lens_defs)

lemma prism_sum_plus: "Inl\<^sub>\<triangle> +\<^sub>\<triangle> Inr\<^sub>\<triangle> = 1\<^sub>\<triangle>"
  unfolding lens_defs prism_plus_def by (auto simp add: Inr_Inl_False sum.case_eq_if)

subsection \<open> Lens correspondence \<close>

text \<open> Every well-behaved prism can be represented by a partial bijective lens. We prove
  this by exhibiting conversion functions and showing they are (almost) inverses. \<close>

definition prism_lens :: "('a, 's) prism \<Rightarrow> ('a \<Longrightarrow> 's)" where
"prism_lens X = \<lparr> lens_get = (\<lambda> s. the (match\<^bsub>X\<^esub> s)), lens_put = (\<lambda> s v. build\<^bsub>X\<^esub> v) \<rparr>"

definition lens_prism :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a, 's) prism" where
"lens_prism X = \<lparr> prism_match = (\<lambda> s. if (s \<in> \<S>\<^bsub>X\<^esub>) then Some (get\<^bsub>X\<^esub> s) else None)
                , prism_build = create\<^bsub>X\<^esub> \<rparr>"

lemma mwb_prism_lens: "wb_prism a \<Longrightarrow> mwb_lens (prism_lens a)"
  by (simp add: mwb_lens_axioms_def mwb_lens_def weak_lens_def prism_lens_def)

lemma get_prism_lens: "get\<^bsub>prism_lens X\<^esub> = the \<circ> match\<^bsub>X\<^esub>"
  by (simp add: prism_lens_def fun_eq_iff)

lemma src_prism_lens: "\<S>\<^bsub>prism_lens X\<^esub> = range (build\<^bsub>X\<^esub>)"
  by (auto simp add: prism_lens_def lens_source_def)

lemma create_prism_lens: "create\<^bsub>prism_lens X\<^esub> = build\<^bsub>X\<^esub>"
  by (simp add: prism_lens_def lens_create_def fun_eq_iff)

lemma prism_lens_inverse:
  "wb_prism X \<Longrightarrow> lens_prism (prism_lens X) = X"
  unfolding lens_prism_def src_prism_lens create_prism_lens get_prism_lens
  by (auto intro: prism.equality simp add: fun_eq_iff domIff wb_prism.range_build)

text \<open> Function @{const lens_prism} is almost inverted by @{const prism_lens}. The $put$
  functions are identical, but the $get$ functions differ when applied to a source where
  the prism @{term X} is undefined. \<close>

lemma lens_prism_put_inverse:
  "pbij_lens X \<Longrightarrow> put\<^bsub>prism_lens (lens_prism X)\<^esub> = put\<^bsub>X\<^esub>"
  unfolding prism_lens_def lens_prism_def
  by (auto simp add: fun_eq_iff pbij_lens.put_is_create)

lemma wb_prism_implies_pbij_lens:
  "wb_prism X \<Longrightarrow> pbij_lens (prism_lens X)"
  by (unfold_locales, simp_all add: prism_lens_def)

lemma pbij_lens_implies_wb_prism:
  assumes "pbij_lens X"
  shows "wb_prism (lens_prism X)"
proof (unfold_locales)
  fix s v
  show "match\<^bsub>lens_prism X\<^esub> (build\<^bsub>lens_prism X\<^esub> v) = Some v"
    by (simp add: lens_prism_def weak_lens.create_closure assms)
  assume a: "match\<^bsub>lens_prism X\<^esub> s = Some v"
  show "s = build\<^bsub>lens_prism X\<^esub> v"
  proof (cases "s \<in> \<S>\<^bsub>X\<^esub>")
    case True
    with a assms show ?thesis
      by (simp add: lens_prism_def lens_create_def,
          metis mwb_lens.weak_get_put pbij_lens.put_det pbij_lens_mwb)
  next
    case False
    with a assms show ?thesis by (simp add: lens_prism_def)
  qed
qed

ML_file \<open>Prism_Lib.ML\<close>

end


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

(*<*)
theory Chapter3_HoareHeap
imports "AutoCorres.AutoCorres"
begin

external_file "swap.c"
(*>*)

subsection \<open>\texttt{swap}\<close>

text \<open>

  Here, we use AutoCorres to verify a C program that reads and writes to the heap.
  Our C function, \texttt{swap}, swaps two words in memory:

\lstinputlisting[language=C, firstline=15]{../../swap.c}

  Again, we translate the program using the C parser and AutoCorres.
\<close>

install_C_file "swap.c"
autocorres [heap_abs_syntax, ts_rules = nondet] "swap.c"
(*<*)
context swap begin
(*>*)

text \<open>
  Most heap operations in C programs consist of accessing a pointer.
  AutoCorres abstracts the global C heap by creating one heap for
  each type. (In our simple \texttt{swap} example, it creates only
  a @{typ word32} heap.) This makes verification easier as long as
  the program does not access the same memory as two different types.

  There are other operations that are relevant to program verification,
  such as changing the type that occupies a given region of memory.
  AutoCorres will not abstract any functions that use these operations,
  so verifying them will be more complicated (but still possible).
\<close>

text \<open>
  The C parser expresses \texttt{swap} like this:
\<close>

thm swap_body_def
text \<open>@{thm [display] swap_body_def}\<close>

text \<open>
  AutoCorres abstracts the function to this:
\<close>

thm swap'_def
text \<open>@{thm [display] swap'_def }\<close>

text \<open>
  There are some things to note:

  The function contains guards (assertions) that the pointers
  \texttt{a} and \texttt{b} are valid. We need to prove that
  these guards never fail when verifying \texttt{swap}.
  Conversely, when verifying any function that calls
  \texttt{swap}, we need to show that the arguments are
  valid pointers.

  We saw a monadic program in the previous section, but here
  the monad is actually being used to carry the program heap.
\<close>

(* FIXME: something about heap syntax here. *)

text \<open>
  Now we prove that \texttt{swap} is correct. We use @{term x}
  and @{term y} to ``remember'' the initial values so that we can
  talk about them in the postcondition.
\<close>
lemma "\<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply clarsimp
  txt \<open>
    The C parser and AutoCorres both model the C heap using functions,
    which takes a pointer to some object in memory. Heap updates are
    modelled using the functional update @{term fun_upd}:

      @{thm [display] fun_upd_def}

    To reason about functional updates, we use the rule fun\_upd\_apply.
\<close>
  apply (simp add: fun_upd_apply)
  done

text \<open>
  Note that we have ``only'' proved that the function swaps its
  arguments. We have not proved that it does \emph{not} change
  any other state. This is a typical \emph{frame problem} with
  pointer reasoning. We can prove a more complete specification
  of \texttt{swap}:
\<close>
lemma "(\<And>x y s. P (s[a := x][b := y]) = P s) \<Longrightarrow>
       \<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<and> P s \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<and> P s \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

text \<open>
  In other words, if predicate @{term P} does not depend on the
  inputs to \texttt{swap}, it will continue to hold.

  \emph{Separation logic} provides a more structured approach
  to this problem.
\<close>

(*<*)
end
end
(*>*)


subsubsection\<open>Mimicking the original\<close>

theory SC_Gentzen
imports SC_Depth SC_Cut
begin

text\<open>This system attempts to mimic the original sequent calculus
  (``Reihen von Formeln, durch Kommata getrennt'', translates roughly to sequences of formulas, separated by a comma)~\cite{gentzen1935untersuchungen}.\<close>
inductive SCg :: "'a formula list \<Rightarrow> 'a formula list \<Rightarrow> bool" (infix "\<Rightarrow>" 30) where
Anfang: "[\<DD>] \<Rightarrow> [\<DD>]" |
FalschA: "[\<bottom>] \<Rightarrow> []" |
VerduennungA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
VerduennungS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
ZusammenziehungA: "\<DD>#\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
ZusammenziehungS: "\<Gamma> \<Rightarrow> \<DD>#\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Theta>" |
VertauschungA: "\<Delta>@\<DD>#\<EE>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<EE>#\<DD>#\<Gamma> \<Rightarrow> \<Theta>" |
VertauschungS: "\<Gamma> \<Rightarrow> \<Theta>@\<EE>#\<DD>#\<Lambda> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<DD>#\<EE>#\<Lambda>" |
Schnitt: "\<lbrakk>\<Gamma> \<Rightarrow> \<DD>#\<Theta>; \<DD>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
UES: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<Gamma> \<Rightarrow> \<BB>#\<Theta>\<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<and>\<BB>#\<Theta>" |
UEA1: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" | UEA2: "\<BB>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<AA>\<^bold>\<and>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
OEA: "\<lbrakk>\<AA>#\<Gamma> \<Rightarrow> \<Theta>; \<BB>#\<Gamma> \<Rightarrow> \<Theta>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<or>\<BB>#\<Gamma> \<Rightarrow> \<Theta>" |
OES1: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" | OES2: "\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<or>\<BB>#\<Theta>" |
FES: "\<AA>#\<Gamma> \<Rightarrow> \<BB>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Theta>" |
FEA: "\<lbrakk>\<Gamma> \<Rightarrow> \<AA>#\<Theta>; \<BB>#\<Delta> \<Rightarrow> \<Lambda>\<rbrakk> \<Longrightarrow> \<AA>\<^bold>\<rightarrow>\<BB>#\<Gamma>@\<Delta> \<Rightarrow> \<Theta>@\<Lambda>" |
NES: "\<AA>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<^bold>\<not>\<AA>#\<Theta>" |
NEA: "\<Gamma> \<Rightarrow> \<AA>#\<Theta> \<Longrightarrow> \<^bold>\<not>\<AA>#\<Gamma> \<Rightarrow> \<Theta>"
text\<open>Nota bene: E here stands for ``Einführung'', which is introduction and not elemination.\<close>
text\<open>The rule for @{term \<bottom>} is not part of the original calculus. Its addition is necessary to show equivalence to our @{const SCp}.\<close>

text\<open>Note that we purposefully did not recreate the fact that Gentzen sometimes puts his principal formulas on end and sometimes on the beginning of the list.\<close>

lemma AnfangTauschA: "\<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta>"
  by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
lemma AnfangTauschS: "\<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta>"
  by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)
lemma MittenTauschA: "\<Delta>@\<DD>#\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<DD>#\<Delta>@\<Gamma> \<Rightarrow> \<Theta>"
  by(induction \<Delta> arbitrary: \<Gamma> rule: List.rev_induct) (simp_all add: VertauschungA)
lemma MittenTauschS: "\<Gamma> \<Rightarrow> \<Delta>@\<DD>#\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<DD>#\<Delta>@\<Theta>"
  by(induction \<Delta> arbitrary: \<Theta> rule: List.rev_induct) (simp_all add: VertauschungS)

lemma BotLe: "\<bottom>\<in>set \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>"
proof -
  have A: "\<bottom>#\<Gamma>\<Rightarrow>[]" for \<Gamma> by(induction \<Gamma>) (simp_all add: FalschA VerduennungA VertauschungA[where \<Delta>=Nil, simplified])
  have *: "\<bottom>#\<Gamma>\<Rightarrow>\<Delta>" for \<Gamma> by(induction \<Delta>) (simp_all add: A VerduennungS)
  assume "\<bottom>\<in>set \<Gamma>" then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1@\<bottom>#\<Gamma>2" by (meson split_list)
  show ?thesis unfolding \<Gamma> using AnfangTauschA * by blast
qed

lemma Axe: "A \<in> set \<Gamma> \<Longrightarrow> A \<in> set \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  have A: "A#\<Gamma> \<Rightarrow> [A]" for \<Gamma> by(induction \<Gamma>) (simp_all add: Anfang VertauschungA[where \<Delta>=Nil, simplified] VerduennungA)
  have S: "A#\<Gamma> \<Rightarrow> A#\<Delta>" for \<Gamma> \<Delta> by(induction \<Delta>) (simp_all add: A Anfang VertauschungS[where \<Theta>=Nil, simplified] VerduennungS)
  assume "A \<in> set \<Gamma>" "A \<in> set \<Delta>" thus ?thesis
    apply(-)
    apply(drule split_list)+
    apply(clarify)
    apply(intro AnfangTauschA AnfangTauschS)
    apply(rule S)
  done
qed

lemma VerduennungListeA: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma>'@\<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
  proof(induction \<Gamma>')
    case (Cons a as)
    from \<open>\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ a # as\<close> guess \<Gamma>'' ..
    hence "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ as" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
    from Cons.IH[OF Cons.prems(1) this] have "as @ \<Gamma> \<Rightarrow> \<Theta>" .
    thus ?case using VerduennungA by simp
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma>@\<Gamma> \<Rightarrow> \<Theta>" by simp
qed
lemma VerduennungListeS: "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>'@\<Theta>" for \<Theta>'
  proof(induction \<Theta>')
    case (Cons a as)
    from \<open>\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ a # as\<close> guess \<Theta>'' ..
    hence "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ as" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
    from Cons.IH[OF Cons.prems(1) this] have " \<Gamma> \<Rightarrow> as @ \<Theta>" .
    thus ?case using VerduennungS by simp
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>@\<Theta>" by simp
qed
(* wak, those weren't the droids I was looking for. *)
lemma ZusammenziehungListeA: "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma>'@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<exists>\<Gamma>''. \<Gamma>=\<Gamma>''@\<Gamma>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Gamma>'
  proof(induction \<Gamma>')
    case (Cons a \<Gamma>')
    from \<open>\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ a # \<Gamma>'\<close> guess \<Gamma>'' .. note \<Gamma>'' = this
    then obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ a # \<Gamma>2" by blast
    from \<Gamma>'' have **: "\<exists>\<Gamma>''. \<Gamma> = \<Gamma>'' @ \<Gamma>'" by(intro exI[where x="\<Gamma>'' @ [a]"]) simp
    from Cons.prems(1) have "a # (a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" unfolding \<Gamma>  using MittenTauschA by (metis append_assoc)
    hence "(a # \<Gamma>') @ \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Theta>" using ZusammenziehungA by auto
    hence "\<Gamma>' @ \<Gamma> \<Rightarrow> \<Theta>" unfolding \<Gamma>  using AnfangTauschA by (metis append_Cons append_assoc)
    from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
  qed simp
  thus "\<Gamma>@\<Gamma> \<Rightarrow> \<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" by simp
qed
lemma ZusammenziehungListeS: "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>"
proof -
  have "\<Gamma> \<Rightarrow> \<Theta>'@\<Theta> \<Longrightarrow> \<exists>\<Theta>''. \<Theta>=\<Theta>''@\<Theta>' \<Longrightarrow> \<Gamma> \<Rightarrow> \<Theta>" for \<Theta>'
  proof(induction \<Theta>')
    case (Cons a \<Theta>')
    from \<open>\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ a # \<Theta>'\<close> guess \<Theta>'' .. note \<Theta>'' = this
    then obtain \<Theta>1 \<Theta>2 where \<Theta>: "\<Theta> = \<Theta>1 @ a # \<Theta>2" by blast
    from \<Theta>'' have **: "\<exists>\<Theta>''. \<Theta> = \<Theta>'' @ \<Theta>'" by(intro exI[where x="\<Theta>'' @ [a]"]) simp
    from Cons.prems(1) have "\<Gamma> \<Rightarrow> a # (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" unfolding \<Theta>  using MittenTauschS by (metis append_assoc)
    hence "\<Gamma> \<Rightarrow> (a # \<Theta>') @ \<Theta>1 @ \<Theta>2" using ZusammenziehungS by auto
    hence "\<Gamma> \<Rightarrow> \<Theta>' @ \<Theta>" unfolding \<Theta>  using AnfangTauschS by (metis append_Cons append_assoc)
    from Cons.IH[OF this **] show "\<Gamma> \<Rightarrow> \<Theta>" .
  qed simp
  thus "\<Gamma> \<Rightarrow> \<Theta>@\<Theta> \<Longrightarrow> \<Gamma> \<Rightarrow>\<Theta>" by simp
qed

theorem gentzen_sc_eq: "mset \<Gamma> \<Rightarrow> mset \<Delta> \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>" proof
  assume "mset \<Gamma> \<Rightarrow> mset \<Delta>"
  then obtain n where "mset \<Gamma> \<Rightarrow> mset \<Delta> \<down> n" unfolding SC_SCp_eq[symmetric] ..
  thus "\<Gamma> \<Rightarrow> \<Delta>"
  (* structural induction not necessary at all. I still don't get it. *)
  proof(induction n arbitrary: \<Gamma> \<Delta> rule: nat.induct)
    case (Suc n)
    have sr: "\<exists>\<Gamma>1 \<Gamma>2. \<Gamma> = \<Gamma>1 @ F # \<Gamma>2 \<and> \<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" (is "?s") if "mset \<Gamma> = F, \<Gamma>'" for \<Gamma> \<Gamma>' F proof -
      from that obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ F # \<Gamma>2" by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
      hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using that by auto
      show ?s using \<Gamma> \<Gamma>' by blast
    qed
    from Suc.prems show ?case proof(cases rule: SCc.cases)
      case BotL thus ?thesis using BotLe by simp
    next
      case Ax thus ?thesis using Axe by simp
    next
      case (NotL \<Gamma>' F)
      from \<open>mset \<Gamma> = \<^bold>\<not> F, \<Gamma>'\<close> obtain \<Gamma>1 \<Gamma>2 where \<Gamma>: "\<Gamma> = \<Gamma>1 @ \<^bold>\<not> F # \<Gamma>2"
        by (metis split_list add.commute ex_mset list.set_intros(1) mset.simps(2) set_mset_mset)
      hence \<Gamma>': "\<Gamma>' = mset (\<Gamma>1@\<Gamma>2)" using NotL(1) by simp
      from \<open>\<Gamma>' \<Rightarrow> F, mset \<Delta> \<down> n\<close> have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" unfolding \<Gamma>' by (simp add: add.commute)
      from Suc.IH[OF this] show ?thesis unfolding \<Gamma> using AnfangTauschA NEA by blast
    next
      case (NotR F \<Delta>')
      from sr[OF NotR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
      with NotR have "mset (F#\<Gamma>) \<Rightarrow> mset (\<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
      from Suc.IH[OF this] show ?thesis using \<Delta> using AnfangTauschS NES by blast
    next
      case (AndR F \<Delta>' G)
      from sr[OF AndR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
      with AndR have "mset \<Gamma> \<Rightarrow> mset (F # \<Delta>1@\<Delta>2) \<down> n" "mset \<Gamma> \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS UES by blast
    next
      case (OrR F G \<Delta>')
      from sr[OF OrR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
      with OrR have "mset \<Gamma> \<Rightarrow> mset (G # F # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
      from this[THEN Suc.IH] have "\<Gamma> \<Rightarrow> G # F # \<Delta>1 @ \<Delta>2" .
      with OES2 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F # \<Delta>1 @ \<Delta>2" .
      with VertauschungS[where \<Theta>=Nil, simplified] have "\<Gamma> \<Rightarrow> F # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
      with OES1 have "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" .
      hence "\<Gamma> \<Rightarrow> F \<^bold>\<or> G # \<Delta>1 @ \<Delta>2" using ZusammenziehungS by fast
      thus ?thesis unfolding \<Delta>[THEN conjunct1] using AnfangTauschS by blast
    next
      case (ImpR F G \<Delta>')
      from sr[OF ImpR(1)] guess \<Delta>1 .. then guess \<Delta>2 .. note \<Delta> = this
      with ImpR have "mset (F#\<Gamma>) \<Rightarrow> mset (G # \<Delta>1@\<Delta>2) \<down> n" by (simp add: add.commute)
      from this[THEN Suc.IH] show ?thesis using \<Delta> using AnfangTauschS FES by blast
    next
      case (AndL F G \<Gamma>')
      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
      with AndL have "mset (G # F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute add.left_commute add_mset_commute)
      from this[THEN Suc.IH] have "G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with UEA2 have "F \<^bold>\<and> G # F # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with VertauschungA[where \<Delta>=Nil, simplified] have "F # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      with UEA1 have "F \<^bold>\<and> G # F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      hence "F \<^bold>\<and> G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" using ZusammenziehungA by fast
      thus ?thesis unfolding \<Gamma>[THEN conjunct1] using AnfangTauschA by blast
    next
      case (OrL F \<Delta>' G)
      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
      with OrL have "mset (F # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] show ?thesis using \<Gamma> using AnfangTauschA OEA by blast
    next
      case (ImpL \<Gamma>' F G)
      from sr[OF this(1)] guess \<Gamma>1 .. then guess \<Gamma>2 .. note \<Gamma> = this
      with ImpL have "mset (\<Gamma>1@\<Gamma>2) \<Rightarrow> mset (F#\<Delta>) \<down> n" "mset (G # \<Gamma>1@\<Gamma>2) \<Rightarrow> mset \<Delta> \<down> n" by (simp add: add.commute)+
      from this[THEN Suc.IH] have "\<Gamma>1 @ \<Gamma>2 \<Rightarrow> F # \<Delta>" "G # \<Gamma>1 @ \<Gamma>2 \<Rightarrow> \<Delta>" .
      from FEA[OF this] have "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" .
      hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) @ (F \<^bold>\<rightarrow> G # \<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using AnfangTauschA VerduennungA by blast (* given the form of ZusammenziehungListeA, using this intermediate step is just easier. maybe a different from for ZusammenziehungListeA would be nice? *)
      hence "F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2) \<Rightarrow> \<Delta> @ \<Delta>" using ZusammenziehungListeA[where \<Gamma>="F \<^bold>\<rightarrow> G # (\<Gamma>1 @ \<Gamma>2)"] by simp
      thus ?thesis unfolding \<Gamma>[THEN conjunct1] by(intro AnfangTauschA; elim ZusammenziehungListeS)
    qed
  qed blast
next
  have mset_Cons[simp]: "mset (A # S) = A, mset S" for A::"'a formula" and S by (simp add: add.commute)
  note mset.simps(2)[simp del]
  show "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> mset \<Gamma> \<Rightarrow> mset \<Delta>" proof(induction rule: SCg.induct)
    (*sed -n '/^\([^\\]*\):/ {N;s/_\\\?//g; s/let.*$//; s/\n//; s/[\\:]//g; s/fix //; s/  / /g; s/^.*$/case (&) thus ?case sorry/; p;}' ${print_cases} *)
    case (Anfang \<DD>) thus ?case using extended_Ax SC_SCp_eq by force
  next
    case (FalschA) thus ?case using SCp.BotL by force
  next
    case (VerduennungA \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenL)
  next
    case (VerduennungS \<Gamma> \<Theta> \<DD>) thus ?case by (simp add: SC.weakenR)
  next
    case (ZusammenziehungA \<DD> \<Gamma> \<Theta>) thus ?case using contractL by force
  next
    case (ZusammenziehungS \<Gamma> \<DD> \<Theta>) thus ?case using contract by force
  next
    case (VertauschungA \<Delta> \<DD> \<EE> \<Gamma> \<Theta>) thus ?case by fastforce
  next
    case (VertauschungS \<Gamma> \<Theta> \<EE> \<DD> \<Lambda>) thus ?case by fastforce
  next
    case (Schnitt \<Gamma> \<DD> \<Theta> \<Delta> \<Lambda>)
    hence "mset \<Gamma> \<Rightarrow> \<DD>,mset \<Theta>" "\<DD>,mset \<Delta> \<Rightarrow> mset \<Lambda>" using SC_SCp_eq by auto
    from cut_cf[OF this] show ?case unfolding SC_SCp_eq by simp
  next
    case (UES \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SCp.AndR by (simp add: SC_SCp_eq)
  next
    case (UEA1 \<AA> \<Gamma> \<Theta> \<BB>)
    from \<open>mset (\<AA> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
    thus ?case using SCp.AndL by force
  next
    case (UEA2 \<BB> \<Gamma> \<Theta> \<AA>)
    from \<open>mset (\<BB> # \<Gamma>) \<Rightarrow> mset \<Theta>\<close> have "\<AA>,\<BB>,mset \<Gamma> \<Rightarrow> mset \<Theta>" using SC.weakenL by auto
    thus ?case using SCp.AndL by force
  next
    case (OEA \<AA> \<Gamma> \<Theta> \<BB>) thus ?case unfolding SC_SCp_eq by (simp add: SCp.OrL)
  next
    case (OES1 \<Gamma> \<AA> \<Theta> \<BB>) thus ?case using SC.weakenR[where 'a='a] by(auto intro!: SCp.intros(3-))
  next
    case (OES2 \<Gamma> \<BB> \<Theta> \<AA>) thus ?case by (simp add: SC.weakenR SCp.OrR)
  next
    case (FES \<AA> \<Gamma> \<BB> \<Theta>) thus ?case using weakenR unfolding SC_SCp_eq by (simp add: SCp.ImpR)
  next
    case (FEA \<Gamma> \<AA> \<Theta> \<BB> \<Delta> \<Lambda>)
    from \<open>mset \<Gamma> \<Rightarrow> mset (\<AA> # \<Theta>)\<close>[THEN weakenL_set, THEN weakenR_set, of "mset \<Delta>" "mset \<Lambda>"]
    have S: "mset (\<Gamma>@\<Delta>) \<Rightarrow> \<AA>,mset (\<Theta>@\<Lambda>)" unfolding mset_append mset_Cons by (simp add: add_ac) (* sledgehammer comes up with some funny proof using cut\<dots> *)
    from FEA obtain m where "mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Lambda>" by blast
    hence "mset \<Gamma> + mset (\<BB> # \<Delta>) \<Rightarrow> mset \<Theta> + mset \<Lambda>" using weakenL_set weakenR_set by fast
    hence A: "\<BB>,mset (\<Gamma>@\<Delta>) \<Rightarrow> mset (\<Theta>@\<Lambda>)" by (simp add: add.left_commute)
    show ?case using S A SC_SCp_eq SCp.ImpL unfolding mset_Cons by blast
  next
    case (NES \<AA> \<Gamma> \<Theta>) thus ?case using SCp.NotR by(simp add: SC_SCp_eq)
  next
    case (NEA \<Gamma> \<AA> \<Theta>) thus ?case using SCp.NotL by(simp add: SC_SCp_eq)
  qed
qed

end