(*  Title:       Executable Transitive Closures
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2012 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* A work-list algorithm for reflexive-transitive closures *}

theory RTrancl
imports "../Regular-Sets/Regexp_Method"
begin

text {* In previous work \cite{rtrancl_fin} we described a generic work-list
algorithm to compute reflexive-transitive closures for \emph{finite} relations:
given a finite relation $r$, it computed $@{term "r^*"}$.

In the following, we develop a similar, though different work-list algorithm
for reflexive-transitive closures, it computes @{term "r^* `` init"} for a given
relation $r$ and finite set @{term "init"}.
The main differences are that
\begin{itemize}
\item The relation $r$ does not have to be finite, only @{term "{b. (a,b) \<in> r^* }"} has to be finite
  for each $a$. Moreover, it is no longer required that $r$ is given
  explicitly as a list of pairs.
 Instead $r$ must be provided in the form of a function which computes
  for each element the
  set of one-step successors.
\item One can use a subsumption relation to indicate which elements to no longer
  have to be explored.
\end{itemize}

These new features have been essential to certify size-change termination
proofs \cite{sct} where the transitive closure of all size-change graphs
has to be computed. Here, the relation is size-change graph composition.
\begin{itemize}
\item Given an initial set of size-change graphs with $n$ arguments,
  there are roughly $N := 3^{n^2}$ many potential size-change graphs that
  have to be considered as left-hand sides of the composition relation.
  Since the composition relation is even larger than $N$,
  an explicit representation of the composition relation would have been
  too expensive. However, using the new algorithm the number of generated
  graphs is usually far below the theoretical upper bound.
\item Subsumption was useful to generate even fewer elements.
\end{itemize}

*}

subsection {* The generic case *}

text {*
  Let $r$ be some finite relation.

  We present a standard work-list algorithm to compute all elements
  that are reachable from some initial set.
  The algorithm is generic in the sense that the
  underlying data structure can freely be chosen, you just have to provide
  certain operations like union, selection of an element.

  In contrast to \cite{rtrancl_fin}, the algorithm does not demand that $r$ is finite
  and that $r$ is explicitly provided (e.g., as a list of pairs).
  Instead, it suffices that for every element, only finitely many
  elements can be reached via $r$, and $r$ can be provided as a function which
  computes for every element $a$ all one-step successors w.r.t.\ $r$.
  Hence, $r$ can in particular be any
  well-founded and finitely branching relation.

  The algorithm can further be parametrized by a subsumption relation
  which allows for early pruning.
*}

text {* In the following locales, $r$ is a relation of type @{typ "'a \<Rightarrow> 'a"},
  the successors of an element are represented by some collection
  type @{typ 'b} which size can be measured using the @{term size} function.
  The selection function @{term sel} is used to meant to split a non-empty
  collection into one element and a remaining collection. The union on
  @{typ 'b} is given by @{term un}.
*}

locale subsumption =
  fixes r :: "'a \<Rightarrow> 'b"
   and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   and set_of :: "'b \<Rightarrow> 'a set"
  assumes
       subsumes_refl: "\<And> a. subsumes a a"
   and subsumes_trans: "\<And> a b c. subsumes a b \<Longrightarrow> subsumes b c \<Longrightarrow> subsumes a c"
   and subsumes_step: "\<And> a b c. subsumes a b \<Longrightarrow> c \<in> set_of (r b) \<Longrightarrow> \<exists> d \<in> set_of (r a). subsumes d c"
begin
abbreviation R where "R \<equiv> { (a,b). b \<in> set_of (r a) }"
end

locale subsumption_impl = subsumption r subsumes set_of
  for r :: "'a \<Rightarrow> 'b"
  and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and set_of :: "'b \<Rightarrow> 'a set" +
  fixes
      sel :: "'b \<Rightarrow> 'a \<times> 'b"
   and un :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
   and size :: "'b \<Rightarrow> nat"
  assumes set_of_fin: "\<And> b. finite (set_of b)"
   and sel: "\<And> b a c. set_of b \<noteq> {} \<Longrightarrow> sel b = (a,c) \<Longrightarrow> set_of b = insert a (set_of c) \<and> size b > size c"
   and un: "set_of (un a b) = set_of a \<union> set_of b"

locale relation_subsumption_impl = subsumption_impl r subsumes set_of sel un size
  for r subsumes set_of sel un size +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set_of (r a)}^*}"
begin

lemma finite_Rs: assumes init: "finite init"
  shows "finite (R^* `` init)"
proof -
  let ?R = "\<lambda> a. {b . (a,b) \<in> R^*}"
  let ?S = "{ ?R a | a . a \<in> init}"
  have id: "R^* `` init = \<Union> ?S" by auto
  show ?thesis unfolding id
  proof (rule)
    fix M
    assume "M \<in> ?S"
    then obtain a where M: "M = ?R a" by auto
    show "finite M" unfolding M by (rule rtrancl_fin)
  next
    show "finite {{b. (a, b) \<in> R^*} | a. a \<in> init}"
      using init by auto
  qed
qed

text {* a standard work-list algorithm with subsumption *}
function mk_rtrancl_main where
  "mk_rtrancl_main todo fin = (if set_of todo = {} then fin
      else (let (a,tod) = sel todo
             in (if (\<exists> b \<in> fin. subsumes b a) then mk_rtrancl_main tod fin
                 else mk_rtrancl_main (un (r a) tod) (insert a fin))))"
  by pat_completeness auto

termination mk_rtrancl_main
proof -
  let ?r1 = "\<lambda> (todo, fin). card (R^* `` (set_of todo) - fin)"
  let ?r2 = "\<lambda> (todo, fin). size todo"
  show ?thesis
  proof
    show "wf (measures [?r1,?r2])" by simp
  next
    fix todo fin pair tod a
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by simp
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((tod,fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_lesseq[OF _ measures_less], unfold split)
      from sel
      show "size tod < size todo" by simp
    next
      from sel have subset: "R^* `` set_of tod - fin \<subseteq> R^* `` set_of todo - fin" (is "?l \<subseteq> ?r") by auto
      show "card ?l \<le> card ?r"
        by (rule card_mono[OF _ subset], rule finite_Diff, rule finite_Rs[OF fin])
    qed
  next
    fix todo fin a tod pair
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair" and nmem: "\<not> (\<exists> b \<in> fin. subsumes b a)"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by auto
    from nmem subsumes_refl[of a] have nmem: "a \<notin> fin" by auto
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((un (r a) tod,insert a fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_less, unfold split,
        rule psubset_card_mono[OF finite_Diff[OF finite_Rs[OF fin]]])
      let ?l = "R^* `` set_of (un (r a) tod) - insert a fin"
      let ?r = "R^* `` set_of todo - fin"
      from sel have at: "a \<in> set_of todo" by auto
      have ar: "a \<in> ?r" using nmem at by auto
      show "?l \<subset> ?r"
      proof
        show "?l \<noteq> ?r" using ar by auto
      next
        have "R^* `` set_of (r a) \<subseteq> R^* `` set_of todo"
        proof
          fix b
          assume "b \<in> R^* `` set_of (r a)"
          then obtain c where cb: "(c,b) \<in> R^*" and ca: "c \<in> set_of (r a)" by blast
          hence ab: "(a,b) \<in> R O R^*" by auto
          have "(a,b) \<in> R^*"
            by (rule set_mp[OF _ ab], regexp)
          with at show "b \<in> R^* `` set_of todo" by auto
        qed
        thus "?l \<subseteq> ?r" using sel unfolding un by auto
      qed
    qed
  qed
qed

declare mk_rtrancl_main.simps[simp del]

lemma mk_rtrancl_main_sound: "set_of todo \<union> fin \<subseteq> R^* `` init \<Longrightarrow> mk_rtrancl_main todo fin \<subseteq> R^* `` init"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    show ?thesis unfolding simp using True 1(3) by auto
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by auto
    obtain a tod where selt: "sel todo = (a,tod)" by force
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric]]
    note IH2 = 1(2)[OF False refl selt[symmetric]]
    note simp = simp nempty if_False Let_def selt
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      hence "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      with IH1[OF True] 1(3) show ?thesis using sel by auto
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r a) tod) (insert a fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        from sel 1(3) have subset: "set_of todo \<union> insert a fin \<subseteq> R^* `` init" by auto
        {
          fix b
          assume b: "b \<in> set_of (r a)"
          hence ab: "(a,b) \<in> R" by auto
          from sel 1(3) have "a \<in> R^* `` init" by auto
          then obtain c where c: "c \<in> init" and ca: "(c,a) \<in> R^*" by blast
          from ca ab have cb: "(c,b) \<in> R^* O R" by auto
          have "(c,b) \<in> R^*"
            by (rule set_mp[OF _ cb], regexp)
          with c have "b \<in> R^* `` init" by auto
        }
        with subset
        show "set_of (un (r a) tod) \<union> (insert a fin) \<subseteq> R^* `` init"
          unfolding un using sel by auto
      qed
    qed
  qed
qed

lemma mk_rtrancl_main_complete:
  "\<lbrakk>\<And> a. a \<in> init \<Longrightarrow> \<exists> b. b \<in> set_of todo \<union> fin \<and> subsumes b a\<rbrakk>
  \<Longrightarrow> \<lbrakk> \<And> a b . a \<in> fin \<Longrightarrow> b \<in> set_of (r a) \<Longrightarrow> \<exists> c. c \<in> set_of todo \<union> fin \<and> subsumes c b\<rbrakk>
  \<Longrightarrow> c \<in> R^* `` init
  \<Longrightarrow> \<exists> b. b \<in> mk_rtrancl_main todo fin \<and> subsumes b c"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  from 1(5) have c: "c \<in> R^* `` init" .
  note finr = 1(4)
  note init = 1(3)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    hence id: "mk_rtrancl_main todo fin = fin" unfolding simp by simp
    from c obtain a where a: "a \<in> init" and ac: "(a,c) \<in> R^*" by blast
    show ?thesis unfolding id using ac
    proof (induct rule: rtrancl_induct)
      case base
      from init[OF a] show ?case unfolding True by auto
    next
      case (step b c)
      from step(3) obtain d where d: "d \<in> fin" and db: "subsumes d b" by auto
      from step(2) have cb: "c \<in> set_of (r b)" by auto
      from subsumes_step[OF db cb] obtain a where a: "a \<in> set_of (r d)" and ac: "subsumes a c" by auto
      from finr[OF d a] obtain e where e: "e \<in> fin" and ea: "subsumes e a" unfolding True by auto
      from subsumes_trans[OF ea ac] e
      show ?case by auto
    qed
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by simp
    obtain A tod where selt: "sel todo = (A,tod)" by force
    note simp = nempty simp if_False Let_def selt
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric] _ _ _ c]
    note IH2 = 1(2)[OF False refl selt[symmetric] _ _ _ c]
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b A")
      case True note oTrue = this
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      from True obtain b where b: "b \<in> fin" and ba: "subsumes b A" by auto
      show ?thesis unfolding id
      proof (rule IH1[OF True])
        fix a
        assume a: "a \<in> init"
        from init[OF a] obtain c where c: "c \<in> set_of todo \<union> fin" and ca: "subsumes c a" by blast
        show "\<exists> b. b \<in> set_of tod \<union> fin \<and> subsumes b a"
        proof (cases "c = A")
          case False
          thus ?thesis using c ca sel by auto
        next
          case True
          show ?thesis using b subsumes_trans[OF ba, of a] ca unfolding True[symmetric] by auto
        qed
      next
        fix a c
        assume a: "a \<in> fin" and c: "c \<in> set_of (r a)"
        from finr[OF a c] obtain e where e: "e \<in> set_of todo \<union> fin" and ec: "subsumes e c" by auto
        show "\<exists> d. d \<in> set_of tod \<union> fin \<and> subsumes d c"
        proof (cases "A = e")
          case False
          with e ec show ?thesis using sel by auto
        next
          case True
          from subsumes_trans[OF ba[unfolded True] ec]
          show ?thesis using b by auto
        qed
      qed
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r A) tod) (insert A fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        fix a
        assume a: "a \<in> init"
        from init[OF a]
        show "\<exists> b. b \<in> set_of (un (r A) (tod)) \<union> insert A fin \<and> subsumes b a"
          using sel unfolding un by auto
      next
        fix a b
        assume a: "a \<in> insert A fin" and b: "b \<in> set_of (r a)"
        show "\<exists> c. c \<in> set_of (un (r A) tod) \<union> insert A fin \<and> subsumes c b"
        proof (cases "a \<in> fin")
          case True
          from finr[OF True b] show ?thesis using sel unfolding un by auto
        next
          case False
          with a have a: "A = a" by simp
          show ?thesis unfolding a un using b subsumes_refl[of b] by blast
        qed
      qed
    qed
  qed
qed

definition mk_rtrancl where "mk_rtrancl init \<equiv> mk_rtrancl_main init {}"

lemma mk_rtrancl_complete: assumes a: "a \<in> R^* `` set_of init"
  shows "\<exists> b. b \<in> mk_rtrancl init \<and> subsumes b a"
  unfolding mk_rtrancl_def
proof (rule mk_rtrancl_main_complete[OF _ _ a])
  fix a
  assume a: "a \<in> set_of init"
  thus "\<exists> b. b \<in> set_of init \<union> {} \<and> subsumes b a" using subsumes_refl[of a] by blast
qed auto

lemma mk_rtrancl_no_subsumption: assumes "subsumes = (op =)"
  shows "mk_rtrancl init = R^* `` set_of init"
  using mk_rtrancl_sound[of init] mk_rtrancl_complete[of _ init] assms
  by auto
end

subsection {* Instantiation using list operations *}

text {* It follows an implementation based on lists.
 Here, the working list algorithm is implemented outside the locale so that
 it can be used for code generation. In general, it is not terminating,
 therefore we use partial\_function instead of function. *}

partial_function(tailrec) mk_rtrancl_list_main where
 [code]:  "mk_rtrancl_list_main subsumes r todo fin = (case todo of [] \<Rightarrow> fin
     | Cons a tod \<Rightarrow>
             (if (\<exists> b \<in> set fin. subsumes b a) then mk_rtrancl_list_main subsumes r tod fin
                 else mk_rtrancl_list_main subsumes r (r a @ tod) (a # fin)))"

definition mk_rtrancl_list where
  "mk_rtrancl_list subsumes r init \<equiv> mk_rtrancl_list_main subsumes r init []"

locale subsumption_list = subsumption r subsumes set
  for r :: "'a \<Rightarrow> 'a list" and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

locale relation_subsumption_list = subsumption_list r subsumes for r subsumes +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set (r a)}^*}"

abbreviation(input) sel_list where "sel_list x \<equiv> case x of Cons h t \<Rightarrow> (h,t)"

sublocale subsumption_list \<subseteq> subsumption_impl r subsumes set sel_list append length
proof(unfold_locales, rule finite_set)
  fix b a c
  assume "set b \<noteq> {}" and "sel_list b = (a,c)"
  thus "set b = insert a (set c) \<and> length c < length b"
    by (cases b, auto)
qed auto

sublocale relation_subsumption_list \<subseteq> relation_subsumption_impl r subsumes set sel_list append length
  by (unfold_locales, rule rtrancl_fin)

context relation_subsumption_list
begin

text {* The main equivalence proof between the generic work list algorithm
and the one operating on lists *}
lemma mk_rtrancl_list_main: "fin = set finl \<Longrightarrow> set (mk_rtrancl_list_main subsumes r todo finl) = mk_rtrancl_main todo fin"
proof (induct todo fin arbitrary: finl rule: mk_rtrancl_main.induct)
  case (1 todo fin finl)
  note simp = mk_rtrancl_list_main.simps[of _ _ todo finl] mk_rtrancl_main.simps[of todo fin]
  show ?case (is "?l = ?r")
  proof (cases todo)
    case Nil
    show ?thesis unfolding simp unfolding Nil 1(3) by simp
  next
    case (Cons a tod)
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      from True have l: "?l = set (mk_rtrancl_list_main subsumes r tod finl)"
        unfolding simp unfolding Cons 1(3) by simp
      from True have r: "?r = mk_rtrancl_main tod fin"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(1)[OF _ refl _ True], insert 1(3) Cons, auto)
    next
      case False
      from False have l: "?l = set (mk_rtrancl_list_main subsumes r (r a @ tod) (a # finl))"
        unfolding simp unfolding Cons 1(3) by simp
      from False have r: "?r = mk_rtrancl_main (r a @ tod) (insert a fin)"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(2)[OF _ refl _ False], insert 1(3) Cons, auto)
    qed
  qed
qed

lemma mk_rtrancl_list: "set (mk_rtrancl_list subsumes r init) = mk_rtrancl init"
  unfolding mk_rtrancl_list_def mk_rtrancl_def
  by (rule mk_rtrancl_list_main, simp)

end

end


theory Simulation_Graphs_Certification2
  imports
    Certification.Simulation_Graphs_Certification
    TA_Library.Graphs
begin

context
  fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool"
    and less_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<preceq>" 50)\<^cancel>\<open> and less (infix "\<prec>" 50)\<close>
  \<^cancel>\<open>assumes preorder: "class.preorder less_eq less"\<close>
  assumes mono: "a \<preceq> B \<Longrightarrow> E a a' \<Longrightarrow> P a \<Longrightarrow> (\<forall>b \<in> B. P b)
    \<Longrightarrow> \<exists>B'. (\<forall>b' \<in> B'. \<exists>b \<in> B. E b b') \<and> a' \<preceq> B'"
  assumes invariant: "P a \<Longrightarrow> E a a' \<Longrightarrow> P b"
begin

\<^cancel>\<open>interpretation preorder less_eq less
  by (rule preorder)\<close>

\<^cancel>\<open>interpretation Simulation_Invariant
  E "\<lambda> x y. \<exists> z. z \<preceq> y \<and> E x z \<and> P z" "(\<preceq>)" P P
  by standard (auto 0 4 intro: invariant dest: mono)\<close>

interpretation Graph_Defs E .

interpretation Graph_Invariant E P
  by standard (rule invariant)

interpretation B: Graph_Invariant "\<lambda>B B'. \<forall>b' \<in> B'. \<exists>b \<in> B. E b b'" "\<lambda>B. \<forall>b \<in> B. P b"
  by standard (auto 4 3 intro: invariant)

context
  fixes F :: "'a \<Rightarrow> bool" \<comment> \<open>Final states\<close>
  assumes F_mono[intro]: "F a \<Longrightarrow> a \<preceq> B \<Longrightarrow> \<exists>b \<in> B'. F b"
begin

lemma reaches_mono:
  assumes
    "a \<preceq> B" and
    "a \<rightarrow>* a'" and
    "P a" and
    "\<forall>b\<in>B. P b"
  shows "\<exists>B'. (\<forall>b'\<in>B'. \<exists>b\<in>B. b \<rightarrow>* b') \<and> a' \<preceq> B'"
  using assms(2) assms(1,3-)
proof (induction arbitrary: )
  case base
  then show ?case
    by auto
next
  case (step y z)
  then obtain B' where
    "a \<rightarrow>* y"
    "y \<rightarrow> z"
    "P a"
    "\<forall>a\<in>B. P a"
    "\<forall>b'\<in>B'. \<exists>b\<in>B. b \<rightarrow>* b'"
    "y \<preceq> B'"
    by auto
  then have \<open>P y\<close> \<open>\<forall>x\<in>B'. P x\<close>
    by (auto 4 3 intro: invariant_reaches)
  with mono[OF \<open>y \<preceq> B'\<close> \<open>y \<rightarrow> z\<close>] this obtain B\<^sub>z where
    "\<forall>b'\<in>B\<^sub>z. \<exists>b\<in>B'. b \<rightarrow> b'"
    "z \<preceq> B\<^sub>z"
    by auto
  with \<open>\<forall>b'\<in>B'. \<exists>b\<in>B. b \<rightarrow>* b'\<close> show ?case
    including graph_automation_aggressive by (inst_existentials B\<^sub>z) blast
qed

corollary reachability_correct:
  "\<nexists> s'. reaches a s' \<and> F s'"
  if "\<nexists> B' b'. B.reaches B B' \<and> b' \<in> B' \<and> F b'" "a \<preceq> B" "P a" "\<forall>b \<in> B. P b"
  using that by (meson F_mono reaches_mono rtranclp.rtrancl_refl)

end (* Context for property *)

end (* Context for over-approximation *)

locale Unreachability_Invariant_pre_defs =
  fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool"
    and less_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<preceq>" 50)
begin

sublocale Graph_Defs E .

definition
  "Step S T \<equiv> \<forall>t \<in> T. \<exists>s \<in> S. E s t"

notation Step ("_ \<rightarrow>'' _" [100, 100] 40)

definition Subsumed where
  "Subsumed S T \<equiv> \<forall>s \<in> S. \<exists>T' \<subseteq> T. s \<preceq> T'"

notation Subsumed (infix "\<sqsubseteq>" 50)

end

locale Unreachability_Invariant_defs =
  fixes E :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool"
    and less_eq :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<preceq>" 50)
    and I :: "'a \<Rightarrow> bool" and SE :: "'a \<Rightarrow> 'a set \<Rightarrow> bool"
begin

sublocale Unreachability_Invariant_pre_defs .

definition Subsumed' where
  "Subsumed' S T \<equiv> \<forall>s \<in> S. \<exists>T' \<subseteq> T. SE s T'"

notation Subsumed' (infix "\<sqsubseteq>''" 50)

definition Inv where
  "Inv T \<equiv> \<forall>t \<in> T. I t"

definition Step' where
  "Step' S T \<equiv> \<exists>S'. Step S S' \<and> S' \<sqsubseteq>' T \<and> Inv T"

end

locale Unreachability_Invariant =
  Unreachability_Invariant_defs +
  assumes mono: "a \<preceq> B \<Longrightarrow> E a a' \<Longrightarrow> P a \<Longrightarrow> (\<forall>b \<in> B. P b)
    \<Longrightarrow> \<exists>B'. (\<forall>b' \<in> B'. \<exists>b \<in> B. E b b') \<and> a' \<preceq> B'"
  assumes S_E_subsumed: "I s \<Longrightarrow> E s t \<Longrightarrow> \<exists> T. (\<forall>t' \<in> T. I t') \<and> SE t T"
  assumes subsumptions_subsume: "SE s T \<Longrightarrow> s \<preceq> T"
  assumes I_P[intro]: "I s \<Longrightarrow> P s"
  assumes P_invariant: "P a \<Longrightarrow> E a a' \<Longrightarrow> P a'"
  assumes subsumes_Subsumed: "a \<preceq> A \<Longrightarrow> A \<sqsubseteq> A' \<Longrightarrow> a \<preceq> A'"
begin

interpretation Graph_Invariant E P
  by standard (rule P_invariant)

interpretation BB: Graph_Invariant "\<lambda>B B'. \<forall>b' \<in> B'. \<exists>b \<in> B. E b b'" "\<lambda>B. \<forall>b \<in> B. P b"
  by standard (auto 4 3 intro: invariant)

lemma S_E_subsumed':
  assumes "Inv S" "S \<rightarrow>' T" shows "\<exists> T'. Inv T' \<and> T \<sqsubseteq>' T'"
proof -
  define T' where "T' \<equiv> \<lambda>t. SOME T'. SE t T' \<and> Inv T'"
  have "SE t (T' t) \<and> Inv (T' t)" if "t \<in> T" for t
    using S_E_subsumed that assms unfolding T'_def Step_def Inv_def by - (rule someI_ex, blast)
  then show ?thesis
    unfolding Step_def Inv_def Subsumed'_def by (inst_existentials "\<Union>t \<in> T. T' t"; blast)
qed

lemma Subsumed'_Subsumed:
  "A \<sqsubseteq> A'" if "A \<sqsubseteq>' A'"
  using that unfolding Subsumed_def Subsumed'_def by (blast intro: subsumptions_subsume)

lemma subsumes_Subsumed':
  assumes "a \<preceq> A" "A \<sqsubseteq>' A'" shows "a \<preceq> A'"
  using assms by (elim subsumes_Subsumed Subsumed'_Subsumed)

interpretation Simulation_Invariant E Step' "(\<preceq>)" P Inv
proof standard
  fix a b :: \<open>'a\<close> and A
  assume \<open>a \<rightarrow> b\<close> \<open>P a\<close> \<open>Inv A\<close> \<open>a \<preceq> A\<close>
  with mono[OF \<open>a \<preceq> A\<close> \<open>a \<rightarrow> b\<close>] obtain B where "b \<preceq> B" "\<forall>b'\<in>B. \<exists>a\<in>A. a \<rightarrow> b'"
    by (auto simp: Inv_def)
  then have "b \<preceq> B" "A \<rightarrow>' B"
    by (auto simp: Step_def)
  with S_E_subsumed'[OF \<open>Inv A\<close>] \<open>a \<preceq> A\<close> \<open>P a\<close> obtain C where "Inv C" "B \<sqsubseteq>' C"
    by auto
  with \<open>A \<rightarrow>' B\<close> have "Step' A C"
    unfolding Step'_def by auto
  with \<open>b \<preceq> B\<close> \<open>B \<sqsubseteq>' C\<close> subsumptions_subsume show \<open>\<exists>b'. Step' A b' \<and> b \<preceq> b'\<close>
    by (blast intro: subsumes_Subsumed')
qed (auto simp: Step'_def P_invariant)

\<comment> \<open>Not really necessary\<close>
sublocale Post: Simulation_Graph_Poststable
  where C = E
    and A = Step
  by standard (auto simp: Step_def)

context
  fixes s\<^sub>0 S\<^sub>0
  assumes "s\<^sub>0 \<preceq> S\<^sub>0" "P s\<^sub>0" "Inv S\<^sub>0"
begin

lemma run_subsumed:
  assumes "run (s\<^sub>0 ## xs)"
  obtains ys where "B.run (S\<^sub>0 ## ys)" "stream_all2 (\<preceq>) xs ys" "pred_stream Inv ys"
proof -
  from \<open>s\<^sub>0 \<preceq> _\<close> \<open>P s\<^sub>0\<close> \<open>Inv S\<^sub>0\<close> have "equiv' s\<^sub>0 S\<^sub>0"
    unfolding equiv'_def by auto
  with assms show ?thesis
    by - (drule simulation_run, auto
          dest: PB_invariant.invariant_run elim: stream_all2_weaken intro!: that simp: equiv'_def)
qed

context
  fixes F :: "'a \<Rightarrow> bool" \<comment> \<open>Final states\<close>
  assumes F_mono[intro]: "P a \<Longrightarrow> F a \<Longrightarrow> a \<preceq> B \<Longrightarrow> \<forall>b \<in> B. P b \<Longrightarrow> \<exists>b \<in> B. F b"
begin

corollary final_unreachable:
  "\<nexists> s'. reaches s\<^sub>0 s' \<and> F s'" if "\<forall>s'. I s' \<longrightarrow> \<not> F s'"
  using \<open>s\<^sub>0 \<preceq> _\<close> \<open>P s\<^sub>0\<close> \<open>Inv S\<^sub>0\<close> simulation_reaches that I_P F_mono unfolding Inv_def by metis

lemma buechi_run_lasso:
  assumes "finite {s. I s}" "run (s\<^sub>0 ## xs)" "alw (ev (holds F)) (s\<^sub>0 ## xs)"
  obtains s where "B.reaches S\<^sub>0 s" "B.reaches1 s s" "\<exists>s' \<in> s. F s'"
proof -
  interpret Finite: Finite_Graph Step' S\<^sub>0
    by (standard, rule finite_subset[OF _ assms(1)[THEN finite_Collect_subsets]])
       (auto dest: PB_invariant.invariant_reaches[OF _ \<open>Inv S\<^sub>0\<close>] simp: Inv_def)
  from run_subsumed[OF assms(2)] obtain ys where ys:
    "B.run (S\<^sub>0 ## ys)" "stream_all2 (\<preceq>) xs ys" "pred_stream Inv ys" .
  moreover from \<open>run _\<close> have "pred_stream P xs"
    using \<open>P s\<^sub>0\<close> invariant_run by auto
  ultimately have "stream_all2 (\<lambda>x y. x \<preceq> y \<and> P x \<and> Inv y) xs ys"
    by (smt stream.pred_set stream.rel_mono_strong)
  with assms(3) \<open>s\<^sub>0 \<preceq> _\<close> \<open>P s\<^sub>0\<close> \<open>Inv S\<^sub>0\<close> have "alw (ev (holds (\<lambda>S. \<exists>s \<in> S. F s))) (S\<^sub>0 ## ys)"
    by (elim alw_ev_lockstep) (erule stream.rel_intros[rotated], auto simp: I_P Inv_def)
  from Finite.buechi_run_lasso[OF ys(1) this] show ?thesis
    using that .
qed

end (* Context for property *)

end (* Start state *)

end (* Unreachability Invariant *)

context Simulation_Graphs_Certification.Unreachability_Invariant1
begin

interpretation Unreachability_Invariant
  where less_eq = "\<lambda>s S. \<exists>s'. S = {s'} \<and> s \<preceq> s'"
    and SE = "\<lambda>s S. \<exists>s'. S = {s'} \<and> SE s s'"
  apply standard
  subgoal premises prems for a B a'
    using prems apply -
    by (metis mono singletonD singletonI)

subgoal premises prems for s t
  using prems apply -
  sorry

subgoal premises prems for s T
  using prems apply -
  sorry

subgoal premises prems for s
  using prems apply -
  sorry

subgoal premises prems for a a'
  using prems apply -
  sorry

subgoal premises prems for a A A'
  using prems apply -
  unfolding Unreachability_Invariant_pre_defs.Subsumed_def
  apply auto
  oops

end

end


section \<open>Public Announcement Logic (PAL) in HOL\<close>

text \<open>An earlier encoding and automation of the wise men puzzle, utilizing a shallow embedding of
higher-order (multi-)modal logic in HOL, has been presented in \<^cite>\<open>"J41" and "J44"\<close>. However, this work did not
convincingly address the interaction dynamics between the involved agents. Here we therefore extend and adapt
the universal (meta-)logical reasoning approach of \<^cite>\<open>"J41"\<close> for public announcement logic (PAL) and
we demonstrate how it can be utilized to achieve a convincing encoding and automation of the
wise men puzzle in HOL, so that also the interaction dynamics as given in the scenario is adequately
addressed. For further background information on the work presented here we refer to \<^cite>\<open>"R78" and "C90"\<close>.\<close>

theory PAL imports Main begin  (* Sebastian Reiche and Christoph Benzmüller, 2021 *)
nitpick_params[user_axioms,expect=genuine]

text \<open>Type i is associated with possible worlds\<close>
 typedecl i (* Type of possible worlds *)
 type_synonym \<sigma> = "i\<Rightarrow>bool" (*Type of world domains *)
 type_synonym \<tau> = "\<sigma>\<Rightarrow>i\<Rightarrow>bool" (* Type of world depended formulas (truth sets) *)
 type_synonym \<alpha> = "i\<Rightarrow>i\<Rightarrow>bool" (* Type of accessibility relations between world *)
 type_synonym \<rho> = "\<alpha>\<Rightarrow>bool" (* Type of groups of agents *)

text \<open>Some useful relations (for constraining accessibility relations)\<close>
definition reflexive::"\<alpha>\<Rightarrow>bool"
  where "reflexive R \<equiv> \<forall>x. R x x"
definition symmetric::"\<alpha>\<Rightarrow>bool"
  where "symmetric R \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"
definition transitive::"\<alpha>\<Rightarrow>bool"
  where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
definition euclidean::"\<alpha>\<Rightarrow>bool"
  where "euclidean R \<equiv> \<forall>x y z. R x y \<and> R x z \<longrightarrow> R y z"
definition intersection_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>"
  where "intersection_rel R Q \<equiv> \<lambda>u v. R u v \<and> Q u v"
definition union_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>"
  where "union_rel R Q \<equiv> \<lambda>u v. R u v \<or> Q u v"
definition sub_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool"
  where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
definition inverse_rel::"\<alpha>\<Rightarrow>\<alpha>"
  where "inverse_rel R \<equiv> \<lambda>u v. R v u"
definition big_union_rel::"\<rho>\<Rightarrow>\<alpha>"
  where "big_union_rel X \<equiv> \<lambda>u v. \<exists>R. (X R) \<and> (R u v)"
definition big_intersection_rel::"\<rho>\<Rightarrow>\<alpha>"
  where "big_intersection_rel X \<equiv> \<lambda>u v. \<forall>R. (X R) \<longrightarrow> (R u v)"

text \<open>In HOL the transitive closure of a relation can be defined in a single line.\<close>
definition tc::"\<alpha>\<Rightarrow>\<alpha>"
  where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

text \<open>Logical connectives for PAL\<close>
abbreviation patom::"\<sigma>\<Rightarrow>\<tau>" ("\<^sup>A_"[79]80)
  where "\<^sup>Ap \<equiv> \<lambda>W w. W w \<and> p w"
abbreviation ptop::"\<tau>" ("\<^bold>\<top>")
  where "\<^bold>\<top> \<equiv> \<lambda>W w. True"
abbreviation pneg::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53)
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>W w. \<not>(\<phi> W w)"
abbreviation pand::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51)
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<and> (\<psi> W w)"
abbreviation por::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50)
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<or> (\<psi> W w)"
abbreviation pimp::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49)
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> W w)"
abbreviation pequ::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48)
  where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longleftrightarrow> (\<psi> W w)"
abbreviation pknow::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K_ _")
  where "\<^bold>K r \<phi> \<equiv> \<lambda>W w.\<forall>v. (W v \<and> r w v) \<longrightarrow> (\<phi> W v)"
abbreviation ppal::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>[\<^bold>!_\<^bold>]_")
  where "\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> (\<lambda>z. W z \<and> \<phi> W z) w)"

text \<open>Glogal validity of PAL formulas\<close>
abbreviation pvalid::"\<tau> \<Rightarrow> bool" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>"[7]8)
  where "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor> \<equiv> \<forall>W.\<forall>w. W w \<longrightarrow> \<phi> W w"

text \<open>Introducing agent knowledge (K), mutual knowledge (E), distributed knowledge (D) and common knowledge (C).\<close>
abbreviation EVR::"\<rho>\<Rightarrow>\<alpha>"
  where "EVR G \<equiv> big_union_rel G"
abbreviation DIS::"\<rho>\<Rightarrow>\<alpha>"
  where "DIS G \<equiv> big_intersection_rel G"
abbreviation agttknows::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K\<^sub>_ _")
  where "\<^bold>K\<^sub>r \<phi> \<equiv>  \<^bold>K r \<phi>"
abbreviation evrknows::"\<rho>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>E\<^sub>_ _")
  where "\<^bold>E\<^sub>G \<phi> \<equiv>  \<^bold>K (EVR G) \<phi>"
abbreviation disknows :: "\<rho>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>D\<^sub>_ _")
  where "\<^bold>D\<^sub>G \<phi> \<equiv> \<^bold>K (DIS G) \<phi>"
abbreviation prck::"\<rho>\<Rightarrow>\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_\<^bold>\<lparr>_\<^bold>|_\<^bold>\<rparr>")
  where "\<^bold>C\<^sub>G\<^bold>\<lparr>\<phi>\<^bold>|\<psi>\<^bold>\<rparr> \<equiv> \<lambda>W w. \<forall>v. (tc (intersection_rel (EVR G) (\<lambda>u v. W v \<and> \<phi> W v)) w v) \<longrightarrow> (\<psi> W v)"
abbreviation pcmn::"\<rho>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_ _")
  where "\<^bold>C\<^sub>G \<phi> \<equiv>  \<^bold>C\<^sub>G\<^bold>\<lparr>\<^bold>\<top>\<^bold>|\<phi>\<^bold>\<rparr>"

text \<open>Postulating S5 principles for the agent’s accessibility relations.\<close>
abbreviation S5Agent::"\<alpha>\<Rightarrow>bool"
  where  "S5Agent i \<equiv> reflexive i \<and> transitive i \<and> euclidean i"
abbreviation S5Agents::"\<rho>\<Rightarrow>bool"
  where "S5Agents A \<equiv> \<forall>i. (A i \<longrightarrow> S5Agent i)"

text \<open>Introducing "Defs" as the set of the above definitions; useful for convenient unfolding.\<close>
named_theorems Defs
declare reflexive_def[Defs] symmetric_def[Defs] transitive_def[Defs]
  euclidean_def[Defs] intersection_rel_def[Defs] union_rel_def[Defs]
  sub_rel_def[Defs] inverse_rel_def[Defs] big_union_rel_def[Defs]
  big_intersection_rel_def[Defs] tc_def[Defs]

text \<open>Consistency: nitpick reports a model.\<close>
 lemma True nitpick [satisfy] oops (* model found *)

section \<open>Automating the Wise Men Puzzle\<close>

text \<open>Agents are modeled as accessibility relations.\<close>
consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>"
abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x = a \<or> x = b \<or> x = c"
axiomatization where  group_S5: "S5Agents \<A>"

text \<open>Common knowledge: At least one of a, b and c has a white spot.\<close>
consts ws::"\<alpha>\<Rightarrow>\<sigma>"
axiomatization where WM1: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^sup>Aws a \<^bold>\<or> \<^sup>Aws b \<^bold>\<or> \<^sup>Aws c)\<^bold>\<rfloor>"

text \<open>Common knowledge: If x does not have a white spot then y knows this.\<close>
axiomatization where
  WM2ab: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
  WM2ac: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
  WM2ba: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
  WM2bc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
  WM2ca: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
  WM2cb: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>"

text \<open>Positive introspection principles are implied.\<close>
lemma WM2ab': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws a))\<^bold>\<rfloor>"
  using WM2ab group_S5 unfolding Defs by metis
lemma WM2ac': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws a))\<^bold>\<rfloor>"
  using WM2ac group_S5 unfolding Defs by metis
lemma WM2ba': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws b))\<^bold>\<rfloor>"
  using WM2ba group_S5 unfolding Defs by metis
lemma WM2bc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws b))\<^bold>\<rfloor>"
  using WM2bc group_S5 unfolding Defs by metis
lemma WM2ca': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws c))\<^bold>\<rfloor>"
  using WM2ca group_S5 unfolding Defs by metis
lemma WM2cb': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws c))\<^bold>\<rfloor>"
  using WM2cb group_S5 unfolding Defs by metis

text \<open>Automated solutions of the Wise Men Puzzle.\<close>
theorem whitespot_c: "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>a(\<^sup>Aws a)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>b(\<^sup>Aws b)\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
  using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

text \<open>For the following, alternative formulation a proof is found by sledgehammer, while the
reconstruction of this proof using trusted methods (often) fails; this hints at further opportunities to
improve the reasoning tools in Isabelle/HOL.\<close>
theorem whitespot_c':
  "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
  using WM1 WM2ab WM2ac WM2ba WM2bc WM2ca WM2cb unfolding Defs
   \<comment> \<open>sledgehammer by (smt (verit))\<close>
  oops

text \<open>Consistency: nitpick reports a model.\<close>
lemma True nitpick [satisfy] oops
end