(* Author: Julian Brunner *)
(* This is originally a part of the CAVA model checker *)
theory Sequence_LTL
imports
  Sequence
  "HOL-Library.Linear_Temporal_Logic_on_Streams"
begin

  (* basics *)

  lemmas [iff] = ev_sconst alw_sconst ev_smap alw_smap hld_smap'

  lemmas [iff] = alw_ev_stl
  lemma alw_ev_sdrop[iff]: "alw (ev P) (sdrop n w) \<longleftrightarrow> alw (ev P) w"
    using alw_ev_sdrop alw_sdrop by blast
  lemma alw_ev_scons[iff]: "alw (ev P) (a ## w) \<longleftrightarrow> alw (ev P) w" by (metis alw_ev_stl stream.sel(2))
  lemma alw_ev_shift[iff]: "alw (ev P) (u @- v) \<longleftrightarrow> alw (ev P) v" by (induct u) (auto)

  lemmas [simp del, iff] = ev_alw_stl
  lemma ev_alw_sdrop[iff]: "ev (alw P) (sdrop n w) \<longleftrightarrow> ev (alw P) w"
    using alwD alw_alw alw_sdrop ev_alw_imp_alw_ev not_ev_iff by metis
  lemma ev_alw_scons[iff]: "ev (alw P) (a ## w) \<longleftrightarrow> ev (alw P) w" by (metis ev_alw_stl stream.sel(2))
  lemma ev_alw_shift[iff]: "ev (alw P) (u @- v) \<longleftrightarrow> ev (alw P) v" by (induct u) (auto)

  lemma HLD_sconst[iff]: "HLD A (sconst a) \<longleftrightarrow> a \<in> A" unfolding HLD_def by simp

  lemma ev_stl: "ev \<phi> (stl w) \<longleftrightarrow> (\<exists> u v. w = u @- v \<and> u \<noteq> [] \<and> \<phi> v)"
    by (metis ev.base ev_shift list.distinct(1) rotate1.simps(2) rotate1_is_Nil_conv
        sdrop.simps(2) sdrop_wait shift_simps(2) stake_Suc stake_sdrop
      )

  lemma ev_HLD_sset: "ev (HLD A) w \<longleftrightarrow> sset w \<inter> A \<noteq> {}" unfolding HLD_def ev_holds_sset by auto

  lemma alw_ev_coinduct[case_names alw_ev, consumes 1]:
    assumes "R w"
    assumes "\<And> w. R w \<Longrightarrow> ev \<phi> w \<and> ev R (stl w)"
    shows "alw (ev \<phi>) w"
  proof -
    have "ev R w" using assms(1) by rule
    then show ?thesis using assms(2) by (coinduct) (metis alw_sdrop not_ev_iff sdrop_stl sdrop_wait)
  qed

  (* acceptance conditions *)

  abbreviation "infs A w \<equiv> alw (ev (HLD A)) w"

  lemma infs_suffix: "infs A w \<longleftrightarrow> (\<forall> u v. w = u @- v \<longrightarrow> sset v \<inter> A \<noteq> {})"
    using alwD alw_iff_sdrop alw_shift ev_HLD_sset stake_sdrop by metis
  lemma infs_snth: "infs A w \<longleftrightarrow> (\<forall> n. \<exists> k \<ge> n. w !! k \<in> A)"
    by (auto simp: alw_iff_sdrop ev_iff_sdrop HLD_iff intro: le_add1 dest: le_Suc_ex)
  lemma infs_infm: "infs A w \<longleftrightarrow> (\<exists>\<^sub>\<infinity> i. w !! i \<in> A)"
    unfolding infs_snth INFM_nat_le by rule

  lemma infs_supset[trans]: "infs A w \<Longrightarrow> sset w \<inter> A \<subseteq> B \<Longrightarrow> infs B w" unfolding infs_snth by force

  lemma infsI_sset: "sset w \<subseteq> A \<Longrightarrow> infs A w" unfolding infs_snth by force
  lemma infsD_sset: "infs A w \<Longrightarrow> sset w \<inter> A \<noteq> {}" unfolding ev_HLD_sset by auto

  lemma infs_sset[intro!, simp]: "infs (sset w) w" by (auto intro: infsI_sset)
  lemma infs_UNIV[intro!, simp]: "infs UNIV w" by (auto intro: infsI_sset)

  lemma infs_union[iff]: "infs (A \<union> B) w \<longleftrightarrow> infs A w \<or> infs B w"
    unfolding infs_snth by (auto) (meson le_trans nat_le_linear)

  lemma infs_cycle[iff]:
    assumes "w \<noteq> []"
    shows "infs A (cycle w) \<longleftrightarrow> set w \<inter> A \<noteq> {}"
  proof
    show "infs A (cycle w) \<Longrightarrow> set w \<inter> A \<noteq> {}"
      using assms by (auto simp: ev_HLD_sset dest: alwD)
    show "set w \<inter> A \<noteq> {} \<Longrightarrow> infs A (cycle w)"
      using assms by (coinduction rule: infs_coinduct) (blast dest: cycle_decomp)
  qed

end


theory BL imports Main

begin

typedecl a

type_synonym i = "(a\<Rightarrow>bool)"

consts impl:: "i \<Rightarrow> i => i" (infixr "\<^bold>\<rightarrow>" 49)
consts con:: "i \<Rightarrow> i \<Rightarrow> i" (infixr "\<^bold>&" 50)

axiomatization where
  A1: "((\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> ((\<psi> \<^bold>\<rightarrow> \<chi>) \<^bold>\<rightarrow> (\<phi> \<^bold>\<rightarrow> \<chi>)))(x)" and
  A2: "((\<phi> \<^bold>& \<psi>) \<^bold>\<rightarrow> \<phi>)(x)" and
  A3: "((\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> (\<psi> \<^bold>\<rightarrow> \<phi>))(x)" and
  A4: "((\<phi> \<^bold>& (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> (\<psi> \<^bold>& (\<psi> \<^bold>\<rightarrow> \<phi>))))(x)" and
  A5a: "((\<phi> \<^bold>\<rightarrow> (\<psi> \<^bold>\<rightarrow> \<chi>)) \<^bold>\<rightarrow> ((\<phi> \<^bold>& \<psi>) \<^bold>\<rightarrow> \<chi>))(x)" and
  A5b: "(((\<phi> \<^bold>& \<psi>) \<^bold>\<rightarrow> \<chi>) \<^bold>\<rightarrow> (\<phi> \<^bold>\<rightarrow> (\<psi> \<^bold>\<rightarrow> \<chi>)))(x)" and
  A6: "(((\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<rightarrow> \<chi>) \<^bold>\<rightarrow> (((\<psi> \<^bold>\<rightarrow> \<phi>) \<^bold>\<rightarrow> \<chi>) \<^bold>\<rightarrow> \<chi>))(x)" and
  A7: "False \<Longrightarrow> \<phi>(x::a)"

 axiomatization where
  ModusPonens: "(\<phi> \<^bold>\<rightarrow> \<psi>)(x) \<Longrightarrow> \<phi>(x) \<Longrightarrow>  \<psi>(x)"

lemma True nitpick[satisfy, user_axioms] oops

lemma "(\<phi> \<^bold>\<rightarrow> \<phi>)(x)" sledgehammer
  by (meson A2 A3 A5b ModusPonens)

lemma "(\<phi> \<^bold>\<rightarrow> (\<psi> \<^bold>\<rightarrow> \<phi>))(x)" sledgehammer
  using A2 A5b ModusPonens by blast

end


section \<open> UTP Variables \<close>

theory utp_var
  imports
  "UTP-Toolkit.utp_toolkit"
  utp_parser_utils
begin

text \<open> In this first UTP theory we set up variables, which are are built on lenses~\<^cite>\<open>"Foster09" and "Foster16a"\<close>.
  A large part of this theory is setting up the parser for UTP variable syntax. \<close>

subsection \<open> Initial syntax setup \<close>

text \<open> We will overload the square order relation with refinement and also the lattice operators so
  we will turn off these notations. \<close>

purge_notation
  Order.le (infixl "\<sqsubseteq>\<index>" 50) and
  Lattice.sup ("\<Squnion>\<index>_" [90] 90) and
  Lattice.inf ("\<Sqinter>\<index>_" [90] 90) and
  Lattice.join (infixl "\<squnion>\<index>" 65) and
  Lattice.meet (infixl "\<sqinter>\<index>" 70) and
  Set.member ("op :") and
  Set.member ("(_/ : _)" [51, 51] 50) and
  disj  (infixr "|" 30) and
  conj  (infixr "&" 35)

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
declare comp_vwb_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]
declare lens_comp_quotient [simp]
declare plus_lens_distr [THEN sym, simp]

subsection \<open> Variable foundations \<close>

text \<open> This theory describes the foundational structure of UTP variables, upon which the rest
  of our model rests. We start by defining alphabets, which following~\<^cite>\<open>"Feliachi2010" and "Feliachi2012"\<close>
  in this shallow model are simply represented as types @{typ "'\<alpha>"}, though by convention usually a record
  type where each field corresponds to a variable. UTP variables in this frame are simply modelled
  as lenses @{typ "'a \<Longrightarrow> '\<alpha>"}, where the view type @{typ "'a"} is the variable type, and the
  source type \<open>'\<alpha>\<close> is the alphabet or state-space type.

  We define some lifting functions for variables to create input and output variables.
  These simply lift the alphabet to a tuple type since relations will ultimately be defined
  by a tuple alphabet.
\<close>

definition in_var :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out_var x = x ;\<^sub>L snd\<^sub>L"

text \<open> Variables can also be used to effectively define sets of variables. Here we define the
  the universal alphabet ($\Sigma$) to be the bijective lens @{term "1\<^sub>L"}. This characterises
  the whole of the source type, and thus is effectively the set of all alphabet variables. \<close>

abbreviation (input) univ_alpha :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<Sigma>") where
"univ_alpha \<equiv> 1\<^sub>L"

text \<open> The next construct is vacuous and simply exists to help the parser distinguish predicate
  variables from input and output variables. \<close>

definition pr_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<beta>)" where
[lens_defs]: "pr_var x = x"

subsection \<open> Variable lens properties \<close>

text \<open> We can now easily show that our UTP variable construction are various classes of
  well-behaved lens .\<close>

lemma in_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (in_var x)"
  by (simp add: comp_weak_lens in_var_def)

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma pr_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_mwb_lens [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_vwb_lens [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (out_var x)"
  by (simp add: comp_weak_lens out_var_def)

lemma out_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (out_var x)"
  by (simp add: comp_mwb_lens out_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

text \<open> Moreover, we can show that input and output variables are independent, since they refer
  to different sections of the alphabet. \<close>

lemma out_in_indep [simp]:
  "out_var x \<bowtie> in_var y"
  by (simp add: lens_indep_def in_var_def out_var_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

lemma pr_var_indeps [simp]:
  "x \<bowtie> y \<Longrightarrow> pr_var x \<bowtie> y"
  "x \<bowtie> y \<Longrightarrow> x \<bowtie> pr_var y"
  by (simp_all add: pr_var_def)

lemma prod_lens_indep_in_var [simp]:
  "a \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> in_var x"
  by (metis in_var_def in_var_indep out_in_indep out_var_def plus_pres_lens_indep prod_as_plus)

lemma prod_lens_indep_out_var [simp]:
  "b \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> out_var x"
  by (metis in_out_indep in_var_def out_var_def out_var_indep plus_pres_lens_indep prod_as_plus)

lemma in_var_pr_var [simp]:
  "in_var (pr_var x) = in_var x"
  by (simp add: pr_var_def)

lemma out_var_pr_var [simp]:
  "out_var (pr_var x) = out_var x"
  by (simp add: pr_var_def)

lemma pr_var_idem [simp]:
  "pr_var (pr_var x) = pr_var x"
  by (simp add: pr_var_def)

lemma pr_var_lens_plus [simp]:
  "pr_var (x +\<^sub>L y) = (x +\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_lens_comp_1 [simp]:
  "pr_var x ;\<^sub>L y = pr_var (x ;\<^sub>L y)"
  by (simp add: pr_var_def)

lemma in_var_plus [simp]: "in_var (x +\<^sub>L y) = in_var x +\<^sub>L in_var y"
  by (simp add: in_var_def)

lemma out_var_plus [simp]: "out_var (x +\<^sub>L y) = out_var x +\<^sub>L out_var y"
  by (simp add: out_var_def)

text \<open> Similar properties follow for sublens \<close>

lemma in_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> in_var y \<subseteq>\<^sub>L in_var x"
  by (metis (no_types, opaque_lifting) in_var_def lens_comp_assoc sublens_def)

lemma out_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> out_var y \<subseteq>\<^sub>L out_var x"
  by (metis (no_types, opaque_lifting) out_var_def lens_comp_assoc sublens_def)

lemma pr_var_sublens [simp]:
  "y \<subseteq>\<^sub>L x \<Longrightarrow> pr_var y \<subseteq>\<^sub>L pr_var x"
  by (simp add: pr_var_def)

subsection \<open> Lens simplifications \<close>

text \<open> We also define some lookup abstraction simplifications. \<close>

lemma var_lookup_in [simp]: "lens_get (in_var x) (A, A') = lens_get x A"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_lookup_out [simp]: "lens_get (out_var x) (A, A') = lens_get x A'"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma var_update_in [simp]: "lens_put (in_var x) (A, A') v = (lens_put x A v, A')"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_update_out [simp]: "lens_put (out_var x) (A, A') v = (A, lens_put x A' v)"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma get_lens_plus [simp]: "get\<^bsub>x +\<^sub>L y\<^esub> s = (get\<^bsub>x\<^esub> s, get\<^bsub>y\<^esub> s)"
  by (simp add: lens_defs)

subsection \<open> Syntax translations \<close>

text \<open> In order to support nice syntax for variables, we here set up some translations. The first
  step is to introduce a collection of non-terminals. \<close>

nonterminal svid and svids and svar and svars and salpha

text \<open> These non-terminals correspond to the following syntactic entities. Non-terminal
  @{typ "svid"} is an atomic variable identifier, and @{typ "svids"} is a list of identifier.
  @{typ "svar"} is a decorated variable, such as an input or output variable, and @{typ "svars"} is
  a list of decorated variables. @{typ "salpha"} is an alphabet or set of variables. Such sets can
  be constructed only through lens composition due to typing restrictions. Next we introduce some
  syntax constructors. \<close>

syntax \<comment> \<open> Identifiers \<close>
  "_svid"         :: "id \<Rightarrow> svid" ("_" [999] 999)
  "_svid_unit"    :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"    :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"   :: "svid" ("\<^bold>v")
  "_svid_dot"     :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [998,999] 998)
  "_mk_svid_list" :: "svids \<Rightarrow> logic" \<comment> \<open> Helper function for summing a list of identifiers \<close>

text \<open> A variable identifier can either be a HOL identifier, the complete set of variables in the
  alphabet $\textbf{v}$, or a composite identifier separated by colons, which
  corresponds to a sort of qualification. The final option is effectively a lens composition. \<close>

syntax \<comment> \<open> Decorations \<close>
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [990] 990)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [990] 990)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [990] 990)

text \<open> A variable can be decorated with an ampersand, to indicate it is a predicate variable, with
  a dollar to indicate its an unprimed relational variable, or a dollar and ``acute'' symbol to
  indicate its a primed relational variable. Isabelle's parser is extensible so additional
  decorations can be and are added later. \<close>

syntax \<comment> \<open> Variable sets \<close>
  "_salphaid"    :: "svid \<Rightarrow> salpha" ("_" [990] 990)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [990] 990)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_salphaprod"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<times>" 85)
  "_salpha_all"  :: "salpha" ("\<Sigma>")
  "_salpha_none" :: "salpha" ("\<emptyset>")
  "_svar_nil"    :: "svar \<Rightarrow> svars" ("_")
  "_svar_cons"   :: "svar \<Rightarrow> svars \<Rightarrow> svars" ("_,/ _")
  "_salphaset"   :: "svars \<Rightarrow> salpha" ("{_}")
  "_salphamk"    :: "logic \<Rightarrow> salpha"

text \<open> The terminals of an alphabet are either HOL identifiers or UTP variable identifiers.
  We support two ways of constructing alphabets; by composition of smaller alphabets using
  a semi-colon or by a set-style construction $\{a,b,c\}$ with a list of UTP variables. \<close>

syntax \<comment> \<open> Quotations \<close>
  "_ualpha_set"  :: "svars \<Rightarrow> logic" ("{_}\<^sub>\<alpha>")
  "_svar"        :: "svar \<Rightarrow> logic" ("'(_')\<^sub>v")

text \<open> For various reasons, the syntax constructors above all yield specific grammar categories and
  will not parser at the HOL top level (basically this is to do with us wanting to reuse the syntax
  for expressions). As a result we provide some quotation constructors above.

  Next we need to construct the syntax translations rules. First we need a few polymorphic constants. \<close>

consts
  svar :: "'v \<Rightarrow> 'e"
  ivar :: "'v \<Rightarrow> 'e"
  ovar :: "'v \<Rightarrow> 'e"

adhoc_overloading
  svar pr_var and ivar in_var and ovar out_var

text \<open> The functions above turn a representation of a variable (type @{typ "'v"}), including
  its name and type, into some lens type @{typ "'e"}. @{term "svar"} constructs a predicate variable,
  @{term "ivar"} and input variables, and @{term "ovar"} and output variable. The functions bridge
  between the model and encoding of the variable and its interpretation as a lens in order to integrate it
  into the general lens-based framework. Overriding these functions is then all we need to make
  use of any kind of variables in terms of interfacing it with the system. Although in core UTP
  variables are always modelled using record field, we can overload these constants to allow other
  kinds of variables, such as deep variables with explicit syntax and type information.

  Finally, we set up the translations rules. \<close>

translations
  \<comment> \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "\<Sigma>"
  "_svid_dot x y" \<rightharpoonup> "y ;\<^sub>L x"
  "_mk_svid_list (_svid_unit x)" \<rightharpoonup> "x"
  "_mk_svid_list (_svid_list x xs)" \<rightharpoonup> "x +\<^sub>L _mk_svid_list xs"

  \<comment> \<open> Decorations \<close>
  "_spvar \<Sigma>"  \<leftharpoondown>  "CONST svar CONST id_lens"
  "_sinvar \<Sigma>"  \<leftharpoondown> "CONST ivar 1\<^sub>L"
  "_soutvar \<Sigma>" \<leftharpoondown> "CONST ovar 1\<^sub>L"
  "_spvar (_svid_dot x y)" \<leftharpoondown> "CONST svar (CONST lens_comp y x)"
  "_sinvar (_svid_dot x y)" \<leftharpoondown> "CONST ivar (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" \<leftharpoondown> "CONST ovar (CONST lens_comp y x)"
  "_svid_dot (_svid_dot x y) z" \<leftharpoondown> "_svid_dot (CONST lens_comp y x) z"

  "_spvar x" \<rightleftharpoons> "CONST svar x"
  "_sinvar x" \<rightleftharpoons> "CONST ivar x"
  "_soutvar x" \<rightleftharpoons> "CONST ovar x"

  \<comment> \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphacomp x y" \<rightharpoonup> "x +\<^sub>L y"
  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b"
  "_salphavar x" \<rightharpoonup> "x"
  "_svar_nil x" \<rightharpoonup> "x"
  "_svar_cons x xs" \<rightharpoonup> "x +\<^sub>L xs"
  "_salphaset A" \<rightharpoonup> "A"
  "(_svar_cons x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"
  "_salpha_all" \<rightleftharpoons> "1\<^sub>L"
  "_salpha_none" \<rightleftharpoons> "0\<^sub>L"

  \<comment> \<open> Quotations \<close>
  "_ualpha_set A" \<rightharpoonup> "A"
  "_svar x" \<rightharpoonup> "x"

text \<open> The translation rules mainly convert syntax into lens constructions, using a mixture
  of lens operators and the bespoke variable definitions. Notably, a colon variable identifier
  qualification becomes a lens composition, and variable sets are constructed using len sum.
  The translation rules are carefully crafted to ensure both parsing and pretty printing.

  Finally we create the following useful utility translation function that allows us to construct a
  UTP variable (lens) type given a return and alphabet type. \<close>

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation \<open>
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax lens} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
\<close>

end


theory PLTL
  imports Main LTL.LTL Samplers StutterEquivalence
begin

section \<open>Stuttering Invariant LTL Formulas\<close>

text \<open>
  We show that the next-free fragment of propositional linear-time
  temporal logic PLTL is invariant to finite stuttering.
\<close>

subsection \<open>Finite Conjunctions and Disjunctions in PLTL\<close>

(* It would be tempting to define these operators as follows:

definition OR where "OR \<Phi> = Finite_Set.fold or false \<Phi>"
definition AND where "AND \<Phi> = Finite_Set.fold and true \<Phi>"

However, this would only work if "or" and "and" were left-commutative,
which they are not (syntactically). We must therefore resort to
the more general fold_graph predicate, effectively picking a
conjunction (or disjunction) in arbitrary order.

An alternative would be to define these generalized operators
over lists of formulas, but working with sets is more natural
in the following.
*)

definition OR where "OR \<Phi> \<equiv> SOME \<phi>. fold_graph Or_ltlp False_ltlp \<Phi> \<phi>"

definition AND where "AND \<Phi> \<equiv> SOME \<phi>. fold_graph And_ltlp True_ltlp \<Phi> \<phi>"

lemma fold_graph_OR: "finite \<Phi> \<Longrightarrow> fold_graph Or_ltlp False_ltlp \<Phi> (OR \<Phi>)"
  unfolding OR_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma fold_graph_AND: "finite \<Phi> \<Longrightarrow> fold_graph And_ltlp True_ltlp \<Phi> (AND \<Phi>)"
  unfolding AND_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma holds_of_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "(\<sigma> \<Turnstile>\<^sub>p OR \<Phi>) = (\<exists>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile>\<^sub>p \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph Or_ltlp False_ltlp \<Phi> \<psi>"
    hence "(\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<exists>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile>\<^sub>p \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma holds_of_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "(\<sigma> \<Turnstile>\<^sub>p AND \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile>\<^sub>p \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph And_ltlp True_ltlp \<Phi> \<psi>"
    hence "(\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<forall>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile>\<^sub>p \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

subsection \<open>Next-Free PLTL Formulas\<close>

text \<open>
  A PLTL formula is called \emph{next-free} if it does not contain any
  subformula.
\<close>

fun next_free :: "'a pltl \<Rightarrow> bool"
where
  "next_free false\<^sub>p = True"
| "next_free (atom\<^sub>p(p)) = True"
| "next_free (\<phi> implies\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
| "next_free (X\<^sub>p \<phi>) = False"
| "next_free (\<phi> U\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"

lemma next_free_not [simp]:
  "next_free (not\<^sub>p \<phi>) = next_free \<phi>"
  by (simp add: Not_ltlp_def)

lemma next_free_true [simp]:
  "next_free true\<^sub>p"
  by (simp add: True_ltlp_def)

lemma next_free_or [simp]:
  "next_free (\<phi> or\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (simp add: Or_ltlp_def)

lemma next_free_and [simp]: "next_free (\<phi> and\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (simp add: And_ltlp_def)

lemma next_free_eventually [simp]:
  "next_free (F\<^sub>p \<phi>) = next_free \<phi>"
  by (simp add: Eventually_ltlp_def)

lemma next_free_always [simp]:
  "next_free (G\<^sub>p \<phi>) = next_free \<phi>"
  by (simp add: Always_ltlp_def)

lemma next_free_release [simp]:
  "next_free (\<phi> R\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (simp add: Release_ltlp_def)

lemma next_free_weak_until [simp]:
  "next_free (\<phi> W\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (auto simp: WeakUntil_ltlp_def)

lemma next_free_strong_release [simp]:
  "next_free (\<phi> M\<^sub>p \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (auto simp: StrongRelease_ltlp_def)

lemma next_free_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "next_free (OR \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph Or_ltlp False_ltlp \<Phi> \<psi>"
    hence "next_free \<psi> = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma next_free_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "next_free (AND \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph And_ltlp True_ltlp \<Phi> \<psi>"
    hence "next_free \<psi> = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

subsection \<open>Stuttering Invariance of PLTL Without ``Next''\<close>

text \<open>
  A PLTL formula is \emph{stuttering invariant} if for any stuttering equivalent
  state sequences \<open>\<sigma> \<approx> \<tau>\<close>, the formula holds of \<open>\<sigma>\<close> iff it
  holds of \<open>\<tau>\<close>.
\<close>

definition stutter_invariant where
  "stutter_invariant \<phi> = (\<forall>\<sigma> \<tau>. (\<sigma> \<approx> \<tau>) \<longrightarrow> (\<sigma> \<Turnstile>\<^sub>p \<phi>) = (\<tau> \<Turnstile>\<^sub>p \<phi>))"

text \<open>
  Since stuttering equivalence is symmetric, it is enough to show an
  implication in the above definition instead of an equivalence.
\<close>

lemma stutter_invariantI [intro!]:
  assumes "\<And>\<sigma> \<tau>. \<lbrakk>\<sigma> \<approx> \<tau>; \<sigma> \<Turnstile>\<^sub>p \<phi>\<rbrakk> \<Longrightarrow> \<tau> \<Turnstile>\<^sub>p \<phi>"
  shows "stutter_invariant \<phi>"
proof -
  {
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and f: "\<sigma> \<Turnstile>\<^sub>p \<phi>"
    hence "\<tau> \<Turnstile>\<^sub>p \<phi>" by (rule assms)
  }
moreover
  {
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and f: "\<tau> \<Turnstile>\<^sub>p \<phi>"
    from st have "\<tau> \<approx> \<sigma>" by (rule stutter_equiv_sym)
    from this f have "\<sigma> \<Turnstile>\<^sub>p \<phi>" by (rule assms)
  }
ultimately show ?thesis by (auto simp: stutter_invariant_def)
qed

lemma stutter_invariantD [dest]:
  assumes "stutter_invariant \<phi>" and "\<sigma> \<approx> \<tau>"
  shows "(\<sigma> \<Turnstile>\<^sub>p \<phi>) = (\<tau> \<Turnstile>\<^sub>p \<phi>)"
  using assms by (auto simp: stutter_invariant_def)

text \<open>
  We first show that next-free PLTL formulas are indeed stuttering invariant.
  The proof proceeds by straightforward induction on the syntax of PLTL formulas.
\<close>
theorem next_free_stutter_invariant:
  "next_free \<phi> \<Longrightarrow> stutter_invariant (\<phi>::'a pltl)"
proof (induct "\<phi>")
    show "stutter_invariant false\<^sub>p" by auto
next
  fix p :: "'a \<Rightarrow> bool"
  show "stutter_invariant (atom\<^sub>p(p))"
  proof
    fix \<sigma> \<tau>
    assume "\<sigma> \<approx> \<tau>" "\<sigma> \<Turnstile>\<^sub>p atom\<^sub>p(p)"
    thus "\<tau> \<Turnstile>\<^sub>p atom\<^sub>p(p)" by (simp add: stutter_equiv_0)
  qed
next
  fix \<phi> \<psi> :: "'a pltl"
  assume ih: "next_free \<phi> \<Longrightarrow> stutter_invariant \<phi>"
             "next_free \<psi> \<Longrightarrow> stutter_invariant \<psi>"
  assume "next_free (\<phi> implies\<^sub>p \<psi>)"
  with ih show "stutter_invariant (\<phi> implies\<^sub>p \<psi>)" by auto
next
  fix \<phi> :: "'a pltl"
  assume "next_free (X\<^sub>p \<phi>)"  \<comment> \<open>hence contradiction\<close>
  thus "stutter_invariant (X\<^sub>p \<phi>)" by simp
next
  fix \<phi> \<psi> :: "'a pltl"
  assume ih: "next_free \<phi> \<Longrightarrow> stutter_invariant \<phi>"
             "next_free \<psi> \<Longrightarrow> stutter_invariant \<psi>"
  assume "next_free (\<phi> U\<^sub>p \<psi>)"
  with ih have stinv: "stutter_invariant \<phi>" "stutter_invariant \<psi>" by auto
  show "stutter_invariant (\<phi> U\<^sub>p \<psi>)"
  proof
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and unt: "\<sigma> \<Turnstile>\<^sub>p \<phi> U\<^sub>p \<psi>"
    from unt obtain m
      where 1: "\<sigma>[m..] \<Turnstile>\<^sub>p \<psi>" and 2: "\<forall>j<m. (\<sigma>[j..] \<Turnstile>\<^sub>p \<phi>)" by auto
    from st obtain n
      where 3: "(\<sigma>[m..]) \<approx> (\<tau>[n..])" and 4: "\<forall>i<n. \<exists>j<m. (\<sigma>[j..]) \<approx> (\<tau>[i..])"
      by (rule stutter_equiv_suffixes_right)
    from 1 3 stinv have "\<tau>[n..] \<Turnstile>\<^sub>p \<psi>" by auto
    moreover
    from 2 4 stinv have "\<forall>i<n. (\<tau>[i..] \<Turnstile>\<^sub>p \<phi>)" by force
    ultimately show "\<tau> \<Turnstile>\<^sub>p \<phi> U\<^sub>p \<psi>" by auto
  qed
qed

subsection \<open>Atoms, Canonical State Sequences, and Characteristic Formulas\<close>

text \<open>
  We now address the converse implication: any stutter invariant PLTL
  formula \<open>\<phi>\<close> can be equivalently expressed by a next-free formula.
  The construction of that formula requires attention to the atomic
  formulas that appear in \<open>\<phi>\<close>. We will also prove that the
  next-free formula does not need any new atoms beyond those present
  in \<open>\<phi>\<close>.

  The following function collects the atoms (of type \<open>'a \<Rightarrow> bool\<close>)
  of a PLTL formula.
\<close>

lemma atoms_pltl_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "atoms_pltl (OR \<Phi>) = (\<Union>\<phi>\<in>\<Phi>. atoms_pltl \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph Or_ltlp False_ltlp \<Phi> \<psi>"
    hence "atoms_pltl \<psi> = (\<Union>\<phi>\<in>\<Phi>. atoms_pltl \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma atoms_pltl_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "atoms_pltl (AND \<Phi>) = (\<Union>\<phi>\<in>\<Phi>. atoms_pltl \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph And_ltlp True_ltlp \<Phi> \<psi>"
    hence "atoms_pltl \<psi> = (\<Union>\<phi>\<in>\<Phi>. atoms_pltl \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

text \<open>
  Given a set of atoms \<open>A\<close> as above, we say that two states
  are \<open>A\<close>-similar if they agree on all atoms in \<open>A\<close>.
  Two state sequences \<open>\<sigma>\<close> and \<open>\<tau>\<close> are \<open>A\<close>-similar
  if corresponding states are \<open>A\<close>-equal.
\<close>

definition state_sim :: "['a, ('a \<Rightarrow> bool) set, 'a] \<Rightarrow> bool"
  ("_ ~_~ _" [70,100,70] 50) where
  "s ~A~ t = (\<forall>p\<in>A. p s \<longleftrightarrow> p t)"

definition seq_sim :: "[nat \<Rightarrow> 'a, ('a \<Rightarrow> bool) set, nat \<Rightarrow> 'a] \<Rightarrow> bool"
  ("_ \<simeq>_\<simeq> _" [70,100,70] 50)  where
  "\<sigma> \<simeq>A\<simeq> \<tau> = (\<forall>n. (\<sigma> n) ~A~ (\<tau> n))"

text \<open>
  These relations are (indexed) equivalence relations. Moreover
  \<open>s ~A~ t\<close> implies \<open>s ~B~ t\<close> for \<open>B \<subseteq> A\<close>,
  and similar for \<open>\<sigma> \<simeq>A\<simeq> \<tau>\<close> and \<open>\<sigma> \<simeq>B\<simeq> \<tau>\<close>.
\<close>

lemma state_sim_refl [simp]: "s ~A~ s"
  by (simp add: state_sim_def)

lemma state_sim_sym: "s ~A~ t \<Longrightarrow> t ~A~ s"
  by (auto simp: state_sim_def)

lemma state_sim_trans[trans]: "s ~A~ t \<Longrightarrow> t ~A~ u \<Longrightarrow> s ~A~ u"
  unfolding state_sim_def by blast

lemma state_sim_mono:
  assumes "s ~A~ t" and "B \<subseteq> A"
  shows "s ~B~ t"
  using assms unfolding state_sim_def by auto

lemma seq_sim_refl [simp]: "\<sigma> \<simeq>A\<simeq> \<sigma>"
  by (simp add: seq_sim_def)

lemma seq_sim_sym: "\<sigma> \<simeq>A\<simeq> \<tau> \<Longrightarrow> \<tau> \<simeq>A\<simeq> \<sigma>"
  by (auto simp: seq_sim_def state_sim_sym)

lemma seq_sim_trans[trans]: "\<rho> \<simeq>A\<simeq> \<sigma> \<Longrightarrow> \<sigma> \<simeq>A\<simeq> \<tau> \<Longrightarrow> \<rho> \<simeq>A\<simeq> \<tau>"
  unfolding seq_sim_def by (blast intro: state_sim_trans)

lemma seq_sim_mono:
  assumes "\<sigma> \<simeq>A\<simeq> \<tau>" and "B \<subseteq> A"
  shows "\<sigma> \<simeq>B\<simeq> \<tau>"
  using assms unfolding seq_sim_def by (blast intro: state_sim_mono)

text \<open>
  State sequences that are similar w.r.t. the atoms of a PLTL formula
  evaluate that formula to the same value.
\<close>

lemma pltl_seq_sim: "\<sigma> \<simeq> atoms_pltl \<phi> \<simeq> \<tau> \<Longrightarrow> (\<sigma> \<Turnstile>\<^sub>p \<phi>) = (\<tau> \<Turnstile>\<^sub>p \<phi>)"
  (is "?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>")
proof (induct \<phi> arbitrary: \<sigma> \<tau>)
  fix \<sigma> \<tau>
  show "?P \<sigma> false\<^sub>p \<tau>" by simp
next
  fix p \<sigma> \<tau>
  assume "?sim \<sigma> (atom\<^sub>p(p)) \<tau>" thus "?P \<sigma> (atom\<^sub>p(p)) \<tau>"
    by (auto simp: seq_sim_def state_sim_def)
next
  fix \<phi> \<psi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
             "\<And>\<sigma> \<tau>. ?sim \<sigma> \<psi> \<tau> \<Longrightarrow> ?P \<sigma> \<psi> \<tau>"
     and sim: "?sim \<sigma> (\<phi> implies\<^sub>p \<psi>) \<tau>"
  from sim have "?sim \<sigma> \<phi> \<tau>" "?sim \<sigma> \<psi> \<tau>"
    by (auto elim: seq_sim_mono)
  with ih show "?P \<sigma> (\<phi> implies\<^sub>p \<psi>) \<tau>" by simp
next
  fix \<phi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
     and sim: "\<sigma> \<simeq> atoms_pltl (X\<^sub>p \<phi>) \<simeq> \<tau>"
  from sim have "(\<sigma>[1..]) \<simeq> atoms_pltl \<phi> \<simeq> (\<tau>[1..])"
    by (auto simp: seq_sim_def)
  with ih show "?P \<sigma> (X\<^sub>p \<phi>) \<tau>" by auto
next
  fix \<phi> \<psi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
             "\<And>\<sigma> \<tau>. ?sim \<sigma> \<psi> \<tau> \<Longrightarrow> ?P \<sigma> \<psi> \<tau>"
     and sim: "?sim \<sigma> (\<phi> U\<^sub>p \<psi>) \<tau>"
  from sim have "\<forall>i. (\<sigma>[i..]) \<simeq> atoms_pltl \<phi> \<simeq> (\<tau>[i..])" "\<forall>j. (\<sigma>[j..]) \<simeq> atoms_pltl \<psi> \<simeq> (\<tau>[j..])"
    by (auto simp: seq_sim_def state_sim_def)
  with ih have "\<forall>i. ?P (\<sigma>[i..]) \<phi> (\<tau>[i..])" "\<forall>j. ?P (\<sigma>[j..]) \<psi> (\<tau>[j..])"
    by blast+
  thus "?P \<sigma> (\<phi> U\<^sub>p \<psi>) \<tau>"
    by (meson semantics_pltl.simps(5))
qed

text \<open>
  The following function picks an arbitrary representative among
  \<open>A\<close>-similar states. Because the choice is functional,
  any two \<open>A\<close>-similar states are mapped to the same state.
\<close>

definition canonize where
  "canonize A s \<equiv> SOME t. t ~A~ s"

lemma canonize_state_sim: "canonize A s ~A~ s"
  unfolding canonize_def by (rule someI, rule state_sim_refl)

lemma canonize_canonical:
  assumes st: "s ~A~ t"
  shows "canonize A s = canonize A t"
proof -
  from st have "\<forall>u. (u ~A~s) = (u ~A~ t)"
    by (auto elim: state_sim_sym state_sim_trans)
  thus ?thesis unfolding canonize_def by simp
qed

lemma canonize_idempotent:
  "canonize A (canonize A s) = canonize A s"
  by (rule canonize_canonical[OF canonize_state_sim])

text \<open>
  In a canonical state sequence, any two \<open>A\<close>-similar states
  are in fact equal.
\<close>

definition canonical_sequence where
  "canonical_sequence A \<sigma> \<equiv> \<forall>m (n::nat). \<sigma> m ~A~ \<sigma> n \<longrightarrow> \<sigma> m = \<sigma> n"

text \<open>
  Every suffix of a canonical sequence is canonical, as is any
  (sampled) subsequence, in particular any stutter-sampling.
\<close>

lemma canonical_suffix:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<sigma>[k..])"
  by (auto simp: canonical_sequence_def)

lemma canonical_sampled:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<sigma> \<circ> f)"
  by (auto simp: canonical_sequence_def)

lemma canonical_reduced:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<natural>\<sigma>)"
  unfolding stutter_reduced_def by (rule canonical_sampled)

text \<open>
  For any sequence \<open>\<sigma>\<close> there exists a canonical
  \<open>A\<close>-similar sequence \<open>\<tau>\<close>. Such a \<open>\<tau>\<close>
  can be obtained by canonizing all states of \<open>\<sigma>\<close>.
\<close>

lemma canonical_exists:
  obtains \<tau> where "\<tau> \<simeq>A\<simeq> \<sigma>" "canonical_sequence A \<tau>"
proof -
  have "(canonize A \<circ> \<sigma>) \<simeq>A\<simeq> \<sigma>"
    by (simp add: seq_sim_def canonize_state_sim)
  moreover
  have "canonical_sequence A (canonize A \<circ> \<sigma>)"
    by (auto simp: canonical_sequence_def canonize_idempotent
             dest: canonize_canonical)
  ultimately
  show ?thesis using that by blast
qed

text \<open>
  Given a state \<open>s\<close> and a set \<open>A\<close> of atoms, we define
  the characteristic formula of \<open>s\<close> as the conjunction of
  all atoms in \<open>A\<close> that hold of \<open>s\<close> and the negation of
  the atoms in \<open>A\<close> that do not hold of \<open>s\<close>.
\<close>

definition characteristic_formula where
  "characteristic_formula A s \<equiv>
   ((AND { atom\<^sub>p(p) | p . p \<in> A \<and> p s }) and\<^sub>p (AND { not\<^sub>p (atom\<^sub>p(p)) | p . p \<in> A \<and> \<not>(p s) }))"

lemma characteristic_holds:
  "finite A \<Longrightarrow> \<sigma> \<Turnstile>\<^sub>p characteristic_formula A (\<sigma> 0)"
  by (auto simp: characteristic_formula_def)

lemma characteristic_state_sim:
  assumes fin: "finite A"
  shows "(\<sigma> 0 ~A~ \<tau> 0) = (\<tau> \<Turnstile>\<^sub>p characteristic_formula A (\<sigma> (0::nat)))"
proof
  assume sim: "\<sigma> 0 ~A~ \<tau> 0"
  {
    fix p
    assume "p \<in> A"
    with sim have "p (\<tau> 0) = p (\<sigma> 0)" by (auto simp: state_sim_def)
  }
  with fin show "\<tau> \<Turnstile>\<^sub>p characteristic_formula A (\<sigma> 0)"
    by (auto simp: characteristic_formula_def) (blast+)
next
  assume "\<tau> \<Turnstile>\<^sub>p characteristic_formula A (\<sigma> 0)"
  with fin show "\<sigma> 0 ~A~ \<tau> 0"
    by (auto simp: characteristic_formula_def state_sim_def)
qed

subsection \<open>Stuttering Invariant PLTL Formulas Don't Need Next\<close>

text \<open>
  The following is the main lemma used in the proof of the
  completeness theorem: for any PLTL formula \<open>\<phi>\<close> there
  exists a next-free formula \<open>\<psi>\<close> such that the two
  formulas evaluate to the same value over stutter-free and
  canonical sequences (w.r.t. some \<open>A \<supseteq> atoms_pltl \<phi>\<close>).
\<close>

lemma ex_next_free_stutter_free_canonical:
  assumes A: "atoms_pltl \<phi> \<subseteq> A" and fin: "finite A"
  shows "\<exists>\<psi>. next_free \<psi> \<and> atoms_pltl \<psi> \<subseteq> A \<and>
             (\<forall>\<sigma>. stutter_free \<sigma> \<and> canonical_sequence A \<sigma> \<longrightarrow> (\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<sigma> \<Turnstile>\<^sub>p \<phi>))"
    (is "\<exists>\<psi>. ?P \<phi> \<psi>")
using A proof (induct \<phi>)
  txt \<open>The cases of \<open>false\<close> and atomic formulas are trivial.\<close>
  have "?P false\<^sub>p false\<^sub>p" by auto
  thus "\<exists>\<psi>. ?P false\<^sub>p \<psi>" ..
next
  fix p
  assume "atoms_pltl (atom\<^sub>p(p)) \<subseteq> A"
  hence "?P (atom\<^sub>p(p)) (atom\<^sub>p(p))" by auto
  thus "\<exists>\<psi>. ?P (atom\<^sub>p(p)) \<psi>" ..
next
  txt \<open>Implication is easy, using the induction hypothesis.\<close>
  fix \<phi> \<psi>
  assume "atoms_pltl \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<phi>'. ?P \<phi> \<phi>'"
     and "atoms_pltl \<psi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>'. ?P \<psi> \<psi>'"
     and "atoms_pltl (\<phi> implies\<^sub>p \<psi>) \<subseteq> A"
  then obtain \<phi>' \<psi>' where "?P \<phi> \<phi>'" "?P \<psi> \<psi>'" by auto
  hence "?P (\<phi> implies\<^sub>p \<psi>) (\<phi>' implies\<^sub>p \<psi>')" by auto
  thus "\<exists>\<chi>. ?P (\<phi> implies\<^sub>p \<psi>) \<chi>" ..
next
  txt \<open>The case of \<open>until\<close> follows similarly.\<close>
  fix \<phi> \<psi>
  assume "atoms_pltl \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<phi>'. ?P \<phi> \<phi>'"
     and "atoms_pltl \<psi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>'. ?P \<psi> \<psi>'"
     and "atoms_pltl (\<phi> U\<^sub>p \<psi>) \<subseteq> A"
  then obtain \<phi>' \<psi>' where 1: "?P \<phi> \<phi>'" and 2: "?P \<psi> \<psi>'" by auto
  {
    fix \<sigma>
    assume sigma: "stutter_free \<sigma>" "canonical_sequence A \<sigma>"
    hence "\<And>k. stutter_free (\<sigma>[k..])" "\<And>k. canonical_sequence A (\<sigma>[k..])"
      by (auto simp: stutter_free_suffix canonical_suffix)
    with 1 2
    have "\<And>k. (\<sigma>[k..] \<Turnstile>\<^sub>p \<phi>') = (\<sigma>[k..] \<Turnstile>\<^sub>p \<phi>)"
     and "\<And>k. (\<sigma>[k..] \<Turnstile>\<^sub>p \<psi>') = (\<sigma>[k..] \<Turnstile>\<^sub>p \<psi>)"
      by (blast+)
    hence "(\<sigma> \<Turnstile>\<^sub>p \<phi>' U\<^sub>p \<psi>') = (\<sigma> \<Turnstile>\<^sub>p \<phi> U\<^sub>p \<psi>)"
      by auto
  }
  with 1 2 have "?P (\<phi> U\<^sub>p \<psi>) (\<phi>' U\<^sub>p \<psi>')" by auto
  thus "\<exists>\<chi>. ?P (\<phi> U\<^sub>p \<psi>) \<chi>" ..
next
  txt \<open>The interesting case is the one of the \<open>next\<close>-operator.\<close>
  fix \<phi>
  assume ih: "atoms_pltl \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>. ?P \<phi> \<psi>" and at: "atoms_pltl (X\<^sub>p \<phi>) \<subseteq> A"
  then obtain \<psi> where psi: "?P \<phi> \<psi>" by auto
  txt \<open>A valuation (over \<open>A\<close>) is a set \<open>val \<subseteq> A\<close> of atoms. We
    define some auxiliary notions: the valuation corresponding to a state and
    the characteristic formula for a valuation. Finally, we define the formula
    \<open>psi'\<close> that we will prove to be equivalent to \<open>X\<^sub>p \<phi>\<close> over
    the stutter-free and canonical sequence \<open>\<sigma>\<close>.\<close>
  define stval where "stval = (\<lambda>s. { p \<in> A . p s })"
  define chi where "chi = (\<lambda>val. ((AND {atom\<^sub>p(p) | p . p \<in> val}) and\<^sub>p
                        (AND {not\<^sub>p (atom\<^sub>p(p)) | p . p \<in> A - val})))"
  define psi' where "psi' = ((\<psi> and\<^sub>p (OR {G\<^sub>p (chi val) | val . val \<subseteq> A })) or\<^sub>p
                  (OR {(chi val) and\<^sub>p ((chi val) U\<^sub>p ( \<psi> and\<^sub>p (chi val'))) | val val'.
                        val \<subseteq> A \<and> val' \<subseteq> A \<and> val' \<noteq> val }))"
        (is "_ = (( _ and\<^sub>p (OR ?ALW)) or\<^sub>p (OR ?UNT))")

  have "\<And>s. {not\<^sub>p (atom\<^sub>p(p)) | p . p \<in> A - stval s}
           = {not\<^sub>p (atom\<^sub>p(p)) | p . p \<in> A \<and> \<not>(p s)}"
    by (auto simp: stval_def)
  hence chi1: "\<And>s. chi (stval s) = characteristic_formula A s"
    by (auto simp: chi_def stval_def characteristic_formula_def)
  {
    fix val \<tau>
    assume val: "val \<subseteq> A" and tau: "\<tau> \<Turnstile>\<^sub>p chi val"
    with fin have "val = stval (\<tau> 0)"
      by (auto simp: stval_def chi_def finite_subset)
  }
  note chi2 = this

  have "?UNT \<subseteq> (\<lambda>(val,val'). (chi val) and\<^sub>p ((chi val) U\<^sub>p (\<psi> and\<^sub>p (chi val'))))
               ` (Pow A \<times> Pow A)"
    (is "_ \<subseteq> ?S")
    by auto
  with fin have fin_UNT: "finite ?UNT"
    by (auto simp: finite_subset)

  have nf: "next_free psi'"
  proof -
    from fin have "\<And>val. val \<subseteq> A \<Longrightarrow> next_free (chi val)"
      by (auto simp: chi_def finite_subset)
    with fin fin_UNT psi show ?thesis
      by (force simp: psi'_def finite_subset)
  qed

  have atoms_pltl: "atoms_pltl psi' \<subseteq> A"
  proof -
    from fin have at_chi: "\<And>val. val \<subseteq> A \<Longrightarrow> atoms_pltl (chi val) \<subseteq> A"
      by (auto simp: chi_def finite_subset)
    with fin psi have at_alw: "atoms_pltl (\<psi> and\<^sub>p (OR ?ALW)) \<subseteq> A"
      by auto blast?    (** FRAGILE: auto leaves trivial goal about subset **)
    from fin fin_UNT psi at_chi have "atoms_pltl (OR ?UNT) \<subseteq> A"
      by auto (blast+)? (** FRAGILE: even more left-over goals here **)
    with at_alw show ?thesis by (auto simp: psi'_def)
  qed

  {
    fix \<sigma>
    assume st: "stutter_free \<sigma>" and can: "canonical_sequence A \<sigma>"
    have "(\<sigma> \<Turnstile>\<^sub>p X\<^sub>p \<phi>) = (\<sigma> \<Turnstile>\<^sub>p psi')"
    proof (cases "\<sigma> (Suc 0) = \<sigma> 0")
      case True
      txt \<open>In the case of a stuttering transition at the beginning, we must have
        infinite stuttering, and the first disjunct of \<open>psi'\<close> holds,
        whereas the second does not.\<close>
      {
        fix n
        have "\<sigma> n = \<sigma> 0"
        proof (cases n)
          case 0 thus ?thesis by simp
        next
          case Suc
          hence "n > 0" by simp
          with True st show ?thesis unfolding stutter_free_def by blast
        qed
      }
      note alleq = this
      have suffix: "\<And>n. \<sigma>[n..] = \<sigma>"
      proof (rule ext)
        fix n i
        have "(\<sigma>[n..]) i = \<sigma> 0" by (auto intro: alleq)
        moreover have "\<sigma> i = \<sigma> 0" by (rule alleq)
        ultimately show "(\<sigma>[n..]) i = \<sigma> i" by simp
      qed
      with st can psi have 1: "(\<sigma> \<Turnstile>\<^sub>p X\<^sub>p \<phi>) = (\<sigma> \<Turnstile>\<^sub>p \<psi>)" by simp

      from fin have "\<sigma> \<Turnstile>\<^sub>p chi (stval (\<sigma> 0))" by (simp add: chi1 characteristic_holds)
      with suffix have "\<sigma> \<Turnstile>\<^sub>p G\<^sub>p (chi (stval (\<sigma> 0)))" (is "_ \<Turnstile>\<^sub>p ?alw") by simp
      moreover have "?alw \<in> ?ALW" by (auto simp: stval_def)
      ultimately have 2: "\<sigma> \<Turnstile>\<^sub>p OR ?ALW"
        using fin by (auto simp: finite_subset simp del: semantics_pltl_sugar)

      have 3: "\<not>(\<sigma> \<Turnstile>\<^sub>p OR ?UNT)"
      proof
        assume unt: "\<sigma> \<Turnstile>\<^sub>p OR ?UNT"
        with fin_UNT obtain val val' k where
          val: "val \<subseteq> A" "val' \<subseteq> A" "val' \<noteq> val" and
          now: "\<sigma> \<Turnstile>\<^sub>p chi val" and k: "\<sigma>[k..] \<Turnstile>\<^sub>p chi val'"
          by auto (blast+)?  (* FRAGILE: similar as above *)
        from \<open>val \<subseteq> A\<close> now have "val = stval (\<sigma> 0)" by (rule chi2)
        moreover
        from \<open>val' \<subseteq> A\<close> k suffix have "val' = stval (\<sigma> 0)" by (simp add: chi2)
        moreover note \<open>val' \<noteq> val\<close>
        ultimately show "False" by simp
      qed

      from 1 2 3 show ?thesis by (simp add: psi'_def)

    next
      case False
      txt \<open>Otherwise, \<open>\<sigma> \<Turnstile>\<^sub>p X\<^sub>p \<phi>\<close> is equivalent to \<open>\<sigma>\<close> satisfying
        the second disjunct of \<open>psi'\<close>. We show both implications separately.\<close>
      let ?val = "stval (\<sigma> 0)"
      let ?val' = "stval (\<sigma> 1)"
      from False can have vals: "?val' \<noteq> ?val"
        by (auto simp: canonical_sequence_def state_sim_def stval_def)

      show ?thesis
      proof
        assume phi: "\<sigma> \<Turnstile>\<^sub>p X\<^sub>p \<phi>"
        from fin have 1: "\<sigma> \<Turnstile>\<^sub>p chi ?val" by (simp add: chi1 characteristic_holds)

        from st can have "stutter_free (\<sigma>[1..])" "canonical_sequence A (\<sigma>[1..])"
          by (auto simp: stutter_free_suffix canonical_suffix)
        with phi psi have 2: "\<sigma>[1..] \<Turnstile>\<^sub>p \<psi>" by auto

        from fin have "\<sigma>[1..] \<Turnstile>\<^sub>p characteristic_formula A ((\<sigma>[1..]) 0)"
          by (rule characteristic_holds)
        hence 3: "\<sigma>[1..] \<Turnstile>\<^sub>p chi ?val'" by (simp add: chi1)

        from 1 2 3 have "\<sigma> \<Turnstile>\<^sub>p And_ltlp (chi ?val) ((chi ?val) U\<^sub>p (And_ltlp \<psi> (chi ?val')))"
          (is "_ \<Turnstile>\<^sub>p ?unt")
          by auto
        moreover from vals have "?unt \<in> ?UNT"
          by (auto simp: stval_def)
        ultimately have "\<sigma> \<Turnstile>\<^sub>p OR ?UNT"
          using fin_UNT[THEN holds_of_OR] by blast
        thus "\<sigma> \<Turnstile>\<^sub>p psi'" by (simp add: psi'_def)

      next
        assume psi': "\<sigma> \<Turnstile>\<^sub>p psi'"
        have "\<not>(\<sigma> \<Turnstile>\<^sub>p OR ?ALW)"
        proof
          assume "\<sigma> \<Turnstile>\<^sub>p OR ?ALW"
          with fin obtain val where 1: "val \<subseteq> A" and 2: "\<forall>n. (\<sigma>[n..] \<Turnstile>\<^sub>p chi val)"
            by (force simp: finite_subset)
          from 2 have "\<sigma>[0..] \<Turnstile>\<^sub>p chi val" ..
          with 1 have "val = ?val" by (simp add: chi2)
          moreover
          from 2 have "\<sigma>[1..] \<Turnstile>\<^sub>p chi val" ..
          with 1 have "val = ?val'" by (force dest: chi2)
          ultimately
          show "False" using vals by simp
        qed
        with psi' have "\<sigma> \<Turnstile>\<^sub>p OR ?UNT" by (simp add: psi'_def)
        with fin_UNT obtain val val' k where
          val: "val \<subseteq> A" "val' \<subseteq> A" "val' \<noteq> val" and
          now: "\<sigma> \<Turnstile>\<^sub>p chi val" and
          k: "\<sigma>[k..] \<Turnstile>\<^sub>p \<psi>" "\<sigma>[k..] \<Turnstile>\<^sub>p chi val'" and
          i: "\<forall>i<k. (\<sigma>[i..] \<Turnstile>\<^sub>p chi val)"
          by auto (blast+)?  (* FRAGILE: similar as above *)

        from val now have 1: "val = ?val" by (simp add: chi2)

        have 2: "k \<noteq> 0"
        proof
          assume "k=0"
          with val k have "val' = ?val" by (simp add: chi2)
          with 1 \<open>val' \<noteq> val\<close> show "False" by simp
        qed

        have 3: "k \<le> 1"
        proof (rule ccontr)
          assume "\<not>(k \<le> 1)"
          with i have "\<sigma>[1..] \<Turnstile>\<^sub>p chi val" by simp
          with 1 have "\<sigma>[1..] \<Turnstile>\<^sub>p characteristic_formula A (\<sigma> 0)"
            by (simp add: chi1)
          hence "(\<sigma> 0) ~A~ ((\<sigma>[1..]) 0)"
            using characteristic_state_sim[OF fin] by blast
          with can have "\<sigma> 0 = \<sigma> 1"
            by (simp add: canonical_sequence_def)
          with \<open>\<sigma> (Suc 0) \<noteq> \<sigma> 0\<close> show "False" by simp
        qed

        from 2 3 have "k=1" by simp
        moreover
        from st can have "stutter_free (\<sigma>[1..])" "canonical_sequence A (\<sigma>[1..])"
          by (auto simp: stutter_free_suffix canonical_suffix)
        ultimately show "\<sigma> \<Turnstile>\<^sub>p X\<^sub>p \<phi>" using \<open>\<sigma>[k..] \<Turnstile>\<^sub>p \<psi>\<close> psi by auto
      qed
    qed
  }
  with nf atoms_pltl show "\<exists>\<psi>'. ?P (X\<^sub>p \<phi>) \<psi>'" by blast
qed

text \<open>
  Comparing the definition of the next-free formula in the case of
  formulas \<open>X\<^sub>p \<phi>\<close> with the one that appears in~\cite{peled:ltl-x},
  there is a subtle difference. Peled and Wilke define the second disjunct as
  a disjunction of formulas
%
  \begin{center}\(
    \<open>(chi val) U\<^sub>p (\<psi> and\<^sub>p (chi val'))\<close>
  \)\end{center}
%
  for subsets \<open>val, val' \<subseteq> A\<close> whereas we conjoin the formula
  \<open>chi val\<close> to the ``until'' formula. This conjunct is indeed
  necessary in order to rule out the case of the ``until'' formula
  being true because of \<open>chi val'\<close> being true immediately.
  The subtle error in the definition of the formula was acknowledged
  by Peled and Wilke and apparently had not been noticed since the
  publication of~\cite{peled:ltl-x} in 1996 (which has been cited more
  than a hundred times according to Google Scholar). Although the error
  was corrected easily, the fact that authors, reviewers, and readers
  appear to have missed it for so long underscores the usefulness of
  formal proofs.

  We now show that any stuttering invariant PLTL formula
  can be expressed without the \<open>X\<^sub>p\<close> operator.
\<close>

theorem stutter_invariant_next_free:
  assumes phi: "stutter_invariant \<phi>"
  obtains \<psi> where "next_free \<psi>" "atoms_pltl \<psi> \<subseteq> atoms_pltl \<phi>"
                  "\<forall>\<sigma>. (\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<sigma> \<Turnstile>\<^sub>p \<phi>)"
proof -
  have "atoms_pltl \<phi> \<subseteq> atoms_pltl \<phi>" "finite (atoms_pltl \<phi>)" by simp_all
  then obtain \<psi> where
    psi: "next_free \<psi>" "atoms_pltl \<psi> \<subseteq> atoms_pltl \<phi>" and
    equiv: "\<forall>\<sigma>. stutter_free \<sigma> \<and> canonical_sequence (atoms_pltl \<phi>) \<sigma> \<longrightarrow> (\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<sigma> \<Turnstile>\<^sub>p \<phi>)"
    by (blast dest: ex_next_free_stutter_free_canonical)
  from \<open>next_free \<psi>\<close> have sinv: "stutter_invariant \<psi>"
    by (rule next_free_stutter_invariant)
  {
    fix \<sigma>
    obtain \<tau> where 1: "\<tau> \<simeq> atoms_pltl \<phi> \<simeq> \<sigma>" and 2: "canonical_sequence (atoms_pltl \<phi>) \<tau>"
      by (rule canonical_exists)
    from 1 \<open>atoms_pltl \<psi> \<subseteq> atoms_pltl \<phi>\<close> have 3: "\<tau> \<simeq> atoms_pltl \<psi> \<simeq> \<sigma>"
      by (rule seq_sim_mono)

    from 1 have "(\<sigma> \<Turnstile>\<^sub>p \<phi>) = (\<tau> \<Turnstile>\<^sub>p \<phi>)" by (simp add: pltl_seq_sim)
    also from phi stutter_reduced_equivalent have "... = (\<natural>\<tau> \<Turnstile>\<^sub>p \<phi>)" by auto
    also from 2[THEN canonical_reduced] equiv stutter_reduced_stutter_free
    have "... = (\<natural>\<tau> \<Turnstile>\<^sub>p \<psi>)" by auto
    also from sinv stutter_reduced_equivalent have "... = (\<tau> \<Turnstile>\<^sub>p \<psi>)" by auto
    also from 3 have "... = (\<sigma> \<Turnstile>\<^sub>p \<psi>)" by (simp add: pltl_seq_sim)
    finally have "(\<sigma> \<Turnstile>\<^sub>p \<psi>) = (\<sigma> \<Turnstile>\<^sub>p \<phi>)" by (rule sym)
  }
  with psi that show ?thesis by blast
qed

text \<open>
  Combining theorems \<open>next_free_stutter_invariant\<close> and
  \<open>stutter_invariant_next_free\<close>, it follows that a PLTL
  formula is stuttering invariant iff it is equivalent to a next-free
  formula.
\<close>

theorem pltl_stutter_invariant:
  "stutter_invariant \<phi> \<longleftrightarrow>
   (\<exists>\<psi>. next_free \<psi> \<and> atoms_pltl \<psi> \<subseteq> atoms_pltl \<phi> \<and> (\<forall>\<sigma>. \<sigma> \<Turnstile>\<^sub>p \<psi> \<longleftrightarrow> \<sigma> \<Turnstile>\<^sub>p \<phi>))"
proof -
  {
    assume "stutter_invariant \<phi>"
    hence "\<exists>\<psi>. next_free \<psi> \<and> atoms_pltl \<psi> \<subseteq> atoms_pltl \<phi> \<and> (\<forall>\<sigma>. \<sigma> \<Turnstile>\<^sub>p \<psi> \<longleftrightarrow> \<sigma> \<Turnstile>\<^sub>p \<phi>)"
      by (rule stutter_invariant_next_free) blast
  }
  moreover
  {
    fix \<psi>
    assume 1: "next_free \<psi>" and 2: "\<forall>\<sigma>. \<sigma> \<Turnstile>\<^sub>p \<psi> \<longleftrightarrow> \<sigma> \<Turnstile>\<^sub>p \<phi>"
    from 1 have "stutter_invariant \<psi>" by (rule next_free_stutter_invariant)
    with 2 have "stutter_invariant \<phi>" by blast
  }
  ultimately show ?thesis by blast
qed

subsection \<open>Stutter Invariance for LTL with Syntactic Sugar\<close>

text \<open>We lift the results for PLTL to an extensive version of LTL.\<close>

primrec ltlc_next_free :: "'a ltlc \<Rightarrow> bool"
  where
    "ltlc_next_free true\<^sub>c = True"
  | "ltlc_next_free false\<^sub>c = True"
  | "ltlc_next_free (prop\<^sub>c(q)) = True"
  | "ltlc_next_free (not\<^sub>c \<phi>) = ltlc_next_free \<phi>"
  | "ltlc_next_free (\<phi> and\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (\<phi> or\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (\<phi> implies\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (X\<^sub>c \<phi>) = False"
  | "ltlc_next_free (F\<^sub>c \<phi>) = ltlc_next_free \<phi>"
  | "ltlc_next_free (G\<^sub>c \<phi>) = ltlc_next_free \<phi>"
  | "ltlc_next_free (\<phi> U\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (\<phi> R\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (\<phi> W\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"
  | "ltlc_next_free (\<phi> M\<^sub>c \<psi>) = (ltlc_next_free \<phi> \<and> ltlc_next_free \<psi>)"

lemma ltlc_next_free_iff[simp]: "next_free (ltlc_to_pltl \<phi>) \<longleftrightarrow> ltlc_next_free \<phi>"
  by (induction \<phi>) auto

text \<open>A next free formula cannot distinguish between stutter-equivalent runs.\<close>

theorem ltlc_next_free_stutter_invariant:
  assumes next_free: "ltlc_next_free \<phi>"
  assumes eq: "r \<approx> r'"
  shows "r \<Turnstile>\<^sub>c \<phi> \<longleftrightarrow> r' \<Turnstile>\<^sub>c \<phi>"
proof -
  {
    fix r r'
    assume eq: "r \<approx> r'" and holds: "r \<Turnstile>\<^sub>c \<phi>"
    then have "r \<Turnstile>\<^sub>p (ltlc_to_pltl \<phi>)"by simp

    from next_free_stutter_invariant[of "ltlc_to_pltl \<phi>"] next_free
    have "PLTL.stutter_invariant (ltlc_to_pltl \<phi>)" by simp
    from stutter_invariantD[OF this eq] holds have "r' \<Turnstile>\<^sub>c \<phi>" by simp
  } note aux=this

  from aux[of r r'] aux[of r' r] eq stutter_equiv_sym[OF eq] show ?thesis
    by blast
qed

end


(* Copyright 2020 (C) Mihails Milehins *)

section\<open>Ordinal numbers\<close>
theory CZH_ECAT_Ordinal
  imports CZH_ECAT_Small_Order
begin

subsection\<open>Background\<close>

text\<open>
The content of this section is based on the treatment of the ordinal numbers
from the perspective of category theory as exposed, for example,
in Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

named_theorems cat_ordinal_cs_simps
named_theorems cat_ordinal_cs_intros

subsection\<open>Arrows associated with an ordinal number\<close>

definition ordinal_arrs :: "V \<Rightarrow> V"
  where "ordinal_arrs A \<equiv> set {[a, b]\<^sub>\<circ> | a b. a \<in>\<^sub>\<circ> A \<and> b \<in>\<^sub>\<circ> A \<and> a \<le> b}"

lemma small_ordinal_arrs[simp]:
  "small {[a, b]\<^sub>\<circ> | a b. a \<in>\<^sub>\<circ> A \<and> b \<in>\<^sub>\<circ> A \<and> a \<le> b}"
  by (rule down[where x=\<open>A \<times>\<^sub>\<bullet> A\<close>]) auto

text\<open>Rules.\<close>

lemma ordinal_arrsI[cat_ordinal_cs_intros]:
  assumes "x = [a, b]\<^sub>\<circ>" and "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b"
  shows "x \<in>\<^sub>\<circ> ordinal_arrs A"
  using assms unfolding ordinal_arrs_def by auto

lemma ordinal_arrsD[dest]:
  assumes "[a, b]\<^sub>\<circ> \<in>\<^sub>\<circ> ordinal_arrs A"
  shows "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b"
  using assms unfolding ordinal_arrs_def by auto

lemma ordinal_arrsE[elim]:
  assumes "x \<in>\<^sub>\<circ> ordinal_arrs A"
  obtains a b where "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b" and "x = [a, b]\<^sub>\<circ>"
  using assms unfolding ordinal_arrs_def by clarsimp

subsection\<open>Composable arrows\<close>

abbreviation ordinal_composable :: "V \<Rightarrow> V"
  where "ordinal_composable A \<equiv> set
    {
      [[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ> | a b c.
        a \<in>\<^sub>\<circ> A \<and> b \<in>\<^sub>\<circ> A \<and> c \<in>\<^sub>\<circ> A \<and> a \<le> b \<and> b \<le> c
    }"

lemma small_ordinal_composable[simp]:
  "small
    {
      [[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ> | a b c.
        a \<in>\<^sub>\<circ> A \<and> b \<in>\<^sub>\<circ> A \<and> c \<in>\<^sub>\<circ> A \<and> a \<le> b \<and> b \<le> c
    }"
  by (rule down[where x=\<open>(A \<times>\<^sub>\<bullet> A) \<times>\<^sub>\<bullet> (A \<times>\<^sub>\<bullet> A)\<close>]) auto

text\<open>Rules.\<close>

lemma ordinal_composableI[cat_ordinal_cs_intros]:
  assumes "x = [[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ>"
    and "a \<in>\<^sub>\<circ> A"
    and "b \<in>\<^sub>\<circ> A"
    and "c \<in>\<^sub>\<circ> A"
    and "a \<le> b"
    and "b \<le> c"
  shows "x \<in>\<^sub>\<circ> ordinal_composable A"
  using assms by auto

lemma ordinal_composableD[dest]:
  assumes "[[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ> \<in>\<^sub>\<circ> ordinal_composable A"
  shows "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "c \<in>\<^sub>\<circ> A" and "a \<le> b" and "b \<le> c"
  using assms by auto

lemma ordinal_composableE[elim]:
  assumes "x \<in>\<^sub>\<circ> ordinal_composable A"
  obtains a b c
    where "x = [[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ>"
      and "a \<in>\<^sub>\<circ> A"
      and "b \<in>\<^sub>\<circ> A"
      and "c \<in>\<^sub>\<circ> A"
      and "a \<le> b"
      and "b \<le> c"
  using assms by clarsimp

subsection\<open>Ordinal number as a category\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition cat_ordinal :: "V \<Rightarrow> V"
  where "cat_ordinal A =
    [
      A,
      ordinal_arrs A,
      (\<lambda>f\<in>\<^sub>\<circ>ordinal_arrs A. f\<lparr>0\<rparr>),
      (\<lambda>f\<in>\<^sub>\<circ>ordinal_arrs A. f\<lparr>1\<^sub>\<nat>\<rparr>),
      (\<lambda>gf\<in>\<^sub>\<circ>ordinal_composable A. [gf\<lparr>1\<^sub>\<nat>\<rparr>\<lparr>0\<rparr>, gf\<lparr>0\<rparr>\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>),
      (\<lambda>x\<in>\<^sub>\<circ>A. [x, x]\<^sub>\<circ>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma cat_ordinal_components:
  shows [cat_ordinal_cs_simps]: "cat_ordinal A\<lparr>Obj\<rparr> = A"
    and [cat_ordinal_cs_simps]: "cat_ordinal A\<lparr>Arr\<rparr> = ordinal_arrs A"
    and "cat_ordinal A\<lparr>Dom\<rparr> = (\<lambda>f\<in>\<^sub>\<circ>ordinal_arrs A. f\<lparr>0\<rparr>)"
    and "cat_ordinal A\<lparr>Cod\<rparr> = (\<lambda>f\<in>\<^sub>\<circ>ordinal_arrs A. f\<lparr>1\<^sub>\<nat>\<rparr>)"
    and "cat_ordinal A\<lparr>Comp\<rparr> =
      (\<lambda>gf\<in>\<^sub>\<circ>ordinal_composable A. [gf\<lparr>1\<^sub>\<nat>\<rparr>\<lparr>0\<rparr>, gf\<lparr>0\<rparr>\<lparr>1\<^sub>\<nat>\<rparr>]\<^sub>\<circ>)"
    and "cat_ordinal A\<lparr>CId\<rparr> = (\<lambda>x\<in>\<^sub>\<circ>A. [x, x]\<^sub>\<circ>)"
  unfolding cat_ordinal_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Domain\<close>

mk_VLambda cat_ordinal_components(3)
  |vsv cat_ordinal_Dom_vsv[cat_ordinal_cs_intros]|
  |vdomain
    cat_ordinal_Dom_vdomain[
      folded cat_ordinal_components, cat_ordinal_cs_simps
      ]
  |

lemma cat_ordinal_Dom_app[cat_ordinal_cs_simps]:
  assumes "x \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Arr\<rparr>" and "x = [a, b]\<^sub>\<circ>"
  shows "cat_ordinal A\<lparr>Dom\<rparr>\<lparr>x\<rparr> = a"
  using assms(1) unfolding assms(2) cat_ordinal_components by auto

lemma cat_ordinal_Dom_vrange: "\<R>\<^sub>\<circ> (cat_ordinal A\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
  unfolding cat_ordinal_components
  by (intro vrange_VLambda_vsubset, elim ordinal_arrsE) simp

subsubsection\<open>Codomain\<close>

mk_VLambda cat_ordinal_components(4)
  |vsv cat_ordinal_Cod_vsv[cat_ordinal_cs_intros]|
  |vdomain
    cat_ordinal_Cod_vdomain[
      folded cat_ordinal_components, cat_ordinal_cs_simps
      ]
  |

lemma cat_ordinal_Cod_app[cat_ordinal_cs_simps]:
  assumes "x \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Arr\<rparr>" and "x = [a, b]\<^sub>\<circ>"
  shows "cat_ordinal A\<lparr>Cod\<rparr>\<lparr>x\<rparr> = b"
  using assms(1)
  unfolding assms(2) cat_ordinal_components
  by (auto simp: nat_omega_simps)

lemma cat_ordinal_Cod_vrange: "\<R>\<^sub>\<circ> (cat_ordinal A\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
  unfolding cat_ordinal_components
  by (intro vrange_VLambda_vsubset, elim ordinal_arrsE)
    (simp add: nat_omega_simps)

subsubsection\<open>Arrow with a domain and a codomain\<close>

text\<open>Rules.\<close>

lemma cat_ordinal_is_arrI[cat_ordinal_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b" and "f = [a, b]\<^sub>\<circ>"
  shows "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
proof(intro is_arrI, unfold cat_ordinal_components(2))
  from assms show "f \<in>\<^sub>\<circ> ordinal_arrs A" by (intro ordinal_arrsI)
  then show "cat_ordinal A\<lparr>Dom\<rparr>\<lparr>f\<rparr> = a" "cat_ordinal A\<lparr>Cod\<rparr>\<lparr>f\<rparr> = b"
    by (cs_concl cs_simp: cat_ordinal_cs_simps assms(4))+
qed

lemma cat_ordinal_is_arrD[dest]:
  assumes "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  shows "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b" and "f = [a, b]\<^sub>\<circ>"
proof-
  note f = is_arrD[OF assms, unfolded cat_ordinal_components(2)]
  from f(1) obtain a' b'
    where a': "a' \<in>\<^sub>\<circ> A"
      and b': "b' \<in>\<^sub>\<circ> A"
      and a'b': "a' \<le> b'"
      and f_def: "f = [a', b']\<^sub>\<circ>"
    unfolding ordinal_arrs_def by clarsimp
  from f(2) a' b' a'b' have a'_def: "a' = a"
    by
      (
        cs_prems cs_shallow
          cs_simp: cat_ordinal_cs_simps f_def cs_intro: cat_ordinal_cs_intros
      )
  from f(3) a' b' a'b' have b'_def: "b' = b"
    by
      (
        cs_prems cs_shallow
          cs_simp: cat_ordinal_cs_simps f_def cs_intro: cat_ordinal_cs_intros
      )
  from a' b' a'b' f_def show "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b" and "f = [a, b]\<^sub>\<circ>"
    unfolding a'_def b'_def by auto
qed

lemma cat_ordinal_is_arrE[elim]:
  assumes "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  obtains "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A" and "a \<le> b" and "f = [a, b]\<^sub>\<circ>"
  using assms by auto

text\<open>Elementary properties.\<close>

lemma cat_ordinal_is_arr_not:
  assumes "\<not>a \<le> b"
  shows "\<not>f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
proof(rule ccontr, unfold not_not)
  assume "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  with cat_ordinal_is_arrD(3)[OF this] assms show False by simp
qed

lemma cat_ordinal_is_arr_is_unique:
  assumes "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b" and "g : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  shows "f = g"
  by
    (
      simp add:
        cat_ordinal_is_arrD(4)[OF assms(1)]
        cat_ordinal_is_arrD(4)[OF assms(2)]
    )

lemma cat_ordinal_Hom_ne:
  assumes "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  shows "Hom (cat_ordinal A) a b = set {f}"
  using assms cat_ordinal_is_arr_is_unique
  by (intro vsubset_antisym vsubsetI) auto

lemma cat_ordinal_Hom_empty:
  assumes "\<not>a \<le> b"
  shows "Hom (cat_ordinal A) a b = 0"
  using assms by (intro vsubset_antisym vsubsetI) auto

lemma cat_ordinal_inj:
  assumes "cat_ordinal m = cat_ordinal n"
  shows "m = n"
  by (metis assms cat_ordinal_components(1))

subsubsection\<open>Composition\<close>

mk_VLambda cat_ordinal_components(5)
  |vsv cat_ordinal_Comp_vsv[cat_ordinal_cs_intros]|
  |vdomain cat_ordinal_Comp_vdomain[folded cat_ordinal_components, cat_cs_simps]|

lemma cat_ordinal_Comp_app[cat_ordinal_cs_simps]:
  assumes "g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c" and "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  shows "g \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f = [a, c]\<^sub>\<circ>"
proof-
  from assms(2) have a: "a \<in>\<^sub>\<circ> A"
    and b: "b \<in>\<^sub>\<circ> A"
    and ab: "a \<le> b"
    and f_def: "f = [a, b]\<^sub>\<circ>"
    by auto
  from assms(1) have c: "c \<in>\<^sub>\<circ> A" and bc: "b \<le> c" and g_def: "g = [b, c]\<^sub>\<circ>"
    by auto
  from a b c ab bc have "[g, f]\<^sub>\<circ> \<in>\<^sub>\<circ> ordinal_composable A"
    by (cs_concl cs_shallow cs_simp: g_def f_def cs_intro: cat_ordinal_cs_intros)
  then show "g \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f = [a, c]\<^sub>\<circ>"
    unfolding cat_ordinal_components by (simp add: g_def f_def nat_omega_simps)
qed

subsubsection\<open>Identity\<close>

mk_VLambda cat_ordinal_components(6)
  |vsv cat_ordinal_CId_vsv[cat_ordinal_cs_intros]|
  |vdomain cat_ordinal_CId_vdomain[cat_ordinal_cs_simps]|
  |app cat_ordinal_CId_app[cat_ordinal_cs_simps]|

subsubsection\<open>Order relation\<close>

lemma cat_ordinal_is_leD[dest]:
  assumes "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b"
  shows "[a, b]\<^sub>\<circ> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
proof(intro cat_ordinal_is_arrI)
  from is_leD[OF assms] obtain f where "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b" by fastforce
  then show "a \<in>\<^sub>\<circ> A" "b \<in>\<^sub>\<circ> A" "a \<subseteq>\<^sub>\<circ> b" by auto
qed simp

lemma cat_ordinal_is_leE[elim]:
  assumes "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b"
  obtains "[a, b]\<^sub>\<circ> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  using assms by auto

lemma cat_ordinal_is_le_iff:
  "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b \<longleftrightarrow> [a, b]\<^sub>\<circ> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
  using cat_ordinal_is_leD cat_ordinal_is_leE
  by (metis HomI is_le_def vempty_nin)

subsubsection\<open>Every ordinal number is a category\<close>

lemma (in \<Z>) cat_linear_order_cat_ordinal[cat_ordinal_cs_intros]:
  assumes "Ord A" and "A \<subseteq>\<^sub>\<circ> \<alpha>"
  shows "cat_linear_order \<alpha> (cat_ordinal A)"
proof(intro cat_linear_orderI cat_partial_orderI cat_preorderI categoryI')
  show "vfsequence (cat_ordinal A)" unfolding cat_ordinal_def by auto
  show "vcard (cat_ordinal A) = 6\<^sub>\<nat>"
    unfolding cat_ordinal_def by (simp add: nat_omega_simps)
  show "\<R>\<^sub>\<circ> (cat_ordinal A\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
    by (rule cat_ordinal_Dom_vrange)
  show "\<R>\<^sub>\<circ> (cat_ordinal A\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
    by (rule cat_ordinal_Cod_vrange)
  show "(gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (cat_ordinal A\<lparr>Comp\<rparr>)) \<longleftrightarrow>
    (
      \<exists>g f b c a.
        gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c \<and> f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b
    )"
    for gf
    unfolding cat_ordinal_Comp_vdomain
  proof
    assume "gf \<in>\<^sub>\<circ> ordinal_composable A"
    then obtain a b c
      where gf_def: "gf = [[b, c]\<^sub>\<circ>, [a, b]\<^sub>\<circ>]\<^sub>\<circ>"
        and a: "a \<in>\<^sub>\<circ> A"
        and b: "b \<in>\<^sub>\<circ> A"
        and c: "c \<in>\<^sub>\<circ> A"
        and ab: "a \<le> b"
        and bc: "b \<le> c"
      by clarsimp
    from a b c ab bc show
      "\<exists>g f b c a.
        gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c \<and> f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
      unfolding gf_def
      by (intro exI conjI)
        (
          cs_concl cs_shallow
            cs_simp: cat_ordinal_cs_simps cs_intro: cat_ordinal_cs_intros
        )+
  next
    assume
      "\<exists>g f b c a.
        gf = [g, f]\<^sub>\<circ> \<and>
        g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c \<and>
        f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
    then obtain g f b c a
      where gf_def: "gf = [g, f]\<^sub>\<circ>"
        and g: "g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c"
        and f: "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
      by clarsimp
    note g = cat_ordinal_is_arrD[OF g]
    note f = cat_ordinal_is_arrD[OF f]
    from g(1-3) f(1-3) show "gf \<in>\<^sub>\<circ> ordinal_composable A"
      unfolding gf_def g(4) f(4)
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_ordinal_cs_simps cs_intro: cat_ordinal_cs_intros
        )
  qed
  show [cat_ordinal_cs_intros]: "g \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> c"
    if "g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c" and "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b" for b c g a f
  proof-
    note g = cat_ordinal_is_arrD[OF that(1)]
    note f = cat_ordinal_is_arrD[OF that(2)]
    show ?thesis
    proof(intro cat_ordinal_is_arrI g(1,2) f(1,2), unfold g(4) f(4))
      from g(3) f(3) show "a \<subseteq>\<^sub>\<circ> c" by auto
      from g(1,2,3) f(1,2,3) show " [b, c]\<^sub>\<circ> \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> [a, b]\<^sub>\<circ> = [a, c]\<^sub>\<circ>"
        by
          (
            cs_concl cs_shallow
              cs_simp: cat_ordinal_cs_simps cs_intro: cat_ordinal_cs_intros
          )
    qed
  qed
  show
    "h \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> g \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f =
      h \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> (g \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f)"
    if "h : c \<mapsto>\<^bsub>cat_ordinal A\<^esub> d"
      and "g : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c"
      and "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
    for c d h b g a f
  proof-
    note h = cat_ordinal_is_arrD[OF that(1)]
    note g = cat_ordinal_is_arrD[OF that(2)]
    note f = cat_ordinal_is_arrD[OF that(3)]
    from that(1-3) h(1-3) g(1-4) f(1-3) show ?thesis
      unfolding h(4) g(4) f(4) (*slow*)
      by (cs_concl cs_simp: cat_ordinal_cs_simps cs_intro: cat_ordinal_cs_intros)
  qed
  show "cat_ordinal A\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> a"
    if "a \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>" for a
  proof-
    from that have "a \<in>\<^sub>\<circ> A" unfolding cat_ordinal_components by simp
    then show "cat_ordinal A\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> a"
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_ordinal_cs_simps
            cs_intro: cat_ordinal_cs_intros V_cs_intros
        )
  qed
  show "cat_ordinal A\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> f = f"
    if "f : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b" for a b f
  proof-
    note f = cat_ordinal_is_arrD[OF that]
    from f(1-3) show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_ordinal_cs_simps f(4)
            cs_intro: cat_ordinal_cs_intros V_cs_intros
        )
  qed
  show "f \<circ>\<^sub>A\<^bsub>cat_ordinal A\<^esub> cat_ordinal A\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"
    if "f : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c" for b c f
  proof-
    note f = cat_ordinal_is_arrD[OF that]
    from f(1-3) show ?thesis
      by
        (
          cs_concl cs_shallow
            cs_simp: cat_ordinal_cs_simps f(4)
            cs_intro: cat_ordinal_cs_intros V_cs_intros
        )
  qed
  from assms Ord_\<alpha> show "cat_ordinal A\<lparr>Obj\<rparr> \<subseteq>\<^sub>\<circ> Vset \<alpha>"
    unfolding cat_ordinal_components by auto
  show "(\<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. \<Union>\<^sub>\<circ>c\<in>\<^sub>\<circ>C. Hom (cat_ordinal A) b c) \<in>\<^sub>\<circ> Vset \<alpha>"
    if "B \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
      and "C \<subseteq>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
      and "B \<in>\<^sub>\<circ> Vset \<alpha>"
      and "C \<in>\<^sub>\<circ> Vset \<alpha>"
    for B C
  proof-
    have "(\<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. \<Union>\<^sub>\<circ>c\<in>\<^sub>\<circ>C. Hom (cat_ordinal A) b c) \<subseteq>\<^sub>\<circ> B \<times>\<^sub>\<bullet> C"
    proof(rule vsubsetI)
      fix f assume "f \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. \<Union>\<^sub>\<circ>c\<in>\<^sub>\<circ>C. Hom (cat_ordinal A) b c)"
      then obtain b c
        where b: "b \<in>\<^sub>\<circ> B" and c: "c \<in>\<^sub>\<circ> C" and f: "f : b \<mapsto>\<^bsub>cat_ordinal A\<^esub> c"
        by auto
      note f = cat_ordinal_is_arrD[OF f]
      from b c show "f \<in>\<^sub>\<circ> B \<times>\<^sub>\<bullet> C"
        unfolding f(4) by auto
    qed
    moreover from that(3,4) have "B \<times>\<^sub>\<bullet> C \<in>\<^sub>\<circ> Vset \<alpha>"
      by (auto intro: Limit_ftimes_in_VsetI)
    ultimately show ?thesis by blast
  qed
  show "(\<exists>f. Hom (cat_ordinal A) a b = set {f}) \<or> Hom (cat_ordinal A) a b = 0"
    if "a \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>" for a b
  proof-
    from that have a: "a \<in>\<^sub>\<circ> A" and b: "b \<in>\<^sub>\<circ> A"
      unfolding cat_ordinal_components by simp_all
    then consider \<open>a \<le> b\<close> | \<open>\<not>a \<le> b\<close> by auto
    then show ?thesis
    proof cases
      case 1
      with a b have "[a, b]\<^sub>\<circ> : a \<mapsto>\<^bsub>cat_ordinal A\<^esub> b"
        by (auto intro: cat_ordinal_is_arrI)
      then show ?thesis by (simp add: cat_ordinal_Hom_ne)
    qed (simp add: cat_ordinal_Hom_empty)
  qed
  show "a = b"
    if "a \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
      and "b \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>"
      and "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b"
      and "b \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> a"
    for a b
    using
      that(3,4)[unfolded cat_ordinal_is_le_iff cat_ordinal_components]
      cat_ordinal_is_arr_is_unique
    by auto
  show "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b \<or> b \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> a"
    if "a \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> cat_ordinal A\<lparr>Obj\<rparr>" for a b
  proof-
    from that[unfolded cat_ordinal_components] have a: "a \<in>\<^sub>\<circ> A" and b: "b \<in>\<^sub>\<circ> A"
      by simp_all
    with assms have "Ord a" "Ord b" by auto
    then consider \<open>a \<le> b\<close> | \<open>b \<le> a\<close> by (meson Ord_linear_le)
    then show "a \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> b \<or> b \<le>\<^sub>O\<^bsub>cat_ordinal A\<^esub> a"
      by cases (auto simp: a b cat_ordinal_is_le_iff intro: cat_ordinal_is_arrI)
  qed
qed (auto intro: cat_ordinal_cs_intros simp: cat_ordinal_cs_simps)

lemmas [cat_ordinal_cs_intros] = \<Z>.cat_linear_order_cat_ordinal

lemma (in \<Z>) cat_tiny_linear_order_cat_ordinal[cat_ordinal_cs_intros]:
  assumes "Ord A" and "A \<in>\<^sub>\<circ> \<alpha>"
  shows "cat_tiny_linear_order \<alpha> (cat_ordinal A)"
proof(intro cat_tiny_linear_orderI' cat_linear_order_cat_ordinal assms(1))
  from assms show "A \<subseteq>\<^sub>\<circ> \<alpha>"
    by (meson Ord_\<alpha> Ord_linear_le mem_not_refl vsubsetE)
  from assms(1) this interpret A: cat_linear_order \<alpha> \<open>cat_ordinal A\<close>
    by (intro cat_linear_order_cat_ordinal)
  from assms(2) have A_in_Vset: "A \<in>\<^sub>\<circ> Vset \<alpha>" by (simp add: Ord_\<alpha> Ord_in_in_VsetI)
  have "cat_ordinal A\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> A \<times>\<^sub>\<bullet> A"
    unfolding ordinal_arrs_def cat_ordinal_components by clarsimp
  moreover from A_in_Vset have "A \<times>\<^sub>\<bullet> A \<in>\<^sub>\<circ> Vset \<alpha>"
    by (intro Limit_ftimes_in_VsetI) auto
  ultimately have "cat_ordinal A\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    using vsubset_in_VsetI unfolding cat_ordinal_components by simp
  moreover have "cat_ordinal A\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    unfolding cat_ordinal_components by (intro A_in_Vset)
  ultimately show "tiny_category \<alpha> (cat_ordinal A)"
    by (cs_concl cs_shallow cs_intro: cat_cs_intros tiny_categoryI')
qed

lemmas [cat_ordinal_cs_intros] = \<Z>.cat_linear_order_cat_ordinal

lemma (in \<Z>) finite_category_cat_ordinal[cat_ordinal_cs_intros]:
  assumes "a \<in>\<^sub>\<circ> \<omega>"
  shows "finite_category \<alpha> (cat_ordinal a)"
proof-
  from assms have "Ord a" "a \<in>\<^sub>\<circ> \<alpha>" by (auto simp: Ord_\<alpha> Ord_trans)
  then interpret cat_ordinal: cat_tiny_linear_order \<alpha> \<open>cat_ordinal a\<close>
    by (cs_concl cs_shallow cs_intro: cat_ordinal_cs_intros)
  show ?thesis
  proof(intro finite_categoryI')
    from assms show "category \<alpha> (cat_ordinal a)"
      by (cs_concl cs_shallow cs_intro: cat_cs_intros)
    from assms show "vfinite (cat_ordinal a\<lparr>Obj\<rparr>)"
      unfolding cat_ordinal_components by auto
    from assms show "vfinite (cat_ordinal a\<lparr>Arr\<rparr>)"
    proof-
      have "cat_ordinal a\<lparr>Arr\<rparr> \<subseteq>\<^sub>\<circ> a \<times>\<^sub>\<bullet> a"
        unfolding cat_ordinal_components by auto
      moreover from assms have "vfinite (a \<times>\<^sub>\<bullet> a)"
        by (intro vfinite_ftimesI) auto
      ultimately show ?thesis by (auto simp: vfinite_vsubset)
    qed
  qed
qed

lemmas [cat_ordinal_cs_intros] = \<Z>.finite_category_cat_ordinal

end