(*<*)
theory Interval
  imports "HOL-Library.Extended_Nat" "HOL-Library.Product_Lexorder"
begin
(*>*)

section \<open>Intervals\<close>

definition upclosed :: "(nat \<Rightarrow> bool) \<Rightarrow> bool" where
  "upclosed mem = (\<forall>l m. mem l \<longrightarrow> l \<le> m \<longrightarrow> mem m)"

definition downclosed :: "(nat \<Rightarrow> bool) \<Rightarrow> bool" where
  "downclosed mem = (\<forall>m r. mem r \<longrightarrow> m \<le> r \<longrightarrow> mem m)"

typedef \<I> = "{(memL, memR, bounded).
  (\<exists>m. memL m \<and> memR m) \<and> upclosed memL \<and> downclosed memR \<and> (bounded \<longleftrightarrow> (\<exists>m. \<not> memR m))}"
  by (intro exI[of _ "(\<lambda>_. True, \<lambda>_. True, False)"]) (auto simp: upclosed_def downclosed_def)

setup_lifting type_definition_\<I>

lift_definition memL :: "\<I> \<Rightarrow> nat \<Rightarrow> bool" is fst .
lift_definition memR :: "\<I> \<Rightarrow> nat \<Rightarrow> bool" is "fst o snd" .
lift_definition bounded :: "\<I> \<Rightarrow> bool" is "snd o snd" .
abbreviation mem :: "\<I> \<Rightarrow> nat \<Rightarrow> bool" where "mem \<I> n \<equiv> memL \<I> n \<and> memR \<I> n"

lemma memL_mono[elim]: "memL I l \<Longrightarrow> l \<le> m \<Longrightarrow> memL I m"
  by transfer (auto simp: upclosed_def)
lemma memR_antimono[elim]: "memR I r \<Longrightarrow> m \<le> r \<Longrightarrow> memR I m"
  by transfer (auto simp: downclosed_def)
lemma memR_zero[simp]: "memR I 0"
  by transfer (auto simp: downclosed_def)
lemma memR_nonzeroD: "\<not> memR I t \<Longrightarrow> t > 0"
  by (erule contrapos_np) simp

lemma bounded_memR: "bounded I \<longleftrightarrow> (\<exists>m. \<not> memR I m)"
  by transfer auto

lift_definition all :: \<I> is "(\<lambda>_. True, \<lambda>_. True, False)" by (auto simp: upclosed_def downclosed_def)
lift_definition point :: "nat \<Rightarrow> \<I>" is "\<lambda>n. ((\<le>) n, (\<ge>) n, True)"
  by (auto simp: upclosed_def downclosed_def not_le)
lift_definition subtract :: "nat \<Rightarrow> \<I> \<Rightarrow> \<I>" is
  "\<lambda>n (memL, memR, b). (\<lambda>i. memL (i + n), \<lambda>i. i = 0 \<or> memR (i + n), b)"
    apply (auto simp: upclosed_def downclosed_def)
   apply (metis add.commute le_iff_add linear)
  by (metis le0 linorder_neqE_nat nat_le_iff_add not_less0)

lemma point_simps[simp]:
  "memL (point n) = (\<le>) n"
  "memR (point n) = (\<ge>) n"
  "bounded (point n) = True"
  by (transfer; auto)+

lemma subtract_simps[simp]:
  "subtract 0 I = I"
  "subtract x (point y) = point (y - x)"
  "memL (subtract x I) n = memL I (n + x)"
  "memR (subtract x I) n = (n = 0 \<or> memR I (n + x))"
  "bounded (subtract x I) = bounded I"
  by (transfer; auto simp: downclosed_def)+

lift_definition interval :: "nat \<Rightarrow> enat \<Rightarrow> \<I>" is
  "\<lambda>l. \<lambda>r. (if enat l \<le> r then (\<lambda>i. l \<le> i, \<lambda>i. enat i \<le> r, r \<noteq> \<infinity>) else (\<lambda>_. True, \<lambda>_. True, False))"
  using enat_iless
  by (auto simp: upclosed_def downclosed_def not_le order_subst2)

(*<*)
end
(*>*)


(*  Title:      HOL/Cardinals/Wellfounded_More.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

More on well-founded relations.
*)

section \<open>More on Well-Founded Relations\<close>

theory Wellfounded_More
imports Wellfounded Order_Relation_More
begin

subsection \<open>Well-founded recursion via genuine fixpoints\<close>

(*2*)lemma adm_wf_unique_fixpoint:
fixes r :: "('a * 'a) set" and
      H :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" and
      f :: "'a \<Rightarrow> 'b" and g :: "'a \<Rightarrow> 'b"
assumes WF: "wf r" and ADM: "adm_wf r H" and fFP: "f = H f" and gFP: "g = H g"
shows "f = g"
proof-
  {fix x
   have "f x = g x"
   proof(rule wf_induct[of r "(\<lambda>x. f x = g x)"],
         auto simp add: WF)
     fix x assume "\<forall>y. (y, x) \<in> r \<longrightarrow> f y = g y"
     hence "H f x = H g x" using ADM adm_wf_def[of r H] by auto
     thus "f x = g x" using fFP and gFP by simp
   qed
  }
  thus ?thesis by (simp add: ext)
qed

(*2*)lemma wfrec_unique_fixpoint:
fixes r :: "('a * 'a) set" and
      H :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" and
      f :: "'a \<Rightarrow> 'b"
assumes WF: "wf r" and ADM: "adm_wf r H" and
        fp: "f = H f"
shows "f = wfrec r H"
proof-
  have "H (wfrec r H) = wfrec r H"
  using assms wfrec_fixpoint[of r H] by simp
  thus ?thesis
  using assms adm_wf_unique_fixpoint[of r H "wfrec r H"] by simp
qed

end


(*  Title:      HOL/Proofs/Extraction/Warshall.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Warshall's algorithm\<close>

theory Warshall
imports "HOL-Library.Realizers"
begin

text \<open>
  Derivation of Warshall's algorithm using program extraction,
  based on Berger, Schwichtenberg and Seisenberger \<^cite>\<open>"Berger-JAR-2001"\<close>.
\<close>

datatype b = T | F

primrec is_path' :: "('a \<Rightarrow> 'a \<Rightarrow> b) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_path' r x [] z \<longleftrightarrow> r x z = T"
| "is_path' r x (y # ys) z \<longleftrightarrow> r x y = T \<and> is_path' r y ys z"

definition is_path :: "(nat \<Rightarrow> nat \<Rightarrow> b) \<Rightarrow> (nat * nat list * nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "is_path r p i j k \<longleftrightarrow>
    fst p = j \<and> snd (snd p) = k \<and>
    list_all (\<lambda>x. x < i) (fst (snd p)) \<and>
    is_path' r (fst p) (fst (snd p)) (snd (snd p))"

definition conc :: "'a \<times> 'a list \<times> 'a \<Rightarrow> 'a \<times> 'a list \<times> 'a \<Rightarrow> 'a \<times> 'a list * 'a"
  where "conc p q = (fst p, fst (snd p) @ fst q # fst (snd q), snd (snd q))"

theorem is_path'_snoc [simp]: "\<And>x. is_path' r x (ys @ [y]) z = (is_path' r x ys y \<and> r y z = T)"
  by (induct ys) simp+

theorem list_all_scoc [simp]: "list_all P (xs @ [x]) \<longleftrightarrow> P x \<and> list_all P xs"
  by (induct xs) (simp+, iprover)

theorem list_all_lemma: "list_all P xs \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> list_all Q xs"
proof -
  assume PQ: "\<And>x. P x \<Longrightarrow> Q x"
  show "list_all P xs \<Longrightarrow> list_all Q xs"
  proof (induct xs)
    case Nil
    show ?case by simp
  next
    case (Cons y ys)
    then have Py: "P y" by simp
    from Cons have Pys: "list_all P ys" by simp
    show ?case
      by simp (rule conjI PQ Py Cons Pys)+
  qed
qed

theorem lemma1: "\<And>p. is_path r p i j k \<Longrightarrow> is_path r p (Suc i) j k"
  unfolding is_path_def
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (erule list_all_lemma)
  apply simp
  done

theorem lemma2: "\<And>p. is_path r p 0 j k \<Longrightarrow> r j k = T"
  unfolding is_path_def
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (case_tac a)
  apply simp_all
  done

theorem is_path'_conc: "is_path' r j xs i \<Longrightarrow> is_path' r i ys k \<Longrightarrow>
  is_path' r j (xs @ i # ys) k"
proof -
  assume pys: "is_path' r i ys k"
  show "\<And>j. is_path' r j xs i \<Longrightarrow> is_path' r j (xs @ i # ys) k"
  proof (induct xs)
    case (Nil j)
    then have "r j i = T" by simp
    with pys show ?case by simp
  next
    case (Cons z zs j)
    then have jzr: "r j z = T" by simp
    from Cons have pzs: "is_path' r z zs i" by simp
    show ?case
      by simp (rule conjI jzr Cons pzs)+
  qed
qed

theorem lemma3:
  "\<And>p q. is_path r p i j i \<Longrightarrow> is_path r q i i k \<Longrightarrow>
    is_path r (conc p q) (Suc i) j k"
  apply (unfold is_path_def conc_def)
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule is_path'_conc)
  apply assumption+
  done

theorem lemma5:
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> \<not> is_path r p i j k \<Longrightarrow>
    (\<exists>q. is_path r q i j i) \<and> (\<exists>q'. is_path r q' i i k)"
proof (simp cong add: conj_cong add: split_paired_all is_path_def, (erule conjE)+)
  fix xs
  assume asms:
    "list_all (\<lambda>x. x < Suc i) xs"
    "is_path' r j xs k"
    "\<not> list_all (\<lambda>x. x < i) xs"
  show "(\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i) \<and>
    (\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k)"
  proof
    have "\<And>j. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
    \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i" (is "PROP ?ih xs")
    proof (induct xs)
      case Nil
      then show ?case by simp
    next
      case (Cons a as j)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and Cons have "r j i = T" by simp
          then show "list_all (\<lambda>x. x < i) [] \<and> is_path' r j [] i" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule Cons)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r a ys i"
        proof
          from Cons show "list_all (\<lambda>x. x < Suc i) as" by simp
          from Cons show "is_path' r a as k" by simp
          from Cons and False show "\<not> list_all (\<lambda>x. x < i) as" by (simp)
        qed
        show ?thesis
        proof
          from Cons False ys
          show "list_all (\<lambda>x. x<i) (a#ys) \<and> is_path' r j (a#ys) i" by simp
        qed
      qed
    qed
    from this asms show "\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i" .
    have "\<And>k. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
      \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k" (is "PROP ?ih xs")
    proof (induct xs rule: rev_induct)
      case Nil
      then show ?case by simp
    next
      case (snoc a as k)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and snoc have "r i k = T" by simp
          then show "list_all (\<lambda>x. x < i) [] \<and> is_path' r i [] k" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule snoc)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys a"
        proof
          from snoc show "list_all (\<lambda>x. x < Suc i) as" by simp
          from snoc show "is_path' r j as a" by simp
          from snoc and False show "\<not> list_all (\<lambda>x. x < i) as" by simp
        qed
        show ?thesis
        proof
          from snoc False ys
          show "list_all (\<lambda>x. x < i) (ys @ [a]) \<and> is_path' r i (ys @ [a]) k"
            by simp
        qed
      qed
    qed
    from this asms show "\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k" .
  qed
qed

theorem lemma5':
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> \<not> is_path r p i j k \<Longrightarrow>
    \<not> (\<forall>q. \<not> is_path r q i j i) \<and> \<not> (\<forall>q'. \<not> is_path r q' i i k)"
  by (iprover dest: lemma5)

theorem warshall: "\<And>j k. \<not> (\<exists>p. is_path r p i j k) \<or> (\<exists>p. is_path r p i j k)"
proof (induct i)
  case (0 j k)
  show ?case
  proof (cases "r j k")
    assume "r j k = T"
    then have "is_path r (j, [], k) 0 j k"
      by (simp add: is_path_def)
    then have "\<exists>p. is_path r p 0 j k" ..
    then show ?thesis ..
  next
    assume "r j k = F"
    then have "r j k \<noteq> T" by simp
    then have "\<not> (\<exists>p. is_path r p 0 j k)"
      by (iprover dest: lemma2)
    then show ?thesis ..
  qed
next
  case (Suc i j k)
  then show ?case
  proof
    assume h1: "\<not> (\<exists>p. is_path r p i j k)"
    from Suc show ?case
    proof
      assume "\<not> (\<exists>p. is_path r p i j i)"
      with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
        by (iprover dest: lemma5')
      then show ?case ..
    next
      assume "\<exists>p. is_path r p i j i"
      then obtain p where h2: "is_path r p i j i" ..
      from Suc show ?case
      proof
        assume "\<not> (\<exists>p. is_path r p i i k)"
        with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
          by (iprover dest: lemma5')
        then show ?case ..
      next
        assume "\<exists>q. is_path r q i i k"
        then obtain q where "is_path r q i i k" ..
        with h2 have "is_path r (conc p q) (Suc i) j k"
          by (rule lemma3)
        then have "\<exists>pq. is_path r pq (Suc i) j k" ..
        then show ?case ..
      qed
    qed
  next
    assume "\<exists>p. is_path r p i j k"
    then have "\<exists>p. is_path r p (Suc i) j k"
      by (iprover intro: lemma1)
    then show ?case ..
  qed
qed

extract warshall

text \<open>
  The program extracted from the above proof looks as follows
  @{thm [display, eta_contract=false] warshall_def [no_vars]}
  The corresponding correctness theorem is
  @{thm [display] warshall_correctness [no_vars]}
\<close>

ML_val "@{code warshall}"

end


theory Examples
imports Main
begin

(*
text {* The following presentation will use notation of
  Isabelle's meta logic, hence a few sentences to explain this.
  The logical
  primitives are universal quantification (@{text "\<And>"}), entailment
  (@{text "\<Longrightarrow>"}) and equality (@{text "\<equiv>"}).  Variables (not bound
  variables) are sometimes preceded by a question mark.  The logic is
  typed.  Type variables are denoted by~@{text "'a"},~@{text "'b"}
  etc., and~@{text "\<Rightarrow>"} is the function type.  Double brackets~@{text
  "\<lbrakk>"} and~@{text "\<rbrakk>"} are used to abbreviate nested entailment.
*}
*)

section {* Introduction *}

text {*
  Locales are based on contexts.  A \emph{context} can be seen as a
  formula schema
\[
  @{text "\<And>x\<^sub>1\<dots>x\<^sub>n. \<lbrakk> A\<^sub>1; \<dots> ;A\<^sub>m \<rbrakk> \<Longrightarrow> \<dots>"}
\]
  where the variables~@{text "x\<^sub>1"}, \ldots,~@{text "x\<^sub>n"} are called
  \emph{parameters} and the premises $@{text "A\<^sub>1"}, \ldots,~@{text
  "A\<^sub>m"}$ \emph{assumptions}.  A formula~@{text "C"}
  is a \emph{theorem} in the context if it is a conclusion
\[
  @{text "\<And>x\<^sub>1\<dots>x\<^sub>n. \<lbrakk> A\<^sub>1; \<dots> ;A\<^sub>m \<rbrakk> \<Longrightarrow> C"}.
\]
  Isabelle/Isar's notion of context goes beyond this logical view.
  Its contexts record, in a consecutive order, proved
  conclusions along with \emph{attributes}, which can provide context
  specific configuration information for proof procedures and concrete
  syntax.  From a logical perspective, locales are just contexts that
  have been made persistent.  To the user, though, they provide
  powerful means for declaring and combining contexts, and for the
  reuse of theorems proved in these contexts.
  *}

section {* Simple Locales *}

text {*
  In its simplest form, a
  \emph{locale declaration} consists of a sequence of context elements
  declaring parameters (keyword \isakeyword{fixes}) and assumptions
  (keyword \isakeyword{assumes}).  The following is the specification of
  partial orders, as locale @{text partial_order}.
  *}

  locale partial_order =
    fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
    assumes refl [intro, simp]: "x \<sqsubseteq> x"
      and anti_sym [intro]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y"
      and trans [trans]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

text (in partial_order) {* The parameter of this locale is~@{text le},
  which is a binary predicate with infix syntax~@{text \<sqsubseteq>}.  The
  parameter syntax is available in the subsequent
  assumptions, which are the familiar partial order axioms.

  Isabelle recognises unbound names as free variables.  In locale
  assumptions, these are implicitly universally quantified.  That is,
  @{term "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"} in fact means
  @{term "\<And>x y z. \<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"}.

  Two commands are provided to inspect locales:
  \isakeyword{print\_locales} lists the names of all locales of the
  current theory; \isakeyword{print\_locale}~$n$ prints the parameters
  and assumptions of locale $n$; the variation \isakeyword{print\_locale!}~$n$
  additionally outputs the conclusions that are stored in the locale.
  We may inspect the new locale
  by issuing \isakeyword{print\_locale!} @{term partial_order}.  The output
  is the following list of context elements.
\begin{small}
\begin{alltt}
  \isakeyword{fixes} le :: "'a \(\Rightarrow\) 'a \(\Rightarrow\)  bool" (\isakeyword{infixl} "\(\sqsubseteq\)" 50)
  \isakeyword{assumes} "partial_order op \(\sqsubseteq\)"
  \isakeyword{notes} assumption
    refl [intro, simp] = `?x \(\sqsubseteq\) ?x`
    \isakeyword{and}
    anti_sym [intro] = `\(\isasymlbrakk\)?x \(\sqsubseteq\) ?y; ?y \(\sqsubseteq\) ?x\(\isasymrbrakk\) \(\Longrightarrow\) ?x = ?y`
    \isakeyword{and}
    trans [trans] = `\(\isasymlbrakk\)?x \(\sqsubseteq\) ?y; ?y \(\sqsubseteq\) ?z\(\isasymrbrakk\) \(\Longrightarrow\) ?x \(\sqsubseteq\) ?z`
\end{alltt}
\end{small}

  This differs from the declaration.  The assumptions have turned into
  conclusions, denoted by the keyword \isakeyword{notes}.  Also,
  there is only one assumption, namely @{term "partial_order le"}.
  The locale declaration has introduced the predicate @{term
  partial_order} to the theory.  This predicate is the
  \emph{locale predicate}.  Its definition may be inspected by
  issuing \isakeyword{thm} @{thm [source] partial_order_def}.
  @{thm [display, indent=2] partial_order_def}
  In our example, this is a unary predicate over the parameter of the
  locale.  It is equivalent to the original assumptions, which have
  been turned into conclusions and are
  available as theorems in the context of the locale.  The names and
  attributes from the locale declaration are associated to these
  theorems and are effective in the context of the locale.

  Each conclusion has a \emph{foundational theorem} as counterpart
  in the theory.  Technically, this is simply the theorem composed
  of context and conclusion.  For the transitivity theorem, this is
  @{thm [source] partial_order.trans}:
  @{thm [display, indent=2] partial_order.trans}
*}

subsection {* Targets: Extending Locales *}

text {*
  The specification of a locale is fixed, but its list of conclusions
  may be extended through Isar commands that take a \emph{target} argument.
  In the following, \isakeyword{definition} and
  \isakeyword{theorem} are illustrated.
  Table~\ref{tab:commands-with-target} lists Isar commands that accept
  a target.  Isar provides various ways of specifying the target.  A
  target for a single command may be indicated with keyword
  \isakeyword{in} in the following way:

\begin{table}
\hrule
\vspace{2ex}
\begin{center}
\begin{tabular}{ll}
  \isakeyword{definition} & definition through an equation \\
  \isakeyword{inductive} & inductive definition \\
  \isakeyword{primrec} & primitive recursion \\
  \isakeyword{fun}, \isakeyword{function} & general recursion \\
  \isakeyword{abbreviation} & syntactic abbreviation \\
  \isakeyword{theorem}, etc.\ & theorem statement with proof \\
  \isakeyword{theorems}, etc.\ & redeclaration of theorems \\
  \isakeyword{text}, etc.\ & document markup
\end{tabular}
\end{center}
\hrule
\caption{Isar commands that accept a target.}
\label{tab:commands-with-target}
\end{table}
  *}

  definition (in partial_order)
    less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
    where "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

text (in partial_order) {* The strict order @{text less} with infix
  syntax~@{text \<sqsubset>} is
  defined in terms of the locale parameter~@{text le} and the general
  equality of the object logic we work in.  The definition generates a
  \emph{foundational constant}
  @{term partial_order.less} with definition @{thm [source]
  partial_order.less_def}:
  @{thm [display, indent=2] partial_order.less_def}
  At the same time, the locale is extended by syntax transformations
  hiding this construction in the context of the locale.  Here, the
  abbreviation @{text less} is available for
  @{text "partial_order.less le"}, and it is printed
  and parsed as infix~@{text \<sqsubset>}.  Finally, the conclusion @{thm [source]
  less_def} is added to the locale:
  @{thm [display, indent=2] less_def}
*}

text {* The treatment of theorem statements is more straightforward.
  As an example, here is the derivation of a transitivity law for the
  strict order relation. *}

  lemma (in partial_order) less_le_trans [trans]:
    "\<lbrakk> x \<sqsubset> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubset> z"
    unfolding %visible less_def by %visible (blast intro: trans)

text {* In the context of the proof, conclusions of the
  locale may be used like theorems.  Attributes are effective: @{text
  anti_sym} was
  declared as introduction rule, hence it is in the context's set of
  rules used by the classical reasoner by default.  *}

subsection {* Context Blocks *}

text {* When working with locales, sequences of commands with the same
  target are frequent.  A block of commands, delimited by
  \isakeyword{begin} and \isakeyword{end}, makes a theory-like style
  of working possible.  All commands inside the block refer to the
  same target.  A block may immediately follow a locale
  declaration, which makes that locale the target.  Alternatively the
  target for a block may be given with the \isakeyword{context}
  command.

  This style of working is illustrated in the block below, where
  notions of infimum and supremum for partial orders are introduced,
  together with theorems about their uniqueness.  *}

  context partial_order
  begin

  definition
    is_inf where "is_inf x y i =
      (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

  definition
    is_sup where "is_sup x y s =
      (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

  lemma %invisible is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
      (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
    by (unfold is_inf_def) blast

  lemma %invisible is_inf_lower [elim?]:
    "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
    by (unfold is_inf_def) blast

  lemma %invisible is_inf_greatest [elim?]:
      "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
    by (unfold is_inf_def) blast

  theorem is_inf_uniq: "\<lbrakk>is_inf x y i; is_inf x y i'\<rbrakk> \<Longrightarrow> i = i'"
    proof -
    assume inf: "is_inf x y i"
    assume inf': "is_inf x y i'"
    show ?thesis
    proof (rule anti_sym)
      from inf' show "i \<sqsubseteq> i'"
      proof (rule is_inf_greatest)
        from inf show "i \<sqsubseteq> x" ..
        from inf show "i \<sqsubseteq> y" ..
      qed
      from inf show "i' \<sqsubseteq> i"
      proof (rule is_inf_greatest)
        from inf' show "i' \<sqsubseteq> x" ..
        from inf' show "i' \<sqsubseteq> y" ..
      qed
    qed
  qed

  theorem %invisible is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
  proof -
    assume "x \<sqsubseteq> y"
    show ?thesis
    proof
      show "x \<sqsubseteq> x" ..
      show "x \<sqsubseteq> y" by fact
      fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
    qed
  qed

  lemma %invisible is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
      (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
    by (unfold is_sup_def) blast

  lemma %invisible is_sup_least [elim?]:
      "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
    by (unfold is_sup_def) blast

  lemma %invisible is_sup_upper [elim?]:
      "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
    by (unfold is_sup_def) blast

  theorem is_sup_uniq: "\<lbrakk>is_sup x y s; is_sup x y s'\<rbrakk> \<Longrightarrow> s = s'"
    proof -
    assume sup: "is_sup x y s"
    assume sup': "is_sup x y s'"
    show ?thesis
    proof (rule anti_sym)
      from sup show "s \<sqsubseteq> s'"
      proof (rule is_sup_least)
        from sup' show "x \<sqsubseteq> s'" ..
        from sup' show "y \<sqsubseteq> s'" ..
      qed
      from sup' show "s' \<sqsubseteq> s"
      proof (rule is_sup_least)
        from sup show "x \<sqsubseteq> s" ..
        from sup show "y \<sqsubseteq> s" ..
      qed
    qed
  qed

  theorem %invisible is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
  proof -
    assume "x \<sqsubseteq> y"
    show ?thesis
    proof
      show "x \<sqsubseteq> y" by fact
      show "y \<sqsubseteq> y" ..
      fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
      show "y \<sqsubseteq> z" by fact
    qed
  qed

  end

text {* The syntax of the locale commands discussed in this tutorial is
  shown in Table~\ref{tab:commands}.  The grammar is complete with the
  exception of the context elements \isakeyword{constrains} and
  \isakeyword{defines}, which are provided for backward
  compatibility.  See the Isabelle/Isar Reference
  Manual @{cite IsarRef} for full documentation.  *}

section {* Import \label{sec:import} *}

text {*
  Algebraic structures are commonly defined by adding operations and
  properties to existing structures.  For example, partial orders
  are extended to lattices and total orders.  Lattices are extended to
  distributive lattices. *}

text {*
  With locales, this kind of inheritance is achieved through
  \emph{import} of locales.  The import part of a locale declaration,
  if present, precedes the context elements.  Here is an example,
  where partial orders are extended to lattices.
  *}

  locale lattice = partial_order +
    assumes ex_inf: "\<exists>inf. is_inf x y inf"
      and ex_sup: "\<exists>sup. is_sup x y sup"
  begin

text {* These assumptions refer to the predicates for infimum
  and supremum defined for @{text partial_order} in the previous
  section.  We now introduce the notions of meet and join.  *}

  definition
    meet (infixl "\<sqinter>" 70) where "x \<sqinter> y = (THE inf. is_inf x y inf)"
  definition
    join (infixl "\<squnion>" 65) where "x \<squnion> y = (THE sup. is_sup x y sup)"

  lemma %invisible meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
  proof (unfold meet_def)
    assume "is_inf x y i"
    then show "(THE i. is_inf x y i) = i"
      by (rule the_equality) (rule is_inf_uniq [OF _ `is_inf x y i`])
  qed

  lemma %invisible meetI [intro?]:
      "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
    by (rule meet_equality, rule is_infI) blast+

  lemma %invisible is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
  proof (unfold meet_def)
    from ex_inf obtain i where "is_inf x y i" ..
    then show "is_inf x y (THE i. is_inf x y i)"
      by (rule theI) (rule is_inf_uniq [OF _ `is_inf x y i`])
  qed

  lemma %invisible meet_left [intro?]:
    "x \<sqinter> y \<sqsubseteq> x"
    by (rule is_inf_lower) (rule is_inf_meet)

  lemma %invisible meet_right [intro?]:
    "x \<sqinter> y \<sqsubseteq> y"
    by (rule is_inf_lower) (rule is_inf_meet)

  lemma %invisible meet_le [intro?]:
    "\<lbrakk> z \<sqsubseteq> x; z \<sqsubseteq> y \<rbrakk> \<Longrightarrow> z \<sqsubseteq> x \<sqinter> y"
    by (rule is_inf_greatest) (rule is_inf_meet)

  lemma %invisible join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
  proof (unfold join_def)
    assume "is_sup x y s"
    then show "(THE s. is_sup x y s) = s"
      by (rule the_equality) (rule is_sup_uniq [OF _ `is_sup x y s`])
  qed

  lemma %invisible joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
      (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
    by (rule join_equality, rule is_supI) blast+

  lemma %invisible is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
  proof (unfold join_def)
    from ex_sup obtain s where "is_sup x y s" ..
    then show "is_sup x y (THE s. is_sup x y s)"
      by (rule theI) (rule is_sup_uniq [OF _ `is_sup x y s`])
  qed

  lemma %invisible join_left [intro?]:
    "x \<sqsubseteq> x \<squnion> y"
    by (rule is_sup_upper) (rule is_sup_join)

  lemma %invisible join_right [intro?]:
    "y \<sqsubseteq> x \<squnion> y"
    by (rule is_sup_upper) (rule is_sup_join)

  lemma %invisible join_le [intro?]:
    "\<lbrakk> x \<sqsubseteq> z; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
    by (rule is_sup_least) (rule is_sup_join)

  theorem %invisible meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  proof (rule meetI)
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
    proof
      show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
      show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
      proof -
        have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
    qed
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> z" ..
      finally show ?thesis .
    qed
    fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
    show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
    proof
      show "w \<sqsubseteq> x"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> x" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> y \<sqinter> z"
      proof
        show "w \<sqsubseteq> y"
        proof -
          have "w \<sqsubseteq> x \<sqinter> y" by fact
          also have "\<dots> \<sqsubseteq> y" ..
          finally show ?thesis .
        qed
        show "w \<sqsubseteq> z" by fact
      qed
    qed
  qed

  theorem %invisible meet_commute: "x \<sqinter> y = y \<sqinter> x"
  proof (rule meetI)
    show "y \<sqinter> x \<sqsubseteq> x" ..
    show "y \<sqinter> x \<sqsubseteq> y" ..
    fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
    then show "z \<sqsubseteq> y \<sqinter> x" ..
  qed

  theorem %invisible meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
  proof (rule meetI)
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> x \<squnion> y" ..
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
    show "z \<sqsubseteq> x" by fact
  qed

  theorem %invisible join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  proof (rule joinI)
    show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof
      show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
      proof -
        have "y \<sqsubseteq> y \<squnion> z" ..
        also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
        finally show ?thesis .
      qed
    qed
    show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "z \<sqsubseteq> y \<squnion> z"  ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
    fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
    show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
    proof
      show "x \<sqsubseteq> w"
      proof -
        have "x \<sqsubseteq> x \<squnion> y" ..
        also have "\<dots> \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "y \<squnion> z \<sqsubseteq> w"
      proof
        show "y \<sqsubseteq> w"
        proof -
          have "y \<sqsubseteq> x \<squnion> y" ..
          also have "... \<sqsubseteq> w" by fact
          finally show ?thesis .
        qed
        show "z \<sqsubseteq> w" by fact
      qed
    qed
  qed

  theorem %invisible join_commute: "x \<squnion> y = y \<squnion> x"
  proof (rule joinI)
    show "x \<sqsubseteq> y \<squnion> x" ..
    show "y \<sqsubseteq> y \<squnion> x" ..
    fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
    then show "y \<squnion> x \<sqsubseteq> z" ..
  qed

  theorem %invisible join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
  proof (rule joinI)
    show "x \<sqsubseteq> x" ..
    show "x \<sqinter> y \<sqsubseteq> x" ..
    fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
    show "x \<sqsubseteq> z" by fact
  qed

  theorem %invisible meet_idem: "x \<sqinter> x = x"
  proof -
    have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
    also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
    finally show ?thesis .
  qed

  theorem %invisible meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
  proof (rule meetI)
    assume "x \<sqsubseteq> y"
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    show "z \<sqsubseteq> x" by fact
  qed

  theorem %invisible meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
    by (drule meet_related) (simp add: meet_commute)

  theorem %invisible join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
  proof (rule joinI)
    assume "x \<sqsubseteq> y"
    show "y \<sqsubseteq> y" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed

  theorem %invisible join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
    by (drule join_related) (simp add: join_commute)

  theorem %invisible meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
  proof
    assume "x \<sqsubseteq> y"
    then have "is_inf x y x" ..
    then show "x \<sqinter> y = x" ..
  next
    have "x \<sqinter> y \<sqsubseteq> y" ..
    also assume "x \<sqinter> y = x"
    finally show "x \<sqsubseteq> y" .
  qed

  theorem %invisible join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  proof
    assume "x \<sqsubseteq> y"
    then have "is_sup x y y" ..
    then show "x \<squnion> y = y" ..
  next
    have "x \<sqsubseteq> x \<squnion> y" ..
    also assume "x \<squnion> y = y"
    finally show "x \<sqsubseteq> y" .
  qed

  theorem %invisible meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
    using meet_commute meet_connection by simp

  theorem %invisible join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
    using join_commute join_connection by simp

  text %invisible {* Naming according to Jacobson I, p.\ 459. *}
  lemmas %invisible L1 = join_commute meet_commute
  lemmas %invisible L2 = join_assoc meet_assoc
  (* lemmas L3 = join_idem meet_idem *)
  lemmas %invisible L4 = join_meet_absorb meet_join_absorb

  end

text {* Locales for total orders and distributive lattices follow to
  establish a sufficiently rich landscape of locales for
  further examples in this tutorial.  Each comes with an example
  theorem. *}

  locale total_order = partial_order +
    assumes total: "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

  lemma (in total_order) less_total: "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x"
    using total
    by (unfold less_def) blast

  locale distrib_lattice = lattice +
    assumes meet_distr: "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z"

  lemma (in distrib_lattice) join_distr:
    "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"  (* txt {* Jacobson I, p.\ 462 *} *)
    proof -
    have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
    also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
    also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
    also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
    also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
    finally show ?thesis .
  qed

text {*
  The locale hierarchy obtained through these declarations is shown in
  Figure~\ref{fig:lattices}(a).

\begin{figure}
\hrule \vspace{2ex}
\begin{center}
\subfigure[Declared hierarchy]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (-1.5,-1) {@{text lattice}};
  \node (dlat) at (-1.5,-2) {@{text distrib_lattice}};
  \node (to) at (1.5,-1) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (po) -- (to);
%  \draw[->, dashed] (lat) -- (to);
\end{tikzpicture}
} \\
\subfigure[Total orders are lattices]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (0,-1) {@{text lattice}};
  \node (dlat) at (-1.5,-2) {@{text distrib_lattice}};
  \node (to) at (1.5,-2) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (lat) -- (to);
%  \draw[->, dashed] (dlat) -- (to);
\end{tikzpicture}
} \quad
\subfigure[Total orders are distributive lattices]{
\begin{tikzpicture}
  \node (po) at (0,0) {@{text partial_order}};
  \node (lat) at (0,-1) {@{text lattice}};
  \node (dlat) at (0,-2) {@{text distrib_lattice}};
  \node (to) at (0,-3) {@{text total_order}};
  \draw (po) -- (lat);
  \draw (lat) -- (dlat);
  \draw (dlat) -- (to);
\end{tikzpicture}
}
\end{center}
\hrule
\caption{Hierarchy of Lattice Locales.}
\label{fig:lattices}
\end{figure}
  *}

section {* Changing the Locale Hierarchy
  \label{sec:changing-the-hierarchy} *}

text {*
  Locales enable to prove theorems abstractly, relative to
  sets of assumptions.  These theorems can then be used in other
  contexts where the assumptions themselves, or
  instances of the assumptions, are theorems.  This form of theorem
  reuse is called \emph{interpretation}.  Locales generalise
  interpretation from theorems to conclusions, enabling the reuse of
  definitions and other constructs that are not part of the
  specifications of the locales.

  The first form of interpretation we will consider in this tutorial
  is provided by the \isakeyword{sublocale} command.  It enables to
  modify the import hierarchy to reflect the \emph{logical} relation
  between locales.

  Consider the locale hierarchy from Figure~\ref{fig:lattices}(a).
  Total orders are lattices, although this is not reflected here, and
  definitions, theorems and other conclusions
  from @{term lattice} are not available in @{term total_order}.  To
  obtain the situation in Figure~\ref{fig:lattices}(b), it is
  sufficient to add the conclusions of the latter locale to the former.
  The \isakeyword{sublocale} command does exactly this.
  The declaration \isakeyword{sublocale} $l_1
  \subseteq l_2$ causes locale $l_2$ to be \emph{interpreted} in the
  context of $l_1$.  This means that all conclusions of $l_2$ are made
  available in $l_1$.

  Of course, the change of hierarchy must be supported by a theorem
  that reflects, in our example, that total orders are indeed
  lattices.  Therefore the \isakeyword{sublocale} command generates a
  goal, which must be discharged by the user.  This is illustrated in
  the following paragraphs.  First the sublocale relation is stated.
*}

  sublocale %visible total_order \<subseteq> lattice

txt {* \normalsize
  This enters the context of locale @{text total_order}, in
  which the goal @{subgoals [display]} must be shown.
  Now the
  locale predicate needs to be unfolded --- for example, using its
  definition or by introduction rules
  provided by the locale package.  For automation, the locale package
  provides the methods @{text intro_locales} and @{text
  unfold_locales}.  They are aware of the
  current context and dependencies between locales and automatically
  discharge goals implied by these.  While @{text unfold_locales}
  always unfolds locale predicates to assumptions, @{text
  intro_locales} only unfolds definitions along the locale
  hierarchy, leaving a goal consisting of predicates defined by the
  locale package.  Occasionally the latter is of advantage since the goal
  is smaller.

  For the current goal, we would like to get hold of
  the assumptions of @{text lattice}, which need to be shown, hence
  @{text unfold_locales} is appropriate. *}

  proof unfold_locales

txt {* \normalsize
  Since the fact that both lattices and total orders are partial
  orders is already reflected in the locale hierarchy, the assumptions
  of @{text partial_order} are discharged automatically, and only the
  assumptions introduced in @{text lattice} remain as subgoals
  @{subgoals [display]}
  The proof for the first subgoal is obtained by constructing an
  infimum, whose existence is implied by totality. *}

    fix x y
    from total have "is_inf x y (if x \<sqsubseteq> y then x else y)"
      by (auto simp: is_inf_def)
    then show "\<exists>inf. is_inf x y inf" ..
txt {* \normalsize
   The proof for the second subgoal is analogous and not
  reproduced here. *}
  next %invisible
    fix x y
    from total have "is_sup x y (if x \<sqsubseteq> y then y else x)"
      by (auto simp: is_sup_def)
    then show "\<exists>sup. is_sup x y sup" .. qed %visible

text {* Similarly, we may establish that total orders are distributive
  lattices with a second \isakeyword{sublocale} statement. *}

  sublocale total_order \<subseteq> distrib_lattice
    proof unfold_locales
    fix %"proof" x y z
    show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
      txt {* Jacobson I, p.\ 462 *}
    proof -
      { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
        from c have "?l = y \<squnion> z"
          by (metis c join_connection2 join_related2 meet_related2 total)
        also from c have "... = ?r" by (metis meet_related2)
        finally have "?l = ?r" . }
      moreover
      { assume c: "x \<sqsubseteq> y \<or> x \<sqsubseteq> z"
        from c have "?l = x"
          by (metis join_connection2 join_related2 meet_connection total trans)
        also from c have "... = ?r"
          by (metis join_commute join_related2 meet_connection meet_related2 total)
        finally have "?l = ?r" . }
      moreover note total
      ultimately show ?thesis by blast
    qed
  qed

text {* The locale hierarchy is now as shown in
  Figure~\ref{fig:lattices}(c). *}

text {*
  Locale interpretation is \emph{dynamic}.  The statement
  \isakeyword{sublocale} $l_1 \subseteq l_2$ will not just add the
  current conclusions of $l_2$ to $l_1$.  Rather the dependency is
  stored, and conclusions that will be
  added to $l_2$ in future are automatically propagated to $l_1$.
  The sublocale relation is transitive --- that is, propagation takes
  effect along chains of sublocales.  Even cycles in the sublocale relation are
  supported, as long as these cycles do not lead to infinite chains.
  Details are discussed in the technical report @{cite Ballarin2006a}.
  See also Section~\ref{sec:infinite-chains} of this tutorial.  *}

end


section "Kripke structures and CTL"

text \<open>We apply Kripke structures and CTL to model state based systems and analyse properties under
dynamic state changes. Snapshots of systems are the states on which we define a state transition.
Temporal logic is then employed to express security and privacy properties.\<close>
theory MC
imports Main
begin

subsection "Lemmas to support least and greatest fixpoints"

lemma predtrans_empty:
  assumes "mono (\<tau> :: 'a set \<Rightarrow> 'a set)"
  shows "\<forall> i. (\<tau> ^^ i) ({}) \<subseteq> (\<tau> ^^(i + 1))({})"
  using assms funpow_decreasing le_add1 by blast

lemma ex_card: "finite S \<Longrightarrow> \<exists> n:: nat. card S = n"
by simp

lemma less_not_le: "\<lbrakk>(x:: nat) < y; y \<le> x\<rbrakk> \<Longrightarrow> False"
by arith

lemma infchain_outruns_all:
  assumes "finite (UNIV :: 'a set)"
    and "\<forall>i :: nat. ((\<tau> :: 'a set \<Rightarrow> 'a set)^^ i) ({}:: 'a set) \<subset> (\<tau> ^^ (i + 1)) {}"
  shows "\<forall>j :: nat. \<exists>i :: nat. j < card ((\<tau> ^^ i) {})"
proof (rule allI, induct_tac j)
  show "\<exists>i. 0 < card ((\<tau> ^^ i) {})" using assms
    by (metis bot.not_eq_extremum card_gt_0_iff finite_subset subset_UNIV)
next show "\<And>j n. \<exists>i. n < card ((\<tau> ^^ i) {})
             \<Longrightarrow> \<exists>i. Suc n < card ((\<tau> ^^ i) {})"
    proof -
      fix j n
      assume a: "\<exists>i. n < card ((\<tau> ^^ i) {})"
      obtain i where "n < card ((\<tau> ^^ i) {})"
        using a by blast
      thus "\<exists> i. Suc n < card ((\<tau> ^^ i) {})" using assms
        by (meson finite_subset le_less_trans le_simps(3) psubset_card_mono subset_UNIV)
    qed
  qed

lemma no_infinite_subset_chain:
   assumes "finite (UNIV :: 'a set)"
    and    "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
    and    "\<forall>i :: nat. ((\<tau> :: 'a set \<Rightarrow> 'a set) ^^ i) {} \<subset> (\<tau> ^^ (i + (1 :: nat))) ({} :: 'a set)"
  shows   "False"
text \<open>Proof idea: since @{term "UNIV"} is finite, we have from @{text \<open>ex_card\<close>} that there is
    an n with @{term "card UNIV = n"}. Now, use @{text \<open>infchain_outruns_all\<close>} to show as
    contradiction point that
    @{term "\<exists> i :: nat. card UNIV < card ((\<tau> ^^ i) {})"}.
    Since all sets are subsets of @{term "UNIV"}, we also have
    @{term "card ((\<tau> ^^ i) {}) \<le> card UNIV"}:
    Contradiction!, i.e. proof of False  \<close>
proof -
  have a: "\<forall> (j :: nat). (\<exists> (i :: nat). (j :: nat) < card((\<tau> ^^ i)({} :: 'a set)))" using assms
    by (erule_tac \<tau> = \<tau> in infchain_outruns_all)
  hence b: "\<exists> (n :: nat). card(UNIV :: 'a set) = n" using assms
    by (erule_tac S = UNIV in ex_card)
  from this obtain n where c: "card(UNIV :: 'a set) = n" by (erule exE)
  hence   d: "\<exists>i. card UNIV < card ((\<tau> ^^ i) {})" using a
    by (drule_tac x = "card UNIV" in spec)
  from this obtain i where e: "card (UNIV :: 'a set) < card ((\<tau> ^^ i) {})"
    by (erule exE)
  hence f: "(card((\<tau> ^^ i){})) \<le> (card (UNIV :: 'a set))" using assms
    apply (erule_tac A = "((\<tau> ^^ i){})" in Finite_Set.card_mono)
    by (rule subset_UNIV)
  thus "False" using e
    by (erule_tac y = "card((\<tau> ^^ i){})" in less_not_le)
qed

lemma finite_fixp:
  assumes "finite(UNIV :: 'a set)"
      and "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
    shows "\<exists> i. (\<tau> ^^ i) ({}) = (\<tau> ^^(i + 1))({})"
text \<open>Proof idea:
with @{text predtrans_empty} we know

@{term "\<forall> i. (\<tau> ^^ i){} \<subseteq> (\<tau> ^^(i + 1))({})"} (1).

If we can additionally show

@{term "\<exists> i.  (\<tau> ^^ i)({}) \<supseteq> (\<tau> ^^(i + 1))({})"} (2),

we can get the goal together with equalityI
@{text "\<subseteq> + \<supseteq> \<longrightarrow> ="}.
To prove (1) we observe that
@{term "(\<tau> ^^ i)({}) \<supseteq> (\<tau> ^^(i + 1))({})"}
can be inferred from
@{term "\<not>((\<tau> ^^ i)({}) \<subseteq> (\<tau> ^^(i + 1))({}))"}
and (1).
Finally, the latter is solved directly by @{text \<open>no_infinite_subset_chain\<close>}.\<close>
proof -
  have a: "\<forall>i. (\<tau> ^^ i) ({}:: 'a set) \<subseteq> (\<tau> ^^ (i + (1))) {}"
    by(rule predtrans_empty, rule assms(2))
  have a3: "\<not> (\<forall> i :: nat. (\<tau> ^^ i) {} \<subset> (\<tau> ^^(i + 1)) {})"
    by (rule notI, rule no_infinite_subset_chain, (rule assms)+)
  hence b: "(\<exists> i :: nat. \<not>((\<tau> ^^ i) {} \<subset> (\<tau> ^^(i + 1)) {}))" using assms a3
    by blast
  thus "\<exists> i. (\<tau> ^^ i) ({}) = (\<tau> ^^(i + 1))({})" using a
    by blast
qed

lemma predtrans_UNIV:
  assumes "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
  shows "\<forall> i. (\<tau> ^^ i) (UNIV) \<supseteq> (\<tau> ^^(i + 1))(UNIV)"
proof (rule allI, induct_tac i)
  show "(\<tau> ^^ ((0) + (1))) UNIV \<subseteq> (\<tau> ^^ (0)) UNIV"
    by simp
next show "\<And>(i) n.
       (\<tau> ^^ (n + (1))) UNIV \<subseteq> (\<tau> ^^ n) UNIV \<Longrightarrow> (\<tau> ^^ (Suc n + (1))) UNIV \<subseteq> (\<tau> ^^ Suc n) UNIV"
  proof -
    fix i n
    assume a: "(\<tau> ^^ (n + (1))) UNIV \<subseteq> (\<tau> ^^ n) UNIV"
    have "(\<tau> ((\<tau> ^^ n) UNIV)) \<supseteq> (\<tau> ((\<tau> ^^ (n + (1 :: nat))) UNIV))" using assms a
      by (rule monoE)
    thus "(\<tau> ^^ (Suc n + (1))) UNIV \<subseteq> (\<tau> ^^ Suc n) UNIV" by simp
   qed
 qed

lemma card_univ_subtract:
  assumes "finite (UNIV :: 'a set)" and  "mono \<tau>"
     and  "(\<forall>i :: nat. ((\<tau> :: 'a set \<Rightarrow> 'a set) ^^ (i + (1 :: nat)))(UNIV :: 'a set) \<subset> (\<tau> ^^ i) UNIV)"
   shows "(\<forall> i :: nat. card((\<tau> ^^ i) (UNIV ::'a set)) \<le> (card (UNIV :: 'a set)) - i)"
proof (rule allI, induct_tac i)
  show "card ((\<tau> ^^ (0)) UNIV) \<le> card (UNIV :: 'a set) - (0)" using assms
    by (simp)
next show "\<And>(i) n.
       card ((\<tau> ^^ n) (UNIV :: 'a set)) \<le> card (UNIV :: 'a set) - n \<Longrightarrow>
       card ((\<tau> ^^ Suc n) (UNIV :: 'a set)) \<le> card (UNIV :: 'a set) - Suc n" using assms
  proof -
    fix i n
    assume a: "card ((\<tau> ^^ n) (UNIV :: 'a set)) \<le> card (UNIV :: 'a set) - n"
    have b: "(\<tau> ^^ (n + (1)))(UNIV :: 'a set) \<subset> (\<tau> ^^ n) UNIV" using assms
      by (erule_tac x = n in spec)
    have "card((\<tau> ^^ (n + (1 :: nat)))(UNIV :: 'a set)) < card((\<tau> ^^ n) (UNIV :: 'a set))"
      by (rule psubset_card_mono, rule finite_subset, rule subset_UNIV, rule assms(1), rule b)
    thus "card ((\<tau> ^^ Suc n) (UNIV :: 'a set)) \<le> card (UNIV :: 'a set) - Suc n" using a
      by simp
    qed
  qed

lemma card_UNIV_tau_i_below_zero:
  assumes "finite (UNIV :: 'a set)" and "mono \<tau>"
   and  "(\<forall>i :: nat. ((\<tau> :: ('a set \<Rightarrow> 'a set)) ^^ (i + (1 :: nat)))(UNIV :: 'a set) \<subset> (\<tau> ^^ i) UNIV)"
 shows "card((\<tau> ^^ (card (UNIV ::'a set))) (UNIV ::'a set)) \<le> 0"
proof -
  have "(\<forall> i :: nat. card((\<tau> ^^ i) (UNIV ::'a set)) \<le> (card (UNIV :: 'a set)) - i)" using assms
    by (rule card_univ_subtract)
  thus "card((\<tau> ^^ (card (UNIV ::'a set))) (UNIV ::'a set)) \<le> 0"
   by (drule_tac x = "card (UNIV ::'a set)" in spec, simp)
qed

lemma finite_card_zero_empty: "\<lbrakk> finite S; card S \<le> 0\<rbrakk> \<Longrightarrow> S = {}"
by simp

lemma UNIV_tau_i_is_empty:
  assumes "finite (UNIV :: 'a set)" and "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
    and   "(\<forall>i :: nat. ((\<tau> :: 'a set \<Rightarrow> 'a set) ^^ (i + (1 :: nat)))(UNIV :: 'a set) \<subset> (\<tau> ^^ i) UNIV)"
  shows "(\<tau> ^^ (card (UNIV ::'a set))) (UNIV ::'a set) = {}"
  by (meson assms card_UNIV_tau_i_below_zero finite_card_zero_empty finite_subset subset_UNIV)

lemma down_chain_reaches_empty:
  assumes "finite (UNIV :: 'a set)" and "mono (\<tau> :: 'a set \<Rightarrow> 'a set)"
   and "(\<forall>i :: nat. ((\<tau> :: 'a set \<Rightarrow> 'a set) ^^ (i + (1 :: nat))) UNIV \<subset> (\<tau> ^^ i) UNIV)"
 shows "\<exists> (j :: nat). (\<tau> ^^ j) UNIV = {}"
  using UNIV_tau_i_is_empty assms by blast

lemma no_infinite_subset_chain2:
  assumes "finite (UNIV :: 'a set)" and "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
      and "\<forall>i :: nat. (\<tau> ^^ i) UNIV \<supset> (\<tau> ^^ (i + (1 :: nat))) UNIV"
  shows "False"
proof -
  have "\<exists> j :: nat. (\<tau> ^^ j) UNIV = {}" using assms
    by (rule down_chain_reaches_empty)
  from this obtain j where a: "(\<tau> ^^ j) UNIV = {}" by (erule exE)
  have "(\<tau> ^^ (j + (1))) UNIV \<subset> (\<tau> ^^ j) UNIV" using assms
    by (erule_tac x = j in spec)
  thus False using a by simp
qed

lemma finite_fixp2:
  assumes "finite(UNIV :: 'a set)" and "mono (\<tau> :: ('a set \<Rightarrow> 'a set))"
  shows "\<exists> i. (\<tau> ^^ i) UNIV = (\<tau> ^^(i + 1)) UNIV"
proof -
  have "\<forall>i. (\<tau> ^^ (i + (1))) UNIV \<subseteq> (\<tau> ^^ i) UNIV"
    by (rule predtrans_UNIV , simp add: assms(2))
  moreover have "\<exists>i. \<not> (\<tau> ^^ (i + (1))) UNIV \<subset> (\<tau> ^^ i) UNIV" using assms
  proof -
    have "\<not> (\<forall> i :: nat. (\<tau> ^^ i) UNIV \<supset> (\<tau> ^^(i + 1)) UNIV)"
      using assms(1) assms(2) no_infinite_subset_chain2 by blast
    thus "\<exists>i. \<not> (\<tau> ^^ (i + (1))) UNIV \<subset> (\<tau> ^^ i) UNIV" by blast
  qed
  ultimately show "\<exists> i. (\<tau> ^^ i) UNIV = (\<tau> ^^(i + 1)) UNIV"
    by blast
qed

lemma lfp_loop:
  assumes "finite (UNIV :: 'b set)" and "mono (\<tau> :: ('b set \<Rightarrow> 'b set))"
  shows "\<exists> n . lfp \<tau>  = (\<tau> ^^ n) {}"
proof -
  have "\<exists>i. (\<tau> ^^ i) {} = (\<tau> ^^ (i + (1))) {}"  using assms
    by (rule finite_fixp)
  from this obtain i where " (\<tau> ^^ i) {} = (\<tau> ^^ (i + (1))) {}"
    by (erule exE)
  hence "(\<tau> ^^ i) {} = (\<tau> ^^ Suc i) {}"
    by simp
  hence "(\<tau> ^^ Suc i) {} = (\<tau> ^^ i) {}"
    by (rule sym)
  hence "lfp \<tau> = (\<tau> ^^ i) {}"
     by (simp add: assms(2) lfp_Kleene_iter)
   thus "\<exists> n . lfp \<tau>  = (\<tau> ^^ n) {}"
   by (rule exI)
qed

text \<open>These next two are repeated from the corresponding
   theorems in HOL/ZF/Nat.thy for the sake of self-containedness of the exposition.\<close>
lemma Kleene_iter_gpfp:
  assumes "mono f" and "p \<le> f p" shows "p \<le> (f^^k) (top::'a::order_top)"
proof(induction k)
  case 0 show ?case by simp
next
  case Suc
  from monoD[OF assms(1) Suc] assms(2)
  show ?case by simp
qed

subsection \<open>Generic type of state with state transition and CTL operators\<close>
text \<open>The system states and their transition relation are defined as a class called
 @{text \<open>state\<close>} containing an abstract constant@{text \<open>state_transition\<close>}. It introduces the
syntactic infix notation @{text \<open>I \<rightarrow>\<^sub>i I'\<close>} to denote that system state @{text \<open>I\<close>} and @{text \<open>I’\<close>}
are in this relation over an arbitrary (polymorphic) type @{text \<open>'a\<close>}.\<close>
class state =
  fixes state_transition :: "['a :: type, 'a] \<Rightarrow> bool"  (infixr "\<rightarrow>\<^sub>i" 50)

text \<open>The above class definition lifts Kripke structures and CTL to a general level.
The definition of the inductive relation is given by a set of specific rules which are,
however, part of an application like infrastructures. Branching time temporal logic CTL
is defined in general over Kripke structures with arbitrary state transitions and can later
be applied to suitable theories, like infrastructures.
Based on the generic state transition @{text \<open>\<rightarrow>\<close>} of the type class state, the CTL-operators
EX and AX express that property f holds in some or all next states, respectively.\<close>

definition AX where "AX f \<equiv> {s. {f0. s \<rightarrow>\<^sub>i f0} \<subseteq> f}"
definition EX' where "EX' f \<equiv> {s . \<exists> f0 \<in> f. s \<rightarrow>\<^sub>i f0 }"

text \<open>The CTL formula @{text \<open>AG f\<close>} means that on all paths branching from a state @{text \<open>s\<close>}
the formula @{text \<open>f\<close>} is always true (@{text \<open>G\<close>} stands for ‘globally’). It can be defined
using the Tarski fixpoint theory by applying the greatest fixpoint operator. In a similar way,
the other CTL operators are defined.\<close>
definition AF where "AF f \<equiv> lfp (\<lambda> Z. f \<union> AX Z)"
definition EF where "EF f \<equiv> lfp (\<lambda> Z. f \<union> EX' Z)"
definition AG where "AG f \<equiv> gfp (\<lambda> Z. f \<inter> AX Z)"
definition EG where "EG f \<equiv> gfp (\<lambda> Z. f \<inter> EX' Z)"
definition AU where "AU f1 f2 \<equiv> lfp(\<lambda> Z. f2 \<union> (f1 \<inter> AX Z))"
definition EU where "EU f1 f2 \<equiv> lfp(\<lambda> Z. f2 \<union> (f1 \<inter> EX' Z))"
definition AR where "AR f1 f2 \<equiv> gfp(\<lambda> Z. f2 \<inter> (f1 \<union> AX Z))"
definition ER where "ER f1 f2 \<equiv> gfp(\<lambda> Z. f2 \<inter> (f1 \<union> EX' Z))"

subsection  \<open>Kripke structures and Modelchecking\<close>
datatype 'a kripke =
  Kripke "'a set" "'a set"

primrec states where "states (Kripke S I) = S"
primrec init where "init (Kripke S I) = I"

text \<open>The formal Isabelle definition of what it means that formula f holds
in a Kripke structure M can be stated as: the initial states of the Kripke
structure init M need to be contained in the set of all states states M that
imply f.\<close>
definition check ("_ \<turnstile> _" 50)
 where "M \<turnstile> f \<equiv> (init M) \<subseteq> {s \<in> (states M). s \<in> f }"

definition state_transition_refl (infixr "\<rightarrow>\<^sub>i*" 50)
where "s \<rightarrow>\<^sub>i* s' \<equiv> ((s,s') \<in> {(x,y). state_transition x y}\<^sup>*)"

subsection \<open>Lemmas for CTL operators\<close>

subsubsection \<open>EF lemmas\<close>
lemma EF_lem0: "(x \<in> EF f) = (x \<in> f \<union> EX' (lfp (\<lambda>Z :: ('a :: state) set. f \<union> EX' Z)))"
proof -
  have "lfp (\<lambda>Z :: ('a :: state) set. f \<union> EX' Z) =
                    f \<union> (EX' (lfp (\<lambda>Z :: 'a set. f \<union> EX' Z)))"
    by (rule def_lfp_unfold, rule reflexive, unfold mono_def EX'_def, auto)
  thus "(x \<in> EF (f :: ('a :: state) set)) = (x \<in> f \<union> EX' (lfp (\<lambda>Z :: ('a :: state) set. f \<union> EX' Z)))"
    by (simp add: EF_def)
qed

lemma EF_lem00: "(EF f) = (f \<union> EX' (lfp (\<lambda> Z :: ('a :: state) set. f \<union> EX' Z)))"
  by (auto simp: EF_lem0)

lemma EF_lem000: "(EF f) = (f \<union> EX' (EF f))"
  by (metis EF_def EF_lem00)

lemma EF_lem1: "x \<in> f \<or> x \<in> (EX' (EF f)) \<Longrightarrow> x \<in> EF f"
proof (simp add: EF_def)
  assume a: "x \<in> f \<or> x \<in> EX' (lfp (\<lambda>Z::'a set. f \<union> EX' Z))"
  show "x \<in> lfp (\<lambda>Z::'a set. f \<union> EX' Z)"
  proof -
    have b: "lfp (\<lambda>Z :: ('a :: state) set. f \<union> EX' Z) =
                    f \<union> (EX' (lfp (\<lambda>Z :: ('a :: state) set. f \<union> EX' Z)))"
      using EF_def EF_lem00 by blast
    thus "x \<in> lfp (\<lambda>Z::'a set. f \<union> EX' Z)" using a
      by (subst b, blast)
  qed
qed

lemma EF_lem2b:
  assumes "x \<in> (EX' (EF f))"
  shows "x \<in> EF f"
  by (simp add: EF_lem1 assms)

lemma EF_lem2a: assumes "x \<in> f" shows "x \<in> EF f"
  by (simp add: EF_lem1 assms)

lemma EF_lem2c: assumes "x \<notin> f" shows "x \<in> EF (- f)"
  by (simp add: EF_lem1 assms)

lemma EF_lem2d: assumes "x \<notin> EF f" shows "x \<notin> f"
  using EF_lem1 assms by auto

lemma EF_lem3b: assumes "x \<in> EX' (f \<union> EX' (EF f))" shows "x \<in> (EF f)"
  by (metis EF_lem000 EF_lem2b assms)

lemma EX_lem0l: "x \<in> (EX' f) \<Longrightarrow> x \<in> (EX' (f \<union> g))"
  by (auto simp: EX'_def)

lemma EX_lem0r: "x \<in> (EX' g) \<Longrightarrow> x \<in> (EX' (f \<union> g))"
  by (auto simp: EX'_def)

lemma EX_step: assumes "x  \<rightarrow>\<^sub>i y" and "y \<in> f" shows "x \<in> EX' f"
  using assms by (auto simp: EX'_def)

lemma EF_step: assumes "x  \<rightarrow>\<^sub>i y" and "y \<in> f" shows "x \<in> EF f"
  using EF_lem3b EX_step assms by blast

lemma EF_step_step: assumes "x  \<rightarrow>\<^sub>i y" and "y \<in> EF f" shows  "x \<in> EF f"
  using EF_lem2b EX_step assms by blast

lemma EF_step_star: "\<lbrakk> x  \<rightarrow>\<^sub>i* y; y \<in> f \<rbrakk> \<Longrightarrow> x \<in> EF f"
proof (simp add: state_transition_refl_def)
  show "(x, y) \<in> {(x::'a, y::'a). x \<rightarrow>\<^sub>i y}\<^sup>* \<Longrightarrow> y \<in> f \<Longrightarrow> x \<in> EF f"
  proof (erule converse_rtrancl_induct)
    show "y \<in> f \<Longrightarrow> y \<in> EF f"
      by (erule EF_lem2a)
    next show "\<And>ya z::'a. y \<in> f \<Longrightarrow>
                 (ya, z) \<in> {(x,y). x \<rightarrow>\<^sub>i y} \<Longrightarrow>
                 (z, y) \<in> {(x,y). x \<rightarrow>\<^sub>i y}\<^sup>* \<Longrightarrow> z \<in> EF f \<Longrightarrow> ya \<in> EF f"
        by (simp add: EF_step_step)
    qed
  qed

lemma EF_induct: "(a::'a::state) \<in> EF f \<Longrightarrow>
    mono (\<lambda> Z. f \<union> EX' Z) \<Longrightarrow>
    (\<And>x. x \<in> ((\<lambda> Z. f \<union> EX' Z)(EF f \<inter> {x::'a::state. P x})) \<Longrightarrow> P x) \<Longrightarrow>
    P a"
  by (metis (mono_tags, lifting) EF_def def_lfp_induct_set)

lemma valEF_E: "M \<turnstile> EF f \<Longrightarrow> x \<in> init M \<Longrightarrow> x \<in> EF f"
  by (auto simp: check_def)

lemma EF_step_star_rev[rule_format]: "x \<in> EF s \<Longrightarrow>  (\<exists> y \<in> s.  x  \<rightarrow>\<^sub>i* y)"
proof (erule EF_induct)
  show "mono (\<lambda>Z::'a set. s \<union> EX' Z)"
    by (force simp add: mono_def EX'_def)
next show "\<And>x::'a. x \<in> s \<union> EX' (EF s \<inter> {x::'a. \<exists>y::'a\<in>s. x \<rightarrow>\<^sub>i* y}) \<Longrightarrow> \<exists>y::'a\<in>s. x \<rightarrow>\<^sub>i* y"
    apply (erule UnE)
    using state_transition_refl_def apply auto[1]
    by (auto simp add: EX'_def state_transition_refl_def intro: converse_rtrancl_into_rtrancl)
qed

lemma EF_step_inv: "(I \<subseteq> {sa::'s :: state. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF s})
         \<Longrightarrow> \<forall> x \<in> I. \<exists> y \<in> s. x \<rightarrow>\<^sub>i* y"
  using EF_step_star_rev by fastforce

subsubsection \<open>AG lemmas\<close>

lemma AG_in_lem:   "x \<in> AG s \<Longrightarrow> x \<in> s"
  by (auto simp add: AG_def gfp_def)

lemma AG_lem1: "x \<in> s \<and> x \<in> (AX (AG s)) \<Longrightarrow> x \<in> AG s"
proof (simp add: AG_def)
  have "gfp (\<lambda>Z::'a set. s \<inter> AX Z) = s \<inter> (AX (gfp (\<lambda>Z::'a set. s \<inter> AX Z)))"
    by (rule def_gfp_unfold) (auto simp: mono_def AX_def)
  then show "x \<in> s \<and> x \<in> AX (gfp (\<lambda>Z::'a set. s \<inter> AX Z)) \<Longrightarrow> x \<in> gfp (\<lambda>Z::'a set. s \<inter> AX Z)"
    by blast
qed

lemma AG_lem2: "x \<in> AG s \<Longrightarrow> x \<in> (s \<inter> (AX (AG s)))"
proof -
  have a: "AG s = s \<inter> (AX (AG s))"
    unfolding AG_def
    by (rule def_gfp_unfold) (auto simp: mono_def AX_def)
  thus "x \<in> AG s \<Longrightarrow> x \<in> (s \<inter> (AX (AG s)))"
   by (erule subst)
qed

lemma AG_lem3: "AG s = (s \<inter> (AX (AG s)))"
  using AG_lem1 AG_lem2 by blast

lemma AG_step: "y \<rightarrow>\<^sub>i z \<Longrightarrow> y \<in> AG s \<Longrightarrow> z \<in> AG s"
  using AG_lem2 AX_def by blast

lemma AG_all_s: " x \<rightarrow>\<^sub>i* y \<Longrightarrow> x \<in> AG s \<Longrightarrow> y \<in> AG s"
proof (simp add: state_transition_refl_def)
  show "(x, y) \<in> {(x,y). x \<rightarrow>\<^sub>i y}\<^sup>* \<Longrightarrow> x \<in> AG s \<Longrightarrow> y \<in> AG s"
    by (erule rtrancl_induct) (auto simp add: AG_step)
qed

lemma AG_imp_notnotEF:
"I \<noteq> {} \<Longrightarrow> ((Kripke {s. \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s)} I  \<turnstile> AG s)) \<Longrightarrow>
 (\<not>(Kripke {s. \<exists> i \<in> I. (i \<rightarrow>\<^sub>i* s)} (I :: ('s :: state)set)  \<turnstile> EF (- s)))"
proof (rule notI, simp add: check_def)
  assume a0: "I \<noteq> {}" and
    a1: "I \<subseteq> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s}" and
    a2: "I \<subseteq> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)}"
  show "False"
  proof -
    have a3: "{sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s} \<inter>
                        {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)} = {}"
      proof -
        have "(? x. x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s} \<and>
                           x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)}) \<Longrightarrow> False"
        proof -
          assume a4: "(? x. x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s} \<and>
                           x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)})"
            from a4 obtain x where  a5: "x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s} \<and>
                                   x \<in> {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)}"
            by (erule exE)
            thus "False"
              by (metis (mono_tags, lifting) AG_all_s AG_in_lem ComplD EF_step_star_rev a5 mem_Collect_eq)
          qed
        thus "{sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> AG s} \<inter>
                        {sa::'s. (\<exists>i\<in>I. i \<rightarrow>\<^sub>i* sa) \<and> sa \<in> EF (- s)} = {}"
        by blast
      qed
    moreover have b: "? x. x : I" using a0
      by blast
    moreover obtain x where "x \<in> I"
      using b by blast
    ultimately show "False" using a0 a1 a2
      by blast
  qed
qed

text \<open>A simplified way of Modelchecking is given by the following lemma.\<close>
lemma check2_def: "(Kripke S I \<turnstile> f) = (I \<subseteq> S \<inter> f)"
  by (auto simp add: check_def)

end