chapter \<open> International System of Units \<close>

section \<open> SI Units Semantics \<close>

theory SI_Units
  imports ISQ
begin

text \<open> An SI unit is simply a particular kind of quantity with an SI tag. \<close>

typedef SI = "UNIV :: unit set" by simp

instance SI :: unit_system
  by (rule unit_system_intro[of "Abs_SI ()"], metis (full_types) Abs_SI_cases UNIV_eq_I insert_iff old.unit.exhaust)

abbreviation "SI \<equiv> unit :: SI"

type_synonym ('n, 'd) SIUnitT = "('n, 'd, SI) QuantT" ("_[_]" [999,0] 999)

text \<open> We now define the seven base units. Effectively, these definitions axiomatise given names
  for the \<^term>\<open>1\<close> elements of the base quantities. \<close>

abbreviation "metre    \<equiv> BUNIT(L, SI)"
abbreviation "kilogram \<equiv> BUNIT(M, SI)"
abbreviation "ampere   \<equiv> BUNIT(I, SI)"
abbreviation "kelvin   \<equiv> BUNIT(\<Theta>, SI)"
abbreviation "mole     \<equiv> BUNIT(N, SI)"
abbreviation "candela  \<equiv> BUNIT(J, SI)"

text \<open> The second is commonly used in unit systems other than SI. Consequently, we define it
  polymorphically, and require that the system type instantiate a type class to use it. \<close>

class time_second = unit_system

instance SI :: time_second ..

abbreviation "second  \<equiv> BUNIT(T, 'a::time_second)"

text \<open>Note that as a consequence of our construction, the term \<^term>\<open>metre\<close> is a SI Unit constant of
SI-type \<^typ>\<open>'a[L, SI]\<close>, so a unit of dimension \<^typ>\<open>Length\<close> with the magnitude of type \<^typ>\<open>'a\<close>.
A magnitude instantiation can be, e.g., an integer, a rational number, a real number, or a vector of
type \<^typ>\<open>real\<^sup>3\<close>. Note than when considering vectors, dimensions refer to the \<^emph>\<open>norm\<close> of the vector,
not to its components. \<close>

lemma BaseUnits:
  "is_base_unit metre" "is_base_unit second" "is_base_unit kilogram" "is_base_unit ampere"
  "is_base_unit kelvin" "is_base_unit mole" "is_base_unit candela"
  by (simp_all add: mk_base_unit)

text \<open> The effect of the above encoding is that we can use the SI base units as synonyms for their
  corresponding dimensions at the type level. \<close>

type_synonym 'a metre    = "'a[Length, SI]"
type_synonym 'a second   = "'a[Time, SI]"
type_synonym 'a kilogram = "'a[Mass, SI]"
type_synonym 'a ampere   = "'a[Current, SI]"
type_synonym 'a kelvin   = "'a[Temperature, SI]"
type_synonym 'a mole     = "'a[Amount, SI]"
type_synonym 'a candela  = "'a[Intensity, SI]"

text \<open> We can therefore construct a quantity such as \<^term>\<open>5 :: rat metre\<close>, which unambiguously
  identifies that the unit of $5$ is metres using the type system. This works because each base
  unit it the one element. \<close>

subsection \<open> Example Unit Equations \<close>

lemma "(metre \<^bold>\<cdot> second\<^sup>-\<^sup>\<one>) \<^bold>\<cdot> second \<cong>\<^sub>Q metre"
  by (si_calc)

subsection \<open> Metrification \<close>

class metrifiable = unit_system +
  fixes convschema :: "'a itself \<Rightarrow> ('a, SI) Conversion" ("schema\<^sub>C")

instantiation SI :: metrifiable
begin
lift_definition convschema_SI :: "SI itself \<Rightarrow> (SI, SI) Conversion"
is "\<lambda> s.
  \<lparr> cLengthF = 1
  , cMassF = 1
  , cTimeF = 1
  , cCurrentF = 1
  , cTemperatureF = 1
  , cAmountF = 1
  , cIntensityF = 1 \<rparr>" by simp
instance ..
end

abbreviation metrify :: "('a::field_char_0)['d::dim_type, 's::metrifiable] \<Rightarrow> 'a['d::dim_type, SI]" where
"metrify \<equiv> qconv (convschema (TYPE('s)))"

text \<open> Conversion via SI units \<close>

abbreviation qmconv ::
  "'s\<^sub>1 itself \<Rightarrow> 's\<^sub>2 itself
   \<Rightarrow> ('a::field_char_0)['d::dim_type, 's\<^sub>1::metrifiable]
   \<Rightarrow> 'a['d::dim_type, 's\<^sub>2::metrifiable]" where
"qmconv s\<^sub>1 s\<^sub>2 x \<equiv> qconv (inv\<^sub>C (schema\<^sub>C s\<^sub>2) \<circ>\<^sub>C schema\<^sub>C s\<^sub>1) x"

syntax
  "_qmconv" :: "type \<Rightarrow> type \<Rightarrow> logic" ("QMC'(_ \<rightarrow> _')")

translations
  "QMC('s\<^sub>1 \<rightarrow> 's\<^sub>2)" == "CONST qmconv TYPE('s\<^sub>1) TYPE('s\<^sub>2)"

lemma qmconv_self: "QMC('s::metrifiable \<rightarrow> 's) = id"
  by (simp add: fun_eq_iff)

end


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

theory Kripke
imports Main
begin
(*>*)

section \<open>A modal logic of knowledge\<close>

text\<open>

\label{sec:kbps-logic-of-knowledge}

We begin with the standard syntax and semantics of the propositional
logic of knowledge based on \emph{Kripke structures}. More extensive
treatments can be found in \<^citet>\<open>"Lenzen:1978"\<close>, \<^citet>\<open>"Chellas:1980"\<close>,
\<^citet>\<open>"Hintikka:1962"\<close> and \<^citet>\<open>\<open>Chapter~2\<close> in "FHMV:1995"\<close>.

The syntax includes one knowledge modality per agent, and one for
\emph{common knowledge} amongst a set of agents. It is parameterised
by the type @{typ "'a"} of agents and @{typ "'p"} of propositions.

\<close>

datatype ('a, 'p) Kform
  = Kprop "'p"
  | Knot "('a, 'p) Kform"
  | Kand "('a, 'p) Kform" "('a, 'p) Kform"
  | Kknows "'a" "('a, 'p) Kform"  ("\<^bold>K\<^sub>_ _")
  | Kcknows "'a list" "('a, 'p) Kform" ("\<^bold>C\<^bsub>_\<^esub> _")

text\<open>

A Kripke structure consists of a set of \emph{worlds} of type @{typ
"'w"}, one \emph{accessibility relation} between worlds for each agent
and a \emph{valuation function} that indicates the truth of a
proposition at a world. This is a very general story that we will
quickly specialise.

\<close>

type_synonym 'w Relation = "('w \<times> 'w) set"

record ('a, 'p, 'w) KripkeStructure =
  worlds :: "'w set"
  relations :: "'a \<Rightarrow> 'w Relation"
  valuation :: "'w \<Rightarrow> 'p \<Rightarrow> bool"

definition kripke :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> bool" where
  "kripke M \<equiv> \<forall>a. relations M a \<subseteq> worlds M \<times> worlds M"

definition
  mkKripke :: "'w set \<Rightarrow> ('a \<Rightarrow> 'w Relation) \<Rightarrow> ('w \<Rightarrow> 'p \<Rightarrow> bool)
            \<Rightarrow> ('a, 'p, 'w) KripkeStructure"
where
  "mkKripke ws rels val \<equiv>
     \<lparr> worlds = ws, relations = \<lambda>a. rels a \<inter> ws \<times> ws, valuation = val \<rparr>"
(*<*)

lemma kripkeI[intro]:
  assumes "\<And>a. relations M a \<subseteq> worlds M \<times> worlds M"
  shows "kripke M"
  using assms unfolding kripke_def by simp

lemma kripke_rels_worlds[dest]:
  assumes "(w, w') \<in> relations M a"
  assumes M: "kripke M"
  shows "w \<in> worlds M \<and> w' \<in> worlds M"
  using assms unfolding kripke_def by auto

lemma kripke_tc_rels_worlds[dest]:
  assumes R: "(w, w') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
  assumes M: "kripke M"
  shows "w \<in> worlds M \<and> w' \<in> worlds M"
  using assms by (induct rule: trancl_induct) auto

lemma kripke_rels_trc_worlds:
  assumes R: "(w, w') \<in> (\<Union>a. relations M a)\<^sup>*"
  assumes w: "w \<in> worlds M"
  assumes M: "kripke M"
  assumes W: "W = worlds M"
  shows "w' \<in> W"
  using assms by (induct rule: rtrancl_induct) auto

lemma mkKripke_kripke[intro, simp]:
  "kripke (mkKripke ws rels val)"
  unfolding kripke_def mkKripke_def by clarsimp

lemma mkKripke_simps[simp]:
  "worlds (mkKripke ws rels val) = ws"
  "relations (mkKripke ws rels val) = (\<lambda>a. rels a \<inter> ws \<times> ws)"
  "valuation (mkKripke ws rels val) = val"
  unfolding mkKripke_def by simp_all
(*>*)

text \<open>

The standard semantics for knowledge is given by taking the
accessibility relations to be equivalence relations, yielding the
S$5_n$ structures, so-called due to their axiomatisation.

\<close>

definition S5n :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> bool" where
  "S5n M \<equiv> \<forall>a. equiv (worlds M) (relations M a)"
(*<*)

lemma S5nI[intro]: "\<lbrakk> \<And>a. equiv (worlds M) (relations M a) \<rbrakk> \<Longrightarrow> S5n M"
  by (simp add: S5n_def)

lemma S5nD[dest]: "S5n M \<Longrightarrow> equiv (worlds M) (relations M a)"
  by (simp add: S5n_def)

lemma S5n_kripke[intro]: "S5n M \<Longrightarrow> kripke M"
  by (rule kripkeI, erule equivE[OF S5nD], auto simp add: refl_on_def)

lemma S5n_rels_closed:
  "S5n M \<Longrightarrow> relations M a `` (relations M a `` X) \<subseteq> relations M a `` X"
  apply (drule S5nD[where a=a])
  apply (erule equivE)
  apply (auto dest: refl_onD symD transD)
  done

(*>*)

text\<open>

Intuitively an agent considers two worlds to be equivalent if it
cannot distinguish between them.

\<close>

subsection\<open>Satisfaction\<close>

text\<open>

A formula $\phi$ is satisfied at a world $w$ in Kripke structure $M$
in the following way:\<close>

fun models :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> ('a, 'p) Kform
           \<Rightarrow> bool" ("(_, _ \<Turnstile> _)" [80,0,80] 80) where
  "M, w \<Turnstile> (Kprop p) = valuation M w p"
| "M, w \<Turnstile> (Knot \<phi>) = (\<not> M, w \<Turnstile> \<phi>)"
| "M, w \<Turnstile> (Kand \<phi> \<psi>) = (M, w \<Turnstile> \<phi> \<and> M, w \<Turnstile> \<psi>)"
| "M, w \<Turnstile> (\<^bold>K\<^sub>a \<phi>) = (\<forall>w' \<in> relations M a `` {w}. M, w' \<Turnstile> \<phi>)"
| "M, w \<Turnstile> (\<^bold>C\<^bsub>as\<^esub> \<phi>) = (\<forall>w' \<in> (\<Union>a \<in> set as. relations M a)\<^sup>+ `` {w}. M, w' \<Turnstile> \<phi>)"

text\<open>

The first three clauses are standard.

The clause for @{term "Kknows a \<phi>"} expresses the idea that an agent
knows @{term "\<phi>"} at world @{term "w"} in structure @{term "M"} iff
@{term "\<phi>"} is true at all worlds it considers possible.

The clause for @{term "Kcknows as \<phi>"} captures what it means for the
set of agents @{term "as"} to commonly know @{term "\<phi>"}; roughly,
everyone knows @{term "\<phi>"} and knows that everyone knows it, and so
forth. Note that the transitive closure and the reflexive-transitive
closure generate the same relation due to the reflexivity of the
agents' accessibility relations; we use the former as it has a more
pleasant induction principle.

\<close>
(*<*)

lemma S5n_rels_eq:
  assumes S5n: "S5n M"
      and ww': "(w, w') \<in> relations M a"
  shows "relations M a `` {w} = relations M a `` {w'}"
  using S5nD[OF S5n] ww' by - (rule equiv_class_eq, blast+)

text\<open>

A key property of the semantics for common knowledge is that it forms
an equivalence class itself.

\<close>

lemma tc_equiv:
  assumes E: "\<And>i. i \<in> is \<Longrightarrow> equiv A (f i)"
      and is_nempty: "is \<noteq> {}"
  shows "equiv A ((\<Union>i\<in>is. f i)\<^sup>+)"
proof(rule equivI)
  from E is_nempty show "refl_on A ((\<Union>i\<in>is. f i)\<^sup>+)"
    unfolding equiv_def
    apply -
    apply (rule refl_onI)
    apply (rule trancl_Int_subset)
    apply (auto dest: refl_onD refl_onD1 refl_onD2)
    done
  from E show "sym ((\<Union>i\<in>is. f i)\<^sup>+)"
    apply -
    apply (rule sym_trancl)
    unfolding equiv_def sym_def by blast
  show "trans  ((\<Union>i\<in>is. f i)\<^sup>+)" by (rule trans_trancl)
qed

lemma S5n_tc_rels_eq:
  assumes S5n: "S5n M"
      and ww': "(w, w') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
  shows "(\<Union>a \<in> as. relations M a)\<^sup>+ `` {w} = (\<Union>a \<in> as. relations M a)\<^sup>+ `` {w'}"
  apply (cases "as = {}")
   apply fastforce
  apply (rule equiv_class_eq[OF _ ww'])
  apply (erule tc_equiv[OF S5nD[OF S5n]])
  done

text\<open>We can show that the standard S5 properties hold of this semantics:\<close>

lemma S5n_knowledge_generalisation:
  "\<lbrakk> S5n M; \<forall>w \<in> worlds M. M, w \<Turnstile> \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> Kknows a \<phi>"
  unfolding S5n_def equiv_def refl_on_def by auto

lemma S5n_knowledge:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Kknows a \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> \<phi>"
  unfolding S5n_def equiv_def refl_on_def by auto

lemma S5n_positive_introspection:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Kknows a \<phi> \<rbrakk> \<Longrightarrow> M, w \<Turnstile> Kknows a (Kknows a \<phi>)"
  unfolding S5n_def equiv_def by simp (blast dest: transD)

lemma S5n_negative_introspection:
  "\<lbrakk> S5n M; w \<in> worlds M; M, w \<Turnstile> Knot (Kknows a \<phi>) \<rbrakk>
     \<Longrightarrow> M, w \<Turnstile> Kknows a (Knot (Kknows a \<phi>))"
  unfolding S5n_def equiv_def by simp (blast dest: symD transD)
(*>*)

text\<open>

The relation between knowledge and common knowledge can be understood
as follows, following \<^citet>\<open>\<open>\S2.4\<close> in "FHMV:1995"\<close>. Firstly, that $\phi$
is common knowledge to a set of agents $as$ can be seen as asserting
that everyone in $as$ knows $\phi$ and moreover knows that it is
common knowledge amongst $as$.

\<close>

lemma S5n_common_knowledge_fixed_point:
  assumes S5n: "S5n M"
  assumes w: "w \<in> worlds M"
  assumes a: "a \<in> set as"
  shows "M, w \<Turnstile> Kcknows as \<phi>
     \<longleftrightarrow> M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
(*<*)
proof
  assume CK: "M, w \<Turnstile> Kcknows as \<phi>"
  from S5n a w CK
  have "M, w \<Turnstile> Kknows a \<phi>"
   and "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
    by (auto intro: trancl_into_trancl2)
  then show "M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
    by simp
next
  assume "M, w \<Turnstile> Kand (Kknows a \<phi>) (Kknows a (Kcknows as \<phi>))"
  hence "M, w \<Turnstile> (Kknows a (Kcknows as \<phi>))" by simp
  with S5n w show "M, w \<Turnstile> (Kcknows as \<phi>)" by (rule S5n_knowledge)
qed

(*>*)
text\<open>

Secondly we can provide an induction schema for the introduction of
common knowledge: from everyone in $as$ knows that $\phi$ implies
$\phi \land \psi$, and that $\phi$ is satisfied at world $w$, infer
that $\psi$ is common knowledge amongst $as$ at $w$.

\<close>

lemma S5n_common_knowledge_induct:
  assumes S5n: "S5n M"
  assumes w: "w \<in> worlds M"
  assumes E: "\<forall>a \<in> set as. \<forall>w \<in> worlds M.
                 M, w \<Turnstile> \<phi> \<longrightarrow> M, w \<Turnstile> \<^bold>K\<^sub>a (Kand \<phi> \<psi>)"
  assumes p: "M, w \<Turnstile> \<phi>"
  shows "M, w \<Turnstile> \<^bold>C\<^bsub>as\<^esub> \<psi>"
(*<*)
proof -
  { fix w' assume ww': "(w, w') \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
    from ww' S5n E p w have "M, w' \<Turnstile> Kand \<phi> \<psi>"
      by ( induct rule: trancl_induct
         , simp_all, blast+) }
  thus ?thesis by simp
qed

(* We actually use a simpler variant. *)

lemma S5n_common_knowledge_fixed_point_simpler:
  assumes S5n: "S5n M"
      and w: "w \<in> worlds M"
      and a: "a \<in> set as"
  shows "M, w \<Turnstile> Kcknows as \<phi> \<longleftrightarrow> M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
proof
  assume CK: "M, w \<Turnstile> Kcknows as \<phi>"
  from S5n a w CK show "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
    by (auto intro: trancl_into_trancl2)
next
  assume "M, w \<Turnstile> Kknows a (Kcknows as \<phi>)"
  with S5n w show "M, w \<Turnstile> (Kcknows as \<phi>)" by (rule S5n_knowledge)
qed

(*>*)

(* **************************************** *)

subsection \<open>Generated models\<close>

text\<open>

\label{sec:generated_models}

The rest of this section introduces the technical machinery we use to
relate Kripke structures.

Intuitively the truth of a formula at a world depends only on the
worlds that are reachable from it in zero or more steps, using any of
the accessibility relations at each step. Traditionally this result is
called the \emph{generated model property}
\<^citep>\<open>\<open>\S3.4\<close> in "Chellas:1980"\<close>.

Given the model generated by @{term "w"} in @{term "M"}:

\<close>

definition
  gen_model :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> ('a, 'p, 'w) KripkeStructure"
where
  "gen_model M w \<equiv>
    let ws' = worlds M \<inter> (\<Union>a. relations M a)\<^sup>* `` {w}
     in \<lparr> worlds = ws',
          relations = \<lambda>a. relations M a \<inter> (ws' \<times> ws'),
          valuation = valuation M \<rparr>"
(*<*)

lemma gen_model_worldsD[dest]:
  "w' \<in> worlds (gen_model M w) \<Longrightarrow> w' \<in> worlds M"
  unfolding gen_model_def by simp

lemma gen_model_world_refl:
  "w \<in> worlds M \<Longrightarrow> w \<in> worlds (gen_model M w)"
  unfolding gen_model_def by simp

lemma gen_model_rels_worlds[dest]:
  assumes "(w', w'') \<in> relations (gen_model M w) a"
  shows "w' \<in> worlds (gen_model M w) \<and> w'' \<in> worlds (gen_model M w)"
  using assms unfolding gen_model_def by simp

lemma gen_model_rels_tc_worlds[dest]:
  assumes "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
  shows "w'' \<in> worlds (gen_model M w)"
  using assms by (induct rule: trancl_induct) auto

lemma gen_model_rels[dest]:
  assumes "(w', w'') \<in> relations (gen_model M w) a"
  shows "(w', w'') \<in> relations M a"
  using assms unfolding gen_model_def by simp

lemma gen_model_worlds:
  "worlds (gen_model M w) = worlds M \<inter> (\<Union>a. relations M a)\<^sup>* `` {w}"
  unfolding gen_model_def by simp

lemma gen_model_tc_rels[dest]:
  assumes M: "kripke M"
      and R: "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
  shows "(w', w'') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
using R
proof(induct rule: trancl_induct)
  case (base y) with M show ?case by auto
next
  case (step y z)
  with M have "y \<in> worlds (gen_model M w)"
          and "z \<in> worlds (gen_model M w)" by auto
  with M step show ?case by (auto intro: trancl_into_trancl)
qed

lemma gen_model_rels_rev[dest]:
  assumes M: "kripke M"
      and "w' \<in> worlds (gen_model M w)"
      and "(w', w'') \<in> relations M a"
  shows "(w', w'') \<in> relations (gen_model M w) a"
  using assms
  unfolding gen_model_def by (auto intro: rtrancl_into_rtrancl)

lemma gen_model_tc_rels_rev[dest]:
  assumes M: "kripke M"
      and R: "(w', w'') \<in> (\<Union>a \<in> as. relations M a)\<^sup>+"
      and W: "w' \<in> worlds (gen_model M w)"
  shows "(w', w'') \<in> (\<Union>a \<in> as. relations (gen_model M w) a)\<^sup>+"
using R W
proof(induct rule: trancl_induct)
  case (base y) with M show ?case by auto
next
  case (step y z)
  with M have "y \<in> worlds (gen_model M w)"
          and "z \<in> worlds (gen_model M w)" by auto
  with M step show ?case by (auto intro: trancl_into_trancl)
qed

lemma gen_model_kripke:
  shows "kripke (gen_model M w)"
  unfolding gen_model_def by auto

(*>*)

text\<open>

where we take the image of @{term "w"} under the reflexive transitive
closure of the agents' relations, we can show that the satisfaction of
a formula @{term "\<phi>"} at a world @{term "w'"} is preserved, provided
@{term "w'"} is relevant to the world @{term "w"} that the sub-model
is based upon:

\<close>

lemma gen_model_semantic_equivalence:
  assumes M: "kripke M"
  assumes w': "w' \<in> worlds (gen_model M w)"
  shows "M, w' \<Turnstile> \<phi> \<longleftrightarrow> (gen_model M w), w' \<Turnstile> \<phi>"
(*<*)
proof -
  { fix w w' assume "w' \<in> worlds (gen_model M w)"
    hence "M, w' \<Turnstile> \<phi> \<longleftrightarrow> (gen_model M w), w' \<Turnstile> \<phi>"
    proof(induct \<phi> arbitrary: w')
      case (Kknows a f w') show ?case
      proof
        assume lhs: "M, w' \<Turnstile> Kknows a f"
        with Kknows show "gen_model M w, w' \<Turnstile> Kknows a f" by auto
      next
        assume rhs: "gen_model M w, w' \<Turnstile> Kknows a f"
        with M Kknows show "M, w' \<Turnstile> Kknows a f"
          by (simp, blast)
      qed
    next
      case (Kcknows as f w') show ?case
      proof
        assume lhs: "M, w' \<Turnstile> Kcknows as f"
        with M Kcknows show "gen_model M w, w' \<Turnstile> Kcknows as f"
          by (simp, blast)
      next
        assume rhs: "gen_model M w, w' \<Turnstile> Kcknows as f"
        with M Kcknows show "M, w' \<Turnstile> Kcknows as f"
          by (simp, blast)
      qed
    qed (simp_all add: gen_model_def) }
  with w' show ?thesis by simp
qed
(*>*)

text\<open>

This is shown by a straightforward structural induction over the
formula @{term "\<phi>"}.

\<close>
(*<*)

lemma gen_model_S5n:
  assumes S5n: "S5n M"
  shows "S5n (gen_model M w)"
proof(intro S5nI equivI)
  show "\<And>n. refl_on (worlds (gen_model M w)) (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by - (rule refl_onI, auto simp add: refl_on_def gen_model_def)
  show "\<And>n. sym (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by (unfold gen_model_def sym_def, auto)
  show "\<And>n. trans (relations (gen_model M w) n)"
    apply (rule equivE[OF S5nD[OF S5n]])
    by - (rule transI, simp add: gen_model_def, unfold trans_def, blast)
qed

text\<open>

If two models generate the same sub-model for a world, they satisfy
the same formulas at that world.

\<close>

lemma gen_model_eq:
  assumes M: "kripke M"
      and M': "kripke M'"
      and "gen_model M w = gen_model M' w"
      and "w' \<in> worlds (gen_model M' w)"
  shows "M, w' \<Turnstile> \<phi> \<longleftrightarrow> M', w' \<Turnstile> \<phi>"
  using assms gen_model_semantic_equivalence[OF M, where w=w]
              gen_model_semantic_equivalence[OF M', where w=w]
  by auto

text \<open>

Our final lemma in this section is technical: it allows us to move
between two Kripke structures that have the same relevant worlds.

\<close>

lemma gen_model_subset_aux:
  assumes R: "\<And>a. relations M a \<inter> T \<times> T = relations M' a \<inter> T \<times> T"
      and T: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> T"
  shows "(\<Union>x. relations M x)\<^sup>* `` {t} \<subseteq> (\<Union>x. relations M' x)\<^sup>* `` {t}"
proof -
  { fix x assume "(t, x) \<in> (\<Union>x. relations M x)\<^sup>*"
    hence "(t, x) \<in> (\<Union>x. relations M' x)\<^sup>*"
    proof(induct rule: rtrancl_induct)
      case (step y z)
      with R T have "(y, z) \<in> (\<Union>a. relations M' a)"
        by auto (blast dest: rtrancl_trans)
      with step show ?case by (blast intro: rtrancl_trans)
    qed simp }
  thus ?thesis by blast
qed

lemma gen_model_subset:
  assumes M: "kripke M"
      and M': "kripke M'"
      and R: "\<And>a. relations M a \<inter> T \<times> T = relations M' a \<inter> T \<times> T"
      and tMT: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> T"
      and tM'T: "(\<Union>a. relations M' a)\<^sup>* `` {t} \<subseteq> T"
      and tM: "t \<in> worlds M"
      and tM': "t \<in> worlds M'"
      and V: "valuation M = valuation M'"
  shows "gen_model M t = gen_model M' t"
proof -
  from tMT tM'T gen_model_subset_aux[OF R] gen_model_subset_aux[OF R[symmetric]]
  have F: "(\<Union>a. relations M a)\<^sup>* `` {t} = (\<Union>a. relations M' a)\<^sup>* `` {t}"
    by - (rule, simp_all)

  from M tMT tM have G: "(\<Union>a. relations M a)\<^sup>* `` {t} \<subseteq> worlds M"
    by (auto dest: kripke_rels_trc_worlds)
  from M' tM'T tM' have H: "(\<Union>a. relations M' a)\<^sup>* `` {t} \<subseteq> worlds M'"
    by (auto dest: kripke_rels_trc_worlds)

  from F G H have WORLDS: "worlds (gen_model M t) = worlds (gen_model M' t)"
    unfolding gen_model_def by (auto iff: Int_absorb1)

  have RELATIONS: "\<And>a. relations (gen_model M t) a = relations (gen_model M' t) a"
  proof (simp add: Int_absorb1 G H gen_model_def)
    fix a
    { fix a x y
      assume XY: "(x, y) \<in> relations M a \<inter> (\<Union>x. relations M x)\<^sup>* `` {t} \<times> (\<Union>x. relations M x)\<^sup>* `` {t}"
      from XY tMT
      have "(x, y) \<in> relations M a \<inter> T \<times> T" by blast
      with R
      have "(x, y) \<in> relations M' a \<inter> T \<times> T" by blast
      with F XY tM'T
      have "(x, y) \<in> relations M' a \<inter> (\<Union>x. relations M' x)\<^sup>* `` {t} \<times> (\<Union>x. relations M' x)\<^sup>* `` {t}"
        by blast }
    moreover
    { fix a x y
      assume XY: "(x, y) \<in> relations M' a \<inter> (\<Union>x. relations M' x)\<^sup>* `` {t} \<times> (\<Union>x. relations M' x)\<^sup>* `` {t}"
      from XY tM'T
      have "(x, y) \<in> relations M' a \<inter> T \<times> T" by blast
      with R
      have "(x, y) \<in> relations M a \<inter> T \<times> T" by blast
      with F XY tMT
      have "(x, y) \<in> relations M a \<inter> (\<Union>x. relations M x)\<^sup>* `` {t} \<times> (\<Union>x. relations M x)\<^sup>* `` {t}"
        by blast }
    ultimately show "Restr (relations M a) ((\<Union>x. relations M x)\<^sup>* `` {t}) =
      Restr (relations M' a) ((\<Union>x. relations M' x)\<^sup>* `` {t})"
    apply -
    apply rule
     apply rule
     apply auto[1]
    apply rule
    apply (case_tac x)
    apply (simp (no_asm_use))
    apply (metis Image_singleton_iff mem_Sigma_iff)
    done
  qed
  from WORLDS RELATIONS V show ?thesis
    unfolding gen_model_def by simp
qed

(*>*)

subsection \<open>Simulations\<close>

text\<open>

\label{sec:kripke-theory-simulations}

A \emph{simulation}, or \emph{p-morphism}, is a mapping from the
worlds of one Kripke structure to another that preserves the truth of
all formulas at related worlds \<^citep>\<open>\<open>\S3.4, Ex. 3.60\<close> in "Chellas:1980"\<close>.
Such a function @{term "f"} must satisfy four properties. Firstly, the
image of the set of worlds of @{term "M"} under @{term "f"} should
equal the set of worlds of @{term "M'"}.

\<close>

definition
  sim_range :: "('a, 'p, 'w1) KripkeStructure
              \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_range M M' f \<equiv> worlds M' = f ` worlds M
                    \<and> (\<forall>a. relations M' a \<subseteq> worlds M' \<times> worlds M')"

text\<open>The value of a proposition should be the same at corresponding
worlds:\<close>

definition
  sim_val :: "('a, 'p, 'w1) KripkeStructure
           \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_val M M' f \<equiv> \<forall>u \<in> worlds M. valuation M u = valuation M' (f u)"

text\<open>

If two worlds are related in @{term "M"}, then the simulation
maps them to related worlds in @{term "M'"}; intuitively the
simulation relates enough worlds. We term this the \emph{forward}
property.

\<close>

definition
  sim_f :: "('a, 'p, 'w1) KripkeStructure
         \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_f M M' f \<equiv>
     \<forall>a u v. (u, v) \<in> relations M a \<longrightarrow> (f u, f v) \<in> relations M' a"

text\<open>

Conversely, if two worlds @{term "f u"} and @{term "v'"} are related
in @{term "M'"}, then there is a pair of related worlds @{term "u"}
and @{term "v"} in @{term "M"} where @{term "f v = v'"}. Intuitively
the simulation makes enough distinctions. We term this the
\emph{reverse} property.

\<close>

definition
  sim_r :: "('a, 'p, 'w1) KripkeStructure
         \<Rightarrow> ('a, 'p, 'w2) KripkeStructure \<Rightarrow> ('w1 \<Rightarrow> 'w2) \<Rightarrow> bool"
where
  "sim_r M M' f \<equiv> \<forall>a. \<forall>u \<in> worlds M. \<forall>v'.
              (f u, v') \<in> relations M' a
           \<longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v')"

definition "sim M M' f \<equiv> sim_range M M' f \<and> sim_val M M' f
                       \<and> sim_f M M' f \<and> sim_r M M' f"
(*<*)

lemma sim_rangeI[intro]:
  "\<lbrakk> worlds M' = f ` worlds M; (\<And>a. relations M' a \<subseteq> worlds M' \<times> worlds M') \<rbrakk>
     \<Longrightarrow> sim_range M M' f"
  unfolding sim_range_def by simp

lemma sim_valI[intro]:
  "(\<And>u. u \<in> worlds M \<Longrightarrow> valuation M u = valuation M' (f u))
   \<Longrightarrow> sim_val M M' f"
  unfolding sim_val_def by simp

lemma sim_fI[intro]:
  "(\<And>a u v. (u, v) \<in> relations M a \<Longrightarrow> (f u, f v) \<in> relations M' a)
   \<Longrightarrow> sim_f M M' f"
  unfolding sim_f_def by simp

lemma sim_fD:
  "\<lbrakk> (u, v) \<in> relations M a; sim M M' f \<rbrakk>
     \<Longrightarrow> (f u, f v) \<in> relations M' a"
  unfolding sim_def sim_f_def by blast

lemma sim_rI[intro]:
  "(\<And>a u v'.
    \<lbrakk>u \<in> worlds M; (f u, v') \<in> relations M' a\<rbrakk>
    \<Longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v'))
  \<Longrightarrow> sim_r M M' f"
  unfolding sim_r_def by simp

lemma sim_rD:
  "\<lbrakk> (f u, v') \<in> relations M' a; sim M M' f; u \<in> worlds M \<rbrakk>
     \<Longrightarrow> (\<exists>v. (u, v) \<in> relations M a \<and> f v = v')"
  unfolding sim_def sim_r_def by blast

lemma simI[intro]:
  "\<lbrakk> sim_range M M' f; sim_val M M' f; sim_f M M' f; sim_r M M' f \<rbrakk>
     \<Longrightarrow> sim M M' f"
  unfolding sim_def by simp

text\<open>The identity is a simulation:\<close>

lemma sim_id: "kripke M \<Longrightarrow> sim M M id"
(*<*)
  unfolding sim_def sim_r_def sim_f_def sim_range_def sim_val_def
  by auto
(*>*)

(*>*)

text\<open>

Due to the common knowledge modality, we need to show the simulation
properties lift through the transitive closure. In particular we can
show that forward simulation is preserved:

\<close>

Reverse simulation also:

\<close>

lemma sim_r_tc:
  assumes M: "kripke M"
  assumes s: "sim M M' f"
  assumes u: "u \<in> worlds M"
  assumes fuv': "(f u, v') \<in> (\<Union>a\<in>as. relations M' a)\<^sup>+"
  obtains v where "f v = v'" and "(u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
(*<*)
proof -
  assume E: "\<And>v. \<lbrakk>f v = v'; (u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+\<rbrakk> \<Longrightarrow> thesis"

  from fuv' have as_nempty: "as \<noteq> {}" by auto
  from fuv' have "\<exists>v. f v = v' \<and> (u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
  proof(induct rule: trancl_induct)
    case (base v') with u s as_nempty show ?case
      by (blast dest: sim_rD)
  next
    case (step v' w')
    hence fuv': "(f u, v') \<in> (\<Union>a\<in>as. relations M' a)\<^sup>+"
      and v'w': "(v', w') \<in> (\<Union>a\<in>as. relations M' a)" by fast+
    from step
    obtain v where vv': "f v = v'"
               and uv: "(u, v) \<in> (\<Union>a\<in>as. relations M a)\<^sup>+"
      by blast
    from s v'w' vv' kripke_tc_rels_worlds[OF uv M]
    obtain w where ww': "f w = w'"
               and vw: "(v, w) \<in> (\<Union>a\<in>as. relations M a)"
      by (blast dest: sim_rD)
    from uv vw ww' show ?case by (blast intro: trancl_trans)
  qed
  with E show thesis by blast
qed

lemma sim_f_trc:
  assumes uv': "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
      and s: "sim M M' f"
  shows "(f u, f v) \<in> (\<Union>a. relations M' a)\<^sup>*"
  using assms
  by - ( induct rule: rtrancl_induct[OF uv']
       , auto dest: sim_fD intro: rtrancl_into_rtrancl )

lemma sim_r_trc:
  assumes s: "sim M M' f"
      and fuv': "(f u, v') \<in> (\<Union>a. relations M' a)\<^sup>*"
      and M: "kripke M"
      and u: "u \<in> worlds M"
  obtains v
    where "f v = v'"
      and "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
proof -
  assume E: "\<And>v. \<lbrakk>f v = v'; (u, v) \<in> (\<Union>a. relations M a)\<^sup>*\<rbrakk> \<Longrightarrow> thesis"
  from fuv' have "\<exists>v. f v = v' \<and> (u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
  proof(induct rule: rtrancl_induct)
    case base show ?case by blast
  next
    case (step v' w')
    hence fuv': "(f u, v') \<in> (\<Union>a. relations M' a)\<^sup>*"
      and v'w': "(v', w') \<in> (\<Union>a. relations M' a)" by fast+
    from step
    obtain v where vv': "f v = v'"
               and uv: "(u, v) \<in> (\<Union>a. relations M a)\<^sup>*"
      by blast
    from s v'w' vv' kripke_rels_trc_worlds[OF uv u M]
    obtain w where ww': "f w = w'"
               and vw: "(v, w) \<in> (\<Union>a. relations M a)"
      by (blast dest: sim_rD)
    from uv vw ww' show ?case by (blast intro: rtrancl_trans)
  qed
  with E show thesis by blast
qed

lemma sim_kripke: "\<lbrakk> sim M M' f; kripke M \<rbrakk> \<Longrightarrow> kripke M'"
  unfolding sim_def sim_range_def by (rule kripkeI, blast)

lemma sim_S5n:
  assumes S5n: "S5n M"
      and sim: "sim M M' f"
  shows "S5n M'"
proof(intro S5nI equivI)
  fix a from S5n sim show "refl_on (worlds M') (relations M' a)"
     using sim_kripke S5n_kripke
     unfolding S5n_def equiv_def sim_def sim_f_def sim_range_def
     by - (rule refl_onI, (simp, blast dest: refl_onD)+)
next
  fix a
  { fix u v assume uv: "(u, v) \<in> relations M' a"
    from sim uv
    obtain u' where uw: "u' \<in> worlds M"
                and fu: "u = f u'"
      unfolding sim_def sim_range_def by bestsimp
    from sim uv fu uw
    obtain v' where u'v': "(u', v') \<in> relations M a"
                and fv: "v = f v'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n u'v' have "(v', u') \<in> relations M a"
      unfolding S5n_def equiv_def by (blast dest: symD)
    with sim fu fv have "(v, u) \<in> relations M' a"
      unfolding sim_def sim_f_def by simp }
  thus "sym (relations M' a)" by (blast intro: symI)
next
  fix a
  { fix x y z
    assume xy: "(x, y) \<in> relations M' a"
       and yz: "(y, z) \<in> relations M' a"
    from sim xy
    obtain x' where xw: "x' \<in> worlds M"
                and fx: "x = f x'"
      unfolding sim_def sim_range_def by bestsimp
    from sim xy fx xw
    obtain y' where x'y': "(x', y') \<in> relations M a"
                and fy: "y = f y'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n sim yz fy x'y'
    obtain z' where y'z': "(y', z') \<in> relations M a"
                and fz: "z = f z'"
      unfolding sim_def sim_r_def sim_range_def by best
    from S5n x'y' y'z' have "(x', z') \<in> relations M a"
      unfolding S5n_def equiv_def by (blast dest: transD)
    with sim fx fy fz have "(x, z) \<in> relations M' a"
      unfolding sim_def sim_f_def by simp }
  thus "trans (relations M' a)" by (blast intro: transI)
qed

(*>*)
text\<open>

Finally we establish the key property of simulations, that they
preserve the satisfaction of all formulas in the following way:

\<close>

lemma sim_semantic_equivalence:
  assumes M: "kripke M"
  assumes s: "sim M M' f"
  assumes u: "u \<in> worlds M"
  shows "M, u \<Turnstile> \<phi> \<longleftrightarrow> M', f u \<Turnstile> \<phi>"
(*<*)
using u
proof(induct \<phi> arbitrary: u)
  case (Kknows a \<psi> u)
  hence u: "u \<in> worlds M" by fast
  show ?case
  proof
    assume lhs: "M, u \<Turnstile> Kknows a \<psi>"
    { fix v' assume "(f u, v') \<in> relations M' a"
      with s u obtain v where uv:  "(u, v) \<in> relations M a"
                          and vv': "f v = v'"
        by (blast dest: sim_rD)
      from lhs uv have "M, v \<Turnstile> \<psi>" by simp
      with kripke_rels_worlds[OF uv M] vv' Kknows
      have "M', v' \<Turnstile> \<psi>" by auto }
    thus "M', f u \<Turnstile> Kknows a \<psi>" by simp
  next
    assume rhs: "M', f u \<Turnstile> Kknows a \<psi>"
    { fix v assume uv: "(u, v) \<in> relations M a"
      with s have "(f u, f v) \<in> relations M' a"
        by (blast dest: sim_fD)
      with rhs have "M', f v \<Turnstile> \<psi>" by simp
      with kripke_rels_worlds[OF uv M] Kknows s
      have "M, v \<Turnstile> \<psi>" by auto }
    thus "M, u \<Turnstile> Kknows a \<psi>" by simp
  qed
next
  case (Kcknows as \<psi>)
  hence u: "u \<in> worlds M" by fast
  show ?case
  proof
    assume lhs: "M, u \<Turnstile> Kcknows as \<psi>"
    { fix v' assume "(f u, v') \<in> (\<Union>x\<in>set as. relations M' x)\<^sup>+"
      with M s u
      obtain v where uv:  "(u, v) \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
                and vv': "f v = v'"
        by (blast intro: sim_r_tc)
      from uv lhs have "M, v \<Turnstile> \<psi>" by simp
      with kripke_tc_rels_worlds[OF uv M] vv' Kcknows
      have "M', v' \<Turnstile> \<psi>" by auto }
    thus "M', f u \<Turnstile> Kcknows as \<psi>" by simp
  next
    assume rhs: "M', f u \<Turnstile> Kcknows as \<psi>"
    { fix v assume uv: "(u, v) \<in> (\<Union>x\<in>set as. relations M x)\<^sup>+"
      with s have "(f u, f v) \<in> (\<Union>x\<in>set as. relations M' x)\<^sup>+"
        by (blast dest: sim_f_tc)
      with rhs have "M', f v \<Turnstile> \<psi>" by simp
      with kripke_tc_rels_worlds[OF uv M] Kcknows s
      have "M, v \<Turnstile> \<psi>" by auto }
    thus "M, u \<Turnstile> Kcknows as \<psi>" by simp
  qed
qed (insert s,
     auto simp add: sim_range_def sim_def sim_val_def)
(*>*)

text\<open>

The proof is by structural induction over the formula @{term "\<phi>"}. The
knowledge cases appeal to our two simulation preservation lemmas.

\<^citet>\<open>"DBLP:journals/toplas/Sangiorgi09"\<close> surveys the history of
p-morphisms and the related concept of \emph{bisimulation}.

This is all we need to know about Kripke structures.

\<close>

(*<*)
end
(*>*)


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

header {* Linear Time Optimization for ``Mark Before Atom'' (for a Fixed Alphabet) *}

(*<*)
theory Before2
imports
  Position_Autos
begin
(*>*)

declare Let_def[simp]

datatype 'a mrexp3 =
  Zero3 |
  One3 |
  Atom3 bool 'a |
  Plus3 "'a mrexp3" "'a mrexp3" (fin1: "'a set") (nul: bool) |
  Times3 "'a mrexp3" "'a mrexp3" (fin1: "'a set") (nul: bool) |
  Star3 "'a mrexp3" (fin1: "'a set")
where
  "fin1 Zero3 = {}"
| "nul Zero3 = False"
| "fin1 One3 = {}"
| "nul One3 = True"
| "fin1 (Atom3 m a) = (if m then {a} else {})"
| "nul (Atom3 _ _) = False"
| "nul (Star3 _ _) = True"

primrec final3 where
  "final3 Zero3 = False"
| "final3 One3 = False"
| "final3 (Atom3 m a) = m"
| "final3 (Plus3 r s _ _) = (final3 r \<or> final3 s)"
| "final3 (Times3 r s _ _) = (final3 s \<or> nul s \<and> final3 r)"
| "final3 (Star3 r _) = final3 r"

primrec mrexps3 :: "'a rexp \<Rightarrow> ('a mrexp3) set" where
  "mrexps3 Zero = {Zero3}"
| "mrexps3 One = {One3} "
| "mrexps3 (Atom a) = {Atom3 True a, Atom3 False a}"
| "mrexps3 (Plus r s) = (\<lambda>(r, s, f1, n). Plus3 r s f1 n) ` (mrexps3 r \<times> mrexps3 s \<times> Pow (atoms (Plus r s)) \<times> UNIV)"
| "mrexps3 (Times r s) = (\<lambda>(r, s, f1, n). Times3 r s f1 n) ` (mrexps3 r \<times> mrexps3 s \<times> Pow (atoms (Times r s))  \<times> UNIV)"
| "mrexps3 (Star r) = (\<lambda>(r, f1). Star3 r f1) ` (mrexps3 r \<times> Pow (atoms (Star r)))"

lemma finite_atoms[simp]: "finite (atoms r)"
  by (induct r) auto

lemma finite_mrexps3[simp]: "finite (mrexps3 r)"
  by (induct r) auto

definition[simp]: "plus3 r s == Plus3 r s (fin1 r \<union> fin1 s) (nul r \<or> nul s)"
definition[simp]: "times3 r s ==
  let ns = nul s in Times3 r s (fin1 s \<union> (if ns then fin1 r else {})) (nul r \<and> ns)"
definition[simp]: "star3 r == Star3 r (fin1 r)"

primrec follow3 :: "bool \<Rightarrow> 'a mrexp3 \<Rightarrow> 'a mrexp3" where
"follow3 m Zero3 = Zero3" |
"follow3 m One3 = One3" |
"follow3 m (Atom3 _ a) = Atom3 m a" |
"follow3 m (Plus3 r s _ _) = plus3 (follow3 m r) (follow3 m s)" |
"follow3 m (Times3 r s _ _) =
  times3 (follow3 m r) (follow3 (final3 r \<or> m \<and> nul r) s)" |
"follow3 m (Star3 r _) = star3(follow3 (final3 r \<or> m) r)"

primrec empty_mrexp3 :: "'a rexp \<Rightarrow> 'a mrexp3" where
"empty_mrexp3 Zero = Zero3" |
"empty_mrexp3 One = One3" |
"empty_mrexp3 (Atom x) = Atom3 False x" |
"empty_mrexp3 (Plus r s) = plus3 (empty_mrexp3 r) (empty_mrexp3 s)" |
"empty_mrexp3 (Times r s) = times3 (empty_mrexp3 r) (empty_mrexp3 s)" |
"empty_mrexp3 (Star r) = star3 (empty_mrexp3 r)"

primrec move3 :: "'a \<Rightarrow> 'a mrexp3 \<Rightarrow> bool \<Rightarrow> 'a mrexp3" where
"move3 _ One3 _ = One3" |
"move3 _ Zero3 _ = Zero3" |
"move3 c (Atom3 _ a) m = Atom3 m a" |
"move3 c (Plus3 r s _ _) m = plus3 (move3 c r m) (move3 c s m)" |
"move3 c (Times3 r s _ _) m =
  times3 (move3 c r m) (move3 c s (c \<in> fin1 r \<or> m \<and> nul r))" |
"move3 c (Star3 r _) m = star3 (move3 c r (c \<in> fin1 r \<or> m))"

primrec strip3 where
"strip3 Zero3 = Zero" |
"strip3 One3 = One" |
"strip3 (Atom3 m x) = Atom (m, x)" |
"strip3 (Plus3 r s _ _) = Plus (strip3 r) (strip3 s)" |
"strip3 (Times3 r s _ _) = Times (strip3 r) (strip3 s)" |
"strip3 (Star3 r _) = Star (strip3 r)"

lemma strip_mrexps3: "(strip o strip3) ` mrexps3 r = {r}"
by (induction r) (auto simp: set_eq_subset subset_iff image_iff)

primrec ok3 :: "'a mrexp3 \<Rightarrow> bool" where
"ok3 Zero3 = True" |
"ok3 One3 = True" |
"ok3 (Atom3 _ _) = True" |
"ok3 (Plus3 r s f1 n) = (ok3 r \<and> ok3 s \<and>
   (let rs = Plus (strip3 r) (strip3 s) in f1 = Collect (final1 rs) \<and> n = nullable rs))" |
"ok3 (Times3 r s f1 n) = (ok3 r \<and> ok3 s \<and>
   (let rs = Times (strip3 r) (strip3 s) in f1 = Collect (final1 rs) \<and> n = nullable rs))" |
"ok3 (Star3 r f1) = (ok3 r \<and> f1 = Collect (final1 (strip3 r)))"

lemma ok3_nul_nullable[simp]: "ok3 r \<Longrightarrow> nul r = nullable (strip3 r)"
  by (induct r) auto

lemma ok3_final3_final[simp]: "ok3 r \<Longrightarrow> final3 r = final (strip3 r)"
  by (induct r) auto

lemma follow3_follow[simp]: "ok3 r \<Longrightarrow> strip3 (follow3 m r) = follow m (strip3 r)"
  by (induct r arbitrary: m) auto

lemma nul_follow3[simp]: "ok3 r \<Longrightarrow> nul (follow3 m r) = nul r"
  by (induct r arbitrary: m) auto

lemma ok3_follow3[simp]: "ok3 r \<Longrightarrow> ok3 (follow3 m r)"
  by (induct r arbitrary: m) auto

lemma fin1_atoms: "\<lbrakk>x \<in> fin1 mr; mr \<in> mrexps3 r\<rbrakk> \<Longrightarrow> x \<in> atoms r"
  by (induct r) auto

lemma follow3_mrexps3[simp]: "r \<in> mrexps3 s \<Longrightarrow> follow3 m r \<in> mrexps3 s"
  by (induct s arbitrary: m r) (fastforce simp add: image_iff dest: fin1_atoms)+

lemma empty_mrexp3_mrexps[simp]: "empty_mrexp3 r \<in> mrexps3 r"
  by (induct r) (auto simp: image_iff dest: fin1_atoms)

lemma strip3_empty_mrexp3[simp]: "strip3 (empty_mrexp3 r) = empty_mrexp r"
  by (induct r) auto

lemma strip3_move3: "ok3 r \<Longrightarrow> strip3(move3 m r c) = move m (strip3 r) c"
apply(induction r arbitrary: c)
apply (auto simp: disj_commute)
done

lemma nul_empty_mrexp3[simp]: "nul (empty_mrexp3 r) = nullable r"
apply(induction r)
apply auto
done

lemma ok3_empty_mrexp3: "ok3 (empty_mrexp3 r)"
apply(induction r)
apply auto
done

lemma ok3_move3: "ok3 r \<Longrightarrow> ok3(move3 m r c)"
apply(induction r arbitrary: c)
apply auto
done

lemma nonfin1_empty_mrexp3[simp]: "c \<notin> fin1 (empty_mrexp3 r)"
  by (induct r) auto

lemma move3_mrexps3[simp]: "r \<in> mrexps3 s \<Longrightarrow> move3 x r a \<in> mrexps3 s"
  by (induct s arbitrary: r x a) (fastforce simp: image_iff dest: fin1_atoms)+

typedef 'a ok_mrexp3 = "{(r :: 'a mrexp3, b :: bool). ok3 r}"
  unfolding mem_Collect_eq split_beta by (metis fst_eqD ok3_empty_mrexp3)

setup_lifting type_definition_ok_mrexp3

abbreviation "init_m r \<equiv> let mr = follow3 True (empty_mrexp3 r) in (mr, nul mr)"

lift_definition init_okm :: "'a rexp \<Rightarrow> 'a ok_mrexp3" is init_m
  by (simp add: ok3_empty_mrexp3)
lift_definition delta_okm :: "'a \<Rightarrow> 'a ok_mrexp3 \<Rightarrow> 'a ok_mrexp3" is
  "\<lambda>a (r, m). (move3 a r False, a \<in> fin1 r)"
  unfolding mem_Collect_eq split_beta fst_conv by (intro ok3_move3) simp
lift_definition nullable_okm :: "'a ok_mrexp3 \<Rightarrow> bool" is "snd" .
lift_definition lang_okm :: "'a ok_mrexp3 \<Rightarrow> 'a lang" is "\<lambda>(r, m). L_b (strip3 r, m)" .

instantiation ok_mrexp3 :: (equal) "equal"
begin

fun eq_mrexp3 where
  "eq_mrexp3 Zero3 Zero3 = True"
| "eq_mrexp3 One3 One3 = True"
| "eq_mrexp3 (Atom3 m x) (Atom3 m' y) = (m = m' \<and> x = y)"
| "eq_mrexp3 (Plus3 r1 s1 _ _) (Plus3 r3 s3 _ _) = (eq_mrexp3 r1 r3 \<and> eq_mrexp3 s1 s3)"
| "eq_mrexp3 (Times3 r1 s1 _ _) (Times3 r3 s3 _ _) = (eq_mrexp3 r1 r3 \<and> eq_mrexp3 s1 s3)"
| "eq_mrexp3 (Star3 r1 _) (Star3 r3 _) = (eq_mrexp3 r1 r3)"
| "eq_mrexp3 r s = False"

lemma eq_mrexp3_imp_eq: "\<lbrakk>eq_mrexp3 r s; ok3 r; ok3 s\<rbrakk> \<Longrightarrow> (r = s)"
  by (induct rule: eq_mrexp3.induct) auto

lemma eq_mrexp3_refl[simplified, simp]: "r = s \<Longrightarrow> eq_mrexp3 r s"
  by (induct rule: eq_mrexp3.induct) auto

lemma eq_mrexp3_eq: "\<lbrakk>ok3 r; ok3 s\<rbrakk> \<Longrightarrow> eq_mrexp3 r s = (r = s)"
  by (metis eq_mrexp3_imp_eq eq_mrexp3_refl)

lift_definition equal_ok_mrexp3 :: "'a ok_mrexp3 \<Rightarrow> 'a ok_mrexp3 \<Rightarrow> bool"
   is "\<lambda>(r1, b1) (r3, b3). b1 = b3 \<and> eq_mrexp3 r1 r3" .

instance by intro_classes (transfer, auto simp: eq_mrexp3_eq)

end

permanent_interpretation before2: rexp_DFA init_okm delta_okm nullable_okm lang_okm
  defining before2_closure = "rexp_DA.closure delta_okm (nullable_okm :: 'a ok_mrexp3 \<Rightarrow> bool)"
    and check_eqv_b2 = "rexp_DA.check_eqv init_okm delta_okm (nullable_okm :: 'a ok_mrexp3 \<Rightarrow> bool)"
    and reachable_b2 = "rexp_DA.reachable (init_okm :: 'a rexp \<Rightarrow> 'a ok_mrexp3) delta_okm"
    and automaton_b2 = "rexp_DA.automaton (init_okm :: 'a rexp \<Rightarrow> 'a ok_mrexp3) delta_okm"
    and match_b2 = "rexp_DA.match init_okm delta_okm (nullable_okm :: 'a ok_mrexp3 \<Rightarrow> bool)"
proof
  case goal1 show "lang_okm (init_okm r) = lang r"
    by transfer (auto simp: split_beta init_a_def nonfinal_empty_mrexp Lm_follow Lm_empty
      map_map_rexp nullable_iff ok3_empty_mrexp3)
next
  case (goal2 a br) show "lang_okm (delta_okm a br) = Deriv a (lang_okm br)"
    apply transfer
    unfolding split_beta fst_conv snd_conv mem_Collect_eq before.L_delta[symmetric] delta_b.simps
      move_follow_read[symmetric] final_read_final1 Let_def
    by (subst strip3_move3) simp_all
next
  case (goal3 br) show  "nullable_okm br = ([] \<in> lang_okm br)"
    by transfer (simp add: split_beta)
next
  case (goal4 s)
  have "{fold (\<lambda>a (r, m). (move3 a r False, a \<in> fin1 r)) w (init_m s) |w. True} \<subseteq>
    mrexps3 s \<times> UNIV"
  proof (intro subsetI, elim CollectE exE conjE, hypsubst)
    fix w show "fold (\<lambda>a (r, m). (move3 a r False, a \<in> fin1 r)) w (init_m s) \<in>
      mrexps3 s \<times> UNIV"
    by (induct w rule: rev_induct) (auto simp: split: prod.splits intro!: move3_mrexps3)
  qed
  then show "finite {fold delta_okm w (init_okm s) |w. True}"
    by transfer (erule finite_subset[OF subset_trans[rotated]], auto)
qed

(*<*)
end
(*>*)


theory PhiSem_Aggregate_Base
  imports PhiSem_Base
begin

text \<open>The base for aggregate values which have inner structures and whose members can be
  accessed using indexes.\<close>

section \<open>Semantics\<close>

type_synonym index = nat

debt_axiomatization
        valid_idx_step :: \<open>TY \<Rightarrow> index \<Rightarrow> bool\<close>
    and idx_step_type  :: \<open>index \<Rightarrow> TY \<Rightarrow> TY\<close>
    and idx_step_value :: \<open>index \<Rightarrow> VAL \<Rightarrow> VAL\<close>
    and idx_step_mod_value :: \<open>index \<Rightarrow> (VAL \<Rightarrow> VAL) \<Rightarrow> VAL \<Rightarrow> VAL\<close>
    and type_measure :: \<open>TY \<Rightarrow> nat\<close>
where idx_step_value_welltyp:
           \<open>valid_idx_step T i
        \<Longrightarrow> v \<in> Well_Type T
        \<Longrightarrow> idx_step_value i v \<in> Well_Type (idx_step_type i T)\<close>
and   idx_step_mod_value :
           \<open>valid_idx_step T i
        \<Longrightarrow> valid_idx_step T j
        \<Longrightarrow> v \<in> Well_Type T
        \<Longrightarrow> idx_step_value i (idx_step_mod_value j f v) =
              (if i = j then f (idx_step_value j v) else idx_step_value i v) \<close>
and   idx_step_mod_value_welltyp:
           \<open>valid_idx_step T i
        \<Longrightarrow> v \<in> Well_Type T
        \<Longrightarrow> f (idx_step_value i v) \<in> Well_Type (idx_step_type i T)
        \<Longrightarrow> idx_step_mod_value i f v \<in> Well_Type T\<close>
and   idx_step_type_measure:
           \<open>valid_idx_step T i \<Longrightarrow> type_measure (idx_step_type i T) < type_measure T\<close>

text \<open>We first formalize the behavior of indexing one-step inside one level of the inner structures,
  and upon them indexing of multiple steps is successively playing each step.

  \<^const>\<open>valid_idx_step\<close> asserts whether an index is valid on the type.
  \<^const>\<open>idx_step_type\<close> steps into the inner type of the given type.
  \<^const>\<open>idx_step_value\<close> gives the inner structure of a given value, and \<^const>\<open>idx_step_mod_value\<close>
    enables to modify the inner structure.
  \<^const>\<open>type_measure\<close> is a scaffold giving a decreasing measurement when indexing inside,
    such as the size of the term. It helps induction over the indexing.
\<close>

abbreviation \<open>index_value \<equiv> fold idx_step_value\<close>
abbreviation \<open>index_type  \<equiv> fold idx_step_type\<close>
abbreviation \<open>index_mod_value \<equiv> foldr idx_step_mod_value\<close>

primrec valid_index :: \<open>TY \<Rightarrow> nat list \<Rightarrow> bool\<close>
  where \<open>valid_index T [] \<longleftrightarrow> True\<close>
      | \<open>valid_index T (i#idx) \<longleftrightarrow> valid_idx_step T i \<and> valid_index (idx_step_type i T) idx\<close>

declare [[\<phi>reason_default_pattern \<open>valid_index ?T ?idx\<close> \<Rightarrow> \<open>valid_index ?T ?idx\<close> (100)]]

lemma [\<phi>reason 1200]: \<open>valid_index T []\<close> by simp

lemma valid_index_tail[simp]:
  \<open>valid_index T (idx@[i]) \<longleftrightarrow> valid_index T idx \<and> valid_idx_step (index_type idx T) i\<close>
  by (induct idx arbitrary: T; simp)

lemma [\<phi>reason 1]:
  \<open> FAIL TEXT(\<open>Fail to show the validity of index\<close> idx \<open>on type\<close> T)
\<Longrightarrow> valid_index T idx\<close>
  by blast

lemma valid_index_cat: \<open>valid_index T (a@b) \<Longrightarrow> valid_index T a \<and> valid_index (index_type a T) b\<close>
  by (induct a arbitrary: T; simp)

lemma valid_index_cons: \<open>valid_index T [i] \<longleftrightarrow> valid_idx_step T i\<close> by simp

lemma index_value_welltyp:
  \<open>valid_index T idx \<Longrightarrow> v \<in> Well_Type T \<Longrightarrow> index_value idx v \<in> Well_Type (index_type idx T)\<close>
  apply (induct idx arbitrary: v T; simp)
  using idx_step_value_welltyp
  by blast

lemma index_type_measure:
  \<open>valid_index T idx \<Longrightarrow> idx \<noteq> [] \<Longrightarrow> type_measure (index_type idx T) < type_measure T\<close>
  apply (induct idx arbitrary: T; simp)
  by (metis dual_order.strict_trans fold_simps(1) idx_step_type_measure)

lemma index_mod_value_welltyp:
   \<open>valid_index T idx
\<Longrightarrow> v \<in> Well_Type T
\<Longrightarrow> f (index_value idx v) \<in> Well_Type (index_type idx T)
\<Longrightarrow> index_mod_value idx f v \<in> Well_Type T\<close>
  apply (induct idx arbitrary: T v; simp)
  using idx_step_mod_value_welltyp idx_step_value_welltyp by blast

lemma index_type_idem:
  \<open>valid_index T idx \<Longrightarrow> index_type idx T = T \<longleftrightarrow> idx = []\<close>
  apply (cases idx; simp; rule)
  using index_type_measure
  by (metis fold_simps(2) list.discI order_less_irrefl valid_index.simps(2))

section \<open>Instructions\<close>

(* definition op_cons_tuple :: "'TY list \<Rightarrow> (VAL list) proc'"
  where "op_cons_tuple tys = (\<lambda>(vs,res).
    let N = length tys in
    if N \<le> length vs \<and> list_all2 (\<lambda>v t. v \<in> Well_Type t) (take N vs) tys
    then Success (V_tup.mk (take N vs) # drop N vs, res)
    else Fail)" *)

definition op_get_aggregate :: "index list \<Rightarrow> TY \<Rightarrow> (VAL, VAL) proc'"
  where "op_get_aggregate idx T = (\<lambda>v.
    \<phi>M_getV T id v (\<lambda>v'.
    \<phi>M_assert (valid_index T idx) \<ggreater>
    Return (\<phi>arg (index_value idx v'))
))"

debt_axiomatization allow_assigning_different_typ :: \<open>TY \<Rightarrow> index list \<Rightarrow> bool\<close>

definition op_set_aggregate :: "TY \<Rightarrow> TY \<Rightarrow> index list \<Rightarrow> (VAL \<times> VAL, VAL) proc'"
  where "op_set_aggregate Tt Tv idx =
    \<phi>M_caseV (\<lambda>v tup.
    \<phi>M_assert (valid_index Tt idx \<and> (index_type idx Tt = Tv \<or> allow_assigning_different_typ Tt idx)) \<ggreater>
    \<phi>M_getV Tv id v (\<lambda>v'.
    \<phi>M_getV Tt id tup (\<lambda>tup'.
    Return (\<phi>arg (index_mod_value idx (\<lambda>_. v') tup'))
)))"

section \<open>Reasoning\<close>

subsection \<open>Evaluate Index\<close>

consts eval_semantic_index :: mode

ML \<open>
structure Eval_Sem_Idx_SS = Simpset (
  val initial_ss = Simpset_Configure.Minimal_SS
  val binding = \<^binding>\<open>eval_semantic_index\<close>
  val comment = "Rules evaluating indexing of semantic type and value"
)\<close>

\<phi>reasoner_ML eval_semantic_index 1300 ( \<open>Simplify eval_semantic_index ?X' ?X\<close>
                                      | \<open>Premise eval_semantic_index ?P\<close> )
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE Eval_Sem_Idx_SS.get'\<close>

lemmas [eval_semantic_index] = nth_Cons_0 nth_Cons_Suc fold_simps list.size simp_thms

subsection \<open>Index to Fields of Structures\<close>

definition \<phi>Index_getter :: \<open>nat list \<Rightarrow> (VAL,'a) \<phi> \<Rightarrow> (VAL,'b) \<phi> \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool\<close>
  where \<open>\<phi>Index_getter idx T U g \<longleftrightarrow> index_value idx \<in> (g \<Ztypecolon> T \<Rrightarrow> U)\<close>

definition \<phi>Index_mapper :: \<open>nat list \<Rightarrow> (VAL,'a) \<phi> \<Rightarrow> (VAL,'a2) \<phi> \<Rightarrow> (VAL,'b) \<phi> \<Rightarrow> (VAL,'b2) \<phi> \<Rightarrow> (('b \<Rightarrow> 'b2) \<Rightarrow> 'a \<Rightarrow> 'a2) \<Rightarrow> bool\<close>
  where \<open>\<phi>Index_mapper idx T T' U U' f
    \<longleftrightarrow> (\<forall>g g'. g \<in> (g' \<Ztypecolon> U \<Rrightarrow> U') \<longrightarrow> index_mod_value idx g \<in> (f g' \<Ztypecolon> T \<Rrightarrow> T'))\<close>

declare [[
  \<phi>reason_default_pattern \<open>\<phi>Index_getter ?idx ?T _ _\<close> \<Rightarrow> \<open>\<phi>Index_getter ?idx ?T _ _\<close> (100),
  \<phi>reason_default_pattern \<open>\<phi>Index_mapper ?idx ?T _ _ _ _\<close> \<Rightarrow> \<open>\<phi>Index_mapper ?idx ?T _ _ _ _\<close> (100)
]]

lemma [\<phi>reason 1200]:
  \<open>\<phi>Index_getter [] T T id\<close>
  unfolding \<phi>Index_getter_def
  by (simp add: \<phi>Mapping_expn)

lemma [\<phi>reason 1200]:
  \<open>\<phi>Index_mapper [] T T' T T' id\<close>
  unfolding \<phi>Index_mapper_def
  by (simp add: \<phi>Mapping_expn)

subsection \<open>IDE-Interfaces\<close>

term ParamTag

definition Index_Param_Tag :: \<open>index list \<Rightarrow> bool\<close> ("\<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> _" [1000] 26)
  where "\<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> x \<equiv> True"

lemma Index_Param_Tag_Swap:
  \<open> \<p>\<a>\<r>\<a>\<m> P \<Longrightarrow> \<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> P \<close>
  unfolding Index_Param_Tag_def ..

ML_file \<open>syntax/index_param.ML\<close>

ML \<open>Scan.pass\<close>

\<phi>processor set_index_param 5000 (premises \<open>\<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> _\<close>) \<open>fn (ctxt,sequent) =>
  Scan.pass (Context.Proof ctxt) Synt_Index_Param.index_term_parser >> (fn term => fn _ =>
      Phi_Sys.set_param term (ctxt, @{thm Index_Param_Tag_Swap} RS sequent))\<close>

section \<open>First-level Abstraction of Instructions\<close>

lemma op_get_aggregate:
  \<open> \<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> idx
\<Longrightarrow> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> valid_index TY idx
\<Longrightarrow> \<phi>Index_getter idx T U f
\<Longrightarrow> \<p>\<r>\<o>\<c> op_get_aggregate idx TY rv \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rv] T \<longmapsto> f x \<Ztypecolon> \<v>\<a>\<l> U \<rbrace>\<close>
  unfolding op_get_aggregate_def \<phi>SemType_def subset_iff \<phi>Index_getter_def
  by (cases rv; simp, rule, simp add: \<phi>expns, rule, simp add: \<phi>Mapping_expn)

lemma op_set_aggregate:
  \<open> \<i>\<n>\<d>\<e>\<x> \<p>\<a>\<r>\<a>\<m> idx
\<Longrightarrow> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>SemType (y \<Ztypecolon> U) TY2
\<Longrightarrow> Premise eval_semantic_index (index_type idx TY = TY2 \<or> allow_assigning_different_typ TY idx)
\<Longrightarrow> valid_index TY idx
\<Longrightarrow> \<phi>Index_mapper idx T T' U' U f
\<Longrightarrow> \<p>\<r>\<o>\<c> op_set_aggregate TY TY2 idx (ru\<^bold>, rv) \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[rv] T\<heavy_comma> y \<Ztypecolon> \<v>\<a>\<l>[ru] U \<longmapsto> f (\<lambda>_. y) x \<Ztypecolon> \<v>\<a>\<l> T' \<rbrace>\<close>
  unfolding op_set_aggregate_def \<phi>SemType_def subset_iff \<phi>Index_mapper_def Premise_def
  by (cases rv; cases ru; simp, rule, rule, simp add: \<phi>expns, rule, simp add: \<phi>expns,
      rule, simp add: \<phi>Mapping_expn)

end


theory FSet_Utils
  imports "HOL-Library.FSet"
    "HOL-Library.List_Lexorder"
    Ground_Terms
begin

context
includes fset.lifting
begin

lift_definition fCollect :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset" is "\<lambda> P. if finite (Collect P) then Collect P else {}"
  by auto

lift_definition fSigma :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> ('a \<times> 'b) fset" is Sigma
  by auto

lift_definition is_fempty :: "'a fset \<Rightarrow> bool" is Set.is_empty .
lift_definition fremove :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Set.remove
  by (simp add: remove_def)

lift_definition finj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> bool" is inj_on .
lift_definition the_finv_into  :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a" is the_inv_into .

lemma fCollect_memberI [intro!]:
  "finite (Collect P) \<Longrightarrow> P x \<Longrightarrow> x |\<in>| fCollect P"
  by transfer auto

lemma fCollect_member [iff]:
  "x |\<in>| fCollect P \<longleftrightarrow> finite (Collect P) \<and> P x"
  by transfer (auto split: if_splits)

lemma fCollect_cong: "(\<And>x. P x = Q x) \<Longrightarrow> fCollect P = fCollect Q"
  by presburger
end

syntax
  "_fColl" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a set"    ("(1{|_./ _|})")
translations
  "{|x. P|}" \<rightleftharpoons> "CONST fCollect (\<lambda>x. P)"

syntax (ASCII)
  "_fCollect" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a set"  ("(1{(_/|:| _)./ _})")
syntax
  "_fCollect" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a set"  ("(1{(_/ |\<in>| _)./ _})")
translations
  "{p|:|A. P}" \<rightharpoonup> "CONST fCollect (\<lambda>p. p |\<in>| A \<and> P)"

syntax (ASCII)
  "_fBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3ALL (_/|:|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX (_/|:|_)./ _)" [0, 0, 10] 10)

syntax (input)
  "_fBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3! (_/|:|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3? (_/|:|_)./ _)" [0, 0, 10] 10)

syntax
  "_fBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)

translations
  "\<forall>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. P)"
  "\<exists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBex A (\<lambda>x. P)"

syntax (ASCII output)
  "_setlessfAll" :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3ALL _|<|_./ _)"  [0, 0, 10] 10)
  "_setlessfEx"  :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3EX _|<|_./ _)"  [0, 0, 10] 10)
  "_setlefAll"   :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3ALL _|<=|_./ _)" [0, 0, 10] 10)
  "_setlefEx"    :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3EX _|<=|_./ _)" [0, 0, 10] 10)

syntax
  "_setlessfAll" :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<forall>_|\<subset>|_./ _)"  [0, 0, 10] 10)
  "_setlessfEx"  :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<exists>_|\<subset>|_./ _)"  [0, 0, 10] 10)
  "_setlefAll"   :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<forall>_|\<subseteq>|_./ _)" [0, 0, 10] 10)
  "_setlefEx"    :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<exists>_|\<subseteq>|_./ _)" [0, 0, 10] 10)

translations
 "\<forall>A|\<subset>|B. P" \<rightharpoonup> "\<forall>A. A |\<subset>| B \<longrightarrow> P"
 "\<exists>A|\<subset>|B. P" \<rightharpoonup> "\<exists>A. A |\<subset>| B \<and> P"
 "\<forall>A|\<subseteq>|B. P" \<rightharpoonup> "\<forall>A. A |\<subseteq>| B \<longrightarrow> P"
 "\<exists>A|\<subseteq>|B. P" \<rightharpoonup> "\<exists>A. A |\<subseteq>| B \<and> P"

syntax
  "_fSetcompr" :: "'a \<Rightarrow> idts \<Rightarrow> bool \<Rightarrow> 'a fset"    ("(1{|_ |/_./ _|})")

parse_translation \<open>
  let
    val ex_tr = snd (Syntax_Trans.mk_binder_tr ("EX ", \<^const_syntax>\<open>Ex\<close>));

    fun nvars (Const (\<^syntax_const>\<open>_idts\<close>, _) $ _ $ idts) = nvars idts + 1
      | nvars _ = 1;

    fun setcompr_tr ctxt [e, idts, b] =
      let
        val eq = Syntax.const \<^const_syntax>\<open>HOL.eq\<close> $ Bound (nvars idts) $ e;
        val P = Syntax.const \<^const_syntax>\<open>HOL.conj\<close> $ eq $ b;
        val exP = ex_tr ctxt [idts, P];
      in Syntax.const \<^const_syntax>\<open>fCollect\<close> $ absdummy dummyT exP end;

  in [(\<^syntax_const>\<open>_fSetcompr\<close>, setcompr_tr)] end
\<close>

print_translation \<open>
 [Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>fBall\<close> \<^syntax_const>\<open>_fBall\<close>,
  Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>fBex\<close> \<^syntax_const>\<open>_fBex\<close>]
\<close> \<comment> \<open>to avoid eta-contraction of body\<close>

print_translation \<open>
let
  val ex_tr' = snd (Syntax_Trans.mk_binder_tr' (\<^const_syntax>\<open>Ex\<close>, "DUMMY"));

  fun setcompr_tr' ctxt [Abs (abs as (_, _, P))] =
    let
      fun check (Const (\<^const_syntax>\<open>Ex\<close>, _) $ Abs (_, _, P), n) = check (P, n + 1)
        | check (Const (\<^const_syntax>\<open>HOL.conj\<close>, _) $
              (Const (\<^const_syntax>\<open>HOL.eq\<close>, _) $ Bound m $ e) $ P, n) =
            n > 0 andalso m = n andalso not (loose_bvar1 (P, n)) andalso
            subset (=) (0 upto (n - 1), add_loose_bnos (e, 0, []))
        | check _ = false;

        fun tr' (_ $ abs) =
          let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr' ctxt [abs]
          in Syntax.const \<^syntax_const>\<open>_fSetcompr\<close> $ e $ idts $ Q end;
    in
      if check (P, 0) then tr' P
      else
        let
          val (x as _ $ Free(xN, _), t) = Syntax_Trans.atomic_abs_tr' abs;
          val M = Syntax.const \<^syntax_const>\<open>_fColl\<close> $ x $ t;
        in
          case t of
            Const (\<^const_syntax>\<open>HOL.conj\<close>, _) $
              (Const (\<^const_syntax>\<open>fmember\<close>, _) $
                (Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (yN, _)) $ A) $ P =>
            if xN = yN then Syntax.const \<^syntax_const>\<open>_fCollect\<close> $ x $ A $ P else M
          | _ => M
        end
    end;
  in [(\<^const_syntax>\<open>fCollect\<close>, setcompr_tr')] end
\<close>

syntax
  "_fSigma" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) set"  ("(3fSIGMA _|:|_./ _)" [0, 0, 10] 10)
translations
  "fSIGMA x|:|A. B" \<rightleftharpoons> "CONST fSigma A (\<lambda>x. B)"

notation
  ffUnion ("|\<Union>|")

context
includes fset.lifting
begin

lemma right_total_cr_fset [transfer_rule]:
  "right_total cr_fset"
  by (auto simp: cr_fset_def right_total_def)

lemma bi_unique_cr_fset [transfer_rule]:
  "bi_unique cr_fset"
  by (auto simp: bi_unique_def cr_fset_def fset_inject)

lemma right_total_pcr_fset_eq [transfer_rule]:
  "right_total (pcr_fset (=))"
  by (simp add: right_total_cr_fset fset.pcr_cr_eq)

lemma bi_unique_pcr_fset [transfer_rule]:
  "bi_unique (pcr_fset (=))"
  by (simp add: fset.pcr_cr_eq bi_unique_cr_fset)

lemma set_fset_of_list_transfer [transfer_rule]:
  "rel_fun (list_all2 A) (pcr_fset A) set fset_of_list"
  unfolding pcr_fset_def rel_set_def rel_fun_def
  by (force simp: list_all2_conv_all_nth in_set_conv_nth cr_fset_def fset_of_list.rep_eq relcompp_apply)

lemma fCollectD: "a |\<in>| {|x . P x|} \<Longrightarrow> P a"
  by transfer (auto split: if_splits)

lemma fCollectI: "P a \<Longrightarrow> finite (Collect P) \<Longrightarrow> a |\<in>| {| x. P x|}"
  by (auto intro: fCollect_memberI)

lemma fCollect_fempty_eq [simp]: "fCollect P = {||} \<longleftrightarrow> (\<forall>x. \<not> P x) \<or> infinite (Collect P)"
  by auto

lemma fempty_fCollect_eq [simp]: "{||} = fCollect P \<longleftrightarrow> (\<forall>x. \<not> P x) \<or> infinite (Collect P)"
  by auto

lemma fset_image_conv:
  "{f x | x. x |\<in>| T} = fset (f |`| T)"
  by transfer auto

lemma fimage_def:
  "f |`| A = {| y. \<exists>x|\<in>|A. y = f x |}"
  by transfer auto

lemma ffilter_simp: "ffilter P A = {a |\<in>| A. P a}"
  by transfer auto

lemmas fset_list_fsubset_eq_nth_conv = set_list_subset_eq_nth_conv[Transfer.transferred]
lemmas mem_idx_fset_sound = mem_idx_sound[Transfer.transferred]
\<comment> \<open>Dealing with fset products\<close>

abbreviation fTimes :: "'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) fset"  (infixr "|\<times>|" 80)
  where "A |\<times>| B \<equiv> fSigma A (\<lambda>_. B)"

lemma fSigma_repeq:
  "fset (A |\<times>| B) = fset A \<times> fset B"
  by (transfer) auto

lemmas fSigmaI [intro!] = SigmaI[Transfer.transferred]
lemmas fSigmaE [elim!] = SigmaE[Transfer.transferred]
lemmas fSigmaD1 = SigmaD1[Transfer.transferred]
lemmas fSigmaD2 = SigmaD2[Transfer.transferred]
lemmas fSigmaE2 = SigmaE2[Transfer.transferred]
lemmas fSigma_cong = Sigma_cong[Transfer.transferred]
lemmas fSigma_mono = Sigma_mono[Transfer.transferred]
lemmas fSigma_empty1 [simp] = Sigma_empty1[Transfer.transferred]
lemmas fSigma_empty2 [simp] = Sigma_empty2[Transfer.transferred]
lemmas fmem_Sigma_iff [iff] = mem_Sigma_iff[Transfer.transferred]
lemmas fmem_Times_iff = mem_Times_iff[Transfer.transferred]
lemmas fSigma_empty_iff = Sigma_empty_iff[Transfer.transferred]
lemmas fTimes_subset_cancel2 = Times_subset_cancel2[Transfer.transferred]
lemmas fTimes_eq_cancel2 = Times_eq_cancel2[Transfer.transferred]
lemmas fUN_Times_distrib = UN_Times_distrib[Transfer.transferred]
lemmas fsplit_paired_Ball_Sigma [simp, no_atp] = split_paired_Ball_Sigma[Transfer.transferred]
lemmas fsplit_paired_Bex_Sigma [simp, no_atp] = split_paired_Bex_Sigma[Transfer.transferred]
lemmas fSigma_Un_distrib1 = Sigma_Un_distrib1[Transfer.transferred]
lemmas fSigma_Un_distrib2 = Sigma_Un_distrib2[Transfer.transferred]
lemmas fSigma_Int_distrib1 = Sigma_Int_distrib1[Transfer.transferred]
lemmas fSigma_Int_distrib2 = Sigma_Int_distrib2[Transfer.transferred]
lemmas fSigma_Diff_distrib1 = Sigma_Diff_distrib1[Transfer.transferred]
lemmas fSigma_Diff_distrib2 = Sigma_Diff_distrib2[Transfer.transferred]
lemmas fSigma_Union = Sigma_Union[Transfer.transferred]
lemmas fTimes_Un_distrib1 = Times_Un_distrib1[Transfer.transferred]
lemmas fTimes_Int_distrib1 = Times_Int_distrib1[Transfer.transferred]
lemmas fTimes_Diff_distrib1 = Times_Diff_distrib1[Transfer.transferred]
lemmas fTimes_empty [simp] = Times_empty[Transfer.transferred]
lemmas ftimes_subset_iff = times_subset_iff[Transfer.transferred]
lemmas ftimes_eq_iff = times_eq_iff[Transfer.transferred]
lemmas ffst_image_times [simp] = fst_image_times[Transfer.transferred]
lemmas fsnd_image_times [simp] = snd_image_times[Transfer.transferred]
lemmas fsnd_image_Sigma = snd_image_Sigma[Transfer.transferred]
lemmas finsert_Times_insert = insert_Times_insert[Transfer.transferred]
lemmas fTimes_Int_Times = Times_Int_Times[Transfer.transferred]
lemmas fimage_paired_Times = image_paired_Times[Transfer.transferred]
lemmas fproduct_swap = product_swap[Transfer.transferred]
lemmas fswap_product = swap_product[Transfer.transferred]
lemmas fsubset_fst_snd = subset_fst_snd[Transfer.transferred]
lemmas map_prod_ftimes = map_prod_times[Transfer.transferred]

lemma fCollect_case_prod [simp]:
  "{|(a, b). P a \<and> Q b|} = fCollect P |\<times>| fCollect Q"
  by transfer (auto dest: finite_cartesian_productD1 finite_cartesian_productD2)
lemma fCollect_case_prodD:
  "x |\<in>| {|(x, y). A x y|} \<Longrightarrow> A (fst x) (snd x)"
  by auto

(*FIX *)
lemmas fCollect_case_prod_Sigma = Collect_case_prod_Sigma[Transfer.transferred]
lemmas ffst_image_Sigma = fst_image_Sigma[Transfer.transferred]
lemmas fimage_split_eq_Sigma = image_split_eq_Sigma[Transfer.transferred]

\<comment> \<open>Dealing with transitive closure\<close>

lift_definition ftrancl :: "('a \<times> 'a) fset \<Rightarrow> ('a \<times> 'a) fset"  ("(_|\<^sup>+|)" [1000] 999) is trancl
  by auto

lemmas fr_into_trancl [intro, Pure.intro] = r_into_trancl[Transfer.transferred]
lemmas ftrancl_into_trancl [Pure.intro] = trancl_into_trancl[Transfer.transferred]
lemmas ftrancl_induct[consumes 1, case_names Base Step] = trancl.induct[Transfer.transferred]
lemmas ftrancl_mono = trancl_mono[Transfer.transferred]
lemmas ftrancl_trans[trans] = trancl_trans[Transfer.transferred]
lemmas ftrancl_empty [simp] = trancl_empty [Transfer.transferred]
lemmas ftranclE[cases set: ftrancl] = tranclE[Transfer.transferred]
lemmas converse_ftrancl_induct[consumes 1, case_names Base Step] = converse_trancl_induct[Transfer.transferred]
lemmas converse_ftranclE = converse_tranclE[Transfer.transferred]
lemma in_ftrancl_UnI:
  "x |\<in>| R|\<^sup>+| \<or> x |\<in>| S|\<^sup>+| \<Longrightarrow> x |\<in>| (R |\<union>| S)|\<^sup>+|"
  by transfer (auto simp add: trancl_mono)

lemma ftranclD:
  "(x, y) |\<in>| R|\<^sup>+| \<Longrightarrow> \<exists>z. (x, z) |\<in>| R \<and> (z = y \<or> (z, y) |\<in>| R|\<^sup>+|)"
  by (induct rule: ftrancl_induct) (auto, meson ftrancl_into_trancl)

lemma ftranclD2:
  "(x, y) |\<in>| R|\<^sup>+| \<Longrightarrow> \<exists>z. (x = z \<or> (x, z) |\<in>| R|\<^sup>+|) \<and> (z, y) |\<in>| R"
  by (induct rule: ftrancl_induct) auto

lemma not_ftrancl_into:
  "(x, z) |\<notin>| r|\<^sup>+| \<Longrightarrow> (y, z) |\<in>| r \<Longrightarrow> (x, y) |\<notin>| r|\<^sup>+|"
  by transfer (auto simp add: trancl.trancl_into_trancl)
lemmas ftrancl_map_both_fRestr = trancl_map_both_Restr[Transfer.transferred]
lemma ftrancl_map_both_fsubset:
  "finj_on f X \<Longrightarrow> R |\<subseteq>| X |\<times>| X \<Longrightarrow> (map_both f |`| R)|\<^sup>+| = map_both f |`| R|\<^sup>+|"
  using ftrancl_map_both_fRestr[of f X R]
  by (simp add: inf_absorb1)
lemmas ftrancl_map_prod_mono = trancl_map_prod_mono[Transfer.transferred]
lemmas ftrancl_map = trancl_map[Transfer.transferred]

lemmas ffUnion_iff [simp] = Union_iff[Transfer.transferred]
lemmas ffUnionI [intro] = UnionI[Transfer.transferred]
lemmas fUn_simps [simp] = UN_simps[Transfer.transferred]

(* TODO Diff *)
lemmas fINT_simps [simp] = INT_simps[Transfer.transferred]

lemmas fUN_ball_bex_simps [simp] = UN_ball_bex_simps[Transfer.transferred]

(* List *)
lemmas in_fset_conv_nth = in_set_conv_nth[Transfer.transferred]
lemmas fnth_mem [simp] = nth_mem[Transfer.transferred]
lemmas distinct_sorted_list_of_fset = distinct_sorted_list_of_set [Transfer.transferred]
lemmas fcard_fset = card_set[Transfer.transferred]
lemma upt_fset:
  "fset_of_list [i..<j] = fCollect (\<lambda> n. i \<le> n \<and> n < j)"
  by (induct j arbitrary: i) auto

(* Restr *)
abbreviation fRestr :: "('a \<times> 'a) fset \<Rightarrow> 'a fset \<Rightarrow> ('a \<times> 'a) fset" where
  "fRestr r A \<equiv> r |\<inter>| (A |\<times>| A)"

(* Identity on set*)

lift_definition fId_on :: "'a fset \<Rightarrow> ('a \<times> 'a) fset" is Id_on
  using Id_on_subset_Times finite_subset by fastforce

lemmas fId_on_empty [simp] = Id_on_empty [Transfer.transferred]
lemmas fId_on_eqI = Id_on_eqI [Transfer.transferred]
lemmas fId_onI [intro!] = Id_onI [Transfer.transferred]
lemmas fId_onE [elim!] = Id_onE [Transfer.transferred]
lemmas fId_on_iff = Id_on_iff [Transfer.transferred]
lemmas fId_on_fsubset_fTimes = Id_on_subset_Times [Transfer.transferred]

(* Converse*)
lift_definition fconverse :: "('a \<times> 'b) fset \<Rightarrow> ('b \<times> 'a) fset"  ("(_|\<inverse>|)" [1000] 999) is converse by auto

lemmas fconverseI [sym] = converseI [Transfer.transferred]
lemmas fconverseD [sym] = converseD [Transfer.transferred]
lemmas fconverseE [elim!] = converseE [Transfer.transferred]
lemmas fconverse_iff [iff] = converse_iff[Transfer.transferred]
lemmas fconverse_fconverse [simp] = converse_converse[Transfer.transferred]
lemmas fconverse_empty[simp] = converse_empty[Transfer.transferred]

(* injectivity *)

lemmas finj_on_def' = inj_on_def[Transfer.transferred]
lemmas fsubset_finj_on = subset_inj_on[Transfer.transferred]
lemmas the_finv_into_f_f = the_inv_into_f_f[Transfer.transferred]
lemmas f_the_finv_into_f = f_the_inv_into_f[Transfer.transferred]
lemmas the_finv_into_into = the_inv_into_into[Transfer.transferred]
lemmas the_finv_into_onto [simp] = the_inv_into_onto[Transfer.transferred]
lemmas the_finv_into_f_eq = the_inv_into_f_eq[Transfer.transferred]
lemmas the_finv_into_comp = the_inv_into_comp[Transfer.transferred]
lemmas finj_on_the_finv_into = inj_on_the_inv_into [Transfer.transferred]
lemmas finj_on_fUn = inj_on_Un[Transfer.transferred]

lemma finj_Inl_Inr:
  "finj_on Inl A" "finj_on Inr A"
  by (transfer, auto)+
lemma finj_CInl_CInr:
  "finj_on CInl A" "finj_on CInr A"
  using finj_Inl_Inr by force+

lemma finj_Some:
  "finj_on Some A"
  by (transfer, auto)

(* Image *)

lift_definition fImage :: "('a \<times> 'b) fset \<Rightarrow> 'a fset \<Rightarrow> 'b fset" (infixr "|``|" 90) is Image
  using finite_Image by force

lemmas fImage_iff = Image_iff[Transfer.transferred]
lemmas fImage_singleton_iff [iff] = Image_singleton_iff[Transfer.transferred]
lemmas fImageI [intro] = ImageI[Transfer.transferred]
lemmas ImageE [elim!] = ImageE[Transfer.transferred]
lemmas frev_ImageI = rev_ImageI[Transfer.transferred]
lemmas fImage_empty1 [simp] = Image_empty1[Transfer.transferred]
lemmas fImage_empty2 [simp] = Image_empty2[Transfer.transferred]
lemmas fImage_fInt_fsubset = Image_Int_subset[Transfer.transferred]
lemmas fImage_fUn = Image_Un[Transfer.transferred]
lemmas fUn_fImage = Un_Image[Transfer.transferred]
lemmas fImage_fsubset = Image_subset[Transfer.transferred]
lemmas fImage_eq_fUN = Image_eq_UN[Transfer.transferred]
lemmas fImage_mono = Image_mono[Transfer.transferred]
lemmas fImage_fUN = Image_UN[Transfer.transferred]
lemmas fUN_fImage = UN_Image[Transfer.transferred]
lemmas fSigma_fImage = Sigma_Image[Transfer.transferred]

(* fix us *)
lemmas fImage_singleton = Image_singleton[Transfer.transferred]
lemmas fImage_Id_on [simp] = Image_Id_on[Transfer.transferred]
lemmas fImage_Id [simp] = Image_Id[Transfer.transferred]
lemmas fImage_fInt_eq = Image_Int_eq[Transfer.transferred]
lemmas fImage_fsubset_eq = Image_subset_eq[Transfer.transferred]
lemmas fImage_fCollect_case_prod [simp] = Image_Collect_case_prod[Transfer.transferred]
lemmas fImage_fINT_fsubset = Image_INT_subset[Transfer.transferred]
(* Misc *)
lemmas term_fset_induct = term.induct[Transfer.transferred]
lemmas fmap_prod_fimageI = map_prod_imageI[Transfer.transferred]
lemmas finj_on_eq_iff = inj_on_eq_iff[Transfer.transferred]
lemmas prod_fun_fimageE = prod_fun_imageE[Transfer.transferred]

lemma rel_set_cr_fset:
  "rel_set cr_fset = (\<lambda> A B. A = fset ` B)"
proof -
  have "rel_set cr_fset A B \<longleftrightarrow> A = fset ` B" for A B
    by (auto simp: image_def rel_set_def cr_fset_def )
  then show ?thesis by blast
qed
lemma pcr_fset_cr_fset:
  "pcr_fset cr_fset = (\<lambda> x y. x = fset (fset |`| y))"
  unfolding pcr_fset_def rel_set_cr_fset
  unfolding cr_fset_def
  by (auto simp: image_def relcompp_apply)

lemma sorted_list_of_fset_id:
  "sorted_list_of_fset x = sorted_list_of_fset y \<Longrightarrow> x = y"
  by (metis sorted_list_of_fset_simps(2))

(*end *)

lemmas fBall_def = Ball_def[Transfer.transferred]
lemmas fBex_def = Bex_def[Transfer.transferred]
lemmas fCollectE = fCollectD [elim_format]
lemma fCollect_conj_eq:
  "finite (Collect P) \<Longrightarrow> finite (Collect Q) \<Longrightarrow> {|x. P x \<and> Q x|} = fCollect P |\<inter>| fCollect Q"
  by auto

lemma finite_ntrancl:
  "finite R \<Longrightarrow> finite (ntrancl n R)"
  by (induct n) auto

lift_definition nftrancl :: "nat \<Rightarrow> ('a \<times> 'a) fset \<Rightarrow> ('a \<times> 'a) fset" is ntrancl
  by (intro finite_ntrancl) simp

lift_definition frelcomp :: "('a \<times> 'b) fset \<Rightarrow> ('b \<times> 'c) fset \<Rightarrow> ('a \<times> 'c) fset" (infixr "|O|" 75) is relcomp
  by (intro finite_relcomp) simp

lemmas frelcompE[elim!] = relcompE[Transfer.transferred]
lemmas frelcompI[intro] = relcompI[Transfer.transferred]
lemma fId_on_frelcomp_id:
  "fst |`| R |\<subseteq>| S \<Longrightarrow> fId_on S |O| R = R"
  by (auto intro!: frelcompI)
lemma fId_on_frelcomp_id2:
 "snd |`| R |\<subseteq>| S \<Longrightarrow> R |O| fId_on S = R"
  by (auto intro!: frelcompI)

lemmas fimage_fset = image_set[Transfer.transferred]
lemmas ftrancl_Un2_separatorE = trancl_Un2_separatorE[Transfer.transferred]

(* finite vars of term finite function symbols of terms *)

lemma finite_funs_term: "finite (funs_term t)" by (induct t) auto
lemma finite_funas_term: "finite (funas_term t)" by (induct t) auto
lemma finite_vars_ctxt: "finite (vars_ctxt C)" by (induct C) auto

lift_definition ffuns_term :: "('f, 'v) term \<Rightarrow> 'f fset" is funs_term using finite_funs_term
  by blast
lift_definition fvars_term :: "('f, 'v) term \<Rightarrow> 'v fset" is vars_term by simp
lift_definition fvars_ctxt :: "('f, 'v) ctxt \<Rightarrow> 'v fset" is vars_ctxt by (simp add: finite_vars_ctxt)

lemmas fvars_term_ctxt_apply [simp] = vars_term_ctxt_apply[Transfer.transferred]
lemmas fvars_term_of_gterm [simp] = vars_term_of_gterm[Transfer.transferred]
lemmas ground_fvars_term_empty [simp] = ground_vars_term_empty[Transfer.transferred]

lemma ffuns_term_Var [simp]: "ffuns_term (Var x) = {||}"
  by transfer auto
lemma fffuns_term_Fun [simp]: "ffuns_term (Fun f ts) = |\<Union>| (ffuns_term |`| fset_of_list ts) |\<union>| {|f|}"
  by transfer auto

lemma fvars_term_Var [simp]: "fvars_term (Var x) = {|x|}"
  by transfer auto
lemma fvars_term_Fun [simp]: "fvars_term (Fun f ts) = |\<Union>| (fvars_term |`| fset_of_list ts)"
  by transfer auto

lift_definition ffunas_term :: "('f, 'v) term \<Rightarrow> ('f \<times> nat) fset" is funas_term
  by (simp add: finite_funas_term)
lift_definition ffunas_gterm :: "'f gterm \<Rightarrow> ('f \<times> nat) fset" is funas_gterm
  by (simp add: finite_funas_gterm)

lemmas ffunas_term_simps [simp] = funas_term.simps[Transfer.transferred]
lemmas ffunas_gterm_simps [simp] = funas_gterm.simps[Transfer.transferred]
lemmas ffunas_term_of_gterm_conv = funas_term_of_gterm_conv[Transfer.transferred]
lemmas ffunas_gterm_gterm_of_term = funas_gterm_gterm_of_term[Transfer.transferred]

lemma sorted_list_of_fset_fimage_dist:
  "sorted_list_of_fset (f |`| A) = sort (remdups (map f (sorted_list_of_fset A)))"
  by (auto simp: sorted_list_of_fset.rep_eq simp flip: sorted_list_of_set_sort_remdups)

end

(* Move me *)
lemma finite_snd [intro]:
  "finite S \<Longrightarrow> finite {x. (y, x) \<in> S}"
  by (induct S rule: finite.induct) auto

lemma finite_Collect_less_eq:
  "Q \<le> P \<Longrightarrow> finite (Collect P) \<Longrightarrow> finite (Collect Q)"
  by (metis (full_types) Ball_Collect infinite_iff_countable_subset rev_predicate1D)

datatype 'a FSet_Lex_Wrapper = Wrapp (ex: "'a fset")

lemma inj_FSet_Lex_Wrapper: "inj Wrapp"
  unfolding inj_def by auto

lemmas ftrancl_map_both = inj_on_trancl_map_both[Transfer.transferred]

instantiation FSet_Lex_Wrapper :: (linorder) linorder
begin

definition less_eq_FSet_Lex_Wrapper :: "('a :: linorder) FSet_Lex_Wrapper \<Rightarrow> 'a FSet_Lex_Wrapper \<Rightarrow> bool"
  where "less_eq_FSet_Lex_Wrapper S T =
    (let S' = sorted_list_of_fset (ex S) in
     let T' = sorted_list_of_fset (ex T) in
     S' \<le> T')"

definition less_FSet_Lex_Wrapper :: "'a FSet_Lex_Wrapper \<Rightarrow> 'a FSet_Lex_Wrapper \<Rightarrow> bool"
  where "less_FSet_Lex_Wrapper S T =
    (let S' = sorted_list_of_fset (ex S) in
     let T' = sorted_list_of_fset (ex T) in
     S' < T')"

instance by (intro_classes)
   (auto simp: less_eq_FSet_Lex_Wrapper_def less_FSet_Lex_Wrapper_def ex_def FSet_Lex_Wrapper.expand dest: sorted_list_of_fset_id)
end

end


(* Formalisation of weakening using locally nameless    *)
(* terms; the nominal infrastructure can also derive    *)
(* strong induction principles for such representations *)
(*                                                      *)
(* Authors: Christian Urban and Randy Pollack           *)
theory LocalWeakening
  imports "../Nominal"
begin

atom_decl name

text \<open>
  Curry-style lambda terms in locally nameless
  representation without any binders
\<close>
nominal_datatype llam =
    lPar "name"
  | lVar "nat"
  | lApp "llam" "llam"
  | lLam "llam"

text \<open>definition of vsub - at the moment a bit cumbersome\<close>

lemma llam_cases:
  "(\<exists>a. t = lPar a) \<or> (\<exists>n. t = lVar n) \<or> (\<exists>t1 t2. t = lApp t1 t2) \<or>
   (\<exists>t1. t = lLam t1)"
by (induct t rule: llam.induct)
   (auto simp add: llam.inject)

nominal_primrec
  llam_size :: "llam \<Rightarrow> nat"
where
  "llam_size (lPar a) = 1"
| "llam_size (lVar n) = 1"
| "llam_size (lApp t1 t2) = 1 + (llam_size t1) + (llam_size t2)"
| "llam_size (lLam t) = 1 + (llam_size t)"
by (rule TrueI)+

function
  vsub :: "llam \<Rightarrow> nat \<Rightarrow> llam \<Rightarrow> llam"
where
   vsub_lPar: "vsub (lPar p) x s = lPar p"
 | vsub_lVar: "vsub (lVar n) x s = (if n < x then (lVar n)
                      else (if n = x then s else (lVar (n - 1))))"
 | vsub_lApp: "vsub (lApp t u) x s = (lApp (vsub t x s) (vsub u x s))"
 | vsub_lLam: "vsub (lLam t) x s = (lLam (vsub t (x + 1) s))"
using llam_cases
apply(auto simp add: llam.inject)
apply(rotate_tac 4)
apply(drule_tac x="a" in meta_spec)
apply(blast)
done
termination by (relation "measure (llam_size \<circ> fst)") auto

lemma vsub_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(vsub t n s) = vsub (pi\<bullet>t) (pi\<bullet>n) (pi\<bullet>s)"
by (induct t arbitrary: n rule: llam.induct)
   (simp_all add: perm_nat_def)

definition freshen :: "llam \<Rightarrow> name \<Rightarrow> llam" where
  "freshen t p \<equiv> vsub t 0 (lPar p)"

lemma freshen_eqvt[eqvt]:
  fixes pi::"name prm"
  shows "pi\<bullet>(freshen t p) = freshen (pi\<bullet>t) (pi\<bullet>p)"
by (simp add: vsub_eqvt freshen_def perm_nat_def)

text \<open>types\<close>

nominal_datatype ty =
    TVar "nat"
  | TArr "ty" "ty" (infix "\<rightarrow>" 200)

lemma ty_fresh[simp]:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (induct T rule: ty.induct)
   (simp_all add: fresh_nat)

text \<open>valid contexts\<close>

type_synonym cxt = "(name\<times>ty) list"

inductive
  valid :: "cxt \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,T)#\<Gamma>)"

equivariance valid

lemma v2_elim:
  assumes a: "valid ((a,T)#\<Gamma>)"
  shows   "a\<sharp>\<Gamma> \<and> valid \<Gamma>"
using a by (cases) (auto)

text \<open>"weak" typing relation\<close>

inductive
  typing :: "cxt\<Rightarrow>llam\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [60,60,60] 60)
where
  t_lPar[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lPar x : T"
| t_lApp[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : T1\<rightarrow>T2; \<Gamma> \<turnstile> t2 : T1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lApp t1 t2 : T2"
| t_lLam[intro]: "\<lbrakk>x\<sharp>t; (x,T1)#\<Gamma> \<turnstile> freshen t x : T2\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> lLam t : T1\<rightarrow>T2"

equivariance typing

lemma typing_implies_valid:
  assumes a: "\<Gamma> \<turnstile> t : T"
  shows "valid \<Gamma>"
using a by (induct) (auto dest: v2_elim)

text \<open>
  we have to explicitly state that nominal_inductive should strengthen
  over the variable x (since x is not a binder)
\<close>
nominal_inductive typing
  avoids t_lLam: x
  by (auto simp add: fresh_prod dest: v2_elim typing_implies_valid)

text \<open>strong induction principle for typing\<close>
thm typing.strong_induct

text \<open>sub-contexts\<close>

abbreviation
  "sub_context" :: "cxt \<Rightarrow> cxt \<Rightarrow> bool" ("_ \<subseteq> _" [60,60] 60)
where
  "\<Gamma>1 \<subseteq> \<Gamma>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>1 \<longrightarrow> (x,T)\<in>set \<Gamma>2"

lemma weakening_almost_automatic:
  fixes \<Gamma>1 \<Gamma>2 :: cxt
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "\<Gamma>1 \<subseteq> \<Gamma>2"
  and     c: "valid \<Gamma>2"
shows "\<Gamma>2 \<turnstile> t : T"
using a b c
apply(nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
apply(auto)
apply(drule_tac x="(x,T1)#\<Gamma>2" in meta_spec)
apply(auto intro!: t_lLam)
done

lemma weakening_in_more_detail:
  fixes \<Gamma>1 \<Gamma>2 :: cxt
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "\<Gamma>1 \<subseteq> \<Gamma>2"
  and     c: "valid \<Gamma>2"
shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof(nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
  case (t_lPar \<Gamma>1 x T \<Gamma>2)  (* variable case *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T)\<in> set \<Gamma>1" by fact
  ultimately show "\<Gamma>2 \<turnstile> lPar x : T" by auto
next
  case (t_lLam x t T1 \<Gamma>1 T2 \<Gamma>2) (* lambda case *)
  have vc: "x\<sharp>\<Gamma>2" "x\<sharp>t" by fact+  (* variable convention *)
  have ih: "\<lbrakk>(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2; valid ((x,T1)#\<Gamma>2)\<rbrakk> \<Longrightarrow> (x,T1)#\<Gamma>2 \<turnstile> freshen t x : T2" by fact
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  then have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" by simp
  moreover
  have "valid \<Gamma>2" by fact
  then have "valid ((x,T1)#\<Gamma>2)" using vc by (simp add: v2)
  ultimately have "(x,T1)#\<Gamma>2 \<turnstile> freshen t x : T2" using ih by simp
  with vc show "\<Gamma>2 \<turnstile> lLam t : T1\<rightarrow>T2" by auto
next
  case (t_lApp \<Gamma>1 t1 T1 T2 t2 \<Gamma>2)
  then show "\<Gamma>2 \<turnstile> lApp t1 t2 : T2" by auto
qed

end


theory Minimal
imports FreeGroupMain Distinct_Inverse
begin

definition union_inv
  where
"union_inv S A \<equiv> S \<union> (m_inv (freegroup A) ` S)"

lemma inv_inv_G:
  assumes "group G" "x \<in> carrier G"
   shows "inv\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> x) = x"
  using assms
  by simp

lemma inv_in_S:
  assumes "x \<in> (m_inv G ` S)" "x \<in> carrier G" "S \<subseteq> carrier G" "group G"
  shows "inv\<^bsub>G\<^esub> x \<in> S"
proof-
 obtain y where y:"x = m_inv G y" "y \<in> S" using assms(1) by force
 have "y = m_inv  G x" using inv_inv_G assms(2,4) unfolding y
   by (metis assms(3) in_mono y(2))
  then show ?thesis using y(2) by blast
qed

lemma intersection_lemma:
  assumes "A \<inter> (f ` A) = {}"
      and "x \<notin> A"
      and "f x \<notin> A"
      and "x \<notin> f ` A"
      and "x \<noteq> f x"
    shows "(A \<union> {x}) \<inter> (f ` (A \<union> { x})) = {}"
  using assms
proof-
  have "(A \<union> {x}) \<inter> (f ` (A \<union> { x})) = (A \<union> {x}) \<inter> ((f  ` A) \<union> {f x})"
    by force
  moreover then have "... =  (A  \<inter> ((f  ` A) \<union> {f x})) \<union> ({x} \<inter> ((f  ` A) \<union> {f x}))"
    by blast
  moreover then have "... = (A  \<inter> (f  ` A)) \<union> (A  \<inter> {f x})  \<union> ({x} \<inter> ((f  ` A)) \<union> ({x} \<inter> {f x}))"
    by fast
  moreover then have "... =  ({x} \<inter> ((f  ` A)) \<union> ({x} \<inter> {f x}))"
    using assms by simp
  moreover then have "... = {}" using assms by blast
  ultimately show ?thesis by simp
qed

definition minimal_set
  where
"minimal_set S A = (SOME X. X \<subseteq> S \<and>  X \<inter> (m_inv (freegroup A) ` X) = {}
                       \<and> union_inv S A = union_inv X A)"
(*
lemma assumes "x \<in> carrier (freegroup A)" "x \<noteq> one (freegroup A)"
  shows "x \<noteq> m_inv (freegroup A) x"
proof(rule ccontr)
  assume "\<not> x \<noteq> inv\<^bsub>freegroup A\<^esub> x"
  then have "x = inv\<^bsub>freegroup A\<^esub> x" by argo
  then obtain w where "w \<in> \<langle>A\<rangle>" "x = A(w)" *)

lemma (in group) one_not_in_inv:
assumes "S \<subseteq> carrier (freegroup A)"
          "\<one>\<^bsub>freegroup A\<^esub> \<notin> S"
shows  "\<one>\<^bsub>freegroup A\<^esub> \<notin>  m_inv (freegroup A) `S"
proof(rule ccontr)
  assume asm:"\<not> \<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub> \<notin> m_inv F\<^bsub>A\<^esub> ` S"
  then have "\<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub> \<in> m_inv F\<^bsub>A\<^esub> ` S" by auto
  then obtain x where x:"\<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub> \<otimes>\<^bsub>F\<^bsub>A\<^esub>\<^esub> x = \<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub>" "x \<in> S"
    unfolding m_inv_def image_def apply simp
    by (meson \<open>\<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub> \<in> m_inv F\<^bsub>A\<^esub> ` S\<close> assms(1) freegroup_is_group group.r_inv group.subgroup_self inv_in_S subgroup.one_closed)
  have "x = \<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub>" using  x(1) x(2) assms(2)
    by (meson assms(1) freegroup_is_group gen_span.gen_one group.l_cancel_one span_liftgen subsetD)
  then show False using x(2) assms(2) by argo
qed

lemma (in group)
  assumes "S \<subseteq> carrier (freegroup A)"
          "\<one>\<^bsub>freegroup A\<^esub> \<notin> S"
   shows "\<exists>X. X \<subseteq> S \<and> X \<inter> (m_inv (freegroup A) ` X) = {} \<and> union_inv S A = union_inv X A"
proof-
  have one_notin:"\<one>\<^bsub>freegroup A\<^esub> \<notin>  m_inv (freegroup A) `S" using one_not_in_inv[OF assms]  .
  define Y where "Y = {X. X \<subseteq> S \<and>  X \<inter> (m_inv (freegroup A) ` X) = {}}"
   {fix C
    assume C:"subset.chain Y C"
    then have 1:"(\<Union> C) \<subseteq> S" using C unfolding Y_def subset.chain_def by blast
     have 11:"(\<Union> C)  \<inter> (m_inv (freegroup A) ` (\<Union> C) ) = {}"
     proof(rule ccontr)
       assume asm:"\<Union> C \<inter> m_inv (freegroup A) ` \<Union> C \<noteq> {}"
       then obtain x where x:"x \<in> \<Union> C \<inter> m_inv (freegroup A) ` \<Union> C" by blast
       then have x_in:"x \<in> m_inv (freegroup A) ` \<Union> C" using IntD2 by blast
       then have 2:"inv\<^bsub>(freegroup A)\<^esub> x \<in>  \<Union> C" using inv_in_S[OF x_in]
           freegroup_is_group[of A] 1 assms by fastforce
       moreover have "x \<in> \<Union> C" using x IntD1 by blast
       then obtain P Q where P_Q:"P \<in> C" "Q \<in> C" "x \<in> P" "inv\<^bsub>(freegroup A)\<^esub> x \<in> Q"
         using 2 by blast
       then have Or:"P \<subseteq> Q \<or>  Q \<subseteq> P" using C unfolding subset.chain_def
         by (meson C subset_chain_def)
       have "P \<subseteq> Q \<Longrightarrow> x \<in> Q \<and> m_inv (freegroup A) x \<in> Q" using P_Q by blast
       hence F1:"P \<subseteq> Q \<Longrightarrow> False" using C P_Q(2) Y_def
         unfolding subset.chain_def[of Y C]
         by blast
       have "Q \<subseteq> P \<Longrightarrow> x \<in> P \<and> m_inv (freegroup A) x \<in> P"
         using P_Q by blast
       hence F2:"Q \<subseteq> P \<Longrightarrow> False"
          using C P_Q(1) Y_def
         unfolding subset.chain_def[of Y C]
         by blast
       show False using F1 F2 Or by argo
     qed
     then have "\<Union>C \<in> Y" using C 1 11 unfolding Y_def by force
   } note inter = this
   obtain M where M:"M \<in> Y" "\<forall>X\<in>Y. M \<subseteq> X \<longrightarrow> X = M" "M \<in> Y"
     using subset_Zorn'[OF inter] by fast
   then have M_sub:"M \<subseteq> S" unfolding Y_def by blast
   then have inv_M_sub:
         "m_inv (freegroup A) `M \<subseteq> m_inv (freegroup A) ` S" by blast
   have a:"M \<inter> m_inv (freegroup A) `M = {}" using M
     using Y_def by fastforce
   have "union_inv M A = union_inv S A"
     unfolding union_inv_def
   proof(rule ccontr)
     assume asm:"M \<union> m_inv (freegroup A) ` M \<noteq> S \<union> m_inv (freegroup A) ` S"
     have "M \<union> m_inv (freegroup A) ` M \<subseteq> S  \<union> m_inv (freegroup A) ` S"
       using M_sub inv_M_sub  by blast
     then obtain x where x:"x \<in> S  \<union> m_inv (freegroup A) ` S"
           "x \<notin> M \<union> m_inv (freegroup A) ` M " using asm
       by auto
     then have "x \<noteq> \<one>\<^bsub>F\<^bsub>A\<^esub>\<^esub>" using one_notin assms(2) by fastforce
     then have not_eq_inv:"x \<noteq> m_inv (freegroup A) x" using not_eq_inv[of x A] x(1) assms(1)
       by (smt (verit) Un_iff gen_span.gen_inv image_iff liftgen_span span_liftgen subsetD)
     then show False
     proof (cases "x \<in> S")
       case True
       have x_not_in:"x \<notin> m_inv (freegroup A) ` M" using x(2) by blast
       then have "m_inv (freegroup A) x \<notin> M" using x
        by (smt (verit, ccfv_threshold) UnE assms freegroup_is_group group.inv_inv imageE imageI in_mono)
       define M1 where "M1 = M \<union> {x}"
       then have "M1 \<subseteq> S" using x M_sub True by fast
       moreover have "M1 \<inter> (m_inv (freegroup A) ` M1) = {}" using x(2) M(1)
         unfolding Y_def
         using intersection_lemma[of M "\<lambda>x. (m_inv (freegroup A) x)" x] not_eq_inv
         unfolding M1_def
         using \<open>inv\<^bsub>F\<^bsub>A\<^esub>\<^esub> x \<notin> M\<close> by fastforce
       ultimately have "M1 \<in> Y" unfolding Y_def by force
       then have "M1 = M" using M(2) M1_def by fast
       then show False using M1_def x by blast
     next
       case False
       then obtain y where y:"y \<in> S" "x = m_inv (freegroup A) y"
         using x by blast
       then have y_inv:"y = m_inv (freegroup A) x"
         by (metis assms(1) freegroup_is_group group.inv_inv subsetD)
       define M1 where M1:"M1 = M \<union> {y}"
       then have "M1 \<subseteq> S" using y M_sub  by fast
       then have "y \<notin> M" using y y_inv x  by blast
       moreover have " inv\<^bsub>F\<^bsub>A\<^esub>\<^esub> y \<notin> M" using y y_inv x by blast
       moreover have "y \<notin>  m_inv F\<^bsub>A\<^esub> ` M"  using y y_inv x
         by (meson M_sub assms(1) calculation(2) freegroup_is_group in_mono inv_in_S subsetI)
       moreover have "y \<noteq> inv\<^bsub>F\<^bsub>A\<^esub>\<^esub> y" using y y_inv not_eq_inv by presburger
       ultimately have "M1 \<inter> (m_inv (freegroup A) ` M1) = {}" using y x(2) M(1)
         unfolding Y_def
         using intersection_lemma[of M "\<lambda>x. (m_inv (freegroup A) x)" y] y y_inv not_eq_inv
         unfolding M1  by fast
       then have "M1 \<in> Y" unfolding Y_def
         using \<open>M1 \<subseteq> S\<close>
         using \<open>M1 \<inter> m_inv F\<^bsub>A\<^esub> ` M1 = {}\<close> by blast
       then have "M1 = M" using M(2) M1 by fast
       then show False using M1 y x by blast
     qed
   qed
  then show ?thesis using M(1) M_sub exI unfolding Y_def
    using CollectD by blast
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_add3acc_comm12
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x y z) = (add3acc y x z))"
  oops

end