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

theory Kripke
imports Main
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 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 \<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>"
      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 \<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 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\<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>"
    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\<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>*"
    proof(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>+"
  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\<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
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\<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
(*>*)


(* Authors: Christian Urban and Mathilde Arnaud                   *)
(*                                                                *)
(* A formalisation of the Church-Rosser proof by Masako Takahashi.*)
(* This formalisation follows with some very slight exceptions    *)
(* the version of this proof given by Randy Pollack in the paper: *)
(*                                                                *)
(*  Polishing Up the Tait-Martin Löf Proof of the                 *)
(*  Church-Rosser Theorem (1995).                                 *)

theory CR_Takahashi
  imports "../Nominal"
begin

atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

section {* Lemmas about Capture-Avoiding Substitution *}

lemma  subst_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(t1[x::=t2]) = (pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)]"
by (nominal_induct t1 avoiding: x t2 rule: lam.strong_induct)
   (auto simp add: perm_bij fresh_atm fresh_bij)

lemma forget:
  shows "x\<sharp>t \<Longrightarrow> t[x::=s] = t"
by (nominal_induct t avoiding: x s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact:
  fixes z::"name"
  shows "\<lbrakk>z\<sharp>s; (z=y \<or> z\<sharp>t)\<rbrakk> \<Longrightarrow> z\<sharp>t[y::=s]"
by (nominal_induct t avoiding: z y s rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_prod fresh_atm)

lemma substitution_lemma:
  assumes a: "x\<noteq>y" "x\<sharp>u"
  shows "t[x::=s][y::=u] = t[y::=u][x::=s[y::=u]]"
using a
by (nominal_induct t avoiding: x y s u rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

lemma subst_rename:
  assumes a: "y\<sharp>t"
  shows "t[x::=s] = ([(y,x)]\<bullet>t)[y::=s]"
using a
by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
   (auto simp add: swap_simps fresh_atm abs_fresh)

section {* Beta-Reduction *}

inductive
  "Beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
  b1[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> App t1 s \<longrightarrow>\<^sub>\<beta> App t2 s"
| b2[intro]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro]: "t1 \<longrightarrow>\<^sub>\<beta> t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>\<beta> Lam [x].t2"
| b4[intro]: "App (Lam [x].t) s \<longrightarrow>\<^sub>\<beta> t[x::=s]"

section {* Transitive Closure of Beta *}

inductive
  "Beta_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta>\<^sup>* _" [80,80] 80)
where
  bs1[intro]: "t \<longrightarrow>\<^sub>\<beta>\<^sup>* t"
| bs2[intro]: "t \<longrightarrow>\<^sub>\<beta> s \<Longrightarrow> t \<longrightarrow>\<^sub>\<beta>\<^sup>* s"
| bs3[intro,trans]: "\<lbrakk>t1\<longrightarrow>\<^sub>\<beta>\<^sup>* t2; t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3\<rbrakk> \<Longrightarrow> t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3"

section {* One-Reduction *}

inductive
  One :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1 _" [80,80] 80)
where
  o1[intro]: "Var x\<longrightarrow>\<^sub>1 Var x"
| o2[intro]: "\<lbrakk>t1\<longrightarrow>\<^sub>1t2; s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> App t1 s1 \<longrightarrow>\<^sub>1 App t2 s2"
| o3[intro]: "t1\<longrightarrow>\<^sub>1t2 \<Longrightarrow> Lam [x].t1 \<longrightarrow>\<^sub>1 Lam [x].t2"
| o4[intro]: "\<lbrakk>x\<sharp>(s1,s2); t1\<longrightarrow>\<^sub>1t2; s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]"

equivariance One
nominal_inductive One
  by (simp_all add: abs_fresh fresh_fact)

lemma One_refl:
  shows "t \<longrightarrow>\<^sub>1 t"
by (nominal_induct t rule: lam.strong_induct) (auto)

lemma One_subst:
  assumes a: "t1 \<longrightarrow>\<^sub>1 t2" "s1 \<longrightarrow>\<^sub>1 s2"
  shows "t1[x::=s1] \<longrightarrow>\<^sub>1 t2[x::=s2]"
using a
by (nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct)
   (auto simp add: substitution_lemma fresh_atm fresh_fact)

lemma better_o4_intro:
  assumes a: "t1 \<longrightarrow>\<^sub>1 t2" "s1 \<longrightarrow>\<^sub>1 s2"
  shows "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp, blast)
  have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]\<bullet>t1)) s1" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>\<^sub>1  ([(y,x)]\<bullet>t2)[y::=s2]" using fs a by (auto simp add: One.eqvt)
  also have "\<dots> = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric])
  finally show "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2[x::=s2]" by simp
qed

lemma One_Var:
  assumes a: "Var x \<longrightarrow>\<^sub>1 M"
  shows "M = Var x"
using a by (cases rule: One.cases) (simp_all)

lemma One_Lam:
  assumes a: "Lam [x].t \<longrightarrow>\<^sub>1 s" "x\<sharp>s"
  shows "\<exists>t'. s = Lam [x].t' \<and> t \<longrightarrow>\<^sub>1 t'"
using a
by (cases rule: One.strong_cases)
   (auto simp add: lam.inject abs_fresh alpha)

lemma One_App:
  assumes a: "App t s \<longrightarrow>\<^sub>1 r"
  shows "(\<exists>t' s'. r = App t' s' \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s') \<or>
         (\<exists>x p p' s'. r = p'[x::=s'] \<and> t = Lam [x].p \<and> p \<longrightarrow>\<^sub>1 p' \<and> s \<longrightarrow>\<^sub>1 s' \<and> x\<sharp>(s,s'))"
using a by (cases rule: One.cases) (auto simp add: lam.inject)

lemma One_Redex:
  assumes a: "App (Lam [x].t) s \<longrightarrow>\<^sub>1 r" "x\<sharp>(s,r)"
  shows "(\<exists>t' s'. r = App (Lam [x].t') s' \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s') \<or>
         (\<exists>t' s'. r = t'[x::=s'] \<and> t \<longrightarrow>\<^sub>1 t' \<and> s \<longrightarrow>\<^sub>1 s')"
using a
by (cases rule: One.strong_cases)
   (auto dest: One_Lam simp add: lam.inject abs_fresh alpha fresh_prod)

section {* Transitive Closure of One *}

inductive
  "One_star" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1\<^sup>* _" [80,80] 80)
where
  os1[intro]: "t \<longrightarrow>\<^sub>1\<^sup>* t"
| os2[intro]: "t \<longrightarrow>\<^sub>1 s \<Longrightarrow> t \<longrightarrow>\<^sub>1\<^sup>* s"
| os3[intro]: "\<lbrakk>t1\<longrightarrow>\<^sub>1\<^sup>* t2; t2 \<longrightarrow>\<^sub>1\<^sup>* t3\<rbrakk> \<Longrightarrow> t1 \<longrightarrow>\<^sub>1\<^sup>* t3"

section {* Complete Development Reduction *}

inductive
  Dev :: "lam \<Rightarrow> lam \<Rightarrow> bool" (" _ \<longrightarrow>\<^sub>d _" [80,80]80)
where
  d1[intro]: "Var x \<longrightarrow>\<^sub>d Var x"
| d2[intro]: "t \<longrightarrow>\<^sub>d s \<Longrightarrow> Lam [x].t \<longrightarrow>\<^sub>d Lam[x].s"
| d3[intro]: "\<lbrakk>\<not>(\<exists>y t'. t1 = Lam [y].t'); t1 \<longrightarrow>\<^sub>d t2; s1 \<longrightarrow>\<^sub>d s2\<rbrakk> \<Longrightarrow> App t1 s1 \<longrightarrow>\<^sub>d App t2 s2"
| d4[intro]: "\<lbrakk>x\<sharp>(s1,s2); t1 \<longrightarrow>\<^sub>d t2; s1 \<longrightarrow>\<^sub>d s2\<rbrakk> \<Longrightarrow> App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]"

equivariance Dev
nominal_inductive Dev
  by (simp_all add: abs_fresh fresh_fact)

lemma better_d4_intro:
  assumes a: "t1 \<longrightarrow>\<^sub>d t2" "s1 \<longrightarrow>\<^sub>d s2"
  shows "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]"
proof -
  obtain y::"name" where fs: "y\<sharp>(x,t1,s1,t2,s2)" by (rule exists_fresh, rule fin_supp,blast)
  have "App (Lam [x].t1) s1 = App (Lam [y].([(y,x)]\<bullet>t1)) s1" using fs
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  also have "\<dots> \<longrightarrow>\<^sub>d  ([(y,x)]\<bullet>t2)[y::=s2]" using fs a by (auto simp add: Dev.eqvt)
  also have "\<dots> = t2[x::=s2]" using fs by (simp add: subst_rename[symmetric])
  finally show "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>d t2[x::=s2]" by simp
qed

lemma Dev_preserves_fresh:
  fixes x::"name"
  assumes a: "M\<longrightarrow>\<^sub>d N"
  shows "x\<sharp>M \<Longrightarrow> x\<sharp>N"
using a
by (induct) (auto simp add: abs_fresh fresh_fact)

lemma Dev_Lam:
  assumes a: "Lam [x].M \<longrightarrow>\<^sub>d N"
  shows "\<exists>N'. N = Lam [x].N' \<and> M \<longrightarrow>\<^sub>d N'"
proof -
  from a have "x\<sharp>Lam [x].M" by (simp add: abs_fresh)
  with a have "x\<sharp>N" by (simp add: Dev_preserves_fresh)
  with a show "\<exists>N'. N = Lam [x].N' \<and> M \<longrightarrow>\<^sub>d N'"
    by (cases rule: Dev.strong_cases)
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma Development_existence:
  shows "\<exists>M'. M \<longrightarrow>\<^sub>d M'"
by (nominal_induct M rule: lam.strong_induct)
   (auto dest!: Dev_Lam intro: better_d4_intro)

lemma Triangle:
  assumes a: "t \<longrightarrow>\<^sub>d t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "t2 \<longrightarrow>\<^sub>1 t1"
using a
proof(nominal_induct avoiding: t2 rule: Dev.strong_induct)
  case (d4 x s1 s2 t1 t1' t2)
  have  fc: "x\<sharp>t2" "x\<sharp>s1" by fact+
  have "App (Lam [x].t1) s1 \<longrightarrow>\<^sub>1 t2" by fact
  then obtain t' s' where reds:
             "(t2 = App (Lam [x].t') s' \<and> t1 \<longrightarrow>\<^sub>1 t' \<and> s1 \<longrightarrow>\<^sub>1 s') \<or>
              (t2 = t'[x::=s'] \<and> t1 \<longrightarrow>\<^sub>1 t' \<and> s1 \<longrightarrow>\<^sub>1 s')"
  using fc by (auto dest!: One_Redex)
  have ih1: "t1 \<longrightarrow>\<^sub>1 t' \<Longrightarrow>  t' \<longrightarrow>\<^sub>1 t1'" by fact
  have ih2: "s1 \<longrightarrow>\<^sub>1 s' \<Longrightarrow>  s' \<longrightarrow>\<^sub>1 s2" by fact
  { assume "t1 \<longrightarrow>\<^sub>1 t'" "s1 \<longrightarrow>\<^sub>1 s'"
    then have "App (Lam [x].t') s' \<longrightarrow>\<^sub>1 t1'[x::=s2]"
      using ih1 ih2 by (auto intro: better_o4_intro)
  }
  moreover
  { assume "t1 \<longrightarrow>\<^sub>1 t'" "s1 \<longrightarrow>\<^sub>1 s'"
    then have "t'[x::=s'] \<longrightarrow>\<^sub>1 t1'[x::=s2]"
      using ih1 ih2 by (auto intro: One_subst)
  }
  ultimately show "t2 \<longrightarrow>\<^sub>1 t1'[x::=s2]" using reds by auto
qed (auto dest!: One_Lam One_Var One_App)

lemma Diamond_for_One:
  assumes a: "t \<longrightarrow>\<^sub>1 t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "\<exists>t3. t2 \<longrightarrow>\<^sub>1 t3 \<and> t1 \<longrightarrow>\<^sub>1 t3"
proof -
  obtain tc where "t \<longrightarrow>\<^sub>d tc" using Development_existence by blast
  with a have "t2 \<longrightarrow>\<^sub>1 tc" and "t1 \<longrightarrow>\<^sub>1 tc" by (simp_all add: Triangle)
  then show "\<exists>t3. t2 \<longrightarrow>\<^sub>1 t3 \<and> t1 \<longrightarrow>\<^sub>1 t3" by blast
qed

lemma Rectangle_for_One:
  assumes a:  "t \<longrightarrow>\<^sub>1\<^sup>* t1" "t \<longrightarrow>\<^sub>1 t2"
  shows "\<exists>t3. t1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3"
using a Diamond_for_One by (induct arbitrary: t2) (blast)+

lemma CR_for_One_star:
  assumes a: "t \<longrightarrow>\<^sub>1\<^sup>* t1" "t \<longrightarrow>\<^sub>1\<^sup>* t2"
    shows "\<exists>t3. t2 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> t1 \<longrightarrow>\<^sub>1\<^sup>* t3"
using a Rectangle_for_One by (induct arbitrary: t2) (blast)+

section {* Establishing the Equivalence of Beta-star and One-star *}

lemma Beta_Lam_cong:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "Lam [x].t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* Lam [x].t2"
using a by (induct) (blast)+

lemma Beta_App_cong_aux:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "App t1 s\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s"
    and "App s t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App s t2"
using a by (induct) (blast)+

lemma Beta_App_cong:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2" "s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* s2"
  shows "App t1 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2"
using a by (blast intro: Beta_App_cong_aux)

lemmas Beta_congs = Beta_Lam_cong Beta_App_cong

lemma One_implies_Beta_star:
  assumes a: "t \<longrightarrow>\<^sub>1 s"
  shows "t \<longrightarrow>\<^sub>\<beta>\<^sup>* s"
using a by (induct) (auto intro!: Beta_congs)

lemma One_congs:
  assumes a: "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
  shows "Lam [x].t1 \<longrightarrow>\<^sub>1\<^sup>* Lam [x].t2"
  and   "App t1 s \<longrightarrow>\<^sub>1\<^sup>* App t2 s"
  and   "App s t1 \<longrightarrow>\<^sub>1\<^sup>* App s t2"
using a by (induct) (auto intro: One_refl)

lemma Beta_implies_One_star:
  assumes a: "t1 \<longrightarrow>\<^sub>\<beta> t2"
  shows "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
using a by (induct) (auto intro: One_refl One_congs better_o4_intro)

lemma Beta_star_equals_One_star:
  shows "t1 \<longrightarrow>\<^sub>1\<^sup>* t2 = t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
proof
  assume "t1 \<longrightarrow>\<^sub>1\<^sup>* t2"
  then show "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2" by (induct) (auto intro: One_implies_Beta_star)
next
  assume "t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  then show "t1 \<longrightarrow>\<^sub>1\<^sup>* t2" by (induct) (auto intro: Beta_implies_One_star)
qed

section {* The Church-Rosser Theorem *}

theorem CR_for_Beta_star:
  assumes a: "t \<longrightarrow>\<^sub>\<beta>\<^sup>* t1" "t\<longrightarrow>\<^sub>\<beta>\<^sup>* t2"
  shows "\<exists>t3. t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3"
proof -
  from a have "t \<longrightarrow>\<^sub>1\<^sup>* t1" and "t\<longrightarrow>\<^sub>1\<^sup>* t2" by (simp_all add: Beta_star_equals_One_star)
  then have "\<exists>t3. t1 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by (simp add: CR_for_One_star)
  then show "\<exists>t3. t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3 \<and> t2 \<longrightarrow>\<^sub>\<beta>\<^sup>* t3" by (simp add: Beta_star_equals_One_star)
qed

end


(*  Title:      HOL/UNITY/Simple/Token.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section \<open>The Token Ring\<close>

theory Token
imports "../WFair"

begin

text\<open>From Misra, "A Logic for Concurrent Programming" (1994), sections 5.2 and 13.2.\<close>

subsection\<open>Definitions\<close>

datatype pstate = Hungry | Eating | Thinking
    \<comment>\<open>process states\<close>

record state =
  token :: "nat"
  proc  :: "nat => pstate"

definition HasTok :: "nat => state set" where
    "HasTok i == {s. token s = i}"

definition H :: "nat => state set" where
    "H i == {s. proc s i = Hungry}"

definition E :: "nat => state set" where
    "E i == {s. proc s i = Eating}"

definition T :: "nat => state set" where
    "T i == {s. proc s i = Thinking}"

locale Token =
  fixes N and F and nodeOrder and "next"
  defines nodeOrder_def:
       "nodeOrder j == measure(%i. ((j+N)-i) mod N) \<inter> {..<N} \<times> {..<N}"
      and next_def:
       "next i == (Suc i) mod N"
  assumes N_positive [iff]: "0<N"
      and TR2:  "F \<in> (T i) co (T i \<union> H i)"
      and TR3:  "F \<in> (H i) co (H i \<union> E i)"
      and TR4:  "F \<in> (H i - HasTok i) co (H i)"
      and TR5:  "F \<in> (HasTok i) co (HasTok i \<union> -(E i))"
      and TR6:  "F \<in> (H i \<inter> HasTok i) leadsTo (E i)"
      and TR7:  "F \<in> (HasTok i) leadsTo (HasTok (next i))"

lemma HasToK_partition: "[| s \<in> HasTok i; s \<in> HasTok j |] ==> i=j"
by (unfold HasTok_def, auto)

lemma not_E_eq: "(s \<notin> E i) = (s \<in> H i | s \<in> T i)"
apply (simp add: H_def E_def T_def)
apply (cases "proc s i", auto)
done

context Token
begin

lemma token_stable: "F \<in> stable (-(E i) \<union> (HasTok i))"
apply (unfold stable_def)
apply (rule constrains_weaken)
apply (rule constrains_Un [OF constrains_Un [OF TR2 TR4] TR5])
apply (auto simp add: not_E_eq)
apply (simp_all add: H_def E_def T_def)
done

subsection\<open>Progress under Weak Fairness\<close>

lemma wf_nodeOrder: "wf(nodeOrder j)"
apply (unfold nodeOrder_def)
apply (rule wf_measure [THEN wf_subset], blast)
done

lemma nodeOrder_eq:
     "[| i<N; j<N |] ==> ((next i, i) \<in> nodeOrder j) = (i \<noteq> j)"
apply (unfold nodeOrder_def next_def)
apply (auto simp add: mod_Suc mod_geq)
apply (auto split: nat_diff_split simp add: linorder_neq_iff mod_geq)
done

text\<open>From "A Logic for Concurrent Programming", but not used in Chapter 4.
  Note the use of \<open>cases\<close>.  Reasoning about leadsTo takes practice!\<close>
lemma TR7_nodeOrder:
     "[| i<N; j<N |] ==>
      F \<in> (HasTok i) leadsTo ({s. (token s, i) \<in> nodeOrder j} \<union> HasTok j)"
apply (cases "i=j")
apply (blast intro: subset_imp_leadsTo)
apply (rule TR7 [THEN leadsTo_weaken_R])
apply (auto simp add: HasTok_def nodeOrder_eq)
done

text\<open>Chapter 4 variant, the one actually used below.\<close>
lemma TR7_aux: "[| i<N; j<N; i\<noteq>j |]
      ==> F \<in> (HasTok i) leadsTo {s. (token s, i) \<in> nodeOrder j}"
apply (rule TR7 [THEN leadsTo_weaken_R])
apply (auto simp add: HasTok_def nodeOrder_eq)
done

lemma token_lemma:
     "({s. token s < N} \<inter> token -` {m}) = (if m<N then token -` {m} else {})"
by auto

text\<open>Misra's TR9: the token reaches an arbitrary node\<close>
lemma leadsTo_j: "j<N ==> F \<in> {s. token s < N} leadsTo (HasTok j)"
apply (rule leadsTo_weaken_R)
apply (rule_tac I = "-{j}" and f = token and B = "{}"
       in wf_nodeOrder [THEN bounded_induct])
apply (simp_all (no_asm_simp) add: token_lemma vimage_Diff HasTok_def)
 prefer 2 apply blast
apply clarify
apply (rule TR7_aux [THEN leadsTo_weaken])
apply (auto simp add: HasTok_def nodeOrder_def)
done

text\<open>Misra's TR8: a hungry process eventually eats\<close>
lemma token_progress:
     "j<N ==> F \<in> ({s. token s < N} \<inter> H j) leadsTo (E j)"
apply (rule leadsTo_cancel1 [THEN leadsTo_Un_duplicate])
apply (rule_tac [2] TR6)
apply (rule psp [OF leadsTo_j TR3, THEN leadsTo_weaken], blast+)
done

end

end


theory ComputeHOL
imports Complex_Main "Compute_Oracle/Compute_Oracle"
begin

lemma Trueprop_eq_eq: "Trueprop X == (X == True)" by (simp add: atomize_eq)
lemma meta_eq_trivial: "x == y \<Longrightarrow> x == y" by simp
lemma meta_eq_imp_eq: "x == y \<Longrightarrow> x = y" by auto
lemma eq_trivial: "x = y \<Longrightarrow> x = y" by auto
lemma bool_to_true: "x :: bool \<Longrightarrow> x == True"  by simp
lemma transmeta_1: "x = y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp
lemma transmeta_2: "x == y \<Longrightarrow> y = z \<Longrightarrow> x = z" by simp
lemma transmeta_3: "x == y \<Longrightarrow> y == z \<Longrightarrow> x = z" by simp

(**** compute_if ****)

lemma If_True: "If True = (\<lambda> x y. x)" by ((rule ext)+,auto)
lemma If_False: "If False = (\<lambda> x y. y)" by ((rule ext)+, auto)

lemmas compute_if = If_True If_False

(**** compute_bool ****)

lemma bool1: "(\<not> True) = False"  by blast
lemma bool2: "(\<not> False) = True"  by blast
lemma bool3: "(P \<and> True) = P" by blast
lemma bool4: "(True \<and> P) = P" by blast
lemma bool5: "(P \<and> False) = False" by blast
lemma bool6: "(False \<and> P) = False" by blast
lemma bool7: "(P \<or> True) = True" by blast
lemma bool8: "(True \<or> P) = True" by blast
lemma bool9: "(P \<or> False) = P" by blast
lemma bool10: "(False \<or> P) = P" by blast
lemma bool11: "(True \<longrightarrow> P) = P" by blast
lemma bool12: "(P \<longrightarrow> True) = True" by blast
lemma bool13: "(True \<longrightarrow> P) = P" by blast
lemma bool14: "(P \<longrightarrow> False) = (\<not> P)" by blast
lemma bool15: "(False \<longrightarrow> P) = True" by blast
lemma bool16: "(False = False) = True" by blast
lemma bool17: "(True = True) = True" by blast
lemma bool18: "(False = True) = False" by blast
lemma bool19: "(True = False) = False" by blast

lemmas compute_bool = bool1 bool2 bool3 bool4 bool5 bool6 bool7 bool8 bool9 bool10 bool11 bool12 bool13 bool14 bool15 bool16 bool17 bool18 bool19

(*** compute_pair ***)

lemma compute_fst: "fst (x,y) = x" by simp
lemma compute_snd: "snd (x,y) = y" by simp
lemma compute_pair_eq: "((a, b) = (c, d)) = (a = c \<and> b = d)" by auto

lemma case_prod_simp: "case_prod f (x,y) = f x y" by simp

lemmas compute_pair = compute_fst compute_snd compute_pair_eq case_prod_simp

(*** compute_option ***)

lemma compute_the: "the (Some x) = x" by simp
lemma compute_None_Some_eq: "(None = Some x) = False" by auto
lemma compute_Some_None_eq: "(Some x = None) = False" by auto
lemma compute_None_None_eq: "(None = None) = True" by auto
lemma compute_Some_Some_eq: "(Some x = Some y) = (x = y)" by auto

definition case_option_compute :: "'b option \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "case_option_compute opt a f = case_option a f opt"

lemma case_option_compute: "case_option = (\<lambda> a f opt. case_option_compute opt a f)"
  by (simp add: case_option_compute_def)

lemma case_option_compute_None: "case_option_compute None = (\<lambda> a f. a)"
  apply (rule ext)+
  apply (simp add: case_option_compute_def)
  done

lemma case_option_compute_Some: "case_option_compute (Some x) = (\<lambda> a f. f x)"
  apply (rule ext)+
  apply (simp add: case_option_compute_def)
  done

lemmas compute_case_option = case_option_compute case_option_compute_None case_option_compute_Some

lemmas compute_option = compute_the compute_None_Some_eq compute_Some_None_eq compute_None_None_eq compute_Some_Some_eq compute_case_option

(**** compute_list_length ****)

lemma length_cons:"length (x#xs) = 1 + (length xs)"
  by simp

lemma length_nil: "length [] = 0"
  by simp

lemmas compute_list_length = length_nil length_cons

(*** compute_case_list ***)

definition case_list_compute :: "'b list \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "case_list_compute l a f = case_list a f l"

lemma case_list_compute: "case_list = (\<lambda> (a::'a) f (l::'b list). case_list_compute l a f)"
  apply (rule ext)+
  apply (simp add: case_list_compute_def)
  done

lemma case_list_compute_empty: "case_list_compute ([]::'b list) = (\<lambda> (a::'a) f. a)"
  apply (rule ext)+
  apply (simp add: case_list_compute_def)
  done

lemma case_list_compute_cons: "case_list_compute (u#v) = (\<lambda> (a::'a) f. (f (u::'b) v))"
  apply (rule ext)+
  apply (simp add: case_list_compute_def)
  done

lemmas compute_case_list = case_list_compute case_list_compute_empty case_list_compute_cons

(*** compute_list_nth ***)
(* Of course, you will need computation with nats for this to work \<dots> *)

lemma compute_list_nth: "((x#xs) ! n) = (if n = 0 then x else (xs ! (n - 1)))"
  by (cases n, auto)

(*** compute_list ***)

lemmas compute_list = compute_case_list compute_list_length compute_list_nth

(*** compute_let ***)

lemmas compute_let = Let_def

(***********************)
(* Everything together *)
(***********************)

lemmas compute_hol = compute_if compute_bool compute_pair compute_option compute_list compute_let

ML \<open>
signature ComputeHOL =
sig
  val prep_thms : thm list -> thm list
  val to_meta_eq : thm -> thm
  val to_hol_eq : thm -> thm
  val symmetric : thm -> thm
  val trans : thm -> thm -> thm
end

structure ComputeHOL : ComputeHOL =
struct

local
fun lhs_of eq = fst (Thm.dest_equals (Thm.cprop_of eq));
in
fun rewrite_conv [] ct = raise CTERM ("rewrite_conv", [ct])
  | rewrite_conv (eq :: eqs) ct =
      Thm.instantiate (Thm.match (lhs_of eq, ct)) eq
      handle Pattern.MATCH => rewrite_conv eqs ct;
end

val convert_conditions = Conv.fconv_rule (Conv.prems_conv ~1 (Conv.try_conv (rewrite_conv [@{thm "Trueprop_eq_eq"}])))

val eq_th = @{thm "HOL.eq_reflection"}
val meta_eq_trivial = @{thm "ComputeHOL.meta_eq_trivial"}
val bool_to_true = @{thm "ComputeHOL.bool_to_true"}

fun to_meta_eq th = eq_th OF [th] handle THM _ => meta_eq_trivial OF [th] handle THM _ => bool_to_true OF [th]

fun to_hol_eq th = @{thm "meta_eq_imp_eq"} OF [th] handle THM _ => @{thm "eq_trivial"} OF [th]

fun prep_thms ths = map (convert_conditions o to_meta_eq) ths

fun symmetric th = @{thm "HOL.sym"} OF [th] handle THM _ => @{thm "Pure.symmetric"} OF [th]

local
    val trans_HOL = @{thm "HOL.trans"}
    val trans_HOL_1 = @{thm "ComputeHOL.transmeta_1"}
    val trans_HOL_2 = @{thm "ComputeHOL.transmeta_2"}
    val trans_HOL_3 = @{thm "ComputeHOL.transmeta_3"}
    fun tr [] th1 th2 = trans_HOL OF [th1, th2]
      | tr (t::ts) th1 th2 = (t OF [th1, th2] handle THM _ => tr ts th1 th2)
in
  fun trans th1 th2 = tr [trans_HOL, trans_HOL_1, trans_HOL_2, trans_HOL_3] th1 th2
end

end
\<close>

end


(*  File:       Profile.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Preference Profile\<close>

theory Profile
  imports Preference_Relation
begin

text \<open>
  Preference profiles denote the decisions made by the individual voters on
  the eligible alternatives. They are represented in the form of one preference
  relation (e.g., selected on a ballot) per voter, collectively captured in a
  list of such preference relations.
  Unlike a the common preference profiles in the social-choice sense, the
  profiles described here considers only the (sub-)set of alternatives that are
  received.
\<close>

subsection \<open>Definition\<close>

text \<open>
  A profile contains one ballot for each voter.
\<close>

type_synonym 'a Profile = "('a Preference_Relation) list"

text \<open>
  A profile on a finite set of alternatives A contains only ballots that are
  linear orders on A.
\<close>

definition profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "profile A p \<equiv> \<forall> i::nat. i < length p \<longrightarrow> linear_order_on A (p!i)"

lemma profile_set : "profile A p \<equiv> (\<forall> b \<in> (set p). linear_order_on A b)"
  unfolding profile_def all_set_conv_all_nth
  by simp

abbreviation finite_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "finite_profile A p \<equiv> finite A \<and> profile A p"

subsection \<open>Preference Counts and Comparisons\<close>

text \<open>
  The win count for an alternative a in a profile p is
  the amount of ballots in p that rank alternative a in first position.
\<close>

fun win_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count p a =
    card {i::nat. i < length p \<and> above (p!i) a = {a}}"

fun win_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count_code Nil a = 0" |
  "win_count_code (p#ps) a =
      (if (above p a = {a}) then 1 else 0) + win_count_code ps a"

lemma win_count_equiv[code]: "win_count p x = win_count_code p x"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume base_case: "win_count p x = win_count_code p x"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall> i < length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "win_count [a] x =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (above r x = {x}))})"
    by simp
  hence one_ballot_equiv:
    "win_count [a] x = win_count_code [a] x"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "win_count (p@[a]) x =
      win_count p x + win_count [a] x"
  proof (simp)
    have
      "{i. i = 0 \<and> (above ([a]!i) x = {x})} =
        (if (above a x = {x}) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (above ([a]!0) x = {x})} =
        card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        {i. i < length p \<and> (above (p!i) x = {x})} \<union>
          {i. i = length p \<and> (above ([a]!0) x = {x})}"
    proof (safe, simp_all)
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p" and
        "xaa \<in> above (p!xa) x"
      thus "xaa = x"
        using less_antisym p_pos_in_ps singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p"
      thus "x \<in> above (p!xa) x"
        using less_antisym insertI1 p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "xa < length p"
        using less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a" and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using less_antisym p_pos_in_ps
              nth_append_length singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append
              nth_append_length singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "xa < length p"
        using insertI1 less_antisym nth_append_length
        by metis
    next
      fix
        xa :: nat and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using insertI1 less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < length p" and
        "above (p!xa) x = {x}" and
        "xaa \<in> above ((p@[a])!xa) x"
      thus "xaa = x"
        by (simp add: nth_append)
    next
      fix xa :: nat
      assume
        "xa < length p" and
        "above (p!xa) x = {x}"
      thus "x \<in> above ((p@[a])!xa) x"
        by (simp add: nth_append)
    qed
    have fin_len_p:
      "finite {n. n < length p \<and> (above (p!n) x = {x})}"
      by simp
    have fin_len_a_0:
      "finite {n. n = length p \<and> (above ([a]!0) x = {x})}"
      by simp
    have
      "card ({i. i < length p \<and> (above (p!i) x = {x})} \<union>
        {i. i = length p \<and> (above ([a]!0) x = {x})}) =
          card {i. i < length p \<and> (above (p!i) x = {x})} +
            card {i. i = length p \<and> (above ([a]!0) x = {x})}"
      using fin_len_p fin_len_a_0 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        card {i. i < length p \<and> (above (p!i) x = {x})} +
          card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      using set_prof_eq shift_idx_a
      by auto
  qed
  have "win_count_code (p@[a]) x = win_count_code p x + win_count_code [a] x"
  proof (induction p, simp)
    fix
      aa :: "'a Preference_Relation" and
      p :: "'a Profile"
    assume
      "win_count_code (p@[a]) x =
        win_count_code p x + win_count_code [a] x"
    thus
      "win_count_code ((aa#p)@[a]) x =
        win_count_code (aa#p) x + win_count_code [a] x"
      by simp
  qed
  thus "win_count (p@[a]) x = win_count_code (p@[a]) x"
    using pref_count_induct base_case one_ballot_equiv
    by presburger
qed

fun prefer_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count p x y =
      card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"

fun prefer_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count_code Nil x y = 0" |
  "prefer_count_code (p#ps) x y =
      (if y \<preceq>\<^sub>p x then 1 else 0) + prefer_count_code ps x y"

lemma pref_count_equiv[code]: "prefer_count p x y = prefer_count_code p x y"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume base_case: "prefer_count p x y = prefer_count_code p x y"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall> i < length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "prefer_count [a] x y =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (y \<preceq>\<^sub>r x))})"
    by simp
  hence one_ballot_equiv:
    "prefer_count [a] x y = prefer_count_code [a] x y"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "prefer_count (p@[a]) x y =
      prefer_count p x y + prefer_count [a] x y"
  proof (simp)
    have
      "{i. i = 0 \<and> (y, x) \<in> [a]!i} =
        (if ((y, x) \<in> a) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (y, x) \<in> [a]!0} =
        card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        {i. i < length p \<and> (y, x) \<in> p!i} \<union>
          {i. i = length p \<and> (y, x) \<in> [a]!0}"
    proof (safe, simp_all)
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "xa \<noteq> length p"
      thus "(y, x) \<in> p!xa"
        using less_antisym p_pos_in_ps
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "xa < length p"
        using less_antisym nth_append_length
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "(y, x) \<in> p!xa"
        using less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix xa :: nat
      assume
        "xa < length p" and
        "(y, x) \<in> p!xa"
      thus "(y, x) \<in> (p@[a])!xa"
        using less_antisym p_pos_in_ps
        by metis
    qed
    have fin_len_p: "finite {n. n < length p \<and> (y, x) \<in> p!n}"
      by simp
    have fin_len_a_0: "finite {n. n = length p \<and> (y, x) \<in> [a]!0}"
      by simp
    have
      "card ({i. i < length p \<and> (y, x) \<in> p!i} \<union>
        {i. i = length p \<and> (y, x) \<in> [a]!0}) =
          card {i. i < length p \<and> (y, x) \<in> p!i} +
            card {i. i = length p \<and> (y, x) \<in> [a]!0}"
      using fin_len_p fin_len_a_0 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        card {i. i < length p \<and> (y, x) \<in> p!i} +
          card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      using set_prof_eq shift_idx_a
      by simp
  qed
  have pref_count_code_induct:
    "prefer_count_code (p@[a]) x y =
      prefer_count_code p x y + prefer_count_code [a] x y"
  proof (simp, safe)
    assume y_pref_x: "(y, x) \<in> a"
    show "prefer_count_code (p@[a]) x y = Suc (prefer_count_code p x y)"
    proof (induction p, simp_all)
      show "(y, x) \<in> a"
        using y_pref_x
        by simp
    qed
  next
    assume not_y_pref_x: "(y, x) \<notin> a"
    show "prefer_count_code (p@[a]) x y = prefer_count_code p x y"
    proof (induction p, simp_all, safe)
      assume "(y, x) \<in> a"
      thus False
        using not_y_pref_x
        by simp
    qed
  qed
  show "prefer_count (p@[a]) x y = prefer_count_code (p@[a]) x y"
    using pref_count_code_induct pref_count_induct
          base_case one_ballot_equiv
    by presburger
qed

lemma set_compr: "{ f x | x . x \<in> S } = f ` S"
  by auto

lemma pref_count_set_compr: "{prefer_count p x y | y . y \<in> A - {x}} =
          (prefer_count p x) ` (A - {x})"
  by auto

lemma pref_count:
  assumes
    prof: "profile A p" and
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A" and
    neq: "x \<noteq> y"
  shows "prefer_count p x y = (length p) - (prefer_count p y x)"
proof -
  have 00: "card {i::nat. i < length p} = length p"
    by simp
  have 10:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by auto
  have 0: "\<forall> i::nat . i < length p \<longrightarrow> linear_order_on A (p!i)"
    using prof
    unfolding profile_def
    by simp
  hence "\<forall> i::nat . i < length p \<longrightarrow> connex A (p!i)"
    by (simp add: lin_ord_imp_connex)
  hence 1: "\<forall> i::nat . i < length p \<longrightarrow>
              \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    using x_in_A y_in_A
    unfolding connex_def
    by metis
  from 0 have
    "\<forall> i::nat . i < length p \<longrightarrow> antisym  (p!i)"
    using lin_imp_antisym
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow> ((y, x) \<in> (p!i) \<longrightarrow> (x, y) \<notin> (p!i))"
    using antisymD neq
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow>
          ((let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> \<not> (let r = (p!i) in (x \<preceq>\<^sub>r y)))"
    by simp
  with 1 have
    "\<forall> i::nat . i < length p \<longrightarrow>
      \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) = (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    by metis
  hence 2:
    "{i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    by metis
  hence 20:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    using 10 2
    by simp
  have
    "{i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))} \<subseteq>
        {i::nat. i < length p}"
    by (simp add: Collect_mono)
  hence 30:
    "card ({i::nat. i < length p} -
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}) =
      (card {i::nat. i < length p}) -
        card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    by (simp add: card_Diff_subset)
  have "prefer_count p x y =
          card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by simp
  also have
    "... = card({i::nat. i < length p} -
            {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using 20
    by simp
  also have
    "... = (card {i::nat. i < length p}) -
              card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using 30
    by metis
  also have
    "... = length p - (prefer_count p y x)"
    by simp
  finally show ?thesis
    by (simp add: 20 30)
qed

lemma pref_count_sym:
  assumes
    p1: "prefer_count p a x \<ge> prefer_count p x b" and
    prof: "profile A p" and
    a_in_A: "a \<in> A" and
    b_in_A: "b \<in> A" and
    x_in_A: "x \<in> A" and
    neq1: "a \<noteq> x" and
    neq2: "x \<noteq> b"
  shows "prefer_count p b x \<ge> prefer_count p x a"
proof -
  from prof a_in_A x_in_A neq1 have 0:
    "prefer_count p a x = (length p) - (prefer_count p x a)"
    using pref_count
    by metis
  moreover from prof x_in_A b_in_A neq2 have 1:
    "prefer_count p x b = (length p) - (prefer_count p b x)"
    using pref_count
    by (metis (mono_tags, lifting))
  hence 2: "(length p) - (prefer_count p x a) \<ge>
              (length p) - (prefer_count p b x)"
    using calculation p1
    by auto
  hence 3: "(prefer_count p x a) - (length p) \<le>
              (prefer_count p b x) - (length p)"
    using a_in_A diff_is_0_eq diff_le_self neq1
          pref_count prof x_in_A
    by (metis (no_types))
  hence "(prefer_count p x a) \<le> (prefer_count p b x)"
    using 1 3 calculation p1
    by linarith
  thus ?thesis
    by linarith
qed

lemma empty_prof_imp_zero_pref_count:
  assumes "p = []"
  shows "\<forall> x y. prefer_count p x y = 0"
  using assms
  by simp

lemma empty_prof_imp_zero_pref_count_code:
  assumes "p = []"
  shows "\<forall> x y. prefer_count_code p x y = 0"
  using assms
  by simp

lemma pref_count_code_incr:
  assumes
    "prefer_count_code ps x y = n" and
    "y \<preceq>\<^sub>p x"
  shows "prefer_count_code (p#ps) x y = n+1"
  using assms
  by simp

lemma pref_count_code_not_smaller_imp_constant:
  assumes
    "prefer_count_code ps x y = n" and
    "\<not>(y \<preceq>\<^sub>p x)"
  shows "prefer_count_code (p#ps) x y = n"
  using assms
  by simp

fun wins :: "'a \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "wins x p y =
    (prefer_count p x y > prefer_count p y x)"

text \<open>
  Alternative a wins against b implies that b does not win against a.
\<close>

lemma wins_antisym:
  assumes "wins a p b"
  shows "\<not> wins b p a"
  using assms
  by simp

lemma wins_irreflex: "\<not> wins w p w"
  using wins_antisym
  by metis

subsection \<open>Condorcet Winner\<close>

fun condorcet_winner :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "condorcet_winner A p w =
      (finite_profile A p \<and>  w \<in> A \<and> (\<forall> x \<in> A - {w} . wins w p x))"

lemma cond_winner_unique:
  assumes
    winner_c: "condorcet_winner A p c" and
    winner_w: "condorcet_winner A p w"
  shows "w = c"
proof (rule ccontr)
  assume w_neq_c: "w \<noteq> c"
  from winner_w
  have "wins w p c"
    using w_neq_c insert_Diff insert_iff winner_c
    by simp
  hence "\<not> wins c p w"
    by (simp add: wins_antisym)
  moreover from winner_c
  have
    c_wins_against_w: "wins c p w"
    using Diff_iff w_neq_c
          singletonD winner_w
    by simp
  ultimately show False
    by simp
qed

lemma cond_winner_unique2:
  assumes
    winner: "condorcet_winner A p w" and
    not_w:  "x \<noteq> w"
  shows "\<not> condorcet_winner A p x"
  using not_w cond_winner_unique winner
  by metis

lemma cond_winner_unique3:
  assumes "condorcet_winner A p w"
  shows "{a \<in> A. condorcet_winner A p a} = {w}"
proof (safe, simp_all, safe)
  fix x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    x_in_A: "x \<in> A" and
    x_wins:
      "\<forall> xa \<in> A - {x}.
        card {i. i < length p \<and> (x, xa) \<in> p!i} <
          card {i. i < length p \<and> (xa, x) \<in> p!i}"
  from assms have assm:
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall> x \<in> A - {w}.
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence
    "(\<forall> x \<in> A - {w}.
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence w_beats_x:
    "x \<noteq> w \<Longrightarrow>
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i}"
    using x_in_A
    by simp
  also from assm have
    "finite_profile A p"
    by simp
  moreover from assm have
    "w \<in> A"
    by simp
  hence x_beats_w:
    "x \<noteq> w \<Longrightarrow>
      card {i. i < length p \<and> (x, w) \<in> p!i} <
        card {i. i < length p \<and> (w, x) \<in> p!i}"
    using x_wins
    by simp
  from w_beats_x x_beats_w show "x = w"
    by linarith
next
  from assms show "w \<in> A"
    by simp
next
  from assms show "finite A"
    by simp
next
  from assms show "profile A p"
    by simp
next
  from assms show "w \<in> A"
    by simp
next
  fix
    x :: "'a" and
    x' :: "'a"
  assume
    x_prime_in_A: "x' \<in> A" and
    w_wins:
      "\<not> card {i. i < length p \<and> (w, x') \<in> p!i} <
        card {i. i < length p \<and> (x', w) \<in> p!i}"
  from assms have
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall> x \<in> A - {w} .
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  thus "x' = w"
    using x_prime_in_A w_wins insert_Diff insert_iff
    by (metis (no_types, lifting))
qed

subsection \<open>Limited Profile\<close>

text \<open>
  This function restricts a profile p to a set A and
  keeps all of A's preferences.
\<close>

fun limit_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile" where
  "limit_profile A p = map (limit A) p"

lemma limit_prof_trans:
  assumes
    "B \<subseteq> A" and
    "B' \<subseteq> B" and
    "finite_profile A p"
  shows "limit_profile B' p = limit_profile B' (limit_profile B p)"
  using assms
  by auto

lemma limit_profile_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S"
  shows "finite_profile A (limit_profile A p)"
proof (safe)
  have "\<forall> A A'. finite (A::'a set) \<longrightarrow> A' \<subseteq> A \<longrightarrow> finite A'"
    using rev_finite_subset
    by metis
  with profile
  show "finite A"
    using subset
    by metis
next
  have prof_is_lin_ord:
    "\<forall> A r.
      (profile (A::'a set) r \<longrightarrow> (\<forall> n < length r. linear_order_on A (r!n))) \<and>
      ((\<forall> n < length r. linear_order_on A (r!n)) \<longrightarrow> profile A r)"
    unfolding profile_def
    by simp
  have limit_prof_simp: "limit_profile A p = map (limit A) p"
    by simp
  obtain n' :: nat where
    prof_limit_n: "(n' < length (limit_profile A p) \<longrightarrow>
            linear_order_on A (limit_profile A p!n')) \<longrightarrow>
          profile A (limit_profile A p)"
    using prof_is_lin_ord
    by metis
  have prof_n_lin_ord: "\<forall> n < length p. linear_order_on S (p!n)"
    using prof_is_lin_ord profile
    by simp
  have prof_length: "length p = length (map (limit A) p)"
    by simp
  have "n' < length p \<longrightarrow> linear_order_on S (p!n')"
    using prof_n_lin_ord
    by simp
  thus "profile A (limit_profile A p)"
    using prof_length prof_limit_n limit_prof_simp limit_presv_lin_ord nth_map subset
    by (metis (no_types))
qed

lemma limit_prof_presv_size: "length p = length (limit_profile A p)"
  by simp

subsection \<open>Lifting Property\<close>

definition equiv_prof_except_a :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow>
                                        'a \<Rightarrow> bool" where
  "equiv_prof_except_a A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall> i::nat.
        i < length p \<longrightarrow>
          equiv_rel_except_a A (p!i) (q!i) a)"

text \<open>
  An alternative gets lifted from one profile to another iff
  its ranking increases in at least one ballot, and nothing else changes.
\<close>

definition lifted :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "lifted A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall> i::nat.
        (i < length p \<and> \<not>Preference_Relation.lifted A (p!i) (q!i) a) \<longrightarrow>
          (p!i) = (q!i)) \<and>
      (\<exists> i::nat. i < length p \<and> Preference_Relation.lifted A (p!i) (q!i) a)"

lemma lifted_imp_equiv_prof_except_a:
  assumes "lifted A p q a"
  shows "equiv_prof_except_a A p q a"
proof (unfold equiv_prof_except_a_def, safe)
  from assms
  show "finite A"
    unfolding lifted_def
    by metis
next
  from assms
  show "profile A p"
    unfolding lifted_def
    by metis
next
  from assms
  show "finite A"
    unfolding lifted_def
    by metis
next
  from assms
  show "profile A q"
    unfolding lifted_def
    by metis
next
  from assms
  show "a \<in> A"
    unfolding lifted_def
    by metis
next
  from assms
  show "length p = length q"
    unfolding lifted_def
    by metis
next
  fix i :: nat
  assume "i < length p"
  with assms
  show "equiv_rel_except_a A (p!i) (q!i) a"
    using lifted_imp_equiv_rel_except_a trivial_equiv_rel
    unfolding lifted_def profile_def
    by (metis (no_types))
qed

lemma negl_diff_imp_eq_limit_prof:
  assumes
    change: "equiv_prof_except_a S p q a" and
    subset: "A \<subseteq> S" and
    notInA: "a \<notin> A"
  shows "limit_profile A p = limit_profile A q"
proof (simp)
  have
    "\<forall> i::nat. i < length p \<longrightarrow>
      equiv_rel_except_a S (p!i) (q!i) a"
    using change equiv_prof_except_a_def
    by metis
  hence "\<forall> i::nat. i < length p \<longrightarrow> limit A (p!i) = limit A (q!i)"
    using notInA negl_diff_imp_eq_limit subset
    by metis
  thus "map (limit A) p = map (limit A) q"
    using change equiv_prof_except_a_def
          length_map nth_equalityI nth_map
    by (metis (mono_tags, lifting))
qed

lemma limit_prof_eq_or_lifted:
  assumes
    lifted_a: "lifted S p q a" and
    subset: "A \<subseteq> S"
  shows
    "limit_profile A p = limit_profile A q \<or>
        lifted A (limit_profile A p) (limit_profile A q) a"
proof (cases)
  assume inA: "a \<in> A"
  have
    "\<forall> i::nat. i < length p \<longrightarrow>
        (Preference_Relation.lifted S (p!i) (q!i) a \<or> (p!i) = (q!i))"
    using lifted_a
    unfolding lifted_def
    by metis
  hence one:
    "\<forall> i::nat. i < length p \<longrightarrow>
         (Preference_Relation.lifted A (limit A (p!i)) (limit A (q!i)) a \<or>
           (limit A (p!i)) = (limit A (q!i)))"
    using limit_lifted_imp_eq_or_lifted subset
    by metis
  thus ?thesis
  proof (cases)
    assume "\<forall> i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i))"
    thus ?thesis
      using length_map lifted_a nth_equalityI nth_map
            limit_profile.simps
      unfolding lifted_def
      by (metis (mono_tags, lifting))
  next
    assume forall_limit_p_q: "\<not>(\<forall> i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i)))"
    let ?p = "limit_profile A p"
    let ?q = "limit_profile A q"
    have "profile A ?p \<and> profile A ?q"
      using lifted_a limit_profile_sound subset
      unfolding lifted_def
      by metis
    moreover have "length ?p = length ?q"
      using lifted_a
      unfolding lifted_def
      by fastforce
    moreover have
      "\<exists> i::nat. i < length ?p \<and> Preference_Relation.lifted A (?p!i) (?q!i) a"
      using forall_limit_p_q length_map lifted_a limit_profile.simps nth_map one
      unfolding lifted_def
      by (metis (no_types, lifting))
    moreover have
      "\<forall> i::nat.
        (i < length ?p \<and> \<not>Preference_Relation.lifted A (?p!i) (?q!i) a) \<longrightarrow>
          (?p!i) = (?q!i)"
      using length_map lifted_a limit_profile.simps nth_map one
      unfolding lifted_def
      by metis
    ultimately have "lifted A ?p ?q a"
      using inA lifted_a rev_finite_subset subset
      unfolding lifted_def
      by (metis (no_types, lifting))
    thus ?thesis
      by simp
  qed
next
  assume "a \<notin> A"
  thus ?thesis
    using lifted_a negl_diff_imp_eq_limit_prof subset
          lifted_imp_equiv_prof_except_a
    by metis
qed

end


theory deMorgan2
  imports Main
begin
  text\<open> Apply style \<close>
   lemma lem_k_1 : " (\<not>p \<and> \<not>q)\<longrightarrow> \<not>(p \<or> q)"
    apply (rule impI)
     apply (erule conjE)
     apply (rule notI)
     apply (erule notE)
     apply (erule disjE)
      apply assumption
     apply (erule notE)
     apply assumption
    done

end