(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Reflexive Transitive Closure *}

theory Relation_Algebra_RTC
  imports Relation_Algebra
begin

text {* We impose the Kleene algebra axioms for the star on relation algebras.
This gives us a reflexive transitive closure operation. *}

class relation_algebra_rtc = relation_algebra + star_op +
  assumes rtc_unfoldl: "1' +  x ; x\<^sup>\<star> \<le> x\<^sup>\<star>"
    and rtc_inductl: "z + x ; y \<le> y \<longrightarrow> x\<^sup>\<star> ; z \<le> y"
    and rtc_inductr: "z + y ; x \<le> y \<longrightarrow> z ; x\<^sup>\<star> \<le> y"

sublocale relation_algebra_rtc < kleene_algebra "op +" "op ;" "1'" 0 "op \<le>" "op <" star
by (unfold_locales, rule rtc_unfoldl, rule rtc_inductl, rule rtc_inductr)

context relation_algebra_rtc
begin

text {* First, we prove that the obvious interaction between the star and
converse is captured by the axioms. *}

lemma star_conv: "(x\<^sup>\<star>)\<^sup>\<smile> = (x\<^sup>\<smile>)\<^sup>\<star>"
proof (rule antisym)
  show "(x\<^sup>\<smile>)\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<smile>"
    by (metis star_inductl_one add_lub_var conv_contrav conv_e conv_iso less_eq_def star_1l star_plus_one star_slide_var)
  show "(x\<^sup>\<star>)\<^sup>\<smile> \<le> (x\<^sup>\<smile>)\<^sup>\<star>"
    by (metis boffa_var conv_add conv_contrav conv_e conv_invol conv_iso star_denest star_ext star_iso star_plus_one sup.idem)
qed

text {* Next we provide an example to show how facts from Kleene algebra are
picked up in relation algebra. *}

lemma rel_church_rosser: "(x\<^sup>\<smile>)\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; (x\<^sup>\<smile>)\<^sup>\<star> \<Longrightarrow> (x + x\<^sup>\<smile>)\<^sup>\<star> = x\<^sup>\<star> ; (x\<^sup>\<smile>)\<^sup>\<star>"
by (metis church_rosser)

end (* relation_algebra_rtc *)

end


theory Iterate
imports Main
begin

inductive iterate :: "('a \<rightharpoonup> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  iter_refl [simp]: "iterate f x x"
| iter_step [simp]: "iterate f x y \<Longrightarrow> f y = Some z \<Longrightarrow> iterate f x z"

inductive iterate_ind :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  iteri_refl [simp]: "iterate_ind f x x"
| iteri_step [simp]: "iterate_ind f x y \<Longrightarrow> f y z \<Longrightarrow> iterate_ind f x z"

lemma iter_one: "f x = Some y \<Longrightarrow> iterate f x y"
  proof -
    assume "f x = Some y"
    moreover have "iterate f x x" by simp
    ultimately show ?thesis by (metis iter_step)
  qed

lemma iter_two: "f x = Some y \<Longrightarrow> f y = Some z \<Longrightarrow> iterate f x z"
  proof -
    assume "f x = Some y"
    moreover assume "f y = Some z"
    moreover have "iterate f x x" by simp
    ultimately show ?thesis by (metis iter_step)
  qed

lemma iter_prestep: "iterate f y z \<Longrightarrow> f x = Some y \<Longrightarrow> iterate f x z"
  by (induction f y z rule: iterate.induct) (simp_all add: iter_one)

lemma iter_many [elim]: "iterate f x y \<Longrightarrow> iterate f y z \<Longrightarrow> iterate f x z"
  proof (induction f x y rule: iterate.induct)
  case iter_refl
    thus ?case by simp
  next case (iter_step f x y w)
    with iter_prestep have "iterate f y z" by fast
    with iter_step show ?case by simp
  qed

end


(*  Title:       Category
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category"

theory Category
imports Main "HOL-Library.FuncSet"
begin

  text \<open>
    This theory develops an ``object-free'' definition of category loosely following
    \cite{AHS}, Sec. 3.52-3.53.
    We define the notion ``category'' in terms of axioms that concern a single
    partial binary operation on a type, some of whose elements are to be regarded
    as the ``arrows'' of the category.

    The nonstandard definition of category has some advantages and disadvantages.
    An advantage is that only one piece of data (the composition operation) is required
    to specify a category, so the use of records is not required to bundle up several
    separate objects.  A related advantage is the fact that functors and natural
    transformations can be defined simply to be functions that satisfy certain axioms,
    rather than more complex composite objects.
    One disadvantage is that the notions of ``object'' and ``identity arrow'' are
    conflated, though this is easy to get used to.  Perhaps a more significant disadvantage
    is that each arrow of a category must carry along the information about its domain
    and codomain. This implies, for example, that the arrows of a category of sets and
    functions cannot be directly identified with functions, but rather only with functions that
    have been equipped with their domain and codomain sets.

    To represent the partiality of the composition operation of a category, we assume that the
    composition for a category has a unique zero element, which we call \<open>null\<close>,
    and we consider arrows to be ``composable'' if and only if their composite is non-null.
    Functors and natural transformations are required to map arrows to arrows and be
    ``extensional'' in the sense that they map non-arrows to null.  This is so that
    equality of functors and natural transformations coincides with their extensional equality
    as functions in HOL.
    The fact that we co-opt an element of the arrow type to serve as \<open>null\<close> means that
    it is not possible to define a category whose arrows exhaust the elements of a given type.
    This presents a disadvantage in some situations.  For example, we cannot construct a
    discrete category whose arrows are directly identified with the set of \emph{all}
    elements of a given type @{typ 'a}; instead, we must pass to a larger type
    (such as @{typ "'a option"}) so that there is an element available for use as \<open>null\<close>.
    The presence of \<open>null\<close>, however, is crucial to our being able to define a
    system of introduction and elimination rules that can be applied automatically to establish
    that a given expression denotes an arrow.  Without \<open>null\<close>, we would be able to
    define an introduction rule to infer, say, that the composition of composable arrows
    is composable, but not an elimination rule to infer that arrows are composable from
    the fact that their composite is an arrow.  Having the ability to do both is critical
    to the usability of the theory.
\<close>

  section "Partial Magmas"

  text \<open>
    A \emph{partial magma} is a partial binary operation \<open>C\<close> defined on the set
    of elements at a type @{typ 'a}.  As discussed above,
    we assume the existence of a unique element \<open>null\<close> of type @{typ 'a}
    that is a zero for \<open>C\<close>, and we use \<open>null\<close> to represent ``undefined''.
    We think of the operation \<open>C\<close> as an operation of ``composition'', and
    we regard elements \<open>f\<close> and \<open>g\<close> of type @{typ 'a} as \emph{composable}
    if \<open>C g f \<noteq> null\<close>.
\<close>

  type_synonym 'a comp = "'a \<Rightarrow> 'a \<Rightarrow> 'a"

  locale partial_magma =
  fixes C :: "'a comp" (infixr "\<cdot>" 55)
  assumes ex_un_null: "\<exists>!n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"
  begin

    definition null :: 'a
    where "null = (THE n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n)"

    lemma null_eqI:
    assumes "\<And>f. n \<cdot> f = n \<and> f \<cdot> n = n"
    shows "n = null"
      using assms null_def ex_un_null the1_equality [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
      by auto

    lemma comp_null [simp]:
    shows "null \<cdot> f = null" and "f \<cdot> null = null"
      using null_def ex_un_null theI' [of "\<lambda>n. \<forall>f. n \<cdot> f = n \<and> f \<cdot> n = n"]
      by auto

    text \<open>
      An \emph{identity} is a self-composable element \<open>a\<close> such that composition of
      any other element \<open>f\<close> with \<open>a\<close> on either the left or the right results in
      \<open>f\<close> whenever the composition is defined.
\<close>

    definition ide
    where "ide a \<equiv> a \<cdot> a \<noteq> null \<and>
                   (\<forall>f. (f \<cdot> a \<noteq> null \<longrightarrow> f \<cdot> a = f) \<and> (a \<cdot> f \<noteq> null \<longrightarrow> a \<cdot> f = f))"

    text \<open>
      A \emph{domain} of an element \<open>f\<close> is an identity \<open>a\<close> for which composition of
      \<open>f\<close> with \<open>a\<close> on the right is defined.
      The notion \emph{codomain} is defined similarly, using composition on the left.
      Note that, although these definitions are completely dual, the choice of terminology
      implies that we will think of composition as being written in traditional order,
      as opposed to diagram order.  It is pretty much essential to do it this way, to maintain
      compatibility with the notation for function application once we start working with
      functors and natural transformations.
\<close>

    definition domains
    where "domains f \<equiv> {a. ide a \<and> f \<cdot> a \<noteq> null}"

    definition codomains
    where "codomains f \<equiv> {b. ide b \<and> b \<cdot> f \<noteq> null}"

    lemma domains_null:
    shows "domains null = {}"
      by (simp add: domains_def)

    lemma codomains_null:
    shows "codomains null = {}"
      by (simp add: codomains_def)

    lemma self_domain_iff_ide:
    shows "a \<in> domains a \<longleftrightarrow> ide a"
      using ide_def domains_def by auto

    lemma self_codomain_iff_ide:
    shows "a \<in> codomains a \<longleftrightarrow> ide a"
      using ide_def codomains_def by auto

    text \<open>
      An element \<open>f\<close> is an \emph{arrow} if either it has a domain or it has a codomain.
      In an arbitrary partial magma it is possible for \<open>f\<close> to have one but not the other,
      but the \<open>category\<close> locale will include assumptions to rule this out.
\<close>

    definition arr
    where "arr f \<equiv> domains f \<noteq> {} \<or> codomains f \<noteq> {}"

    lemma not_arr_null [simp]:
    shows "\<not> arr null"
      by (simp add: arr_def domains_null codomains_null)

    text \<open>
      Using the notions of domain and codomain, we can define \emph{homs}.
      The predicate @{term "in_hom f a b"} expresses ``@{term f} is an arrow from @{term a}
      to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
      It is convenient to have both of these, though passing back and forth sometimes involves
      extra work.  We choose @{term "in_hom"} as the more fundamental notion.
\<close>

    definition in_hom     ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")
    where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<equiv> a \<in> domains f \<and> b \<in> codomains f"

    abbreviation hom
    where "hom a b \<equiv> {f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>}"

    lemma arrI:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "arr f"
      using assms arr_def in_hom_def by auto

    lemma ide_in_hom [intro]:
    shows "ide a \<longleftrightarrow> \<guillemotleft>a : a \<rightarrow> a\<guillemotright>"
      using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce

    text \<open>
      Arrows @{term "f"} @{term "g"} for which the composite @{term "g \<cdot> f"} is defined
      are \emph{sequential}.
\<close>

    abbreviation seq
    where "seq g f \<equiv> arr (g \<cdot> f)"

    lemma comp_arr_ide:
    assumes "ide a" and "seq f a"
    shows "f \<cdot> a = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    lemma comp_ide_arr:
    assumes "ide b" and "seq b f"
    shows "b \<cdot> f = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    text \<open>
      The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
      set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
      arbitrarily from the set of codomains.
\<close>

    definition dom
    where "dom f = (if domains f \<noteq> {} then (SOME a. a \<in> domains f) else null)"

    definition cod
    where "cod f = (if codomains f \<noteq> {} then (SOME b. b \<in> codomains f) else null)"

    lemma dom_null [simp]:
    shows "dom null = null"
      by (simp add: dom_def domains_null)

    lemma cod_null [simp]:
    shows "cod null = null"
      by (simp add: cod_def codomains_null)

    lemma dom_in_domains:
    assumes "domains f \<noteq> {}"
    shows "dom f \<in> domains f"
      using assms dom_def someI [of "\<lambda>a. a \<in> domains f"] by auto

    lemma cod_in_codomains:
    assumes "codomains f \<noteq> {}"
    shows "cod f \<in> codomains f"
      using assms cod_def someI [of "\<lambda>b. b \<in> codomains f"] by auto

  end

  section "Categories"

  text\<open>
    A \emph{category} is defined to be a partial magma whose composition satisfies an
    extensionality condition, an associativity condition, and the requirement that every
    arrow have both a domain and a codomain.
    The associativity condition involves four ``matching conditions''
    (\<open>match_1\<close>, \<open>match_2\<close>, \<open>match_3\<close>, and \<open>match_4\<close>)
    which constrain the domain of definition of the composition, and a fifth condition
    (\<open>comp_assoc'\<close>) which states that the results of the two ways of composing
    three elements are equal.  In the presence of the \<open>comp_assoc'\<close> axiom
    \<open>match_4\<close> can be derived from \<open>match_3\<close> and vice versa.
\<close>

  locale category = partial_magma +
  assumes ext: "g \<cdot> f \<noteq> null \<Longrightarrow> seq g f"
  and has_domain_iff_has_codomain: "domains f \<noteq> {} \<longleftrightarrow> codomains f \<noteq> {}"
  and match_1: "\<lbrakk> seq h g; seq (h \<cdot> g) f \<rbrakk> \<Longrightarrow> seq g f"
  and match_2: "\<lbrakk> seq h (g \<cdot> f); seq g f \<rbrakk> \<Longrightarrow> seq h g"
  and match_3: "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> seq (h \<cdot> g) f"
  and comp_assoc': "\<lbrakk> seq g f; seq h g \<rbrakk> \<Longrightarrow> (h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
  begin

    text\<open>
      Associativity of composition holds unconditionally.  This was not the case in
      previous, weaker versions of this theory, and I did not notice this for some
      time after updating to the current axioms.  It is obviously an advantage that
      no additional hypotheses have to be verified in order to apply associativity,
      but a disadvantage is that this fact is now ``too readily applicable,''
      so that if it is made a default simplification it tends to get in the way of
      applying other simplifications that we would also like to be able to apply automatically.
      So, it now seems best not to make this fact a default simplification, but rather
      to invoke it explicitly where it is required.
\<close>

    lemma comp_assoc:
    shows "(h \<cdot> g) \<cdot> f = h \<cdot> g \<cdot> f"
      by (metis comp_assoc' ex_un_null ext match_1 match_2)

    lemma match_4:
    assumes "seq g f" and "seq h g"
    shows "seq h (g \<cdot> f)"
      using assms match_3 comp_assoc by auto

    lemma domains_comp:
    assumes "seq g f"
    shows "domains (g \<cdot> f) = domains f"
    proof -
      have "domains (g \<cdot> f) = {a. ide a \<and> seq (g \<cdot> f) a}"
        using domains_def ext by auto
      also have "... = {a. ide a \<and> seq f a}"
        using assms ide_def match_1 match_3 by meson
      also have "... = domains f"
        using domains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma codomains_comp:
    assumes "seq g f"
    shows "codomains (g \<cdot> f) = codomains g"
    proof -
      have "codomains (g \<cdot> f) = {b. ide b \<and> seq b (g \<cdot> f)}"
        using codomains_def ext by auto
      also have "... = {b. ide b \<and> seq b g}"
        using assms ide_def match_2 match_4 by meson
      also have "... = codomains g"
        using codomains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma has_domain_iff_arr:
    shows "domains f \<noteq> {} \<longleftrightarrow> arr f"
      by (simp add: arr_def has_domain_iff_has_codomain)

    lemma has_codomain_iff_arr:
    shows "codomains f \<noteq> {} \<longleftrightarrow> arr f"
      using has_domain_iff_arr has_domain_iff_has_codomain by auto

    text\<open>
      A consequence of the category axioms is that domains and codomains, if they exist,
      are unique.
\<close>

    lemma domain_unique:
    assumes "a \<in> domains f" and "a' \<in> domains f"
    shows "a = a'"
    proof -
      have "ide a \<and> seq f a \<and> ide a' \<and> seq f a'"
        using assms domains_def ext by force
      thus ?thesis
        using match_1 ide_def not_arr_null by metis
    qed

    lemma codomain_unique:
    assumes "b \<in> codomains f" and "b' \<in> codomains f"
    shows "b = b'"
    proof -
      have "ide b \<and> seq b f \<and> ide b' \<and> seq b' f"
        using assms codomains_def ext by force
      thus ?thesis
        using match_2 ide_def not_arr_null by metis
    qed

    lemma domains_char:
    assumes "arr f"
    shows "domains f = {dom f}"
      using assms dom_in_domains has_domain_iff_arr domain_unique by auto

    lemma codomains_char:
    assumes "arr f"
    shows "codomains f = {cod f}"
      using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto

    text\<open>
      A consequence of the following lemma is that the notion @{term "arr"} is redundant,
      given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}.  However, I have retained it
      because I have not been able to find a set of usefully powerful simplification rules
      expressed only in terms of @{term "in_hom"} that does not result in looping in many
      situations.
\<close>

    lemma arr_iff_in_hom:
    shows "arr f \<longleftrightarrow> \<guillemotleft>f : dom f \<rightarrow> cod f\<guillemotright>"
      using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
      by auto

    lemma in_homI [intro]:
    assumes "arr f" and "dom f = a" and "cod f = b"
    shows "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
      using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
            in_hom_def
      by auto

    lemma in_homE [elim]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    and "arr f \<Longrightarrow> dom f = a \<Longrightarrow> cod f = b \<Longrightarrow> T"
    shows "T"
     using assms in_hom_def domains_char codomains_char has_domain_iff_arr
     by (metis empty_iff singleton_iff)

    text\<open>
      To obtain the ``only if'' direction in the next two results and in similar results later
      for composition and the application of functors and natural transformations,
      is the reason for assuming the existence of @{term null} as a special element of the
      arrow type, as opposed to, say, using option types to represent partiality.
      The presence of @{term null} allows us not only to make the ``upward'' inference that
      the domain of an arrow is again an arrow, but also to make the ``downward'' inference
      that if @{term "dom f"} is an arrow then so is @{term f}.  Similarly, we will be able
      to infer not only that if @{term f} and @{term g} are composable arrows then
      @{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
      \<open>f\<close> and \<open>g\<close> are composable arrows.  These inferences allow most necessary
      facts about what terms denote arrows to be deduced automatically from minimal
      assumptions.  Typically all that is required is to assume or establish that certain
      terms denote arrows in particular homs at the point where those terms are first
      introduced, and then similar facts about related terms can be derived automatically.
      Without this feature, nearly every proof would involve many tedious additional steps
      to establish that each of the terms appearing in the proof (including all its subterms)
      in fact denote arrows.
\<close>

    lemma arr_dom_iff_arr:
    shows "arr (dom f) \<longleftrightarrow> arr f"
      using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
      by fastforce

    lemma arr_cod_iff_arr:
    shows "arr (cod f) \<longleftrightarrow> arr f"
      using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
      by fastforce

    lemma arr_cod [simp]:
    assumes "arr f"
    shows "arr (cod f)"
      using assms arr_cod_iff_arr by simp

    lemma seqI [simp]:
    assumes "arr f" and "arr g" and "dom g = cod f"
    shows "seq g f"
    proof -
      have "ide (cod f) \<and> seq (cod f) f"
        using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
      moreover have "ide (cod f) \<and> seq g (cod f)"
        using assms(2-3) domains_def domains_char ext by fastforce
      ultimately show ?thesis
        using match_4 ide_def ext by metis
    qed

    text \<open>
      This version of \<open>seqI\<close> is useful as an introduction rule, but not as useful
      as a simplification, because it requires finding the intermediary term \<open>b\<close>.
      Sometimes \emph{auto} is able to do this, but other times it is more expedient
      just to invoke this rule and fill in the missing terms manually, especially
      when dealing with a chain of compositions.
    \<close>

    lemma seqI' [intro]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
    shows "seq g f"
      using assms by fastforce

    lemma compatible_iff_seq:
    shows "domains g \<inter> codomains f \<noteq> {} \<longleftrightarrow> seq g f"
    proof
      show "domains g \<inter> codomains f \<noteq> {} \<Longrightarrow> seq g f"
        using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
              domain_unique codomain_unique
        by (metis Int_emptyI seqI)
      show "seq g f \<Longrightarrow> domains g \<inter> codomains f \<noteq> {}"
      proof -
        assume gf: "seq g f"
        have 1: "cod f \<in> codomains f"
          using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_char by blast
        have "ide (cod f) \<and> seq (cod f) f"
          using 1 codomains_def ext by auto
        hence "seq g (cod f)"
          using gf has_domain_iff_arr match_2 domains_null ide_def by metis
        thus ?thesis
          using domains_def 1 codomains_def by auto
      qed
    qed

    text\<open>
      The following is another example of a crucial ``downward'' rule that would not be possible
      without a reserved @{term null} value.
\<close>

    lemma seqE [elim]:
    assumes "seq g f"
    and "arr f \<Longrightarrow> arr g \<Longrightarrow> dom g = cod f \<Longrightarrow> T"
    shows "T"
      using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
            domains_comp codomains_comp domains_char codomain_unique
      by (metis Int_emptyI singletonD)

    lemma comp_in_homI [intro]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
    shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
    proof
      show 1: "seq g f" using assms compatible_iff_seq by blast
      show "dom (g \<cdot> f) = a"
        using assms 1 domains_comp domains_char by blast
      show "cod (g \<cdot> f) = c"
        using assms 1 codomains_comp codomains_char by blast
    qed

    lemma comp_in_homI' [simp]:
    assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
    shows "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
      using assms by auto

    lemma comp_in_homE [elim]:
    assumes "\<guillemotleft>g \<cdot> f : a \<rightarrow> c\<guillemotright>"
    obtains b where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<guillemotleft>g : b \<rightarrow> c\<guillemotright>"
      using assms in_hom_def domains_comp codomains_comp
      by (metis arrI in_homI seqE)

    text \<open>
      The next two rules are useful as simplifications, but they slow down the
      simplifier too much to use them by default.  So it is necessary to guess when
      they are needed and cite them explicitly.  This is usually not too difficult.
    \<close>

    lemma comp_arr_dom:
    assumes "arr f" and "dom f = a"
    shows "f \<cdot> a = f"
      using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto

    lemma comp_cod_arr:
    assumes "arr f" and "cod f = b"
    shows "b \<cdot> f = f"
      using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto

    lemma ide_char:
    shows "ide a \<longleftrightarrow> arr a \<and> dom a = a \<and> cod a = a"
      using ide_in_hom by auto

    text \<open>
      In some contexts, this rule causes the simplifier to loop, but it is too useful
      not to have as a default simplification.  In cases where it is a problem, usually
      a method like \emph{blast} or \emph{force} will succeed if this rule is cited
      explicitly.
    \<close>

    lemma ideD [simp]:
    assumes "ide a"
    shows "arr a" and "dom a = a" and "cod a = a"
      using assms ide_char by auto

    lemma ide_dom [simp]:
    assumes "arr f"
    shows "ide (dom f)"
      using assms dom_in_domains has_domain_iff_arr domains_def by auto

    lemma ide_cod [simp]:
    assumes "arr f"
    shows "ide (cod f)"
      using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto

    lemma dom_eqI:
    assumes "ide a" and "seq f a"
    shows "dom f = a"
      using assms cod_in_codomains codomain_unique ide_char
      by (metis seqE)

    lemma cod_eqI:
    assumes "ide b" and "seq b f"
    shows "cod f = b"
      using assms dom_in_domains domain_unique ide_char
      by (metis seqE)

    lemma ide_char':
    shows "ide a \<longleftrightarrow> arr a \<and> (dom a = a \<or> cod a = a)"
      using ide_dom ide_cod ide_char by metis

    lemma dom_dom:
    assumes "arr f"
    shows "dom (dom f) = dom f"
      using assms by simp

    lemma cod_cod:
    assumes "arr f"
    shows "cod (cod f) = cod f"
      using assms by simp

    lemma dom_cod:
    assumes "arr f"
    shows "dom (cod f) = cod f"
      using assms by simp

    lemma dom_comp [simp]:
    assumes "seq g f"
    shows "dom (g \<cdot> f) = dom f"
      using assms by (simp add: dom_def domains_comp)

    lemma cod_comp [simp]:
    assumes "seq g f"
    shows "cod (g \<cdot> f) = cod g"
      using assms by (simp add: cod_def codomains_comp)

    lemma comp_ide_self [simp]:
    assumes "ide a"
    shows "a \<cdot> a = a"
      using assms comp_arr_ide arrI by auto

    lemma ide_compE [elim]:
    assumes "ide (g \<cdot> f)"
    and "seq g f \<Longrightarrow> seq f g \<Longrightarrow> g \<cdot> f = dom f \<Longrightarrow> g \<cdot> f = cod g \<Longrightarrow> T"
    shows "T"
      using assms dom_comp cod_comp ide_char ide_in_hom
      by (metis seqE seqI)

    text \<open>
      The next two results are sometimes useful for performing manipulations at the
      head of a chain of composed arrows.  I have adopted the convention that such
      chains are canonically represented in right-associated form.  This makes it
      easy to perform manipulations at the ``tail'' of a chain, but more difficult
      to perform them at the ``head''.  These results take care of the rote manipulations
      using associativity that are needed to either permute or combine arrows at the
      head of a chain.
\<close>

    lemma comp_permute:
    assumes "f \<cdot> g = k \<cdot> l" and "seq f g" and "seq g h"
    shows "f \<cdot> g \<cdot> h = k \<cdot> l \<cdot> h"
      using assms by (metis comp_assoc)

    lemma comp_reduce:
    assumes "f \<cdot> g = k" and "seq f g" and "seq g h"
    shows "f \<cdot> g \<cdot> h = k \<cdot> h"
      using assms comp_assoc by auto

    text\<open>
      Here we define some common configurations of arrows.
      These are defined as abbreviations, because we want all ``diagrammatic'' assumptions
      in a theorem to reduce readily to a conjunction of assertions of the basic forms
      @{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
\<close>

    abbreviation endo
    where "endo f \<equiv> seq f f"

    abbreviation antipar
    where "antipar f g \<equiv> seq g f \<and> seq f g"

    abbreviation span
    where "span f g \<equiv> arr f \<and> arr g \<and> dom f = dom g"

    abbreviation cospan
    where "cospan f g \<equiv> arr f \<and> arr g \<and> cod f = cod g"

    abbreviation par
    where "par f g \<equiv> arr f \<and> arr g \<and> dom f = dom g \<and> cod f = cod g"

  end

end


header {* Automata *}
(* Author: Peter Lammich *)
theory Automata
imports Digraph
begin
  text {*
    In this theory, we define Generalized Buchi Automata and Buchi Automata
    based on directed graphs
    *}

subsection "Generalized Buchi Graphs"
text {*
  A generalized Buchi graph is a graph where each node belongs to a set of
  acceptance classes. An infinite run on this graph is accepted, iff
  it visits nodes from each acceptance class infinitely often.

  The standard encoding of acceptance classes is as a set of sets of nodes,
  each inner set representing one acceptance class.
*}

record 'Q gb_graph_rec = "'Q fr_graph_rec" +
  gbg_F :: "'Q set set"

locale gb_graph = fr_graph G
  for G :: "('Q,'more) gb_graph_rec_scheme" +
  assumes finite_F[simp, intro!]: "finite (gbg_F G)"
  assumes F_ss: "gbg_F G \<subseteq> Pow V"
begin
  abbreviation "F \<equiv> gbg_F G"

  lemma is_gb_graph: "gb_graph G" by unfold_locales

  definition
    is_acc :: "'Q word \<Rightarrow> bool" where "is_acc r \<equiv> (\<forall>A\<in>F. \<exists>\<^sub>\<infinity>i. r i \<in> A)"

  definition "is_acc_run r \<equiv> is_run r \<and> is_acc r"

  (* For presentation in paper *)
  lemma "is_acc_run r \<equiv> is_run r \<and> (\<forall>A\<in>F. \<exists>\<^sub>\<infinity>i. r i \<in> A)"
    unfolding is_acc_run_def is_acc_def .

  lemma acc_run_run: "is_acc_run r \<Longrightarrow> is_run r"
    unfolding is_acc_run_def by simp

  lemmas acc_run_reachable = run_reachable[OF acc_run_run]

    assume "is_acc r"
    hence AUX: "\<forall>A\<in>F. \<exists>\<^sub>\<infinity>i. r i \<in> (A \<inter> range r)"
      unfolding is_acc_def by auto
    have "\<forall>A\<in>F. limit r \<inter> (A \<inter> range r) \<noteq> {}"
      apply (rule ballI)
      apply (drule bspec[OF AUX])
      apply (subst (asm) fin_ex_inf_eq_limit[OF FIN'])
      .
    thus "\<forall>A\<in>F. limit r \<inter> A \<noteq> {}"
      by auto
  qed

  lemma is_acc_run_limit_alt:
    "is_acc_run r \<longleftrightarrow> is_run r \<and> (\<forall>A\<in>F. limit r \<inter> A \<noteq> {})"
    using acc_eq_limit[symmetric]
    unfolding is_acc_run_def by (auto dest: is_run_finite)

  lemma is_acc_suffix[simp]: "is_acc (suffix i r) \<longleftrightarrow> is_acc r"
    unfolding is_acc_def suffix_def
    apply (clarsimp simp: INFM_nat)
    apply (rule iffI)
    apply (metis trans_less_add2)
    by (metis add_lessD1 less_imp_add_positive nat_add_left_cancel_less)
end

locale finFe_gb_graph = gb_graph G
  for G :: "('Q,'more) gb_graph_rec_scheme"+
  assumes finite_Fe[simp, intro]: "\<And>A. A\<in>F \<Longrightarrow> finite A"
begin
  lemma is_finFe_gb_graph: "finFe_gb_graph G" by unfold_locales

end

locale fin_gb_graph = gb_graph G + fin_fr_graph G
  for G :: "('Q,'more) gb_graph_rec_scheme"
begin
  lemma is_fin_gb_graph: "fin_gb_graph G" by unfold_locales

  sublocale finFe_gb_graph G
    apply unfold_locales
    by (metis Pow_iff finite_V infinite_super set_rev_mp F_ss)
end

definition "gb_rename_ecnv ecnv f G \<equiv> \<lparr>
  gbg_F = { f`A | A. A\<in>gbg_F G }, \<dots> = ecnv G
\<rparr>"

abbreviation "gb_rename_ext ecnv f \<equiv> fr_rename_ext (gb_rename_ecnv ecnv f) f"

locale gb_rename_precond = gb_graph G +
  fr_rename_precond G f "gb_rename_ecnv ecnv f"
  for G :: "('u,'more) gb_graph_rec_scheme"
  and f :: "'u \<Rightarrow> 'v" and ecnv
begin
  lemma G'_gb_fields: "gbg_F G' = { f`A | A. A\<in>F }"
    unfolding gb_rename_ecnv_def fr_rename_ext_def
    by simp

  sublocale G'!: gb_graph G'
    apply unfold_locales
    apply (simp_all add: G'_fields G'_gb_fields)
    using F_ss
    by auto

  lemma acc_sim1: "is_acc r \<Longrightarrow> G'.is_acc (f o r)"
    unfolding is_acc_def G'.is_acc_def G'_gb_fields
    by (fastforce intro: imageI simp: INFM_nat)

  lemma acc_sim2:
    assumes "G'.is_acc r" shows "is_acc (fi o r)"
  proof -
    from assms have 1: "\<And>A m. A \<in> gbg_F G \<Longrightarrow> \<exists>i>m. r i \<in> f`A"
      unfolding G'.is_acc_def G'_gb_fields
      by (auto simp: INFM_nat)

    { fix A m
      assume 2: "A \<in> gbg_F G"
      from 1[OF this, of m] have "\<exists>i>m. fi (r i) \<in> A"
        using F_ss
        apply clarsimp
        by (metis Pow_iff 2 fi_f in_mono)
    } thus ?thesis
      unfolding is_acc_def
      by (auto simp: INFM_nat)
  qed

  lemma acc_run_sim1: "is_acc_run r \<Longrightarrow> G'.is_acc_run (f o r)"
    using acc_sim1 run_sim1 unfolding G'.is_acc_run_def is_acc_run_def
    by auto

  lemma acc_run_sim2: "G'.is_acc_run r \<Longrightarrow> is_acc_run (fi o r)"
    using acc_sim2 run_sim2 unfolding G'.is_acc_run_def is_acc_run_def
    by auto

end

subsection "Generalized Buchi Automata"
text {*
  A GBA is obtained from a GBG by adding a labeling function, that associates
  each state with a set of labels. A word is accepted if there is an
  accepting run that can be labeld with this word.
*}

record ('Q,'L) gba_rec = "'Q gb_graph_rec" +
  gba_L :: "'Q \<Rightarrow> 'L \<Rightarrow> bool"

locale gba = gb_graph G for G :: "('Q,'L,'more) gba_rec_scheme" +
  assumes L_ss: "gba_L G q l \<Longrightarrow> q \<in> V"
begin
  abbreviation "L \<equiv> gba_L G"

  lemma is_gba: "gba G" by unfold_locales

  definition "accept w \<equiv> \<exists>r. is_acc_run r \<and> (\<forall>i. L (r i) (w i))"
  lemma acceptI[intro?]: "\<lbrakk>is_acc_run r; \<And>i. L (r i) (w i)\<rbrakk> \<Longrightarrow> accept w"
    by (auto simp: accept_def)

  definition "lang \<equiv> Collect (accept)"
  lemma langI[intro?]: "accept w \<Longrightarrow> w\<in>lang" by (auto simp: lang_def)
end

locale finFe_gba = gba G + finFe_gb_graph G
  for G :: "('Q,'L,'more) gba_rec_scheme"
begin
  lemma is_finFe_gba: "finFe_gba G" by unfold_locales

end

locale fin_gba = gba G + fin_gb_graph G
  for G :: "('Q,'L,'more) gba_rec_scheme"
begin
  lemma is_fin_gba: "fin_gba G" by unfold_locales

  sublocale finFe_gba by unfold_locales
end

definition "gba_rename_ecnv ecnv f G \<equiv> \<lparr>
  gba_L = \<lambda>q l.
    if q\<in>f`frg_V G then
      gba_L G (the_inv_into (frg_V G) f q) l
    else
      False,
  \<dots> = ecnv G
\<rparr>"

abbreviation "gba_rename_ext ecnv f \<equiv> gb_rename_ext (gba_rename_ecnv ecnv f) f"

locale gba_rename_precond =
  gb_rename_precond G f "gba_rename_ecnv ecnv f" + gba G
  for G :: "('u,'L,'more) gba_rec_scheme"
  and f :: "'u \<Rightarrow> 'v" and ecnv
begin
  lemma G'_gba_fields: "gba_L G' = (\<lambda>q l.
    if q\<in>f`V then L (fi q) l else False)"
    unfolding gb_rename_ecnv_def gba_rename_ecnv_def fr_rename_ext_def fi_def
    by simp

  sublocale G'!: gba G'
    apply unfold_locales
    apply (auto simp add: G'_gba_fields G'_fields split: split_if_asm)
    done

  lemma L_sim1: "\<lbrakk>range r \<subseteq> V; L (r i) l\<rbrakk> \<Longrightarrow> G'.L (f (r i)) l"
    by (auto simp: G'_gba_fields fi_def[symmetric] fi_f
      dest: inj_onD[OF INJ]
      dest!: set_rev_mp[OF rangeI[of _ i]])

  lemma L_sim2: "\<lbrakk> range r \<subseteq> f`V; G'.L (r i) l \<rbrakk> \<Longrightarrow> L (fi (r i)) l"
    by (auto
      simp: G'_gba_fields fi_def[symmetric] f_fi
      dest!: set_rev_mp[OF rangeI[of _ i]])

  lemma accept_eq[simp]: "G'.accept = accept"
    apply (rule ext)
    unfolding accept_def G'.accept_def
  proof safe
    fix w r
    assume R: "G'.is_acc_run r"
    assume L: "\<forall>i. G'.L (r i) (w i)"
    from R have RAN: "range r \<subseteq> f`V"
      using G'.run_V[OF G'.acc_run_run[OF R]]
      unfolding G'_fields
      by simp
    from L show "\<exists>r. is_acc_run r \<and> (\<forall>i. L (r i) (w i))"
      using acc_run_sim2[OF R] L_sim2[OF RAN]
      by auto
  next
    fix w r
    assume R: "is_acc_run r"
    assume L: "\<forall>i. L (r i) (w i)"

    from R have RAN: "range r \<subseteq> V"
      using run_V[OF acc_run_run[OF R]] by simp

    from L show "\<exists>r.
        G'.is_acc_run r
      \<and> (\<forall>i. G'.L (r i) (w i))"
      using acc_run_sim1[OF R] L_sim1[OF RAN]
      by auto
  qed

  lemma lang_eq[simp]: "G'.lang = lang"
    unfolding G'.lang_def lang_def by simp
end

abbreviation "gba_rename \<equiv> gba_rename_ext (\<lambda>_. ())"

lemma gba_rename_correct:
  fixes G :: "('v,'l,'m) gba_rec_scheme"
  assumes "gba G"
  assumes INJ: "inj_on f (frg_V G)"
  defines "G' \<equiv> gba_rename f G"
  shows "gba G'"
  and "gba.accept G' = gba.accept G"
  and "gba.lang G' = gba.lang G"
  unfolding G'_def
proof -
  let ?G' = "gba_rename f G"
  interpret gba G by fact

  from INJ interpret gba_rename_precond G f "\<lambda>_. ()"
    apply unfold_locales by simp_all

  show "gba ?G'" by fact
  show "G'.accept = accept" by fact
  show "G'.lang = lang" by fact
qed

locale fin_gba_rename_precond = gba_rename_precond + fin_gba
begin
  sublocale G'!: fin_gba G'
    apply unfold_locales
    apply (auto simp add: G'_gba_fields G'_fields split: split_if_asm)
    done
end

lemma fin_gba_rename_correct:
  fixes G :: "('v,'l,'m) gba_rec_scheme"
  assumes "fin_gba G"
  assumes INJ: "inj_on f (frg_V G)"
  defines "G' \<equiv> gba_rename f G"
  shows "fin_gba G'"
  and "gba.accept G' = gba.accept G"
  and "gba.lang G' = gba.lang G"
  unfolding G'_def
proof -
  let ?G' = "gba_rename f G"
  interpret fin_gba G by fact

  from INJ interpret fin_gba_rename_precond G f "\<lambda>_. ()"
    apply unfold_locales by simp_all

  show "fin_gba ?G'" by fact
  show "G'.accept = accept" by fact
  show "G'.lang = lang" by fact
qed

subsection "Buchi Graphs"

text {* A Buchi graph has exactly one acceptance class *}

record 'Q b_graph_rec = "'Q fr_graph_rec" +
  bg_F :: "'Q set"

locale b_graph = fr_graph G
  for G :: "('Q,'more) b_graph_rec_scheme"
+ assumes F_ss: "bg_F G \<subseteq> V"
begin
  abbreviation F where "F \<equiv> bg_F G"

  lemma is_b_graph: "b_graph G" by unfold_locales

  definition "to_gbg_ext m
    \<equiv> \<lparr> frg_V = V,
        frg_E=E,
        frg_V0=V0,
        gbg_F = if F=UNIV then {} else {F},
        \<dots> = m \<rparr>"
  abbreviation "to_gbg \<equiv> to_gbg_ext ()"

  sublocale gbg!: gb_graph "to_gbg_ext m"
    apply unfold_locales
    using V0_ss E_ss F_ss
    apply (auto simp: to_gbg_ext_def split: split_if_asm)
    done

  definition is_acc :: "'Q word \<Rightarrow> bool" where "is_acc r \<equiv> (\<exists>\<^sub>\<infinity>i. r i \<in> F)"
  definition is_acc_run where "is_acc_run r \<equiv> is_run r \<and> is_acc r"

  lemma to_gbg_alt:
    "gbg.F T m = (if F=UNIV then {} else {F})"
    "gbg.is_run T m = is_run"
    "gbg.is_acc T m = is_acc"
    "gbg.is_acc_run T m = is_acc_run"
    unfolding is_run_def[abs_def] gbg.is_run_def[abs_def]
      is_acc_def[abs_def] gbg.is_acc_def[abs_def]
      is_acc_run_def[abs_def] gbg.is_acc_run_def[abs_def]
    by (auto simp: to_gbg_ext_def)

end

subsection "Buchi Automata"
text {* Buchi automata are labeled Buchi graphs *}

record ('Q,'L) ba_rec = "'Q b_graph_rec" +
  ba_L :: "'Q \<Rightarrow> 'L \<Rightarrow> bool"

locale ba = bg: b_graph G
  for G :: "('Q,'L,'more) ba_rec_scheme" +
  assumes L_ss: "ba_L G q l \<Longrightarrow> q \<in> V"
begin
  abbreviation L where "L == ba_L G"

  lemma is_ba: "ba G" by unfold_locales

  abbreviation "to_gba_ext m \<equiv> to_gbg_ext \<lparr> gba_L = L, \<dots>=m \<rparr>"
  abbreviation "to_gba \<equiv> to_gba_ext ()"

  sublocale gba!: gba "to_gba_ext m"
    apply unfold_locales
    unfolding to_gbg_ext_def
    using L_ss apply auto []
    done

  lemma ba_acc_simps[simp]: "gba.L T m = L"
    by (simp add: to_gbg_ext_def)

  definition "accept w \<equiv> (\<exists>r. is_acc_run r \<and> (\<forall>i. L (r i) (w i)))"
  definition "lang \<equiv> Collect accept"

  lemma to_gba_alt_accept:
    "gba.accept T m = accept"
    apply (intro ext)
    unfolding accept_def gba.accept_def
    apply (simp_all add: to_gbg_alt)
    done

  lemma to_gba_alt_lang:
    "gba.lang T m = lang"
    unfolding lang_def gba.lang_def
    apply (simp_all add: to_gba_alt_accept)
    done

  lemmas to_gba_alt = to_gbg_alt to_gba_alt_accept to_gba_alt_lang
end

subsection "Indexed acceptance classes"
record 'Q igb_graph_rec = "'Q fr_graph_rec" +
  igbg_num_acc :: nat
  igbg_acc :: "'Q \<Rightarrow> nat set"

locale igb_graph =
  fr_graph G for G :: "('Q,'more) igb_graph_rec_scheme" +
  assumes acc_bound: "\<Union>range (igbg_acc G) \<subseteq> {0..<(igbg_num_acc G)}"
  assumes acc_ss: "igbg_acc G q \<noteq> {} \<Longrightarrow> q\<in>V"
begin
  abbreviation num_acc where "num_acc \<equiv> igbg_num_acc G"
  abbreviation acc where "acc \<equiv> igbg_acc G"

  lemma acc_boundI[simp, intro]: "x\<in>acc q \<Longrightarrow> x<num_acc"
    using acc_bound by fastforce

  definition "accn i \<equiv> {q . i\<in>acc q}"
  definition "F \<equiv> { accn i | i. i<num_acc }"

  definition "to_gbg_ext m
    \<equiv> \<lparr> frg_V = V, frg_E = E, frg_V0 = V0, gbg_F = F, \<dots>=m \<rparr>"

  sublocale gbg!: gb_graph "to_gbg_ext m"
    apply unfold_locales
    using V0_ss E_ss acc_ss
    apply (auto simp: to_gbg_ext_def F_def accn_def)
    done

  lemma to_gbg_alt1:
    "gbg.E T m = E"
    "gbg.V0 T m = V0"
    "gbg.F T m = F"
    by (simp_all add: to_gbg_ext_def)

  lemma F_fin[simp,intro!]: "finite F"
    unfolding F_def
    by auto

  definition is_acc :: "'Q word \<Rightarrow> bool"
    where "is_acc r \<equiv> (\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (r i))"
  definition "is_acc_run r \<equiv> is_run r \<and> is_acc r"

  lemma is_run_gbg:
    "gbg.is_run T m = is_run"
    unfolding is_run_def[abs_def] is_acc_run_def[abs_def]
      gbg.is_run_def[abs_def] gbg.is_acc_run_def[abs_def]
    by (simp_all add: to_gbg_ext_def)

  lemma is_acc_gbg:
    "gbg.is_acc T m = is_acc"
    apply (intro ext)
    unfolding gbg.is_acc_def is_acc_def
    apply (simp add: to_gbg_alt1 is_run_gbg)
    unfolding F_def accn_def
    apply (blast intro: INFM_mono)
    done

  lemma is_acc_run_gbg:
    "gbg.is_acc_run T m = is_acc_run"
    apply (intro ext)
    unfolding gbg.is_acc_run_def is_acc_run_def
    by (simp_all add: to_gbg_alt1 is_run_gbg is_acc_gbg)

  lemmas to_gbg_alt = to_gbg_alt1 is_run_gbg is_acc_gbg is_acc_run_gbg

  lemma acc_limit_alt:
    assumes FIN: "finite (range r)"
    shows "is_acc r \<longleftrightarrow> (\<forall>n<num_acc. limit r \<inter> accn n \<noteq> {})"
  proof
    assume "\<forall>n<num_acc. limit r \<inter> accn n \<noteq> {}"
    thus "is_acc r"
      unfolding is_acc_def accn_def
      by (auto dest!: limit_inter_INF)
  next
    from FIN have FIN': "\<And>A. finite (A \<inter> range r)" by simp
    assume "is_acc r"
    hence "\<forall>n<num_acc. limit r \<inter> (accn n \<inter> range r) \<noteq> {}"
      unfolding is_acc_def accn_def
      by (auto simp: fin_ex_inf_eq_limit[OF FIN', symmetric])
    thus "\<forall>n<num_acc. limit r \<inter> accn n \<noteq> {}" by auto
  qed

  lemma acc_limit_alt':
    "finite (range r) \<Longrightarrow> is_acc r \<longleftrightarrow> (\<Union>(acc ` limit r) = {0..<num_acc})"
    unfolding acc_limit_alt
    by (auto simp: accn_def)

end

record ('Q,'L) igba_rec = "'Q igb_graph_rec" +
  igba_L :: "'Q \<Rightarrow> 'L \<Rightarrow> bool"

locale igba = igbg: igb_graph G for G :: "('Q,'L,'more) igba_rec_scheme" +
  assumes L_ss: "igba_L G q l \<Longrightarrow> q \<in> V"
begin
  abbreviation L where "L \<equiv> igba_L G"

  lemma is_igba: "igba G" by unfold_locales

  abbreviation "to_gba_ext m \<equiv> to_gbg_ext \<lparr> gba_L = igba_L G, \<dots>=m \<rparr>"

  sublocale gba!: gba "to_gba_ext m"
    apply unfold_locales
    unfolding to_gbg_ext_def
    using L_ss
    apply auto
    done

  lemma to_gba_alt_L:
    "gba.L T m = L"
    by (auto simp: to_gbg_ext_def)

  definition "accept w \<equiv> \<exists>r. is_acc_run r \<and> (\<forall>i. L (r i) (w i))"
  definition "lang \<equiv> Collect accept"

  lemma accept_gba_alt: "gba.accept T m = accept"
    apply (intro ext)
    unfolding accept_def gba.accept_def
    apply (simp add: to_gbg_alt to_gba_alt_L)
    done

  lemma lang_gba_alt: "gba.lang T m = lang"
    unfolding lang_def gba.lang_def
    apply (simp add: accept_gba_alt)
    done

  lemmas to_gba_alt = to_gbg_alt to_gba_alt_L accept_gba_alt lang_gba_alt

end

subsubsection {* Indexing Conversion *}
definition F_to_idx :: "'Q set set \<Rightarrow> (nat \<times> ('Q \<Rightarrow> nat set)) nres" where
  "F_to_idx F \<equiv> do {
    Flist \<leftarrow> SPEC (\<lambda>Flist. distinct Flist \<and> set Flist = F);
    let num_acc = length Flist;
    let acc = (\<lambda>v. {i . i<num_acc \<and> v\<in>Flist!i});
    RETURN (num_acc,acc)
  }"

lemma F_to_idx_correct:
  shows "F_to_idx F \<le> SPEC (\<lambda>(num_acc,acc). F = { {q. i\<in>acc q} | i. i<num_acc }
    \<and> \<Union>range acc \<subseteq> {0..<num_acc})"
  unfolding F_to_idx_def
  apply (refine_rcg refine_vcg)
  apply (clarsimp dest!: sym[where t=F])
  apply (intro equalityI subsetI)
  apply (auto simp: in_set_conv_nth) [2]

  apply auto []
  done

definition "mk_acc_impl Flist \<equiv> do {
  let acc = Map.empty;

  (_,acc) \<leftarrow> nfoldli Flist (\<lambda>_. True) (\<lambda>A (i,acc). do {
    acc \<leftarrow> FOREACHi (\<lambda>it acc'.
      acc' = (\<lambda>v.
        if v\<in>A-it then
          Some (insert i (the_default {} (acc v)))
        else
          acc v
      )
    )
      A (\<lambda>v acc. RETURN (acc(v\<mapsto>insert i (the_default {} (acc v))))) acc;
    RETURN (Suc i,acc)
  }) (0,acc);
  RETURN (\<lambda>x. the_default {} (acc x))
}"

lemma mk_acc_impl_correct:
  assumes F: "(Flist',Flist)\<in>Id"
  assumes FIN: "\<forall>A\<in>set Flist. finite A"
  shows "mk_acc_impl Flist' \<le> \<Down>Id (RETURN (\<lambda>v. {i . i<length Flist \<and> v\<in>Flist!i}))"
  using F apply simp
  unfolding mk_acc_impl_def

  apply (refine_rcg
    nfoldli_rule[where
      I="\<lambda>l1 l2 (i,res). i=length l1
        \<and> the_default {} o res = (\<lambda>v. {j . j<i \<and> v\<in>Flist!j})"
    ]
    refine_vcg
  )
  using FIN apply (simp_all)
  apply (rule ext) apply auto []

  apply (rule ext) apply (auto split: split_if_asm simp: nth_append nth_Cons') []
  apply (rule ext) apply (auto split: split_if_asm simp: nth_append nth_Cons'
    fun_comp_eq_conv) []

  apply (rule ext) apply (auto simp: fun_comp_eq_conv) []
  done

definition F_to_idx_impl :: "'Q set set \<Rightarrow> (nat \<times> ('Q \<Rightarrow> nat set)) nres" where
  "F_to_idx_impl F \<equiv> do {
    Flist \<leftarrow> SPEC (\<lambda>Flist. distinct Flist \<and> set Flist = F);
    let num_acc = length Flist;
    acc \<leftarrow> mk_acc_impl Flist;
    RETURN (num_acc,acc)
  }"

lemma F_to_idx_refine:
  assumes FIN: "\<forall>A\<in>F. finite A"
  shows "F_to_idx_impl F \<le> \<Down>Id (F_to_idx F)"
  using assms
  unfolding F_to_idx_impl_def F_to_idx_def

  apply (refine_rcg bind_Let_refine2[OF mk_acc_impl_correct])

  apply auto
  done

definition gbg_to_idx_ext
  :: "_ \<Rightarrow> ('a, 'more) gb_graph_rec_scheme \<Rightarrow> ('a, 'more') igb_graph_rec_scheme nres"
  where "gbg_to_idx_ext ecnv A = do {
  (num_acc,acc) \<leftarrow> F_to_idx_impl (gbg_F A);
  RETURN \<lparr>
    frg_V = frg_V A,
    frg_E = frg_E A,
    frg_V0=frg_V0 A,
    igbg_num_acc = num_acc,
    igbg_acc = acc,
    \<dots> = ecnv A
  \<rparr>
}"

lemma (in finFe_gb_graph) gbg_to_idx_ext_correct:
  "gbg_to_idx_ext ecnv G \<le> SPEC (\<lambda>G'.
    igb_graph.is_acc_run G' = is_acc_run
  \<and> frg_V G' = V
  \<and> frg_E G' = E
  \<and> frg_V0 G' = V0
  \<and> igb_graph_rec.more G' = ecnv G
  \<and> igb_graph G'
)"
proof -
  note F_to_idx_refine[of F]
  also note F_to_idx_correct
  finally have R: "F_to_idx_impl F
    \<le> SPEC (\<lambda>(num_acc, acc). F = {{q. i \<in> acc q} |i. i < num_acc}
      \<and> \<Union>range acc \<subseteq> {0..<num_acc})" by simp

  have eq_conjI: "\<And>a b c. (b\<longleftrightarrow>c) \<Longrightarrow> (a&b \<longleftrightarrow> a&c)" by simp

  {
    fix acc :: "'Q \<Rightarrow> nat set" and num_acc r
    have "(\<forall>A. (\<exists>i. A = {q. i \<in> acc q} \<and> i < num_acc) \<longrightarrow> (limit r \<inter> A \<noteq> {}))
      \<longleftrightarrow> (\<forall>i<num_acc. \<exists>q\<in>limit r. i\<in>acc q)"
      by blast
  } note aux1=this

  {
    fix acc :: "'Q \<Rightarrow> nat set" and num_acc i
    assume FE: "F = {{q. i \<in> acc q} |i. i < num_acc}"
    assume INR: "(\<Union>x. acc x) \<subseteq> {0..<num_acc}"
    have "finite {q. i \<in> acc q}"
    proof (cases "i<num_acc")
      case True thus ?thesis using finite_Fe FE by auto
    next
      case False hence "{q. i \<in> acc q} = {}" using INR by force
      thus ?thesis by simp
    qed
  } note aux2=this

  {
    fix acc :: "'Q \<Rightarrow> nat set" and num_acc q
    assume FE: "F = {{q. i \<in> acc q} |i. i < num_acc}"
      and INR: "(\<Union>x. acc x) \<subseteq> {0..<num_acc}"
      and "acc q \<noteq> {}"
    then obtain i where "i\<in>acc q" by auto
    moreover with INR have "i<num_acc" by force
    ultimately have "q\<in>\<Union>F" by (auto simp: FE)
    with F_ss have "q\<in>V" by auto
  } note aux3=this

  show ?thesis
    unfolding gbg_to_idx_ext_def
    apply (refine_rcg order_trans[OF R] refine_vcg)
  proof clarsimp_all
    fix acc and num_acc :: nat
    assume FE[simp]: "F = {{q. i \<in> acc q} |i. i < num_acc}"
      and BOUND: "(\<Union>x. acc x) \<subseteq> {0..<num_acc}"
    let ?G' = "\<lparr>
      frg_V = V,
      frg_E = E,
      frg_V0 = V0,
      igbg_num_acc = num_acc,
      igbg_acc = acc,
      \<dots> = ecnv G\<rparr>"

    interpret G'!: igb_graph ?G'
      apply unfold_locales
      using V0_ss E_ss
      apply (auto simp add: aux2 aux3 BOUND)
      done

    show "igb_graph ?G'" by unfold_locales

    show "G'.is_acc_run = is_acc_run"
      unfolding G'.is_acc_run_def[abs_def] is_acc_run_def[abs_def]
        G'.is_run_def[abs_def] is_run_def[abs_def]
        G'.is_acc_def[abs_def] is_acc_def[abs_def]

      apply (clarsimp intro!: ext eq_conjI)
      apply auto []
      apply (metis (lifting, no_types) INFM_mono mem_Collect_eq)
      done
  qed
qed

abbreviation gbg_to_idx :: "('q,_) gb_graph_rec_scheme \<Rightarrow> 'q igb_graph_rec nres"
  where "gbg_to_idx \<equiv> gbg_to_idx_ext (\<lambda>_. ())"

definition ti_Lcnv where "ti_Lcnv ecnv A \<equiv> \<lparr> igba_L = gba_L A, \<dots>=ecnv A \<rparr>"

abbreviation "gba_to_idx_ext ecnv \<equiv> gbg_to_idx_ext (ti_Lcnv ecnv)"
abbreviation "gba_to_idx \<equiv> gba_to_idx_ext (\<lambda>_. ())"

lemma (in finFe_gba) gba_to_idx_ext_correct:
  "gba_to_idx_ext ecnv G \<le>
  SPEC (\<lambda>G'. igba.accept G' = accept \<and> igba_rec.more G' = ecnv G \<and> igba G')"
  apply (rule order_trans[OF gbg_to_idx_ext_correct])
  apply (rule SPEC_rule)
  apply (elim conjE, intro conjI)
proof -
  fix G'
  assume
    ARUN: "igb_graph.is_acc_run G' = is_acc_run"
    and MORE: "igb_graph_rec.more G' = ti_Lcnv ecnv G"
    and LOC: "igb_graph G'"
    and FIELDS: "frg_V G' = V" "frg_E G' = E" "frg_V0 G' = V0"

  from LOC interpret igb!: igb_graph G' .

  interpret igb!: igba G'
    apply unfold_locales
    using MORE FIELDS L_ss
    unfolding ti_Lcnv_def
    apply (cases G')
    apply simp
    done

  show "igba.accept G' = accept" and "igba_rec.more G' = ecnv G"
    using ARUN MORE
    unfolding accept_def[abs_def] igb.accept_def[abs_def] ti_Lcnv_def
    apply (cases G', (auto) []) +
    done

  show "igba G'" by unfold_locales
qed

corollary (in finFe_gba) gba_to_idx_ext_lang_correct:
  "gba_to_idx_ext ecnv G \<le>
  SPEC (\<lambda>G'. igba.lang G' = lang \<and> igba_rec.more G' = ecnv G \<and> igba G')"
  apply (rule order_trans[OF gba_to_idx_ext_correct])
  apply (rule SPEC_rule)
  unfolding lang_def[abs_def]
  apply (subst igba.lang_def)
  apply auto
  done

subsubsection {* Degeneralization *}

context igb_graph
begin

  definition degeneralize_ext :: "_ \<Rightarrow> ('Q \<times> nat, _) b_graph_rec_scheme" where
    "degeneralize_ext ecnv \<equiv>
      if num_acc = 0 then \<lparr>
        frg_V = V \<times> {0},
        frg_E = {((q,0),(q',0)) | q q'. (q,q')\<in>E},
        frg_V0 = V0\<times>{0},
        bg_F = V \<times> {0},
        \<dots> = ecnv G
      \<rparr>
      else \<lparr>
        frg_V = V \<times> {0..<num_acc},
        frg_E = { ((q,i),(q',i')) | i i' q q'.
            i<num_acc
          \<and> (q,q')\<in>E
          \<and> i' = (if i\<in>acc q then (i+1) mod num_acc else i) },
        frg_V0 = V0 \<times> {0},
        bg_F = {(q,0)| q. 0\<in>acc q},
        \<dots> = ecnv G
      \<rparr>"

  abbreviation degeneralize where "degeneralize \<equiv> degeneralize_ext (\<lambda>_. ())"

  lemma degen_more[simp]: "b_graph_rec.more (degeneralize_ext ecnv) = ecnv G"
    unfolding degeneralize_ext_def
    by auto

  lemma degen_invar: "b_graph (degeneralize_ext ecnv)"
  proof
    let ?G' = "degeneralize_ext ecnv"
    have "((frg_E ?G')\<^sup>* `` frg_V0 ?G')
      \<subseteq> E\<^sup>*``V0 \<times> {0..num_acc}"
    proof -
      {
        fix q n q' n'
        assume "((q,n),(q',n'))\<in>(frg_E ?G')\<^sup>*"
          and 0: "(q,n)\<in>frg_V0 ?G'"
        hence G1: "(q,q')\<in>E\<^sup>* \<and> n'\<le>num_acc"
          apply (induction rule: rtrancl_induct2)
          by (auto simp: degeneralize_ext_def split: split_if_asm)

        from 0 have G2: "q\<in>V0 \<and> n\<le>num_acc"
          by (auto simp: degeneralize_ext_def split: split_if_asm)
        note G1 G2
      } thus ?thesis by fastforce
    qed
    also have "finite \<dots>" by auto
    finally (finite_subset) show "finite ((frg_E ?G')\<^sup>* `` frg_V0 ?G')" .

    show "frg_V0 ?G' \<subseteq> frg_V ?G'"
      unfolding degeneralize_ext_def
      using V0_ss
      by auto

    show "frg_E ?G' \<subseteq> frg_V ?G' \<times> frg_V ?G'"
      unfolding degeneralize_ext_def
      using E_ss
      by auto

    show "bg_F ?G' \<subseteq> frg_V ?G'"
      unfolding degeneralize_ext_def
      using acc_ss
      by auto

  qed

  sublocale degen!: b_graph "degeneralize_ext m" using degen_invar .

  lemma degen_is_run_sound:
    "degen.is_run T m r \<Longrightarrow> is_run (fst o r)"
    unfolding degen.is_run_def is_run_def
    unfolding degeneralize_ext_def
    apply (clarsimp split: split_if_asm simp: ipath_def)
    apply (metis fst_conv)+
    done

  lemma degen_path_sound:
    assumes "path (degen.E T m) u p v"
    shows "path E (fst u) (map fst p) (fst v)"
    using assms
    by induction (auto simp: degeneralize_ext_def path_simps split: split_if_asm)

  lemma degen_V0_sound:
    assumes "u \<in> degen.V0 T m"
    shows "fst u \<in> V0"
    using assms
    by (auto simp: degeneralize_ext_def path_simps split: split_if_asm)

  lemma degen_visit_acc:
    assumes "path (degen.E T m) (q,n) p (q',n')"
    assumes "n\<noteq>n'"
    shows "\<exists>qa. (qa,n)\<in>set p \<and> n\<in>acc qa"
    using assms
  proof (induction _ "(q,n)" p "(q',n')" arbitrary: q rule: path.induct)
    case (path_prepend qnh p)
    then obtain qh nh where [simp]: "qnh=(qh,nh)" by (cases qnh)
    from `((q,n),qnh) \<in> degen.E T m`
    have "nh=n \<or> (nh=(n+1) mod num_acc \<and> n\<in>acc q)"
      by (auto simp: degeneralize_ext_def split: split_if_asm)
    thus ?case proof
      assume [simp]: "nh=n"
      from path_prepend obtain qa where "(qa, n) \<in> set p" and "n \<in> acc qa"
        by auto
      thus ?case by auto
    next
      assume "(nh=(n+1) mod num_acc \<and> n\<in>acc q)" thus ?case by auto
    qed
  qed simp

  lemma degen_run_complete0:
    assumes [simp]: "num_acc = 0"
    assumes R: "is_run r"
    shows "degen.is_run T m (\<lambda>i. (r i,0))"
    using R
    unfolding degen.is_run_def is_run_def
    unfolding ipath_def degeneralize_ext_def
    by auto

  lemma degen_acc_run_complete0:
    assumes [simp]: "num_acc = 0"
    assumes R: "is_acc_run r"
    shows "degen.is_acc_run T m (\<lambda>i. (r i,0))"
    using R
    unfolding degen.is_acc_run_def is_acc_run_def is_acc_def degen.is_acc_def
    apply (simp add: degen_run_complete0)
    unfolding degeneralize_ext_def
    using run_V[of r]
    by (auto simp: INFM_nat)

  lemma degen_run_complete:
    assumes [simp]: "num_acc \<noteq> 0"
    assumes R: "is_run r"
    shows "\<exists>r'. degen.is_run T m r' \<and> r = fst o r'"
    using R
    unfolding degen.is_run_def is_run_def ipath_def
    apply (elim conjE)
  proof -
    assume R0: "r 0 \<in> V0" and RS: "\<forall>i. (r i, r (Suc i)) \<in> E"

    def r'\<equiv>"rec_nat
      (r 0,0)
      (\<lambda>i (q,n). (r (Suc i), if n \<in> acc q then (n+1) mod num_acc else n))"

    have [simp]:
      "r' 0 = (r 0,0)"
      "\<And>i. r' (Suc i) = (
        let
          (q,n)=r' i
        in
          (r (Suc i), if n \<in> acc q then (n+1) mod num_acc else n)
      )"
      unfolding r'_def
      by auto

    have R0': "r' 0 \<in> degen.V0 T m" using R0
      unfolding degeneralize_ext_def by auto

    have MAP: "r = fst o r'" proof (rule ext)
      fix i
      show "r i = (fst o r') i"
        by (cases i) (auto simp: split: prod.split)
    qed

    have [simp]: "0<num_acc" by (cases num_acc) auto

    have SND_LESS: "\<And>i. snd (r' i) < num_acc"
    proof -
      fix i show "snd (r' i) < num_acc" by (induction i) (auto split: prod.split)
    qed

    have RS': "\<forall>i. (r' i, r' (Suc i)) \<in> degen.E T m"
    proof
      fix i
      obtain n where [simp]: "r' i = (r i,n)"
        apply (cases i)
        apply (force)
        apply (force split: prod.split)
        done
      from SND_LESS[of i] have [simp]: "n<num_acc" by simp

      show "(r' i, r' (Suc i)) \<in> degen.E T m" using RS
        by (auto simp: degeneralize_ext_def)
    qed

    from R0' RS' MAP show
      "\<exists>r'. (r' 0 \<in> degen.V0 T m
      \<and> (\<forall>i. (r' i, r' (Suc i)) \<in> degen.E T m))
      \<and> r = fst \<circ> r'" by blast
  qed

  lemma degen_run_bound:
    assumes [simp]: "num_acc \<noteq> 0"
    assumes R: "degen.is_run T m r"
    shows "snd (r i) < num_acc"
    apply (induction i)
    using R
    unfolding degen.is_run_def is_run_def
    unfolding degeneralize_ext_def ipath_def
    apply -
    apply auto []
    apply clarsimp
    by (metis snd_conv)

  lemma degen_acc_run_complete_aux1:
    assumes NN0[simp]: "num_acc \<noteq> 0"
    assumes R: "degen.is_run T m r"
    assumes EXJ: "\<exists>j\<ge>i. n \<in> acc (fst (r j))"
    assumes RI: "r i = (q,n)"
    shows "\<exists>j\<ge>i. \<exists>q'. r j = (q',n) \<and> n \<in> acc q'"
  proof -
    def j \<equiv> "LEAST j. j\<ge>i \<and> n \<in> acc (fst (r j))"

    from RI have "n<num_acc" using degen_run_bound[OF NN0 R, of i] by auto
    from EXJ have
      "j\<ge>i"
      "n \<in> acc (fst (r j))"
      "\<forall>k\<ge>i. n \<in> acc (fst (r k)) \<longrightarrow> j\<le>k"
      using LeastI_ex[OF EXJ]
      unfolding j_def
      apply (auto) [2]
      apply (metis (lifting) Least_le)
      done
    hence "\<forall>k\<ge>i. k<j \<longrightarrow> n \<notin> acc (fst (r k))" by auto

    have "\<forall>k. k\<ge>i \<and> k\<le>j \<longrightarrow> (snd (r k) = n)"
    proof (clarify)
      fix k
      assume "i\<le>k" "k\<le>j"
      thus "snd (r k) = n"
      proof (induction k rule: less_induct)
        case (less k)
        show ?case proof (cases "k=i")
          case True thus ?thesis using RI by simp
        next
          case False with less.prems have "k - 1 < k" "i \<le> k - 1" "k - 1\<le>j"
            by auto
          from less.IH[OF this] have "snd (r (k - 1)) = n" .
          moreover from R have
            "(r (k - 1), r k) \<in> degen.E T m"
            unfolding degen.is_run_def is_run_def ipath_def
            by clarsimp (metis One_nat_def Suc_diff_1 `k - 1 < k`
              less_nat_zero_code neq0_conv)
          moreover have "n \<notin> acc (fst (r (k - 1)))"
            by (metis
              `\<forall>k\<ge>i. k < j \<longrightarrow> n \<notin> local.acc (fst (r k))`
              `i \<le> k - 1` `k - 1 < k` `k - 1 \<le> j`
              le_antisym less.prems(2) min.semilattice_strict_iff_order)
          ultimately show ?thesis
            by (auto simp: degeneralize_ext_def)
        qed
      qed
    qed

    thus ?thesis
      by (metis `i \<le> j` `n \<in> local.acc (fst (r j))`
        order_refl surjective_pairing)
  qed

  lemma degen_acc_run_complete_aux1':
    assumes NN0[simp]: "num_acc \<noteq> 0"
    assumes R: "degen.is_run T m r"
    assumes ACC: "\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (fst (r i))"
    assumes RI: "r i = (q,n)"
    shows "\<exists>j\<ge>i. \<exists>q'. r j = (q',n) \<and> n \<in> acc q'"
  proof -
    from RI have "n<num_acc" using degen_run_bound[OF NN0 R, of i] by auto
    with ACC have EXJ: "\<exists>j\<ge>i. n \<in> acc (fst (r j))"
      unfolding INFM_nat_le by blast

    from degen_acc_run_complete_aux1[OF NN0 R EXJ RI] show ?thesis .
  qed

  lemma degen_acc_run_complete_aux2:
    assumes NN0[simp]: "num_acc \<noteq> 0"
    assumes R: "degen.is_run T m r"
    assumes ACC: "\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (fst (r i))"
    assumes RI: "r i = (q,n)" and OFS: "ofs<num_acc"
    shows "\<exists>j\<ge>i. \<exists>q'.
      r j = (q',(n + ofs) mod num_acc) \<and> (n + ofs) mod num_acc \<in> acc q'"
    using RI OFS
  proof (induction ofs arbitrary: q n i)
    case 0
    from degen_run_bound[OF NN0 R, of i] `r i = (q, n)`
    have NLE: "n<num_acc"
      by simp

    with degen_acc_run_complete_aux1'[OF NN0 R ACC `r i = (q, n)`] show ?case
      by auto
  next
    case (Suc ofs)
    from Suc.IH[OF Suc.prems(1)] Suc.prems(2)
    obtain j q' where "j\<ge>i" and RJ: "r j = (q',(n+ofs) mod num_acc)"
      and A: "(n+ofs) mod num_acc \<in> acc q'"
      by auto
    from R have "(r j, r (Suc j)) \<in> degen.E T m"
      by (auto simp: degen.is_run_def is_run_def ipath_def)
    with RJ A obtain q2 where RSJ: "r (Suc j) = (q2,(n+Suc ofs) mod num_acc)"
      by (auto simp: degeneralize_ext_def mod_Suc_eq_Suc_mod[symmetric])

    have aux: "\<And>j'. i\<le>j \<Longrightarrow> Suc j \<le> j' \<Longrightarrow> i\<le>j'" by auto
    from degen_acc_run_complete_aux1'[OF NN0 R ACC RSJ] `j\<ge>i`
    show ?case
      by (auto dest: aux)
  qed

  lemma degen_acc_run_complete:
    assumes AR: "is_acc_run r"
    obtains r'
    where "degen.is_acc_run T m r'" and "r = fst o r'"
  proof (cases "num_acc = 0")
    case True
    with AR degen_acc_run_complete0
    show ?thesis by (auto intro!: that[of "(\<lambda>i. (r i, 0))"])
  next
    case False
    assume NN0[simp]: "num_acc \<noteq> 0"

    from AR have R: "is_run r" and ACC: "\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (r i)"
      unfolding is_acc_run_def is_acc_def by auto

    from degen_run_complete[OF NN0 R] obtain r' where
      R': "degen.is_run T m r'"
      and [simp]: "r = fst \<circ> r'"
      by auto

    from ACC have ACC': "\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (fst (r' i))" by simp

    have "\<forall>i. \<exists>j>i. r' j \<in> degen.F T m"
    proof
      fix i
      obtain q n where RI: "r' (Suc i) = (q,n)" by (cases "r' (Suc i)")
      have "(n + (num_acc - n mod num_acc)) mod num_acc = 0"
        by (metis NN0 R' `r' (Suc i) = (q, n)` add_diff_cancel_left'
          degen_run_bound less_imp_add_positive mod_self nat_mod_eq' snd_conv)
      then obtain ofs where
        OFS_LESS: "ofs<num_acc"
        and [simp]: "(n + ofs) mod num_acc = 0"
        by (metis NN0 Nat.add_0_right diff_less neq0_conv)
      with degen_acc_run_complete_aux2[OF NN0 R' ACC' RI OFS_LESS]
      obtain j q' where
        "j>i" "r' j = (q',0)" and "0\<in>acc q'"
        by (auto simp: less_eq_Suc_le)
      thus "\<exists>j>i. r' j \<in> degen.F T m"
        by (auto simp: degeneralize_ext_def)
    qed
    hence "\<exists>\<^sub>\<infinity>i. r' i \<in> degen.F T m" by (auto simp: INFM_nat)

    have "degen.is_acc_run T m r'"
      unfolding degen.is_acc_run_def degen.is_acc_def
      by rule fact+
    thus ?thesis by (auto intro: that)
  qed

  lemma degen_run_find_change:
    assumes NN0[simp]: "num_acc \<noteq> 0"
    assumes R: "degen.is_run T m r"
    assumes A: "i\<le>j" "r i = (q,n)" "r j = (q',n')" "n\<noteq>n'"
    obtains k qk where "i\<le>k" "k<j" "r k = (qk,n)" "n \<in> acc qk"
  proof -
    from degen_run_bound[OF NN0 R] A have "n<num_acc" "n'<num_acc"
      by (metis snd_conv)+

    def k \<equiv> "LEAST k. i<k \<and> snd (r k) \<noteq> n"

    have "i<k" "snd (r k) \<noteq> n"
      by (metis (lifting, mono_tags) LeastI_ex A k_def leD less_linear snd_conv)+

    from Least_le[where P="\<lambda>k. i<k \<and> snd (r k) \<noteq> n", folded k_def]
    have LEK_EQN: "\<forall>k'. i\<le>k' \<and> k'<k \<longrightarrow> snd (r k') = n"
      using `r i = (q,n)`
      by clarsimp (metis le_neq_implies_less not_le snd_conv)
    hence SND_RKMO: "snd (r (k - 1)) = n" using `i<k` by auto
    moreover from R have "(r (k - 1), r k) \<in> degen.E T m"
      unfolding degen.is_run_def ipath_def using `i<k`
      by clarsimp (metis Suc_pred gr_implies_not0 neq0_conv)
    moreover note `snd (r k) \<noteq> n`
    ultimately have "n \<in> acc (fst (r (k - 1)))"
      by (auto simp: degeneralize_ext_def split: split_if_asm)
    moreover have "k - 1 < j" using A LEK_EQN
      apply (rule_tac ccontr)
      apply clarsimp
      by (metis One_nat_def `snd (r (k - 1)) = n` less_Suc_eq
        less_imp_diff_less not_less_eq snd_conv)
    ultimately show thesis
      apply -
      apply (rule that[of "k - 1" "fst (r (k - 1))"])
      using `i<k` SND_RKMO by auto
  qed

  lemma degen_run_find_acc_aux:
    assumes NN0[simp]: "num_acc \<noteq> 0"
    assumes AR: "degen.is_acc_run T m r"
    assumes A: "r i = (q,0)" "0 \<in> acc q" "n<num_acc"
    shows "\<exists>j qj. i\<le>j \<and> r j = (qj,n) \<and> n \<in> acc qj"
  proof -
    from AR have R: "degen.is_run T m r"
      and ACC: "\<exists>\<^sub>\<infinity>i. r i \<in> degen.F T m"
      (*and ACC: "limit r \<inter> bg_F (degeneralize_ext ecnv) \<noteq> {}"*)
      unfolding degen.is_acc_run_def degen.is_acc_def by auto
    from ACC have ACC': "\<forall>i. \<exists>j>i. r j \<in> degen.F T m"
      by (auto simp: INFM_nat)

    show ?thesis using `n<num_acc`
    proof (induction n)
      case 0 thus ?case using A by auto
    next
      case (Suc n)
      then obtain j qj where "i\<le>j" "r j = (qj,n)" "n\<in>acc qj" by auto
      moreover from R have "(r j, r (Suc j)) \<in> degen.E T m"
        unfolding degen.is_run_def ipath_def
        by auto
      ultimately obtain qsj where RSJ: "r (Suc j) = (qsj,Suc n)"
        unfolding degeneralize_ext_def using `Suc n<num_acc` by auto

      from ACC' obtain k q0 where "Suc j \<le> k" "r k = (q0, 0)"
        unfolding degeneralize_ext_def apply auto
        by (metis less_imp_le_nat)
      from degen_run_find_change[OF NN0 R `Suc j \<le> k` RSJ `r k = (q0, 0)`]
      obtain l ql where
        "Suc j \<le> l" "l < k" "r l = (ql, Suc n)" "Suc n \<in> acc ql"
        by blast
      thus ?case using `i \<le> j`
        by (intro exI[where x=l] exI[where x=ql]) auto
    qed
  qed

  lemma degen_acc_run_sound:
    assumes A: "degen.is_acc_run T m r"
    shows "is_acc_run (fst o r)"
  proof -
    from A have R: "degen.is_run T m r"
      and ACC: "\<exists>\<^sub>\<infinity>i. r i \<in> degen.F T m"
      unfolding degen.is_acc_run_def degen.is_acc_def by auto
    from degen_is_run_sound[OF R] have R': "is_run (fst o r)" .

    show ?thesis
    proof (cases "num_acc = 0")
      case False[simp] note NN0=this

      from ACC have ACC': "\<forall>i. \<exists>j>i. r j \<in> degen.F T m"
        by (auto simp: INFM_nat)

      have "\<forall>n<num_acc. \<forall>i. \<exists>j>i. n \<in> acc (fst (r j))"
      proof (intro allI impI)
        fix n i

        obtain j qj where "j>i" and RJ: "r j = (qj,0)" and ACCJ: "0 \<in> acc (qj)"
          using ACC' unfolding degeneralize_ext_def by fastforce

        assume NLESS: "n<num_acc"
        show "\<exists>j>i. n \<in> acc (fst (r j))"
        proof (cases n)
          case 0 thus ?thesis using `j>i` RJ ACCJ by auto
        next
          case (Suc n')[simp]
          from degen_run_find_acc_aux[OF NN0 A RJ ACCJ NLESS] obtain k qk where
            "j\<le>k" "r k = (qk,n)" "n \<in> acc qk" by auto
          thus ?thesis
            by (metis `i < j` dual_order.strict_trans1 fst_conv)
        qed
      qed
      hence "\<forall>n<num_acc. \<exists>\<^sub>\<infinity>i. n \<in> acc (fst (r i))"
        by (auto simp: INFM_nat)
      with R' show ?thesis
        unfolding is_acc_run_def is_acc_def by auto
    next
      case True[simp]
      with R' show ?thesis
        unfolding is_acc_run_def is_acc_def
        by auto
    qed
  qed

  lemma degen_acc_run_iff:
    "is_acc_run r \<longleftrightarrow> (\<exists>r'. fst o r' = r \<and> degen.is_acc_run T m r')"
    using degen_acc_run_complete degen_acc_run_sound
    by blast

end

subsection "System Automata"
text {*
  System automata are (finite) rooted graphs with a labeling function. They are
  used to describe the model (system) to be checked.
*}

record ('Q,'L) sa_rec = "'Q fr_graph_rec" +
  sa_L :: "'Q \<Rightarrow> 'L"

locale sa = frg: fr_graph G for G :: "('Q,'L,'more) sa_rec_scheme"
begin
  abbreviation L where "L == sa_L G"

  lemma is_sa: "sa G" by unfold_locales

  definition "accept w \<equiv> \<exists>r. is_run r \<and> w = L o r"
  lemma acceptI[intro?]: "\<lbrakk>is_run r; w = L o r\<rbrakk> \<Longrightarrow> accept w"
    by (auto simp: accept_def)

  definition "lang \<equiv> Collect (accept)"
  lemma langI[intro?]: "accept w \<Longrightarrow> w\<in>lang" by (auto simp: lang_def)

end

subsubsection "Product Construction"
text {*
  In this section we formalize the product construction between a GBA and a system
  automaton. The result is a GBG and a projection function, such that projected
  runs of the GBG correspond to words accepted by the GBA and the system.
*}

locale igba_sys_prod_precond = igba!: igba G + sa!: sa S for
  G :: "('q,'l,'moreG) igba_rec_scheme"
  and S :: "('s,'l,'moreS) sa_rec_scheme"
begin

  definition "prod \<equiv> \<lparr>
    frg_V = igba.V \<times> sa.V,
    frg_E = { ((q,s),(q',s')).
      igba.L q (sa.L s) \<and> (q,q') \<in> igba.E \<and> (s,s') \<in> sa.E },
    frg_V0 = igba.V0 \<times> sa.V0,
    igbg_num_acc = igba.num_acc,
    igbg_acc = (\<lambda>(q,s). if s\<in>sa.V then igba.acc q else {} ) \<rparr>"

  lemma prod_invar:
    shows "igb_graph prod"
  proof -
    {
      fix q s q' s'
      assume "((q,s),(q',s')) \<in> (frg_E prod)\<^sup>*"
      hence "(q,q') \<in> (igba.E)\<^sup>* \<and> (s,s') \<in> (sa.E)\<^sup>*"
        apply (induction rule: rtrancl_induct2)
        apply (auto simp: prod_def)
        done
    } note gsp_reach=this

    have [simp]: "\<And>q s. (q,s) \<in> frg_V0 prod \<longleftrightarrow> q \<in> igba.V0 \<and> s \<in> sa.V0"
      by (auto simp: prod_def)

    have reachSS:
      "((frg_E prod)\<^sup>* `` frg_V0 prod)
      \<subseteq> ((igba.E)\<^sup>* `` igba.V0) \<times> (sa.E\<^sup>* `` sa.V0)"
      by (auto dest: gsp_reach)

    show ?thesis
      apply unfold_locales
      apply (rule finite_subset[OF reachSS])
      apply simp

      using igba.V0_ss sa.V0_ss
      apply (auto simp: prod_def) []

      using igba.E_ss sa.E_ss
      apply (auto simp: prod_def) []

      using igba.acc_bound
      apply (auto simp: prod_def split: split_if_asm) []

      using igba.acc_ss
      apply (fastforce simp: prod_def split: split_if_asm) []
      done
  qed

  sublocale prod!: igb_graph prod using prod_invar .

  lemma prod_fields:
    "prod.V = igba.V \<times> sa.V"
    "prod.E = { ((q,s),(q',s')).
      igba.L q (sa.L s) \<and> (q,q') \<in> igba.E \<and> (s,s') \<in> sa.E }"
    "prod.V0 = igba.V0 \<times> sa.V0"
    "prod.num_acc = igba.num_acc"
    "prod.acc = (\<lambda>(q,s). if s\<in>sa.V then igba.acc q else {} )"
    unfolding prod_def
    apply simp_all
    done

  lemma prod_run: "prod.is_run r \<longleftrightarrow>
      igba.is_run (fst o r)
    \<and> sa.is_run (snd o r)
    \<and> (\<forall>i. igba.L (fst (r i)) (sa.L (snd (r i))))" (is "?L=?R")
    apply rule
    unfolding igba.is_run_def sa.is_run_def prod.is_run_def
    unfolding prod_def ipath_def
    apply (auto split: prod.split_asm intro: in_prod_fst_sndI)
    apply (metis surjective_pairing)
    apply (metis surjective_pairing)
    apply (metis fst_conv snd_conv)
    apply (metis fst_conv snd_conv)
    apply (metis fst_conv snd_conv)
    done

  lemma prod_acc:
    assumes A: "range (snd o r) \<subseteq> sa.V"
    shows "prod.is_acc r \<longleftrightarrow> igba.is_acc (fst o r)"
  proof -
    {
      fix i
      from A have "prod.acc (r i) = igba.acc (fst (r i))"
        unfolding prod_fields
        apply safe
        apply (clarsimp_all split: split_if_asm)
        by (metis UNIV_I comp_apply imageI snd_conv subsetD)
    } note [simp] = this
    show ?thesis
      unfolding prod.is_acc_def igba.is_acc_def
      by (simp add: prod_fields(4))
  qed

  lemma gsp_correct1:
    assumes A: "prod.is_acc_run r"
    shows "sa.is_run (snd o r) \<and> (sa.L o snd o r \<in> igba.lang)"
  proof -
    from A have PR: "prod.is_run r" and PA: "prod.is_acc r"
      unfolding prod.is_acc_run_def by auto

    from prod.run_V[OF PR] have RSR: "range (snd o r) \<subseteq> sa.V"
      by (auto simp add: prod_fields)

    show ?thesis
      using PR PA
      unfolding igba.is_acc_run_def
        igba.lang_def igba.accept_def[abs_def]
      apply (auto simp: prod_run prod_acc[OF RSR])
      done
  qed

  lemma gsp_correct2:
    assumes A: "sa.is_run r" "sa.L o r \<in> igba.lang"
    shows "\<exists>r'. r = snd o r' \<and> prod.is_acc_run r'"
  proof -
    have [simp]: "\<And>r r'. fst o (\<lambda>i. (r i, r' i)) = r"
      "\<And>r r'. snd o (\<lambda>i. (r i, r' i)) = r'"
      by auto

    from A show ?thesis
      unfolding prod.is_acc_run_def
        igba.lang_def igba.accept_def[abs_def] igba.is_acc_run_def
      apply (clarsimp simp: prod_run)
      apply (rename_tac ra)
      apply (rule_tac x="\<lambda>i. (ra i, r i)" in exI)
      apply clarsimp

      apply (subst prod_acc)
      using sa.run_V
      apply auto []

      apply auto []
      done
  qed

end

end


section "Stack Machine and Compilation"

theory ASM imports "~~/src/HOL/IMP/AExp" begin

subsection "Stack Machine"

text_raw{*\snip{ASMinstrdef}{0}{1}{% *}
datatype instr = LOADI val | LOAD vname | ADD
text_raw{*}%endsnip*}

text_raw{*\snip{ASMstackdef}{1}{2}{% *}
type_synonym stack = "val list"
text_raw{*}%endsnip*}

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

text{* \noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.*}

text_raw{*\snip{ASMexeconedef}{0}{1}{% *}
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk  =  Some(n # stk)" |
"exec1 (LOAD x) s stk  =  Some(s(x) # stk)" |
"exec1  ADD _ []  =  None" |
"exec1  ADD _ [_]  =  None" |
"exec1  ADD _ stk  =  Some((hd2 stk + hd stk) # tl2 stk)"
text_raw{*}%endsnip*}

text_raw{*\snip{ASMexecdef}{1}{2}{% *}
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some(stk)" |
"exec (i#is) s stk =
  (case (exec1 i s stk) of
    None \<Rightarrow> None
  | Some(stk') \<Rightarrow> exec is s stk')"
text_raw{*}%endsnip*}

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1@is2) s stk = (case (exec is1 s stk) of None \<Rightarrow> None | Some(stk') \<Rightarrow> exec is2 s stk')"
apply(induction is1 arbitrary: stk)
apply(auto split: option.split)
done

subsection "Compilation"

text_raw{*\snip{ASMcompdef}{0}{2}{% *}
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw{*}%endsnip*}

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "(exec (comp a) s stk) = Some(aval a s # stk)"
apply(induction a arbitrary: stk)
apply(auto split:option.split)
done

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Kleene Algebra with Tests\<close>

theory KAT
  imports Kleene_Algebra.Kleene_Algebra Conway_Tests
begin

text \<open>
  First, we study left Kleene algebras with tests which also have only a left zero.
  These structures can be expanded to demonic refinement algebras.
\<close>

class left_kat_zerol =  left_kleene_algebra_zerol + test_semiring_zerol
begin

lemma star_n_export1: "(n x \<cdot> y)\<^sup>\<star> \<cdot> n x \<le> n x \<cdot> y\<^sup>\<star>"
  by (simp add: local.n_restrictr local.star_sim1)

lemma star_test_export1: "test p \<Longrightarrow> (p \<cdot> x)\<^sup>\<star> \<cdot> p \<le> p \<cdot> x\<^sup>\<star>"
  using star_n_export1 by auto

lemma star_n_export2: "(n x \<cdot> y)\<^sup>\<star> \<cdot> n x \<le> y\<^sup>\<star> \<cdot> n x"
  by (simp add: local.mult_isor local.n_restrictl local.star_iso)

lemma star_test_export2: "test p \<Longrightarrow> (p \<cdot> x)\<^sup>\<star> \<cdot> p \<le> x\<^sup>\<star> \<cdot> p"
  using star_n_export2 by auto

lemma star_n_export_left: "x \<cdot> n y \<le> n y \<cdot> x \<Longrightarrow> x\<^sup>\<star> \<cdot> n y = n y \<cdot> (x \<cdot> n y)\<^sup>\<star>"
proof (rule antisym)
  assume a1: "x \<cdot> n y \<le> n y \<cdot> x"
  hence "x \<cdot> n y = n y \<cdot> x \<cdot> n y"
    by (simp add: local.n_kat_2_opp)
  thus "x\<^sup>\<star> \<cdot> n y \<le> n y \<cdot> (x \<cdot> n y)\<^sup>\<star>"
    by (simp add: local.star_sim1 mult_assoc)
next
  assume a1: "x \<cdot> n y \<le> n y \<cdot> x"
  thus "n y \<cdot> (x \<cdot> n y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> n y"
using local.star_slide star_n_export2 by force
qed

lemma star_test_export_left: "test p \<Longrightarrow> x \<cdot> p \<le> p \<cdot> x \<longrightarrow> x\<^sup>\<star> \<cdot> p = p \<cdot> (x \<cdot> p)\<^sup>\<star>"
  using star_n_export_left by auto

lemma star_n_export_right: "x \<cdot> n y \<le> n y \<cdot> x \<Longrightarrow> x\<^sup>\<star> \<cdot> n y = (n y \<cdot> x)\<^sup>\<star> \<cdot> n y"
  by (simp add: local.star_slide star_n_export_left)

lemma star_test_export_right: "test p \<Longrightarrow> x \<cdot> p \<le> p \<cdot> x \<longrightarrow> x\<^sup>\<star> \<cdot> p = (p \<cdot> x)\<^sup>\<star> \<cdot> p"
  using star_n_export_right by auto

lemma star_n_folk: "n z \<cdot> x = x \<cdot> n z \<Longrightarrow> n z \<cdot> y = y \<cdot> n z \<Longrightarrow> (n z \<cdot> x + t z \<cdot> y)\<^sup>\<star> \<cdot> n z = n z \<cdot> (n z \<cdot> x)\<^sup>\<star>"
proof -
assume a: "n z \<cdot> x = x \<cdot> n z" and b: "n z \<cdot> y = y \<cdot> n z"
  hence "n z \<cdot> (n z \<cdot> x + t z \<cdot> y) = (n z \<cdot> x + t z \<cdot> y) \<cdot> n z"
    using local.comm_add_var local.t_n_closed local.test_def by blast
  hence "(n z \<cdot> x + t z \<cdot> y)\<^sup>\<star> \<cdot> n z = n z \<cdot> ((n z \<cdot> x + t z \<cdot> y) \<cdot> n z)\<^sup>\<star>"
    using local.order_refl star_n_export_left by presburger
  also have "... = n z \<cdot> (n z \<cdot> x \<cdot> n z + t z \<cdot> y \<cdot> n z)\<^sup>\<star>"
    by simp
  also have "... = n z \<cdot> (n z \<cdot> n z \<cdot> x + t z \<cdot> n z \<cdot> y)\<^sup>\<star>"
    by (simp add: a b mult_assoc)
 also have "... = n z \<cdot> (n z \<cdot> x + 0 \<cdot> y)\<^sup>\<star>"
  by (simp add: local.n_mult_comm)
  finally show "(n z \<cdot> x + t z \<cdot> y)\<^sup>\<star> \<cdot> n z = n z \<cdot> (n z \<cdot> x)\<^sup>\<star>"
    by simp
qed

lemma star_test_folk: "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<longrightarrow> p \<cdot> y = y \<cdot> p \<longrightarrow> (p \<cdot> x + !p \<cdot> y)\<^sup>\<star> \<cdot> p = p \<cdot> (p \<cdot> x)\<^sup>\<star>"
  using star_n_folk by auto

end

class kat_zerol = kleene_algebra_zerol + test_semiring_zerol
begin

sublocale conway: near_conway_zerol_tests star ..

lemma n_star_sim_right: "n y \<cdot> x = x \<cdot> n y \<Longrightarrow> n y \<cdot> x\<^sup>\<star> = (n y \<cdot> x)\<^sup>\<star> \<cdot> n y"
  by (metis local.n_mult_idem local.star_sim3 mult_assoc)

lemma star_sim_right: "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<longrightarrow> p \<cdot> x\<^sup>\<star> = (p \<cdot> x)\<^sup>\<star> \<cdot> p"
  using n_star_sim_right by auto

lemma n_star_sim_left: "n y \<cdot> x = x \<cdot> n y \<Longrightarrow> n y \<cdot> x\<^sup>\<star> = n y \<cdot> (x \<cdot> n y)\<^sup>\<star>"
  by (metis local.star_slide n_star_sim_right)

lemma star_sim_left: "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<longrightarrow> p \<cdot> x\<^sup>\<star> = p \<cdot> (x \<cdot> p)\<^sup>\<star>"
  using n_star_sim_left by auto

lemma n_comm_star: "n z \<cdot> x = x \<cdot> n z \<Longrightarrow>  n z \<cdot> y = y \<cdot> n z \<Longrightarrow> n z \<cdot> x \<cdot> (n z \<cdot> y)\<^sup>\<star> = n z \<cdot> x \<cdot> y\<^sup>\<star>"
  using mult_assoc n_star_sim_left by presburger

lemma comm_star: "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<longrightarrow>  p \<cdot> y = y \<cdot> p \<longrightarrow> p \<cdot> x \<cdot> (p \<cdot> y)\<^sup>\<star> = p \<cdot> x \<cdot> y\<^sup>\<star>"
  using n_comm_star by auto

lemma n_star_sim_right_var: "n y \<cdot> x = x \<cdot> n y \<Longrightarrow> x\<^sup>\<star> \<cdot> n y = n y \<cdot> (x \<cdot> n y)\<^sup>\<star>"
  using local.star_sim3 n_star_sim_left by force

lemma star_sim_right_var: "test p \<Longrightarrow> p \<cdot> x = x \<cdot> p \<longrightarrow> x\<^sup>\<star> \<cdot> p = p \<cdot> (x \<cdot> p)\<^sup>\<star>"
  using n_star_sim_right_var by auto

end

text \<open>Finally, we define Kleene algebra with tests.\<close>

class kat = kleene_algebra + test_semiring

begin

sublocale conway: test_pre_conway star ..

end

end