(*  Title:      ZF/ZF_Base.thy
    Author:     Lawrence C Paulson and Martin D Coen, CU Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Base of Zermelo-Fraenkel Set Theory\<close>

theory ZF_Base
imports FOL
begin

subsection \<open>Signature\<close>

declare [[eta_contract = false]]

typedecl i
instance i :: "term" ..

axiomatization mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<in>\<close> 50)  \<comment> \<open>membership relation\<close>
  and zero :: "i"  (\<open>0\<close>)  \<comment> \<open>the empty set\<close>
  and Pow :: "i \<Rightarrow> i"  \<comment> \<open>power sets\<close>
  and Inf :: "i"  \<comment> \<open>infinite set\<close>
  and Union :: "i \<Rightarrow> i"  (\<open>\<Union>_\<close> [90] 90)
  and PrimReplace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"

abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<notin>\<close> 50)  \<comment> \<open>negated membership relation\<close>
  where "x \<notin> y \<equiv> \<not> (x \<in> y)"

subsection \<open>Bounded Quantifiers\<close>

definition Ball :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Ball(A, P) \<equiv> \<forall>x. x\<in>A \<longrightarrow> P(x)"

definition Bex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"
  where "Bex(A, P) \<equiv> \<exists>x. x\<in>A \<and> P(x)"

syntax
  "_Ball" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<forall>_\<in>_./ _)\<close> 10)
  "_Bex" :: "[pttrn, i, o] \<Rightarrow> o"  (\<open>(3\<exists>_\<in>_./ _)\<close> 10)
translations
  "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball(A, \<lambda>x. P)"
  "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex(A, \<lambda>x. P)"

subsection \<open>Variations on Replacement\<close>

(* Derived form of replacement, restricting P to its functional part.
   The resulting set (for functional P) is the same as with
   PrimReplace, but the rules are simpler. *)
definition Replace :: "[i, [i, i] \<Rightarrow> o] \<Rightarrow> i"
  where "Replace(A,P) \<equiv> PrimReplace(A, \<lambda>x y. (\<exists>!z. P(x,z)) \<and> P(x,y))"

syntax
  "_Replace"  :: "[pttrn, pttrn, i, o] \<Rightarrow> i"  (\<open>(1{_ ./ _ \<in> _, _})\<close>)
translations
  "{y. x\<in>A, Q}" \<rightleftharpoons> "CONST Replace(A, \<lambda>x y. Q)"

(* Functional form of replacement -- analgous to ML's map functional *)

definition RepFun :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "RepFun(A,f) \<equiv> {y . x\<in>A, y=f(x)}"

syntax
  "_RepFun" :: "[i, pttrn, i] \<Rightarrow> i"  (\<open>(1{_ ./ _ \<in> _})\<close> [51,0,51])
translations
  "{b. x\<in>A}" \<rightleftharpoons> "CONST RepFun(A, \<lambda>x. b)"

(* Separation and Pairing can be derived from the Replacement
   and Powerset Axioms using the following definitions. *)
definition Collect :: "[i, i \<Rightarrow> o] \<Rightarrow> i"
  where "Collect(A,P) \<equiv> {y . x\<in>A, x=y \<and> P(x)}"

syntax
  "_Collect" :: "[pttrn, i, o] \<Rightarrow> i"  (\<open>(1{_ \<in> _ ./ _})\<close>)
translations
  "{x\<in>A. P}" \<rightleftharpoons> "CONST Collect(A, \<lambda>x. P)"

subsection \<open>General union and intersection\<close>

definition Inter :: "i \<Rightarrow> i"  (\<open>\<Inter>_\<close> [90] 90)
  where "\<Inter>(A) \<equiv> { x\<in>\<Union>(A) . \<forall>y\<in>A. x\<in>y}"

syntax
  "_UNION" :: "[pttrn, i, i] \<Rightarrow> i"  (\<open>(3\<Union>_\<in>_./ _)\<close> 10)
  "_INTER" :: "[pttrn, i, i] \<Rightarrow> i"  (\<open>(3\<Inter>_\<in>_./ _)\<close> 10)
translations
  "\<Union>x\<in>A. B" == "CONST Union({B. x\<in>A})"
  "\<Inter>x\<in>A. B" == "CONST Inter({B. x\<in>A})"

subsection \<open>Finite sets and binary operations\<close>

(*Unordered pairs (Upair) express binary union/intersection and cons;
  set enumerations translate as {a,...,z} = cons(a,...,cons(z,0)...)*)

definition Upair :: "[i, i] \<Rightarrow> i"
  where "Upair(a,b) \<equiv> {y. x\<in>Pow(Pow(0)), (x=0 \<and> y=a) | (x=Pow(0) \<and> y=b)}"

definition Subset :: "[i, i] \<Rightarrow> o"  (infixl \<open>\<subseteq>\<close> 50)  \<comment> \<open>subset relation\<close>
  where subset_def: "A \<subseteq> B \<equiv> \<forall>x\<in>A. x\<in>B"

definition Diff :: "[i, i] \<Rightarrow> i"  (infixl \<open>-\<close> 65)  \<comment> \<open>set difference\<close>
  where "A - B \<equiv> { x\<in>A . \<not>(x\<in>B) }"

definition Un :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<union>\<close> 65)  \<comment> \<open>binary union\<close>
  where "A \<union> B \<equiv> \<Union>(Upair(A,B))"

definition Int :: "[i, i] \<Rightarrow> i"  (infixl \<open>\<inter>\<close> 70)  \<comment> \<open>binary intersection\<close>
  where "A \<inter> B \<equiv> \<Inter>(Upair(A,B))"

definition cons :: "[i, i] \<Rightarrow> i"
  where "cons(a,A) \<equiv> Upair(a,a) \<union> A"

definition succ :: "i \<Rightarrow> i"
  where "succ(i) \<equiv> cons(i, i)"

nonterminal "is"
syntax
  "" :: "i \<Rightarrow> is"  (\<open>_\<close>)
  "_Enum" :: "[i, is] \<Rightarrow> is"  (\<open>_,/ _\<close>)
  "_Finset" :: "is \<Rightarrow> i"  (\<open>{(_)}\<close>)
translations
  "{x, xs}" == "CONST cons(x, {xs})"
  "{x}" == "CONST cons(x, 0)"

subsection \<open>Axioms\<close>

(* ZF axioms -- see Suppes p.238
   Axioms for Union, Pow and Replace state existence only,
   uniqueness is derivable using extensionality. *)

axiomatization
where
  extension:     "A = B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A" and
  Union_iff:     "A \<in> \<Union>(C) \<longleftrightarrow> (\<exists>B\<in>C. A\<in>B)" and
  Pow_iff:       "A \<in> Pow(B) \<longleftrightarrow> A \<subseteq> B" and

  (*We may name this set, though it is not uniquely defined.*)
  infinity:      "0 \<in> Inf \<and> (\<forall>y\<in>Inf. succ(y) \<in> Inf)" and

  (*This formulation facilitates case analysis on A.*)
  foundation:    "A = 0 \<or> (\<exists>x\<in>A. \<forall>y\<in>x. y\<notin>A)" and

  (*Schema axiom since predicate P is a higher-order variable*)
  replacement:   "(\<forall>x\<in>A. \<forall>y z. P(x,y) \<and> P(x,z) \<longrightarrow> y = z) \<Longrightarrow>
                         b \<in> PrimReplace(A,P) \<longleftrightarrow> (\<exists>x\<in>A. P(x,b))"

subsection \<open>Definite descriptions -- via Replace over the set "1"\<close>

definition The :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder \<open>THE \<close> 10)
  where the_def: "The(P)    \<equiv> \<Union>({y . x \<in> {0}, P(y)})"

definition If :: "[o, i, i] \<Rightarrow> i"  (\<open>(if (_)/ then (_)/ else (_))\<close> [10] 10)
  where if_def: "if P then a else b \<equiv> THE z. P \<and> z=a | \<not>P \<and> z=b"

abbreviation (input)
  old_if :: "[o, i, i] \<Rightarrow> i"  (\<open>if '(_,_,_')\<close>)
  where "if(P,a,b) \<equiv> If(P,a,b)"

subsection \<open>Ordered Pairing\<close>

(* this "symmetric" definition works better than {{a}, {a,b}} *)
definition Pair :: "[i, i] \<Rightarrow> i"
  where "Pair(a,b) \<equiv> {{a,a}, {a,b}}"

definition fst :: "i \<Rightarrow> i"
  where "fst(p) \<equiv> THE a. \<exists>b. p = Pair(a, b)"

definition snd :: "i \<Rightarrow> i"
  where "snd(p) \<equiv> THE b. \<exists>a. p = Pair(a, b)"

definition split :: "[[i, i] \<Rightarrow> 'a, i] \<Rightarrow> 'a::{}"  \<comment> \<open>for pattern-matching\<close>
  where "split(c) \<equiv> \<lambda>p. c(fst(p), snd(p))"

(* Patterns -- extends pre-defined type "pttrn" used in abstractions *)
nonterminal patterns
syntax
  "_pattern"  :: "patterns \<Rightarrow> pttrn"         (\<open>\<langle>_\<rangle>\<close>)
  ""          :: "pttrn \<Rightarrow> patterns"         (\<open>_\<close>)
  "_patterns" :: "[pttrn, patterns] \<Rightarrow> patterns"  (\<open>_,/_\<close>)
  "_Tuple"    :: "[i, is] \<Rightarrow> i"              (\<open>\<langle>(_,/ _)\<rangle>\<close>)
translations
  "\<langle>x, y, z\<rangle>"   == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"      == "CONST Pair(x, y)"
  "\<lambda>\<langle>x,y,zs\<rangle>.b" == "CONST split(\<lambda>x \<langle>y,zs\<rangle>.b)"
  "\<lambda>\<langle>x,y\<rangle>.b"    == "CONST split(\<lambda>x y. b)"

definition Sigma :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Sigma(A,B) \<equiv> \<Union>x\<in>A. \<Union>y\<in>B(x). {\<langle>x,y\<rangle>}"

abbreviation cart_prod :: "[i, i] \<Rightarrow> i"  (infixr \<open>\<times>\<close> 80)  \<comment> \<open>Cartesian product\<close>
  where "A \<times> B \<equiv> Sigma(A, \<lambda>_. B)"

subsection \<open>Relations and Functions\<close>

(*converse of relation r, inverse of function*)
definition converse :: "i \<Rightarrow> i"
  where "converse(r) \<equiv> {z. w\<in>r, \<exists>x y. w=\<langle>x,y\<rangle> \<and> z=\<langle>y,x\<rangle>}"

definition domain :: "i \<Rightarrow> i"
  where "domain(r) \<equiv> {x. w\<in>r, \<exists>y. w=\<langle>x,y\<rangle>}"

definition range :: "i \<Rightarrow> i"
  where "range(r) \<equiv> domain(converse(r))"

definition field :: "i \<Rightarrow> i"
  where "field(r) \<equiv> domain(r) \<union> range(r)"

definition relation :: "i \<Rightarrow> o"  \<comment> \<open>recognizes sets of pairs\<close>
  where "relation(r) \<equiv> \<forall>z\<in>r. \<exists>x y. z = \<langle>x,y\<rangle>"

definition "function" :: "i \<Rightarrow> o"  \<comment> \<open>recognizes functions; can have non-pairs\<close>
  where "function(r) \<equiv> \<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> (\<forall>y'. \<langle>x,y'\<rangle> \<in> r \<longrightarrow> y = y')"

definition Image :: "[i, i] \<Rightarrow> i"  (infixl \<open>``\<close> 90)  \<comment> \<open>image\<close>
  where image_def: "r `` A  \<equiv> {y \<in> range(r). \<exists>x\<in>A. \<langle>x,y\<rangle> \<in> r}"

definition vimage :: "[i, i] \<Rightarrow> i"  (infixl \<open>-``\<close> 90)  \<comment> \<open>inverse image\<close>
  where vimage_def: "r -`` A \<equiv> converse(r)``A"

(* Restrict the relation r to the domain A *)
definition restrict :: "[i, i] \<Rightarrow> i"
  where "restrict(r,A) \<equiv> {z \<in> r. \<exists>x\<in>A. \<exists>y. z = \<langle>x,y\<rangle>}"

(* Abstraction, application and Cartesian product of a family of sets *)

definition Lambda :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where lam_def: "Lambda(A,b) \<equiv> {\<langle>x,b(x)\<rangle>. x\<in>A}"

definition "apply" :: "[i, i] \<Rightarrow> i"  (infixl \<open>`\<close> 90)  \<comment> \<open>function application\<close>
  where "f`a \<equiv> \<Union>(f``{a})"

definition Pi :: "[i, i \<Rightarrow> i] \<Rightarrow> i"
  where "Pi(A,B) \<equiv> {f\<in>Pow(Sigma(A,B)). A\<subseteq>domain(f) \<and> function(f)}"

abbreviation function_space :: "[i, i] \<Rightarrow> i"  (infixr \<open>\<rightarrow>\<close> 60)  \<comment> \<open>function space\<close>
  where "A \<rightarrow> B \<equiv> Pi(A, \<lambda>_. B)"

(* binder syntax *)

syntax
  "_PROD"     :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<Prod>_\<in>_./ _)\<close> 10)
  "_SUM"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<Sum>_\<in>_./ _)\<close> 10)
  "_lam"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3\<lambda>_\<in>_./ _)\<close> 10)
translations
  "\<Prod>x\<in>A. B"   == "CONST Pi(A, \<lambda>x. B)"
  "\<Sum>x\<in>A. B"   == "CONST Sigma(A, \<lambda>x. B)"
  "\<lambda>x\<in>A. f"    == "CONST Lambda(A, \<lambda>x. f)"

subsection \<open>ASCII syntax\<close>

notation (ASCII)
  cart_prod       (infixr \<open>*\<close> 80) and
  Int             (infixl \<open>Int\<close> 70) and
  Un              (infixl \<open>Un\<close> 65) and
  function_space  (infixr \<open>->\<close> 60) and
  Subset          (infixl \<open><=\<close> 50) and
  mem             (infixl \<open>:\<close> 50) and
  not_mem         (infixl \<open>\<not>:\<close> 50)

syntax (ASCII)
  "_Ball"     :: "[pttrn, i, o] \<Rightarrow> o"        (\<open>(3ALL _:_./ _)\<close> 10)
  "_Bex"      :: "[pttrn, i, o] \<Rightarrow> o"        (\<open>(3EX _:_./ _)\<close> 10)
  "_Collect"  :: "[pttrn, i, o] \<Rightarrow> i"        (\<open>(1{_: _ ./ _})\<close>)
  "_Replace"  :: "[pttrn, pttrn, i, o] \<Rightarrow> i" (\<open>(1{_ ./ _: _, _})\<close>)
  "_RepFun"   :: "[i, pttrn, i] \<Rightarrow> i"        (\<open>(1{_ ./ _: _})\<close> [51,0,51])
  "_UNION"    :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3UN _:_./ _)\<close> 10)
  "_INTER"    :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3INT _:_./ _)\<close> 10)
  "_PROD"     :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3PROD _:_./ _)\<close> 10)
  "_SUM"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3SUM _:_./ _)\<close> 10)
  "_lam"      :: "[pttrn, i, i] \<Rightarrow> i"        (\<open>(3lam _:_./ _)\<close> 10)
  "_Tuple"    :: "[i, is] \<Rightarrow> i"              (\<open><(_,/ _)>\<close>)
  "_pattern"  :: "patterns \<Rightarrow> pttrn"         (\<open><_>\<close>)

subsection \<open>Substitution\<close>

(*Useful examples:  singletonI RS subst_elem,  subst_elem RSN (2,IntI) *)
lemma subst_elem: "\<lbrakk>b\<in>A;  a=b\<rbrakk> \<Longrightarrow> a\<in>A"
by (erule ssubst, assumption)

subsection\<open>Bounded universal quantifier\<close>

lemma ballI [intro!]: "\<lbrakk>\<And>x. x\<in>A \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x\<in>A. P(x)"
by (simp add: Ball_def)

lemmas strip = impI allI ballI

lemma bspec [dest?]: "\<lbrakk>\<forall>x\<in>A. P(x);  x: A\<rbrakk> \<Longrightarrow> P(x)"
by (simp add: Ball_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_ballE [elim]:
    "\<lbrakk>\<forall>x\<in>A. P(x);  x\<notin>A \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: Ball_def, blast)

lemma ballE: "\<lbrakk>\<forall>x\<in>A. P(x);  P(x) \<Longrightarrow> Q;  x\<notin>A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by blast

(*Used in the datatype package*)
lemma rev_bspec: "\<lbrakk>x: A;  \<forall>x\<in>A. P(x)\<rbrakk> \<Longrightarrow> P(x)"
by (simp add: Ball_def)

(*Trival rewrite rule;   @{term"(\<forall>x\<in>A.P)\<longleftrightarrow>P"} holds only if A is nonempty!*)
lemma ball_triv [simp]: "(\<forall>x\<in>A. P) \<longleftrightarrow> ((\<exists>x. x\<in>A) \<longrightarrow> P)"
by (simp add: Ball_def)

(*Congruence rule for rewriting*)
lemma ball_cong [cong]:
    "\<lbrakk>A=A';  \<And>x. x\<in>A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow> (\<forall>x\<in>A. P(x)) \<longleftrightarrow> (\<forall>x\<in>A'. P'(x))"
by (simp add: Ball_def)

lemma atomize_ball:
    "(\<And>x. x \<in> A \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x\<in>A. P(x))"
  by (simp only: Ball_def atomize_all atomize_imp)

lemmas [symmetric, rulify] = atomize_ball
  and [symmetric, defn] = atomize_ball

subsection\<open>Bounded existential quantifier\<close>

lemma bexI [intro]: "\<lbrakk>P(x);  x: A\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
by (simp add: Bex_def, blast)

(*The best argument order when there is only one @{term"x\<in>A"}*)
lemma rev_bexI: "\<lbrakk>x\<in>A;  P(x)\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
by blast

(*Not of the general form for such rules. The existential quanitifer becomes universal. *)
lemma bexCI: "\<lbrakk>\<forall>x\<in>A. \<not>P(x) \<Longrightarrow> P(a);  a: A\<rbrakk> \<Longrightarrow> \<exists>x\<in>A. P(x)"
by blast

lemma bexE [elim!]: "\<lbrakk>\<exists>x\<in>A. P(x);  \<And>x. \<lbrakk>x\<in>A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (simp add: Bex_def, blast)

(*We do not even have @{term"(\<exists>x\<in>A. True) \<longleftrightarrow> True"} unless @{term"A" is nonempty\<And>*)
lemma bex_triv [simp]: "(\<exists>x\<in>A. P) \<longleftrightarrow> ((\<exists>x. x\<in>A) \<and> P)"
by (simp add: Bex_def)

lemma bex_cong [cong]:
    "\<lbrakk>A=A';  \<And>x. x\<in>A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk>
     \<Longrightarrow> (\<exists>x\<in>A. P(x)) \<longleftrightarrow> (\<exists>x\<in>A'. P'(x))"
by (simp add: Bex_def cong: conj_cong)

subsection\<open>Rules for subsets\<close>

lemma subsetI [intro!]:
    "(\<And>x. x\<in>A \<Longrightarrow> x\<in>B) \<Longrightarrow> A \<subseteq> B"
by (simp add: subset_def)

(*Rule in Modus Ponens style [was called subsetE] *)
lemma subsetD [elim]: "\<lbrakk>A \<subseteq> B;  c\<in>A\<rbrakk> \<Longrightarrow> c\<in>B"
  unfolding subset_def
apply (erule bspec, assumption)
done

(*Classical elimination rule*)
lemma subsetCE [elim]:
    "\<lbrakk>A \<subseteq> B;  c\<notin>A \<Longrightarrow> P;  c\<in>B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (simp add: subset_def, blast)

(*Sometimes useful with premises in this order*)
lemma rev_subsetD: "\<lbrakk>c\<in>A; A\<subseteq>B\<rbrakk> \<Longrightarrow> c\<in>B"
by blast

lemma contra_subsetD: "\<lbrakk>A \<subseteq> B; c \<notin> B\<rbrakk> \<Longrightarrow> c \<notin> A"
  by blast

lemma rev_contra_subsetD: "\<lbrakk>c \<notin> B;  A \<subseteq> B\<rbrakk> \<Longrightarrow> c \<notin> A"
  by blast

lemma subset_refl [simp]: "A \<subseteq> A"
  by blast

lemma subset_trans: "\<lbrakk>A\<subseteq>B;  B\<subseteq>C\<rbrakk> \<Longrightarrow> A\<subseteq>C"
  by blast

(*Useful for proving A\<subseteq>B by rewriting in some cases*)
lemma subset_iff:
     "A\<subseteq>B \<longleftrightarrow> (\<forall>x. x\<in>A \<longrightarrow> x\<in>B)"
  by auto

text\<open>For calculations\<close>
declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

subsection\<open>Rules for equality\<close>

(*Anti-symmetry of the subset relation*)
lemma equalityI [intro]: "\<lbrakk>A \<subseteq> B;  B \<subseteq> A\<rbrakk> \<Longrightarrow> A = B"
  by (rule extension [THEN iffD2], rule conjI)

lemma equality_iffI: "(\<And>x. x\<in>A \<longleftrightarrow> x\<in>B) \<Longrightarrow> A = B"
  by (rule equalityI, blast+)

lemmas equalityD1 = extension [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = extension [THEN iffD1, THEN conjunct2]

lemma equalityE: "\<lbrakk>A = B;  \<lbrakk>A\<subseteq>B; B\<subseteq>A\<rbrakk> \<Longrightarrow> P\<rbrakk>  \<Longrightarrow>  P"
  by (blast dest: equalityD1 equalityD2)

lemma equalityCE:
  "\<lbrakk>A = B;  \<lbrakk>c\<in>A; c\<in>B\<rbrakk> \<Longrightarrow> P;  \<lbrakk>c\<notin>A; c\<notin>B\<rbrakk> \<Longrightarrow> P\<rbrakk>  \<Longrightarrow>  P"
  by (erule equalityE, blast)

lemma equality_iffD:
  "A = B \<Longrightarrow> (\<And>x. x \<in> A \<longleftrightarrow> x \<in> B)"
  by auto

subsection\<open>Rules for Replace -- the derived form of replacement\<close>

lemma Replace_iff:
    "b \<in> {y. x\<in>A, P(x,y)}  \<longleftrightarrow>  (\<exists>x\<in>A. P(x,b) \<and> (\<forall>y. P(x,y) \<longrightarrow> y=b))"
  unfolding Replace_def
  by (rule replacement [THEN iff_trans], blast+)

(*Introduction; there must be a unique y such that P(x,y), namely y=b. *)
lemma ReplaceI [intro]:
    "\<lbrakk>P(x,b);  x: A;  \<And>y. P(x,y) \<Longrightarrow> y=b\<rbrakk> \<Longrightarrow>
     b \<in> {y. x\<in>A, P(x,y)}"
by (rule Replace_iff [THEN iffD2], blast)

(*Elimination; may asssume there is a unique y such that P(x,y), namely y=b. *)
lemma ReplaceE:
    "\<lbrakk>b \<in> {y. x\<in>A, P(x,y)};
        \<And>x. \<lbrakk>x: A;  P(x,b);  \<forall>y. P(x,y)\<longrightarrow>y=b\<rbrakk> \<Longrightarrow> R
\<rbrakk> \<Longrightarrow> R"
by (rule Replace_iff [THEN iffD1, THEN bexE], simp+)

(*As above but without the (generally useless) 3rd assumption*)
lemma ReplaceE2 [elim!]:
  "\<lbrakk>b \<in> {y. x\<in>A, P(x,y)};
        \<And>x. \<lbrakk>x: A;  P(x,b)\<rbrakk> \<Longrightarrow> R
   \<rbrakk> \<Longrightarrow> R"
  by (erule ReplaceE, blast)

lemma Replace_cong [cong]:
  "\<lbrakk>A=B;  \<And>x y. x\<in>B \<Longrightarrow> P(x,y) \<longleftrightarrow> Q(x,y)\<rbrakk> \<Longrightarrow> Replace(A,P) = Replace(B,Q)"
  apply (rule equality_iffI)
  apply (simp add: Replace_iff)
  done

subsection\<open>Rules for RepFun\<close>

lemma RepFunI: "a \<in> A \<Longrightarrow> f(a) \<in> {f(x). x\<in>A}"
by (simp add: RepFun_def Replace_iff, blast)

(*Useful for coinduction proofs*)
lemma RepFun_eqI [intro]: "\<lbrakk>b=f(a);  a \<in> A\<rbrakk> \<Longrightarrow> b \<in> {f(x). x\<in>A}"
  by (blast intro: RepFunI)

lemma RepFunE [elim!]:
  "\<lbrakk>b \<in> {f(x). x\<in>A};
        \<And>x.\<lbrakk>x\<in>A;  b=f(x)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow>
     P"
  by (simp add: RepFun_def Replace_iff, blast)

lemma RepFun_cong [cong]:
  "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> f(x)=g(x)\<rbrakk> \<Longrightarrow> RepFun(A,f) = RepFun(B,g)"
  by (simp add: RepFun_def)

lemma RepFun_iff [simp]: "b \<in> {f(x). x\<in>A} \<longleftrightarrow> (\<exists>x\<in>A. b=f(x))"
  by (unfold Bex_def, blast)

lemma triv_RepFun [simp]: "{x. x\<in>A} = A"
  by blast

subsection\<open>Rules for Collect -- forming a subset by separation\<close>

(*Separation is derivable from Replacement*)
lemma separation [simp]: "a \<in> {x\<in>A. P(x)} \<longleftrightarrow> a\<in>A \<and> P(a)"
  by (auto simp: Collect_def)

lemma CollectI [intro!]: "\<lbrakk>a\<in>A;  P(a)\<rbrakk> \<Longrightarrow> a \<in> {x\<in>A. P(x)}"
  by simp

lemma CollectE [elim!]: "\<lbrakk>a \<in> {x\<in>A. P(x)};  \<lbrakk>a\<in>A; P(a)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by simp

lemma CollectD1: "a \<in> {x\<in>A. P(x)} \<Longrightarrow> a\<in>A" and CollectD2: "a \<in> {x\<in>A. P(x)} \<Longrightarrow> P(a)"
  by auto

lemma Collect_cong [cong]:
  "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> P(x) \<longleftrightarrow> Q(x)\<rbrakk>
     \<Longrightarrow> Collect(A, \<lambda>x. P(x)) = Collect(B, \<lambda>x. Q(x))"
  by (simp add: Collect_def)

subsection\<open>Rules for Unions\<close>

declare Union_iff [simp]

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI [intro]: "\<lbrakk>B: C;  A: B\<rbrakk> \<Longrightarrow> A: \<Union>(C)"
  by auto

lemma UnionE [elim!]: "\<lbrakk>A \<in> \<Union>(C);  \<And>B.\<lbrakk>A: B;  B: C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by auto

subsection\<open>Rules for Unions of families\<close>
(* @{term"\<Union>x\<in>A. B(x)"} abbreviates @{term"\<Union>({B(x). x\<in>A})"} *)

lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B(x)) \<longleftrightarrow> (\<exists>x\<in>A. b \<in> B(x))"
  by blast

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "\<lbrakk>a: A;  b: B(a)\<rbrakk> \<Longrightarrow> b: (\<Union>x\<in>A. B(x))"
  by force

lemma UN_E [elim!]:
  "\<lbrakk>b \<in> (\<Union>x\<in>A. B(x));  \<And>x.\<lbrakk>x: A;  b: B(x)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by blast

lemma UN_cong:
  "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. C(x)) = (\<Union>x\<in>B. D(x))"
  by simp

(*No "Addcongs [UN_cong]" because @{term\<Union>} is a combination of constants*)

(* UN_E appears before UnionE so that it is tried first, to avoid expensive
  calls to hyp_subst_tac.  Cannot include UN_I as it is unsafe: would enlarge
  the search space.*)

subsection\<open>Rules for the empty set\<close>

(*The set @{term"{x\<in>0. False}"} is empty; by foundation it equals 0
  See Suppes, page 21.*)
lemma not_mem_empty [simp]: "a \<notin> 0"
  using foundation by (best dest: equalityD2)

lemmas emptyE [elim!] = not_mem_empty [THEN notE]

lemma empty_subsetI [simp]: "0 \<subseteq> A"
  by blast

lemma equals0I: "\<lbrakk>\<And>y. y\<in>A \<Longrightarrow> False\<rbrakk> \<Longrightarrow> A=0"
  by blast

lemma equals0D [dest]: "A=0 \<Longrightarrow> a \<notin> A"
  by blast

declare sym [THEN equals0D, dest]

lemma not_emptyI: "a\<in>A \<Longrightarrow> A \<noteq> 0"
  by blast

lemma not_emptyE:  "\<lbrakk>A \<noteq> 0;  \<And>x. x\<in>A \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by blast

subsection\<open>Rules for Inter\<close>

(*Not obviously useful for proving InterI, InterD, InterE*)
lemma Inter_iff: "A \<in> \<Inter>(C) \<longleftrightarrow> (\<forall>x\<in>C. A: x) \<and> C\<noteq>0"
  by (force simp: Inter_def)

(* Intersection is well-behaved only if the family is non-empty! *)
lemma InterI [intro!]:
  "\<lbrakk>\<And>x. x: C \<Longrightarrow> A: x;  C\<noteq>0\<rbrakk> \<Longrightarrow> A \<in> \<Inter>(C)"
  by (simp add: Inter_iff)

(*A "destruct" rule -- every B in C contains A as an element, but
  A\<in>B can hold when B\<in>C does not!  This rule is analogous to "spec". *)
lemma InterD [elim, Pure.elim]: "\<lbrakk>A \<in> \<Inter>(C);  B \<in> C\<rbrakk> \<Longrightarrow> A \<in> B"
  by (force simp: Inter_def)

(*"Classical" elimination rule -- does not require exhibiting @{term"B\<in>C"} *)
lemma InterE [elim]:
  "\<lbrakk>A \<in> \<Inter>(C);  B\<notin>C \<Longrightarrow> R;  A\<in>B \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp: Inter_def)

subsection\<open>Rules for Intersections of families\<close>

(* @{term"\<Inter>x\<in>A. B(x)"} abbreviates @{term"\<Inter>({B(x). x\<in>A})"} *)

lemma INT_iff: "b \<in> (\<Inter>x\<in>A. B(x)) \<longleftrightarrow> (\<forall>x\<in>A. b \<in> B(x)) \<and> A\<noteq>0"
  by (force simp add: Inter_def)

lemma INT_I: "\<lbrakk>\<And>x. x: A \<Longrightarrow> b: B(x);  A\<noteq>0\<rbrakk> \<Longrightarrow> b: (\<Inter>x\<in>A. B(x))"
  by blast

lemma INT_E: "\<lbrakk>b \<in> (\<Inter>x\<in>A. B(x));  a: A\<rbrakk> \<Longrightarrow> b \<in> B(a)"
  by blast

lemma INT_cong:
  "\<lbrakk>A=B;  \<And>x. x\<in>B \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Inter>x\<in>A. C(x)) = (\<Inter>x\<in>B. D(x))"
  by simp

(*No "Addcongs [INT_cong]" because @{term\<Inter>} is a combination of constants*)

subsection\<open>Rules for Powersets\<close>

lemma PowI: "A \<subseteq> B \<Longrightarrow> A \<in> Pow(B)"
  by (erule Pow_iff [THEN iffD2])

lemma PowD: "A \<in> Pow(B)  \<Longrightarrow>  A\<subseteq>B"
  by (erule Pow_iff [THEN iffD1])

declare Pow_iff [iff]

lemmas Pow_bottom = empty_subsetI [THEN PowI]    \<comment> \<open>\<^term>\<open>0 \<in> Pow(B)\<close>\<close>
lemmas Pow_top = subset_refl [THEN PowI]         \<comment> \<open>\<^term>\<open>A \<in> Pow(A)\<close>\<close>

subsection\<open>Cantor's Theorem: There is no surjection from a set to its powerset.\<close>

(*The search is undirected.  Allowing redundant introduction rules may
  make it diverge.  Variable b represents ANY map, such as
  (lam x\<in>A.b(x)): A->Pow(A). *)
lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
  by (best elim!: equalityCE del: ReplaceI RepFun_eqI)

end


theory Example
  imports Original
begin

text \<open>As an example we prove that a^nb^n is not regular using the PL\<close>

subsection \<open>aux lemmas\<close>

lemma repeat_length: "\<lbrakk>length w = x; n\<ge>0\<rbrakk> \<Longrightarrow> length (repeat w n) = n*x"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

lemma take_at: "\<lbrakk>i\<le>n; length x = 1\<rbrakk> \<Longrightarrow> take i (repeat x n @ repeat y m) = take i (repeat x n)"
proof (induction i arbitrary: n)
  case 0
  then show ?case by simp
next
  case (Suc i)
  then show ?case
  proof (cases "(repeat x n @ repeat y m)")
    case Nil
    then show ?thesis by auto
  next
    case (Cons a list)
    then show ?thesis
      by (metis Suc.prems(1) Suc.prems(2) append.right_neutral bot_nat_0.extremum diff_is_0_eq' mult.right_neutral repeat_length take_0 take_append)
  qed
qed

lemma drop_at: "\<lbrakk>i\<le>n; length x = 1\<rbrakk> \<Longrightarrow> drop i (repeat x n @ repeat y m) = drop i (repeat x n) @ repeat y m"
proof (induction i arbitrary: n)
  case 0
  then show ?case by simp
next
  case (Suc i)
  then show ?case
    proof (cases "(repeat x n @ repeat y m)")
      case Nil
      then show ?thesis by simp
    next
      case (Cons a list)
      then show ?thesis
        by (metis Suc.prems(1) Suc.prems(2) bot_nat_0.extremum diff_is_0_eq' drop0 drop_append mult.right_neutral repeat_length)
    qed
qed

lemma drop_1_repeat: "length x = 1 \<Longrightarrow> drop 1 (repeat x n) = repeat x (n-1)"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
    by (metis append_eq_conv_conj repeat_rev zero_less_Suc)
qed

lemma drop_repeat: "\<lbrakk>i\<le>n; length x = 1\<rbrakk> \<Longrightarrow> drop i (repeat x n) = repeat x (n-i)"
proof (induction i arbitrary: n)
  case 0
  then show ?case by simp
next
  case (Suc i)
  have "drop (Suc i) (repeat x n) = drop 1 (drop i (repeat x n))" by simp
  then have "drop (Suc i) (repeat x n) = drop 1 (repeat x (n - i))"
    using Suc.IH Suc.prems(1) Suc.prems(2) Suc_leD by presburger
  then have "drop (Suc i) (repeat x n) = repeat x (n-i-1)"
    by (metis Suc.prems(2) drop_1_repeat)
  then show ?case by simp
qed

lemma take_repeat: "\<lbrakk>i\<le>n; length x = 1\<rbrakk> \<Longrightarrow> take i (repeat x n) = repeat x i"
proof (induction i arbitrary: n)
  case 0
  then show ?case by simp
next
  case (Suc i)
  then show ?case
    by (metis Suc_le_D Suc_le_mono bot_nat_0.extremum diff_Suc_1 le_refl mult.right_neutral repeat_length repeat_rev take_all_iff take_append zero_less_Suc)
qed

lemma repeat_concat: "repeat x i @ repeat x j = repeat x (i+j)"
proof (induction i arbitrary: j)
  case 0
  then show ?case by simp
next
  case (Suc i)
  then show ?case
    by (metis Original.i add_Suc_shift append.assoc diff_Suc_1 repeat_rev zero_less_Suc)
qed

lemma set_repeat: "set (repeat a n) \<subseteq> set a"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

subsection\<open>Example proof a^nb^n\<close>
text \<open>Showing that a^nb^n is indeed not a regular language using the pumping lemma definition
from Orginal.thy We assume that the language of the dfa is a^nb^n and the properties of a DFA
(finite and determinstic etc.) then we show that the pumping lemma doesn't hold.\<close>
theorem anbn:
  assumes dfa_lang: "lang dfa = {w. \<exists>n\<ge>0. w=repeat ''a'' n @ (repeat ''b'' n)}"
      and "Q_\<Sigma>_finite (dfa::DFA)"
      and "\<delta>_total_on_Q_\<Sigma> dfa"
      and "q\<^sub>0_in_Q dfa"
      and "F_sub_Q dfa"
    shows "\<not>(\<exists>n::nat>0. \<forall>z \<in> (lang dfa). length z \<ge> n \<longrightarrow> (
        \<exists> u v w. z = u@v@w \<and>
        v \<noteq> '''' \<and>
        length (u@v) \<le> n \<and>
        (\<forall>i::nat. (u@(repeat v i)@w) \<in> (lang dfa))
))"
proof
  text \<open>simply an abbreviation for the PL\<close>
  let ?PL = "(\<exists>n::nat>0. \<forall>z \<in> (lang dfa). length z \<ge> n \<longrightarrow> (
          \<exists> u v w. z = u@v@w \<and>
          v \<noteq> '''' \<and>
          length (u@v) \<le> n \<and>
          (\<forall>i::nat. (u@(repeat v i)@w) \<in> (lang dfa))
  ))"
  text \<open>This is what we want to show and which does falsify the PL, therefore FPL\<close>
  let ?FPL = "\<forall>n>0. \<exists>z\<in>lang dfa. n\<le>length z \<and> (\<forall>u v w. u@v@w=z \<and> v\<noteq> [] \<and> length (u@v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa))"
  show "?PL \<Longrightarrow> False"
  proof -
    let ?a = "''a''"
    let ?b = "''b''"
    have length_a: "length ?a = 1" by simp
    have length_b: "length ?b = 1" by simp
    have uneq_ab: "?a\<noteq>?b" by simp
    have falsify_pl: "?FPL \<Longrightarrow> \<not>?PL"
    proof
      assume asm1: "\<forall>n>0. \<exists>z\<in>lang dfa. n \<le> length z \<and> (\<forall>u v w. u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa))"
      assume asm2: ?PL
      then show False using asm1 by metis
    qed
    text \<open>have the PL hold for contradiction\<close>
    have ?PL using assms pumping_lemma by fast
    text \<open>Now show that the PL actually doesn't hold via our FPL\<close>
    also have ?FPL
    proof (intro allI)
      fix n
      show "0 < n \<longrightarrow>
         (\<exists>z\<in>lang dfa. n \<le> length z \<and> (\<forall>u v w. u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa))) "
      proof
        assume "0 < n"
        show "\<exists>z\<in>lang dfa. n \<le> length z \<and> (\<forall>u v w. u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa)) "
        proof -
          obtain z where z: "z=repeat ?a n @ (repeat ?b n)"
            by simp
          then have z_in_lang: "z \<in> lang dfa"
            using assms(1) using \<open>0 < n\<close> by blast
          have "n \<le> length z " by (simp add: repeat_length z)
          also have "(\<forall>u v w. u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa))"
          proof (intro allI)
            fix u v w
            show "u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n \<longrightarrow> (\<exists>i. u @ repeat v i @ w \<notin> lang dfa)"
            proof
              assume asm_uvw: "u @ v @ w = z \<and> v \<noteq> [] \<and> length (u @ v) \<le> n"
              text \<open>Until this point we were just instantiating the predicates, now we want show
              that u=a^j and v = a^k and therefore if we cut v or multiply it, the amount of as will
              no longer equal the amount of bs\<close>
              then obtain m where m: "u@v = repeat ?a m \<and> m\<le>n" unfolding z using append.assoc append_eq_conv_conj length_a take_at take_repeat by metis
              then have take_m: "take m z = repeat ?a m" unfolding z using length_a take_at take_repeat by metis
              then have w: "w=drop m z" by (metis asm_uvw append.assoc append_take_drop_id m same_append_eq)
              then obtain l where w_l:"w=repeat ?a l @ repeat ?b n \<and> l=(n-m)" unfolding z
                by (metis drop_at drop_repeat length_a m)
              have "repeat ?a m @ repeat ?a l @ repeat ?b n = z" using asm_uvw m w_l by force
              obtain j where j: "u=take j (u@v) \<and> v=drop j (u@v)" using append_eq_conv_conj by blast
              then have u_repeat: "u=repeat ?a j"
                by (metis \<open>\<And>thesis. (\<And>m. u @ v = repeat ''a'' m \<and> m \<le> n \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> asm_uvw bot_nat_0.extremum drop_all length_a linorder_not_less mult.right_neutral order_less_le repeat_length take_repeat)
              obtain k where v_repeat: "v=repeat ?a k \<and> k=(m-j)"
                by (metis asm_uvw bot_nat_0.extremum drop_repeat drop_take j length_a m order_less_le take0 take_m zero_less_diff)
              have "repeat ?a j @ repeat ?a k @ repeat ?a l @ repeat ?b n = z"
                using asm_uvw u_repeat v_repeat w_l by blast
              then have "j+k+l=n"
                by (metis "Original.0" add.commute add_diff_inverse_nat asm_uvw diff_is_0_eq le_add_diff_inverse2 m order_less_le v_repeat w_l)
              have u_v0_w: "u@repeat v 0@w = repeat ?a j @ repeat ?a l @ repeat ?b n"
                using u_repeat w_l using "Original.0" by blast
              then have u_v0_w: "u@repeat v 0@w = repeat ?a (j+l) @ repeat ?b n"
                by (simp add: repeat_concat)
              text \<open>After obtaining uv and w accordingly we show that if we cut v, which is not
              empty, the word u@w is no longer in the language because the number of as and bs is
              unequal. We show this by contradiction and assume u@w is in lang dfa to show that
              they are actually not.\<close>
              have "u@ repeat v 0 @w \<notin> lang dfa"
              proof
                 text \<open>As an auxillary lemma we prove that for every word, if it is in the language
                 of the dfa, then the amount of as and bs must be equal. Because we now j+l<n and
                 this lemma will later indicate that they are equal, which leads to the contradiction.\<close>
                 have in_lang: "\<forall>i j. repeat ?a i @ repeat ?b j \<in> lang dfa \<longrightarrow> i=j"
                 proof (intro allI)
                  fix i j
                  show "repeat ?a i @ repeat ?b j \<in> lang dfa \<longrightarrow> i = j"
                  proof
                    assume "repeat ?a i @ repeat ?b j \<in> lang dfa"
                    then have pre: "\<exists>n\<ge>0. repeat ?a i @ repeat ?b j = repeat ?a n @ (repeat ?b n)"
                      using dfa_lang by blast
                    have "\<exists>n\<ge>0. repeat ?a i @ repeat ?b j = repeat ?a n @ (repeat ?b n) \<Longrightarrow> i=j"
                    proof -
                      assume "\<exists>n\<ge>0. repeat ?a i @ repeat ?b j = repeat ?a n @ repeat ?b n"
                      then obtain n where "n\<ge>0 \<and> repeat ?a i @ repeat ?b j = repeat ?a n @ repeat ?b n" by fast
                      then have eq: "repeat ?a i @ repeat ?b j = repeat ?a n @ repeat ?b n" by simp
                      show ?thesis
                      proof -
                        text \<open>Now the quantors are all unfolded and the proof can be done by induction.
                        To do the proof by induction on n we fold i=j into i=n \<and>j=n\<close>
                        have imp_same: "repeat ?a n @ repeat ?b n = repeat ?a i @ repeat ?b j \<Longrightarrow> i=n \<and> j=n"
                        proof (induction n arbitrary: i j)
                          case 0
                          then show ?case
                            by (metis "Original.0" Nil_is_append_conv list.discI repeat.elims)
                        next
                          case (Suc n)
                          text \<open>simply unfold the repeat function until the IH can be satisfied to
                          then obtain i-1=n and j-1=n, which obviously indicates the case (i=Suc n \<and> j=Suc n)\<close>
                          have "repeat ?a (Suc n) @ repeat ?b (Suc n) = ?a @ repeat ?a (Suc n -1) @ repeat ?b (n) @ ?b"
                            using append.assoc repeat_rev zero_less_Suc by (metis Original.i diff_Suc_1)
                          then have n_extend_ab: "repeat ?a (Suc n) @ repeat ?b (Suc n) = ?a @ repeat ?a n @ repeat ?b n @ ?b" by simp
                          have ijg0: "i>0\<and>j>0"
                          proof
                            have a_sub: "\<forall>x. set (repeat ?a x) \<subseteq> set ?a "
                            proof
                              fix x
                              show "set (repeat ?a x) \<subseteq> set ?a"
                              proof (induction x)
                                case 0
                                then show ?case by simp
                              next
                                case (Suc x)
                                then show ?case by simp
                              qed
                            qed
                            have b_sub:"\<forall>x. set (repeat ?b x) \<subseteq> set ?b "
                            proof
                              fix x
                              show "set (repeat ?b x) \<subseteq> set ?b"
                              proof (induction x)
                                case 0
                                then show ?case by simp
                              next
                                case (Suc x)
                                then show ?case by simp
                              qed
                            qed
                            show i0: "i>0"
                            proof -
                              have "(CHR ''a'') \<in> set (repeat ''a'' (Suc n) @ repeat ''b'' (Suc n))" by simp
                              also have "(CHR ''a'') \<notin> set (repeat ''b'' j)" using b_sub by auto
                              then have "(CHR ''a'') \<in> set (repeat ''a'' i)"
                                using Suc.prems calculation by fastforce
                              then have "length (repeat ''a'' i) > 0" by force
                              then show ?thesis using gr0I by force
                            qed
                            show j0: "j>0"
                            proof -
                              have "(CHR ''b'') \<in> set (repeat ''a'' (Suc n) @ repeat ''b'' (Suc n))" by simp
                              also have "(CHR ''b'') \<notin> set (repeat ''a'' i)" using a_sub by auto
                              then have "(CHR ''b'') \<in> set (repeat ''b'' j)"
                                using Suc.prems calculation by fastforce
                              then have "length (repeat ''b'' j) > 0" by force
                              then show ?thesis using gr0I by force
                            qed
                          qed
                          then have ij_extend_a: "repeat ?a (i) @ repeat ?b (j) = ?a @ repeat ?a (i -1) @ repeat ?b (j)"
                            by (simp add: repeat_rev)
                          then have ij_extend_ab: "repeat ?a (i) @ repeat ?b (j) = ?a @ repeat ?a (i -1) @ repeat ?b (j-1) @ ?b"
                            by (metis Original.i Suc_pred' ijg0)
                          have "repeat ?a n @ repeat ?b n = repeat ?a (i -1) @ repeat ?b (j-1)"
                            using Suc.prems ij_extend_ab n_extend_ab by auto
                          then have " i-1 = n \<and> j-1 = n" using Suc.IH by blast
                          then show ?case by (metis Suc_pred' ijg0)
                        qed
                        show ?thesis using eq imp_same by presburger
                      qed
                    qed
                    then show "i = j" using pre by blast
                  qed
                qed
                text \<open>After the aux lemma, we can now contradict using our assumptions.\<close>
                assume asm2: "u @ repeat v 0 @ w \<in> lang dfa"
                then have jl_eq_n: "(j+l) = n" using in_lang u_v0_w by force
                also have jl_less_n: "j+l<n"
                proof -
                  have "k>0" by (metis "Original.0" asm_uvw v_repeat zero_less_iff_neq_zero)
                  then show ?thesis using \<open>j + k + l = n\<close> by fastforce
                qed
                show False using jl_eq_n jl_less_n by blast
              qed
              then show "\<exists>i. u @ repeat v i @ w \<notin> lang dfa" by blast
            qed
          qed
          then show ?thesis using calculation z_in_lang by blast
      qed
    qed
  qed
    then show ?thesis by (metis calculation)
  qed
qed
end


(*  Title:      LList_Topology.thy
    Author:     Stefan Friedrich
    Maintainer: Stefan Friedrich
    License:    LGPL
*)

section \<open>The topology of llists\<close>

theory LList_Topology
imports Topology "Lazy-Lists-II.LList2"
begin

subsection\<open>The topology of all llists\<close>

text\<open>
  This theory introduces the topologies of all llists, of infinite
  llists, and of the non-empty llists. For all three cases it is
  proved that safety properties are closed sets and that liveness
  properties are dense sets. Finally, we prove in each of the the
  three different topologies the respective theorem of Alpern and
  Schneider \<^cite>\<open>"alpern85:_defin_liven"\<close>, which states that every
  property can be represented as an intersection of a safety property
  and a liveness property.\<close>

definition
  ttop :: "'a set \<Rightarrow> 'a llist top" where
  "ttop A = topo (\<Union> s\<in>A\<^sup>\<star>. {suff A s})"

lemma ttop_topology [iff]: "topology (ttop A)"
  by (auto simp: ttop_def)

locale suffixes =
  fixes A and B
  defines [simp]: "B \<equiv> (\<Union> s\<in>A\<^sup>\<star>. {suff A s})"

locale trace_top = suffixes + topobase

lemma (in trace_top) open_iff [iff]:
  "m open = (m \<in> topo (\<Union> s\<in>A\<^sup>\<star>. {suff A s}))"
  by (simp add: T_def is_open_def)

lemma (in trace_top) suff_open [intro!]:
  "r \<in> A\<^sup>\<star> \<Longrightarrow> suff A r open"
  by auto

lemma (in trace_top) ttop_carrier: "A\<^sup>\<infinity> = carrier"
  by (auto simp: carrier_topo suff_def)

lemma (in trace_top) nhds_LNil [simp]: "nhds LNil = {A\<^sup>\<infinity>}"
proof
  show "nhds LNil \<subseteq> {A\<^sup>\<infinity>}"
  proof clarify
    fix x assume xnhd: "x \<in> nhds LNil"
    then obtain r
      where rfinpref: "r \<in> finpref A LNil" and suffsub: "suff A r \<subseteq> x"
      by (rule suff_nhd_base)
    from rfinpref have "r = LNil" by auto
    hence "suff A r = A\<^sup>\<infinity>" by auto
    with suffsub have "A\<^sup>\<infinity> \<subseteq> x" by auto
    moreover from xnhd have "x \<subseteq> A\<^sup>\<infinity>" by(auto simp: ttop_carrier elim!: nhdE)
    ultimately show "x = A\<^sup>\<infinity>" by auto
  qed
next
  show "{A\<^sup>\<infinity>} \<subseteq> nhds LNil" by (auto simp: ttop_carrier)
qed

lemma (in trace_top) adh_lemma:
assumes xpoint: "x \<in> A\<^sup>\<infinity>"
  and  PA: "P \<subseteq> A\<^sup>\<infinity>"
shows "(x adh P) = (\<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
proof-
  from PA have "\<And>r. r \<in> A\<^sup>\<star> \<Longrightarrow> (\<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) =
        (\<exists> s \<in> P. r \<le> s)"
    by (auto simp: llist_le_def iff: lapp_allT_iff)
  hence  "(\<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P) =
        (\<forall> r \<in> finpref A x. \<exists> s \<in> P. r \<le> s)"
    by (auto simp: finpref_def)
  also have "\<dots> = (\<forall> r \<in> finpref A x. suff A r \<inter> P \<noteq> {})"
  proof-
    have "\<And>r. (\<exists>s\<in>P. r \<le> s) = ({ra. ra \<in> A\<^sup>\<infinity> \<and> r \<le> ra} \<inter> P \<noteq> {})" using PA
      by blast
    thus ?thesis by (simp add: suff_def)
  qed
  also have "\<dots> = (\<forall> u \<in> nhds x. u \<inter> P \<noteq> {})"
  proof safe
    fix r assume uP: "\<forall>u\<in>nhds x. u \<inter> P \<noteq> {}" and
      rfinpref: "r \<in> finpref A x" and rP: "suff A r \<inter> P = {}"
    from rfinpref have "suff A r open" by (auto dest!: finpref_fin)
    hence "suff A r \<in> nhds x" using xpoint rfinpref
      by auto
    with uP rP show "False" by auto
  next
    fix u assume
      inter:     "\<forall>r\<in>finpref A x. suff A r \<inter> P \<noteq> {}" and
      unhd:   "u \<in> nhds x" and
      uinter: "u \<inter> P = {}"
    from unhd obtain r where
      "r \<in> finpref A x" and "suff A r \<subseteq> u"
      by (rule suff_nhd_base)
    with inter uinter show "False" by auto
  qed
  finally show ?thesis by (simp add: adhs_def)
qed

lemma (in trace_top) topology [iff]:
  "topology T"
by (simp add: T_def)

lemma (in trace_top) safety_closed_iff:
  "P \<subseteq> A\<^sup>\<infinity> \<Longrightarrow>  safety A P = (P closed)"
by (auto simp: safety_def topology.closed_adh adh_lemma ttop_carrier)

lemma (in trace_top) liveness_dense_iff:
  assumes P: "P \<subseteq> A\<^sup>\<infinity>"
  shows "liveness A P = (P dense)"
proof-
  have "liveness A P = (\<forall>r\<in>A\<^sup>\<star>. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
    by (simp add: liveness_def)
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<infinity>. \<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
      by (auto simp: finpref_def dest: finsubsetall)
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<infinity>. x adh P)" using P
    by (simp add: adh_lemma)
  also have "\<dots> = (A\<^sup>\<infinity> \<subseteq> closure P)" using P
    by (auto simp: adh_closure_iff ttop_carrier)
  also have "\<dots> = (P dense)"
    by (simp add: liveness_def is_dense_def is_densein_def ttop_carrier)
  finally show ?thesis .
qed

lemma (in trace_top) LNil_safety: "safety A {LNil}"
proof (unfold safety_def, clarify)
  fix t
  assume adh: "t \<in> A\<^sup>\<infinity>" "\<forall>r\<in>finpref A t. \<exists>s\<in>A\<^sup>\<infinity>. r @@ s \<in> {LNil}"
  thus "t = LNil" by (cases t)(auto simp: finpref_def)
qed

lemma (in trace_top) LNil_closed: "{LNil} closed"
by (auto intro: iffD1 [OF safety_closed_iff] LNil_safety)

theorem (in trace_top) alpern_schneider:
assumes Psub:     "P \<subseteq> A\<^sup>\<infinity>"
  shows "\<exists> S L. safety A S \<and> liveness A L \<and> P = S \<inter> L"
proof-
  from Psub have "P \<subseteq> carrier" by (simp add: ttop_carrier)
  then obtain L S where
    Lsub: "L \<subseteq> carrier" and
    Ssub: "S \<subseteq> carrier" and
    Sclosed: "S closed" and
    Ldense: "L dense" and
    Pinter: "P = S \<inter> L"
    by (blast elim: topology.ex_dense_closure_interE [OF topology])
  from Ssub Sclosed have "safety A S"
    by (simp add: safety_closed_iff ttop_carrier)
  moreover from Lsub Ldense have "liveness A L"
    by (simp add: liveness_dense_iff ttop_carrier)
  ultimately show ?thesis using Pinter
    by auto
qed

subsection\<open>The topology of infinite llists\<close>

definition
  itop :: "'a set \<Rightarrow> 'a llist top" where
  "itop A = topo (\<Union> s\<in>A\<^sup>\<star>. {infsuff A s})"

locale infsuffixes =
  fixes A and B
  defines [simp]: "B \<equiv> (\<Union> s\<in>A\<^sup>\<star>. {infsuff A s})"

locale itrace_top = infsuffixes + topobase

lemma (in itrace_top) open_iff [iff]:
  "m open = (m \<in> topo (\<Union> s\<in>A\<^sup>\<star>. {infsuff A s}))"
  by (simp add: T_def is_open_def)

lemma (in itrace_top) topology [iff]: "topology T"
  by (auto simp: T_def)

lemma (in itrace_top) infsuff_open [intro!]:
  "r \<in> A\<^sup>\<star> \<Longrightarrow> infsuff A r open"
  by auto

lemma (in itrace_top) itop_carrier: "carrier = A\<^sup>\<omega>"
  by (auto simp: carrier_topo infsuff_def)

lemma itop_sub_ttop_base:
  fixes A :: "'a set"
    and B :: "'a llist set set"
    and C :: "'a llist set set"
  defines [simp]: "B \<equiv> \<Union>s\<in>A\<^sup>\<star>. {suff A s}" and [simp]: "C \<equiv> \<Union>s\<in>A\<^sup>\<star>. {infsuff A s}"
  shows "C = (\<Union> t\<in>B. {t \<inter> \<Union>C})"
  by (auto simp: infsuff_def suff_def)

lemma itop_sub_ttop [folded ttop_def itop_def]:
  fixes A and C and S (structure)
  defines "C \<equiv> \<Union>s\<in>A\<^sup>\<star>. {infsuff A s}" and "S \<equiv> topo C"
  fixes B and T (structure)
  defines "B \<equiv> \<Union>s\<in>A\<^sup>\<star>. {suff A s}" and "T \<equiv> topo B"
  shows "subtopology S T"
proof -
  interpret itrace_top A C S by fact+
  interpret trace_top A B T by fact+
  show ?thesis
    by (auto intro: itop_sub_ttop_base [THEN subtop_lemma] simp: S_def T_def)
qed

lemma (in itrace_top) infsuff_nhd_base:
  assumes unhd: "u \<in> nhds t"
  and H: "\<And>r. \<lbrakk> r \<in> finpref A t; infsuff A r \<subseteq> u \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof-
  from unhd obtain m where
    uA: "u \<subseteq> A\<^sup>\<omega>" and
    mopen: "m open" and
    tm: "t \<in> m" and
    mu: "m \<subseteq> u"
    by (auto simp: itop_carrier)
  from mopen tm have
    "\<exists>r \<in> finpref A t. infsuff A r \<subseteq> m"
  proof (induct "m")
    case (basic a)
    then obtain s where sA: "s \<in> A\<^sup>\<star>" and as: "a = infsuff A s" and ta: "t \<in> a"
      by auto
    from sA as ta have "s \<in> finpref A t" by (auto dest: infsuff_finpref)
    thus ?case using as by auto
  next case (inter a b)
    then obtain r r' where
      rt: "r \<in> finpref A t" and ra: "infsuff A r \<subseteq> a" and
      r't: "r' \<in> finpref A t" and r'b: "infsuff A r' \<subseteq> b"
      by auto
    from rt r't have "r \<le> r' \<or> r' \<le> r"
      by (auto simp: finpref_def dest: pref_locally_linear)
    thus ?case
    proof
      assume "r \<le> r'"
      hence "infsuff A r' \<subseteq> infsuff A r" by (rule infsuff_mono2)
      thus ?case using r't ra r'b by auto
    next assume "r' \<le> r"
      hence "infsuff A r \<subseteq> infsuff A r'" by (rule infsuff_mono2)
      thus ?case using rt r'b ra by auto
    qed
  next case (union M)
    then obtain v where
      "t \<in> v" and vM: "v \<in> M"
      by blast
    then obtain r where "r\<in>finpref A t" "infsuff A r \<subseteq> v" using union
      by auto
    thus ?case using vM by auto
  qed
  with mu show ?thesis by (auto intro: H)
qed

lemma (in itrace_top) hausdorff [iff]: "T2 T"
proof(rule T2I, clarify)
  fix x y assume xpoint: "x \<in> carrier"
    and ypoint: "y \<in> carrier"
    and neq: "x \<noteq> y"
  from xpoint ypoint have xA: "x \<in> A\<^sup>\<omega>" and yA: "y \<in> A\<^sup>\<omega>"
    by (auto simp: itop_carrier)
  then obtain s where
    sA: "s \<in> A\<^sup>\<star>" and sx: "s \<le> x" and sy: "\<not> s \<le> y" using neq
    by (rule inf_neqE) auto
  from neq have "y \<noteq> x" ..
  with yA xA obtain t where
    tA: "t \<in> A\<^sup>\<star>" and ty: "t \<le> y" and tx: "\<not> t \<le> x"
    by (rule inf_neqE) auto
  let ?u = "infsuff A s" and ?v = "infsuff A t"
  have inter: "?u \<inter> ?v = {}"
  proof (rule ccontr, auto)
    fix z assume "z \<in> ?u" and "z \<in> ?v"
    hence "s \<le> z" and  "t \<le> z" by (unfold infsuff_def) auto
    hence "s \<le> t \<or> t \<le> s" by (rule pref_locally_linear)
    thus False using sx sy tx ty by (auto dest: llist_le_trans)
  qed
  moreover {
    from sA tA have "?u open" and "?v open"
      by auto
    moreover from xA yA sx ty have "x \<in> ?u" and "y \<in> ?v"
      by (auto simp: infsuff_def)
    ultimately have "infsuff A s \<in> nhds x" and
      "infsuff A t \<in> nhds y"
      by auto }
  ultimately show "\<exists> u \<in> nhds x. \<exists> v \<in> nhds y. u \<inter> v = {}"
    by auto
qed

corollary (in itrace_top) unique_convergence:
  "\<lbrakk> x \<in> carrier;
     y \<in> carrier;
     F \<in> Filters ;
     F \<longlongrightarrow> x;
     F \<longlongrightarrow> y \<rbrakk> \<Longrightarrow> x = y"
  apply (rule T2.unique_convergence)
  prefer 2
  apply (rule filter.intro)
  apply auto
  done

(*
lemma safty_closed:
  fixes   A :: "'a set"
  defines "T \<equiv> itop A"
  assumes P: "P \<subseteq> A\<^sup>\<omega>"
  and safety: "safety A P"
  shows "P iscl T"
proof-
  have istopT [iff]: "istop T" by (simp add: T_def)
  have carrT [simp]: "carr T = A\<^sup>\<omega>" by (simp add: T_def itop_carr)
  show ?thesis
  proof (rule closure_eq_closed, auto)
    fix x assume xclos: "x \<in> clos T P"
    with P have "x \<in> carr T"
      by (intro subsetD [OF closure_subset]) auto
    hence xA: "x \<in> A\<^sup>\<omega>" by simp
    moreover
    from P xclos have adhx: "adh T P x" by (auto intro!: closure_imp_adh)
    have "\<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P"
    proof
      fix r assume "r \<in> finpref A x"
      hence "x \<in> infsuff A r" and rA: "r \<in> A\<^sup>\<star>" using xA
        by (auto simp: finpref_def infsuff_def)
      hence "infsuff A r \<in> nhds T x" by (auto simp: T_def)
      with adhx have  "infsuff A r \<inter> P \<noteq> {}" by (elim adhCE) auto
      then obtain t where "t \<in> infsuff A r" and tP: "t \<in> P" by auto
      then obtain s where "s \<in> A\<^sup>\<omega>" and "t = r @@ s" using rA
        by (auto elim!: infsuff_appE)
      thus "\<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P" using tP by auto
    qed
    ultimately show "x \<in> P" using safety
      by (auto elim: safetyE)
  qed
qed
*)
lemma (in itrace_top) adh_lemma:
assumes xpoint: "x \<in> A\<^sup>\<omega>"
  and  PA: "P \<subseteq> A\<^sup>\<omega>"
shows "x adh P = (\<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P)"
proof-
  from PA have "\<And>r. r \<in> A\<^sup>\<star> \<Longrightarrow> (\<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P) =
        (\<exists> s \<in> P. r \<le> s)"
    by (auto simp: llist_le_def iff: lapp_infT)
  hence  "(\<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P) =
        (\<forall> r \<in> finpref A x. \<exists> s \<in> P. r \<le> s)"
    by (auto simp: finpref_def)
  also have "\<dots> = (\<forall> r \<in> finpref A x. infsuff A r \<inter> P \<noteq> {})"
  proof-
    have "\<And>r. (\<exists>s\<in>P. r \<le> s) = ({ra. ra \<in> A\<^sup>\<omega> \<and> r \<le> ra} \<inter> P \<noteq> {})" using PA
      by blast
    thus ?thesis by (simp add: infsuff_def)
  qed
  also have "\<dots> = (\<forall> u \<in> nhds x. u \<inter> P \<noteq> {})"
  proof safe
    fix r assume uP: "\<forall> u \<in> nhds x. u \<inter> P \<noteq> {}" and
      rfinpref: "r \<in> finpref A x" and rP: "infsuff A r \<inter> P = {}"
    from rfinpref have "infsuff A r open" by (auto dest!: finpref_fin)
    hence "infsuff A r \<in> nhds x" using xpoint rfinpref
      by auto
    with uP rP show "False" by auto
  next
    fix u assume
      inter:     "\<forall>r\<in>finpref A x. infsuff A r \<inter> P \<noteq> {}" and
      unhd:   "u \<in> nhds x" and
      uinter: "u \<inter> P = {}"
    from unhd obtain r where
      "r \<in> finpref A x" and "infsuff A r \<subseteq> u"
      by (rule infsuff_nhd_base)
    with inter uinter show "False" by auto
  qed
  finally show ?thesis by (simp add: adhs_def)
qed

lemma (in itrace_top) infsafety_closed_iff:
  "P \<subseteq> A\<^sup>\<omega> \<Longrightarrow>  infsafety A P = (P closed)"
  by (auto simp: infsafety_def topology.closed_adh adh_lemma itop_carrier)

lemma (in itrace_top) empty:
  "A = {} \<Longrightarrow> T = {{}}"
proof (auto simp: T_def)
  fix m x assume "m \<in> topo {{}}" and  xm: "x \<in> m"
  thus False
    by (induct m) auto
qed

lemma itop_empty: "itop {} = {{}}"
proof (auto simp: itop_def)
  fix m x assume "m \<in> topo {{}}" and  xm: "x \<in> m"
  thus False
    by (induct m) auto
qed

lemma infliveness_empty:
  "infliveness {} P \<Longrightarrow> False"
  by (auto simp: infliveness_def)

lemma (in trivial) dense:
  "P dense"
  by auto

lemma (in itrace_top) infliveness_dense_iff:
  assumes notempty: "A \<noteq> {}"
  and P: "P \<subseteq> A\<^sup>\<omega>"
  shows "infliveness A P = (P dense)"
proof-
  have "infliveness A P = (\<forall>r\<in>A\<^sup>\<star>. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P)"
    by (simp add: infliveness_def)
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<omega>. \<forall> r \<in> finpref A x. \<exists> s \<in> A\<^sup>\<omega>. r @@ s \<in> P)"
  proof-
    from notempty obtain a where "a \<in> A"
      by auto
    hence lc: "lconst a \<in> A\<^sup>\<omega>"
      by (rule lconstT)
    hence "\<And>P. (\<forall>x\<in>A\<^sup>\<omega>. \<forall>r\<in>finpref A x. P r) = (\<forall> r\<in>A\<^sup>\<star>. P r)"
    proof (auto dest: finpref_fin)
      fix P r  assume lc: "lconst a \<in> A\<^sup>\<omega>"
        and Pr: "\<forall>x\<in>A\<^sup>\<omega>. \<forall>r\<in>finpref A x. P r"
        and rA: "r \<in> A\<^sup>\<star>"
      from rA lc have rlc: "r @@ lconst a \<in> A\<^sup>\<omega>" by (rule lapp_fin_infT)
      moreover from rA rlc have "r \<in> finpref A (r @@ lconst a)"
        by (auto simp: finpref_def llist_le_def)
      ultimately show "P r" using Pr by auto
    qed
    thus ?thesis by simp
  qed
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<omega>. x adh P)" using P
    by (simp add: adh_lemma)
  also have "\<dots> = (A\<^sup>\<omega> \<subseteq> closure P)" using P
    by (auto simp: adh_closure_iff itop_carrier)
  also have "\<dots> = (P dense)"
    by (simp add: infliveness_def is_dense_def is_densein_def itop_carrier)
  finally show ?thesis .
qed

theorem (in itrace_top) alpern_schneider:
assumes notempty: "A \<noteq> {}"
  and   Psub:     "P \<subseteq> A\<^sup>\<omega>"
  shows "\<exists> S L. infsafety A S \<and> infliveness A L \<and> P = S \<inter> L"
proof-
  from Psub have "P \<subseteq> carrier"
    by (simp add: itop_carrier [THEN sym])
  then obtain L S where
    Lsub: "L \<subseteq> carrier" and
    Ssub: "S \<subseteq> carrier" and
    Sclosed: "S closed" and
    Ldense: "L dense" and
    Pinter: "P = S \<inter> L"
    by (rule topology.ex_dense_closure_interE [OF topology]) auto
  from Ssub Sclosed have "infsafety A S"
    by (simp add: infsafety_closed_iff itop_carrier)
  moreover from notempty Lsub Ldense have "infliveness A L"
    by (simp add: infliveness_dense_iff itop_carrier)
  ultimately show ?thesis using Pinter
    by auto
qed

subsection\<open>The topology of non-empty llists\<close>

definition
  ptop :: "'a set \<Rightarrow> 'a llist top" where
  "ptop A \<equiv> topo (\<Union> s\<in>A\<^sup>\<clubsuit>. {suff A s})"

locale possuffixes =
  fixes A and B
  defines [simp]: "B \<equiv> (\<Union> s\<in>A\<^sup>\<clubsuit>. {suff A s})"

locale ptrace_top = possuffixes + topobase

lemma (in ptrace_top) open_iff [iff]:
  "m open = (m \<in> topo (\<Union> s\<in>A\<^sup>\<clubsuit>. {suff A s}))"
  by (simp add: T_def is_open_def)

lemma (in ptrace_top) topology [iff]: "topology T"
  by (simp add: T_def)

lemma (in ptrace_top) ptop_carrier: "carrier = A\<^sup>\<spadesuit>"
by (auto simp add: carrier_topo suff_def)
   (auto elim: alllsts.cases)

lemma pptop_subtop_ttop:
  fixes S (structure)
  fixes A and B and T (structure)
  defines "B \<equiv> \<Union>s\<in>A\<^sup>\<star>. {suff A s}" and "T \<equiv> topo B"
  defines "S \<equiv> \<Union> t \<in> T. {t - {LNil}}"
  shows "subtopology S T"
by (rule subtopology.intro, auto simp add: is_open_def S_def carr_def)

lemma pptop_top:
  fixes S (structure)
  fixes A and B and T (structure)
  defines "B \<equiv> \<Union>s\<in>A\<^sup>\<star>. {suff A s}" and "T \<equiv> topo B"
  defines "S \<equiv> \<Union> t \<in> T. {t - {LNil}}"
  shows  "topology (\<Union> t \<in> T. {t - {LNil}})"
proof -
  interpret trace_top A B T by fact+
  show ?thesis
    by (auto intro!: subtopology.subtop_topology [OF pptop_subtop_ttop]
      trace_top.topology simp: T_def)
qed

(*
lemma
  includes ptrace_top A B S
  includes trace_top  A C T
  fixes S' (structure)
  defines  "S' \<equiv> (\<Union> t \<in> T. {t - {LNil}})"
  shows "S = S'"
proof-
  have [iff]: "\<And> m. m open\<^sub>3 = (\<exists>t. t open\<^sub>2 \<and> m = t - {LNil})"
    by (auto simp add: S'_def is_open_def)
  show ?thesis
  proof
    fix m assume "m open"
    thus "m open\<^sub>3"
    proof (induct m)
      case (basic m) thus ?case by auto
    next case (inter u v) thus ?case
        by (blast intro: topology.Int_open [OF pptop_top])
    next case (union M) thus ?case
        by (auto intro!: topology.union_open [OF pptop_top] simp: S'_def T_def)
    qed
  next
    fix m assume "m open\<^sub>3"
    then obtain t where "t open\<^sub>2" and mt: "m = t - {LNil}" by auto
    hence "t - {LNil} open\<^sub>1"
    proof (induct t)
      case (basic x)
      then obtain s where sfin: "s \<in> A\<^sup>\<star>" and
        ms: "x = suff A s"
        by auto
      thus ?case
      proof (cases s)
        case LNil_fin with ms
        have "x - {LNil} = carrier" by (auto simp: ptop_carrier)
        thus ?thesis by (auto intro!: topology.carrier_open [OF pptop_top])
      next
        case (LCons_fin a l) with ms show ?thesis
          by (auto simp: ptop_def)
      qed
    next case (inter u v)
      hence "(u - {LNil}) \<inter> (v - {LNil}) \<in> ptop A" by auto
      moreover have "(u - {LNil}) \<inter> (v - {LNil}) = (u \<inter> v) - {LNil}"
        by auto
      ultimately show ?case by auto
    next case (union M)
      hence "\<Union>{u. \<exists>x\<in>M. u = x - {LNil}} \<in> ptop A" by auto
      moreover have "\<Union>{u. \<exists>x\<in>M. u = x - {LNil}} = \<Union>M - {LNil}" by auto
      ultimately show ?case by auto
    qed
    thus "x \<in> ptop A" using xt by auto
  qed
qed
*)
lemma (in ptrace_top) suff_open [intro!]:
  "r \<in> A\<^sup>\<clubsuit> \<Longrightarrow> suff A r open"
  by auto

lemma (in ptrace_top) suff_ptop_nhd_base:
  assumes unhd: "u \<in> nhds t"
  and H: "\<And>r. \<lbrakk> r \<in> pfinpref A t; suff A r \<subseteq> u \<rbrakk> \<Longrightarrow> R"
  shows "R"
proof-
  from unhd obtain m where
    uA: "u \<subseteq> A\<^sup>\<spadesuit>" and
    mopen: "m open" and
    tm: "t \<in> m" and
    mu: "m \<subseteq> u"
    by (auto simp: ptop_carrier)
  from mopen tm have
    "\<exists>r \<in> pfinpref A t. suff A r \<subseteq> m"
  proof (induct "m")
    case (basic a)
    then obtain s where sA: "s \<in> A\<^sup>\<clubsuit>" and as: "a = suff A s" and ta: "t \<in> a"
      by auto
    from sA as ta have "s \<in> pfinpref A t"
      by (auto simp: pfinpref_def dest: suff_finpref)
    thus ?case using as by auto
  next case (inter a b)
    then obtain r r' where
      rt: "r \<in> pfinpref A t" and ra: "suff A r \<subseteq> a" and
      r't: "r' \<in> pfinpref A t" and r'b: "suff A r' \<subseteq> b"
      by auto
    from rt r't have "r \<le> r' \<or> r' \<le> r"
      by (auto simp: pfinpref_def finpref_def dest: pref_locally_linear)
    thus ?case
    proof
      assume "r \<le> r'"
      hence "suff A r' \<subseteq> suff A r" by (rule suff_mono2)
      thus ?case using r't ra r'b by auto
    next assume "r' \<le> r"
      hence "suff A r \<subseteq> suff A r'" by (rule suff_mono2)
      thus ?case using rt r'b ra by auto
    qed
  next case (union M)
    then obtain v where
      "t \<in> v" and vM: "v \<in> M"
      by blast
    then obtain r where "r\<in>pfinpref A t" "suff A r \<subseteq> v" using union
      by auto
    thus ?case using vM by auto
  qed
  with mu show ?thesis by (auto intro: H)
qed

lemma pfinpref_LNil [simp]: "pfinpref A LNil = {}"
  by (auto simp: pfinpref_def)

lemma (in ptrace_top) adh_lemma:
  assumes xpoint: "x \<in> A\<^sup>\<spadesuit>"
  and  P_subset_A: "P \<subseteq> A\<^sup>\<spadesuit>"
  shows "x adh P = (\<forall> r \<in> pfinpref A x. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
proof
  assume adh_x: "x adh P"
  show "\<forall>r\<in>pfinpref A x. \<exists>s\<in>A\<^sup>\<infinity>. r @@ s \<in> P"
  proof
    fix r let ?u = "suff A r"
    assume r_pfinpref_x: "r \<in> pfinpref A x"
    hence r_pos: "r \<in> A\<^sup>\<clubsuit>" by (auto dest: finpref_fin)
    hence "?u open" by auto
    hence "?u \<in> nhds x" using xpoint r_pfinpref_x
      by auto
    with adh_x have  "?u \<inter> P \<noteq> {}" by (auto elim!:adhCE)
    then obtain t where tu: "t \<in> ?u" and tP: "t \<in> P"
      by auto
    from tu obtain s where "t = r @@ s" using r_pos
      by (auto elim!: suff_appE)
    with tP show "\<exists>s\<in>A\<^sup>\<infinity>. r @@ s \<in> P" using P_subset_A r_pos
      by (auto iff: lapp_allT_iff)
  qed
next
  assume H: "\<forall>r\<in>pfinpref A x. \<exists>s\<in>A\<^sup>\<infinity>. r @@ s \<in> P"
  show "x adh P"
  proof
    fix U assume unhd: "U \<in> nhds x"
    then obtain r where r_pfinpref_x: "r \<in> pfinpref A x" and
      suff_subset_U: "suff A r \<subseteq> U" by (elim suff_ptop_nhd_base)
    from r_pfinpref_x have rpos: "r \<in> A\<^sup>\<clubsuit>" by (auto intro: finpref_fin)
    show "U \<inter> P \<noteq> {}" using rpos
    proof (cases r)
      case (LCons a l)
      hence r_pfinpref_x: "r \<in> pfinpref A x" using r_pfinpref_x
        by auto
      with H obtain s where sA: "s \<in> A\<^sup>\<infinity>" and asP: "r@@s \<in> P"
        by  auto
      moreover have "r @@ s \<in> suff A r" using sA rpos
        by (auto simp: suff_def iff: lapp_allT_iff)
      ultimately show ?thesis using suff_subset_U by auto
    qed
  qed
qed

lemma (in ptrace_top) possafety_closed_iff:
  "P \<subseteq> A\<^sup>\<spadesuit> \<Longrightarrow>  possafety A P = (P closed)"
  by (auto simp: possafety_def topology.closed_adh ptop_carrier adh_lemma)
(*
lemma ptop_empty: "ptop {} = {{}}"
proof (auto simp: ptop_def intro!: topobase.basic)
  fix m x assume "m \<in> topo {}" and  xm: "x \<in> m"
  thus False
    by (induct m) auto
qed

lemma posliveness_empty:
  "posliveness {} P"
  by (auto simp: posliveness_def)
*)

lemma (in ptrace_top) posliveness_dense_iff:
  assumes P: "P \<subseteq> A\<^sup>\<spadesuit>"
  shows "posliveness A P = (P dense)"
proof-
  have "posliveness A P = (\<forall>r\<in>A\<^sup>\<clubsuit>. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
    by (simp add: posliveness_def)
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<spadesuit>. \<forall> r \<in> pfinpref A x. \<exists> s \<in> A\<^sup>\<infinity>. r @@ s \<in> P)"
      by (auto simp: pfinpref_def finpref_def dest: finsubsetall)
  also have "\<dots> = (\<forall>x\<in>A\<^sup>\<spadesuit>. x adh P)" using P
    by (auto simp: adh_lemma simp del: poslsts_iff)
  also have "\<dots> = (A\<^sup>\<spadesuit> \<subseteq> closure P)" using P
    by (auto simp: adh_closure_iff ptop_carrier simp del: poslsts_iff)
  also have "\<dots> = (P dense)"
    by (simp add: posliveness_def is_dense_def is_densein_def ptop_carrier)
  finally show ?thesis .
qed

theorem (in ptrace_top) alpern_schneider:
assumes Psub: "P \<subseteq> A\<^sup>\<spadesuit>"
  shows "\<exists> S L. possafety A S \<and> posliveness A L \<and> P = S \<inter> L"
proof-
  from Psub have "P \<subseteq> carrier" by (simp add: ptop_carrier)
  then obtain L S where
    Lsub: "L \<subseteq> carrier" and
    Ssub: "S \<subseteq> carrier" and
    Sclosed: "S closed" and
    Ldense: "L dense" and
    Pinter: "P = S \<inter> L"
    by (blast elim: topology.ex_dense_closure_interE [OF topology])
  from Ssub Sclosed have "possafety A S"
    by (simp add: possafety_closed_iff ptop_carrier)
  moreover from Lsub Ldense have "posliveness A L"
    by (simp add: posliveness_dense_iff ptop_carrier)
  ultimately show ?thesis using Pinter
    by auto
qed

end


theory s184235_2 imports SeCaV begin

\<comment> \<open>Please keep each line shorter than 100 characters and do not modify the above "imports" at all\<close>

(*
  Solutions must be entered directly in this file instead of $$$$$ such that there are no errors.

  IT IS ONLY ALLOWED TO REPLACE $$$$$ WITH LEMMA/PROOF - ABSOLUTELY NO OTHER CHANGES ARE ALLOWED.

  This comment can be removed and of course the theory name should be changed to your student id.
*)

abbreviation \<open>P \<equiv> Pre 0 []\<close>

abbreviation \<open>Q \<equiv> Pre 1 []\<close>

section \<open>Problem 1\<close>

proposition \<open>p \<and> q \<longrightarrow> q \<and> p\<close> by metis

lemma  \<open>\<tturnstile>
  [
    Imp (Con P Q)  (Con Q P)
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con P Q),
      (Con Q P)
    ]
    \<close>
    using that by simp

  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg P,
      Neg Q,
      Con Q P
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Con Q P,
      Neg P,
      Neg Q
    ]
    \<close>
    using that by simp
  with BetaCon have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg P,
      Neg Q
    ]
    \<close> and  \<open>\<tturnstile>
    [
      P,
      Neg P,
      Neg Q
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Q,
      Neg Q
    ]
    \<close> and  \<open>\<tturnstile>
    [
      P,
      Neg P
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

\<comment> \<open>Please keep the "end" command and ensure that Isabelle2020 does not indicate any errors at all\<close>

end


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

section \<open>Models of Omega Algebras\<close>

theory Omega_Algebra_Models
imports Omega_Algebra Kleene_Algebra_Models
begin

text \<open>The trace, path and language model are not really interesting
in this setting.\<close>

subsection \<open>Relation Omega Algebras\<close>

text \<open>In the relational model, the omega of a relation relates all
those elements in the domain of the relation, from which an infinite
chain starts, with all other elements; all other elements are not
related to anything~\cite{hofnerstruth10nontermination}. Thus, the
omega of a relation is most naturally defined coinductively.\<close>

coinductive_set omega :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" for R where
  "\<lbrakk> (x, y) \<in> R; (y, z) \<in> omega R \<rbrakk> \<Longrightarrow> (x, z) \<in> omega R"

(* FIXME: The equivalent, but perhaps more elegant point-free version
  "x \<in> R O omega R \<Longrightarrow> x \<in> omega R"
fails due to missing monotonicity lemmas. *)

text \<open>Isabelle automatically derives a case rule and a coinduction
theorem for @{const omega}. We prove slightly more elegant
variants.\<close>

lemma omega_cases: "(x, z) \<in> omega R \<Longrightarrow>
  (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> omega R \<Longrightarrow> P) \<Longrightarrow> P"
by (metis omega.cases)

lemma omega_coinduct: "X x z \<Longrightarrow>
  (\<And>x z. X x z \<Longrightarrow> \<exists>y. (x, y) \<in> R \<and> (X y z \<or> (y, z) \<in> omega R)) \<Longrightarrow>
  (x, z) \<in> omega R"
by (metis (full_types) omega.coinduct)

lemma omega_weak_coinduct: "X x z \<Longrightarrow>
  (\<And>x z. X x z \<Longrightarrow> \<exists>y. (x, y) \<in> R \<and> X y z) \<Longrightarrow>
  (x, z) \<in> omega R"
by (metis omega.coinduct)

interpretation rel_omega_algebra: omega_algebra "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl omega
proof
  fix x :: "'a rel"
  show "omega x \<subseteq> x O omega x"
    by (auto elim: omega_cases)
next
  fix x y z :: "'a rel"
  assume *: "y \<subseteq> z \<union> x O y"
  {
    fix a b
    assume 1: "(a,b) \<in> y" and 2: "(a,b) \<notin> x\<^sup>* O z"
    have "(a,b) \<in> omega x"
    proof (rule omega_weak_coinduct[where X="\<lambda>a b. (a,b) \<in> x O y \<and> (a,b) \<notin> x\<^sup>* O z"])
      show "(a,b) \<in> x O y \<and> (a,b) \<notin> x\<^sup>* O z"
        using "*" "1" "2" by auto
    next
      fix a c
      assume 1: "(a,c) \<in> x O y \<and> (a,c) \<notin> x\<^sup>* O z"
      then obtain b where 2: "(a,b) \<in> x" and "(b,c) \<in> y"
        by auto
      then have "(b,c) \<in> x O y"
        using "*" "1" by blast
      moreover have "(b,c) \<notin> x\<^sup>* O z"
        using "1" "2" by (meson relcomp.cases relcomp.intros converse_rtrancl_into_rtrancl)
      ultimately show "\<exists>b. (a,b) \<in> x \<and> (b,c) \<in> x O y \<and> (b,c) \<notin> x\<^sup>* O z"
        using "2" by blast
    qed
  }
  then show "y \<subseteq> omega x \<union> x\<^sup>* O z"
    by auto
qed

end


theory Single_Use
  imports Main "../Util/Setsum" "../Core/Update" "../Core/SST" "../Util/Enum_Nat"
begin

definition kronecker :: "'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "kronecker a b = (if a = b then 1 else 0)"

lemma kronecker_eq[simp]: "kronecker a a = 1" unfolding kronecker_def by simp
lemma kronecker_noteq[simp]: "a \<noteq> b \<Longrightarrow> kronecker a b = 0" unfolding kronecker_def by simp

lemma count_list_my_simp:
  "count_list (x#xs) a = kronecker x a + count_list xs a"
  unfolding kronecker_def by simp

lemma sum_kronecker_in:
  assumes "finite A"
  assumes "b \<in> A"
  shows "(\<Sum>a\<in>A. kronecker b a) = Suc 0"
  by (simp add: sum_eq_Suc0_iff assms kronecker_def)

lemma sum_kronecker_mult1_in:
  assumes "finite A"
  assumes "b \<in> A"
  shows "(\<Sum>a\<in>A. kronecker b a * f a) = f b"
proof -
  have "(\<Sum>a\<in>A. kronecker b a * f a)
       = kronecker b b * f b+ (\<Sum>a\<in>A-{b}. kronecker b a * f a)"
    by (rule sum.remove[OF assms])
  also have "... = f b"
    by (simp add: assms kronecker_def)
  finally show ?thesis .
qed

lemma sum_kronecker_mult2_in:
  assumes "finite A"
  assumes "b \<in> A"
  shows "(\<Sum>a\<in>A. f a * kronecker b a) = f b"
proof -
  have "(\<Sum>a\<in>A. f a * kronecker b a)
       = f b * kronecker b b + (\<Sum>a\<in>A-{b}. f a * kronecker b a)"
    by (rule sum.remove[OF assms])
  also have "... = f b"
    by (simp add: assms kronecker_def)
  finally show ?thesis .
qed

lemma sum_kronecker_notin:
  assumes "finite A"
  assumes "b \<notin> A"
  shows "(\<Sum>a\<in>A. kronecker b a) = 0"
  using assms by (simp add: sum_eq_Suc0_iff assms kronecker_def)

lemma sum_kronecker:
  assumes "finite A"
  shows "(\<Sum>a\<in>A. kronecker b a) \<le> Suc 0"
  using assms
  by (cases "b \<in> A", simp_all add: sum_kronecker_in sum_kronecker_notin)

definition count_var :: "[('x::finite, 'y::finite, 'b) update', 'y] \<Rightarrow> nat" where
  "count_var f y0 \<equiv> \<Sum>y\<in>UNIV. count_list (extract_variables (f y)) y0"

definition count_alpha :: "[('x::finite, 'y::finite, 'b) update', 'b] \<Rightarrow> nat" where
  "count_alpha f b0 \<equiv> \<Sum>y\<in>UNIV. count_list (valuate (f y)) b0"

lemma count_list_extract_variables: "count_list (extract_variables u) x = count_list u (Inl x)"
  by (induct u rule: xa_induct, simp_all)

lemma count_list_valuate: "count_list (valuate u) a = count_list u (Inr a)"
  by (induct u rule: xa_induct, simp_all)

lemma sum_count_list_UNIV: "(\<Sum>y\<in>(UNIV::'x::finite set). count_list xs y) = length xs"
  by (rule sum_count_set, simp_all)

definition bounded :: "[nat, ('x::finite, 'y::finite, 'b) update'] \<Rightarrow> bool" where
  "bounded k f \<equiv> (\<forall>y. count_var f y \<le> k)"

abbreviation single_use  :: "(('x::finite, 'y::finite, 'b) update') \<Rightarrow> bool" where
  "single_use f \<equiv> bounded 1 f"

lemma count_list_append[simp]: "count_list (xs@ys) a = count_list xs a + count_list ys a"
  by (induct xs, auto)

lemma card_UNIV_option: "card (UNIV::('a::finite) option set) = Suc (card (UNIV::'a set))"
  by (auto simp add: UNIV_option_conv, rule card_image, rule inj_Some)

lemma basic_count: "count_list (extract_variables (hat_hom f u)) y
  = (\<Sum>z\<in>(UNIV::('a::finite) set). (count_list (extract_variables (f z)) y * count_list (extract_variables u) z))"
proof (induct u rule: xa_induct)
  case Nil
  show ?case by simp
next
  case (Alpha a u)
  then show ?case by simp
next
  case (Var x u)
  then show ?case by (simp add: count_list_my_simp add_mult_distrib2 sum.distrib sum_kronecker_mult2_in del: count_list.simps)
qed

lemma count_var_comp:
  fixes m1 :: "('y::finite, 'z::finite, 'b) update'"
  fixes m2 :: "('x::finite, 'y, 'b) update'"
  shows "count_var (m1 \<bullet> m2) x
       = (\<Sum>y::'y\<in>UNIV. count_list (extract_variables (m1 y)) x * count_var m2 y)"
  unfolding compU_def count_alpha_def count_var_def
  by (simp add: basic_count sum_distrib_left, rule sum.swap)

lemma bounded_copy_closed:
  fixes f :: "('y::finite, 'z::finite, 'b) update'"
  assumes "bounded k f" and "bounded l g"
  shows "bounded (k * l) (f \<bullet> g)"
  unfolding bounded_def
proof (simp add: count_var_comp, rule allI)
  fix y
  have "(\<Sum>ya\<in>UNIV. count_list (extract_variables (f ya)) y * count_var g ya)
      \<le> (\<Sum>ya\<in>UNIV. count_list (extract_variables (f ya)) y * l)" (is "?def \<le> _")
    apply (rule sum_mono, rule mult_le_mono2)
    using assms unfolding bounded_def by simp
  also have "... \<le> k * l"
    using assms unfolding bounded_def count_var_def
    by (simp add: sum_distrib_right[symmetric])
  finally show "?def \<le> k * l" .
qed

lemma single_use_closed:
  fixes f :: "('y::finite, 'z::finite, 'b) update'"
  assumes "single_use f" and "single_use g"
  shows "single_use (f \<bullet> g)"
  using bounded_copy_closed[OF assms] by simp

lemma basic_count_alpha:
  fixes m :: "('y::finite, 'z::finite, 'b) update'"
  fixes xs :: "('y + 'b) list"
  shows "count_list (valuate (hat_hom m u)) a =
         (\<Sum>y::'y\<in>UNIV. (count_list (valuate (m y)) a * count_list (extract_variables u) y)) + count_list (valuate u) a"
proof (induct u rule: xa_induct)
  case Nil
  then show ?case by simp
next
  case (Var x xs)
  then show ?case by (simp del: count_list.simps add: count_list_my_simp add_mult_distrib2 sum.distrib sum_kronecker_mult2_in)
next
  case (Alpha a xs)
  then show ?case by simp
qed

lemma count_alpha_comp:
  fixes m1 :: "('y::finite, 'z::finite, 'b) update'"
  fixes m2 :: "('x::finite, 'y, 'b) update'"
  shows "count_alpha (m1 \<bullet> m2) a
 = (\<Sum>y::'y\<in>UNIV. count_list (valuate (m1 y)) a * count_var m2 y) + count_alpha m2 a"
  unfolding compU_def count_alpha_def count_var_def
  by (simp add: basic_count_alpha sum_distrib_right sum_distrib_left sum.distrib, rule sum.swap)

lemma count_alpha_0_comp_count_alpha_n:
  assumes "count_alpha m1 a = 0"
  assumes "count_alpha m2 a \<le> n"
  shows "count_alpha (m1 \<bullet> m2) a \<le> n"
  using assms by (simp add: count_alpha_comp, simp add: count_alpha_def)

lemma count_alpha_le_1_bounded_copy:
  assumes "count_alpha m1 a \<le> 1"
  assumes "count_alpha m2 a \<le> n"
  assumes "bounded k m2"
  shows "count_alpha (m1 \<bullet> m2) a \<le> k + n"
proof (cases "count_alpha m1 a = 0")
  case True
  then show ?thesis using assms by (simp add: count_alpha_comp, simp add: count_alpha_def)
next
  case False
  then have "count_alpha m1 a = 1" using assms(1) by simp
  then have 1: "(\<Sum>y\<in>UNIV. count_list (valuate (m1 y)) a) = 1" unfolding count_alpha_def by simp
  obtain y1 where y1: "count_list (valuate (m1 y1)) a = 1 \<and> (\<Sum>y0\<in>UNIV-{y1}. count_list (valuate (m1 y0)) a) = 0"
    using sum1[OF finite 1] by auto
  then have y0: "\<forall>y0\<in>UNIV-{y1}. count_list (valuate (m1 y0)) a = 0" by auto
  have "(\<Sum>y\<in>UNIV. count_list (valuate (m1 y)) a * count_var m2 y) = (\<Sum>y\<in>UNIV. if y = y1 then count_var m2 y else 0)"
    by (rule sum.cong, auto simp add: y0 y1)
  also have "... = count_var m2 y1" by simp
  finally have *: "(\<Sum>y\<in>UNIV. count_list (valuate (m1 y)) a  * count_var m2 y) = count_var m2 y1" .
  have "(\<Sum>y\<in>UNIV. count_list (valuate (m1 y)) a * count_var m2 y) \<le> k"
    using assms unfolding bounded_def by (simp add: "*")
  then show ?thesis using assms unfolding bounded_def
    by (simp add: count_alpha_comp)
qed

section \<open>Bounded-ness of SST\<close>

definition bounded_copy_SST :: "[ nat, ('q::finite, 'x::finite, 'a, 'b, 'e) SST_scheme ] \<Rightarrow> bool" where
  "bounded_copy_SST k sst \<equiv> (\<forall>w q. reachable sst q \<longrightarrow> bounded k (SST.eta_hat sst (q, w)))"

lemma bounded_copy_SST_simp:
  assumes "bounded_copy_SST k sst" and "reachable sst q"
  shows "bounded k (SST.eta_hat sst (q, w))"
  using assms unfolding bounded_copy_SST_def by simp

text \<open>Phantom type used to state bounded-ness using size of UNIV :: 'i set\<close>
datatype ('i::enum) boundedness = Boundedness

definition boundedness :: "'i::enum boundedness \<Rightarrow> nat \<Rightarrow> bool" where
  "boundedness B k \<equiv> (k = length (Enum.enum :: 'i list))"

end


theory Queue
imports "../l4v/tools/autocorres/AutoCorres"
begin

text{*

Author: Andrew Gacek
Description: Correctness proofs for enqueue and dequeue operations on a circular queue.

*}

type_synonym 'a queue = "'a list \<times> nat \<times> nat"

fun wf :: "'a queue \<Rightarrow> bool" where
  "wf (xs, f, n) = (0 < length xs \<and> f < length xs \<and> n \<le> length xs)"

fun is_empty :: "'a queue \<Rightarrow> bool" where
  "is_empty (xs, f, n) = (n = 0)"

fun is_full :: "'a queue \<Rightarrow> bool" where
  "is_full (xs, f, n) = (n = length xs)"

fun enqueue :: "'a queue \<Rightarrow> 'a \<Rightarrow> 'a queue" where
  "enqueue (xs, f, n) x =
    (if \<not>is_full (xs, f, n) then
       (xs[(f + n) mod length xs := x], f, n + 1)
     else
       undefined)"

fun dequeue :: "'a queue \<Rightarrow> 'a \<times> 'a queue" where
  "dequeue (xs, f, Suc n) = (xs!f, (xs, (f + 1) mod length xs, n))" |
  "dequeue (xs, f, 0) = undefined"

fun rep :: "'a queue \<Rightarrow> 'a list" where
  "rep (xs, f, n) = take n (rotate f xs)"

lemma enqueue_wf[intro, simp]:
  "\<lbrakk> wf q; \<not>is_full q \<rbrakk> \<Longrightarrow> wf (enqueue q x)"
by (cases q, auto)

lemma dequeue_wf[intro, simp]:
  "\<lbrakk> wf q; \<not>is_empty q \<rbrakk> \<Longrightarrow> wf (snd (dequeue q))"
by (cases q, auto simp: gr0_conv_Suc)

lemma nth_rotate1:
  "i < length xs \<Longrightarrow> rotate1 xs ! i = (if Suc i < length xs then xs ! (Suc i) else xs ! 0)"
apply (cases "xs = []", simp)
apply (auto simp: rotate1_hd_tl nth_append nth_tl hd_conv_nth)
done

lemma nth_rotate1_mod:
  "0 < length xs \<Longrightarrow> rotate1 xs ! (i mod length xs) = xs ! (Suc i mod length xs)"
by (metis hd_rotate_conv_nth length_greater_0_conv length_rotate1 rotate1_rotate_swap rotate_Suc)

lemma rotate1_Suc_update:
  "rotate1 (xs[Suc n mod length xs := x]) = (rotate1 xs)[n mod length xs := x]"
apply (cases "xs = []", simp)
apply (auto simp: mod_Suc nth_list_update nth_rotate1 intro: nth_equalityI)
done

lemma take_rotate_update:
  "n < length xs \<Longrightarrow> take n (rotate f (xs[(f + n) mod length xs := x])) = take n (rotate f xs)"
apply (induction f arbitrary: xs)
apply (auto simp: rotate1_rotate_swap rotate1_Suc_update)
apply (metis length_rotate1)
done

lemma nth_rotate:
  "n < length xs \<Longrightarrow> (rotate f xs) ! n = xs ! ((f + n) mod length xs)"
apply (induction f arbitrary: xs)
apply (auto simp: rotate1_rotate_swap nth_rotate1_mod length_ineq_not_Nil)
done

lemma enqueue_rep:
  "\<lbrakk> wf q; \<not>is_full q \<rbrakk> \<Longrightarrow> rep (enqueue q x) = rep q @ [x]"
by (cases q, auto simp: take_Suc_conv_app_nth take_rotate_update nth_rotate)

lemma dequeue_rep:
  "\<lbrakk> wf q; \<not>is_empty q; dequeue q = (x, q') \<rbrakk> \<Longrightarrow> rep q = x # rep q'"
apply (cases q, simp)
apply (auto simp: gr0_conv_Suc take_Suc hd_rotate_conv_nth rotate_conv_mod[symmetric] rotate1_hd_tl)
done

install_C_file queue.c
autocorres[ts_rules = nondet, heap_abs_syntax] queue.c

context queue begin

definition is_queue :: "lifted_globals \<Rightarrow> bool" where
  "is_queue s \<equiv> front_'' s < 10 \<and> length_'' s \<le> 10"

definition the_queue :: "lifted_globals \<Rightarrow> 8 word queue" where
  "the_queue s \<equiv> (list_array (contents_'' s), unat (front_'' s), unat (length_'' s))"

fun queue_length :: "'a queue \<Rightarrow> nat" where
  "queue_length (xs, f, n) = n"

lemma is_full_wp [wp]:
  "\<lbrace> \<lambda>s. if queue_length (the_queue s) = 10 then Q 1 s else Q 0 s \<rbrace>
   is_full'
   \<lbrace> \<lambda>r s. Q r s \<rbrace>!"
apply (unfold is_full'_def)
apply wp
apply (auto simp: the_queue_def unat_arith_simps)
done

lemma enqueue_full:
  "\<lbrace> \<lambda>s. is_queue s \<and> queue_length (the_queue s) = 10 \<and> P s \<rbrace>
   enqueue' x
   \<lbrace> \<lambda>r s. r = 0 \<and> P s \<rbrace>!"
apply (unfold enqueue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def unat_arith_simps)
done

lemma list_array_update:
  "i < length (list_array a) \<Longrightarrow> list_array (Arrays.update a i x) = list_array a[i := x]"
by (auto simp add: list_array_def nth_list_update intro: nth_equalityI)

lemma enqueue_not_full:
  "(\<And>c n s. P (s\<lparr>contents_'' := c, length_'' := n\<rparr>) = P s) \<Longrightarrow>
   \<lbrace> \<lambda>s. is_queue s \<and>
         q = the_queue s \<and>
         queue_length q < 10 \<and>
         P s \<rbrace>
   enqueue' x
   \<lbrace> \<lambda>r s. r > 0 \<and>
           the_queue s = enqueue q x \<and>
           is_queue s \<and>
           P s \<rbrace>!"
apply (unfold enqueue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def list_array_update unat_arith_simps)
done

lemma is_empty_wp [wp]:
  "\<lbrace> \<lambda>s. if queue_length (the_queue s) = 0 then Q 1 s else Q 0 s \<rbrace>
   is_empty'
   \<lbrace> \<lambda>r s. Q r s \<rbrace>!"
apply (unfold is_empty'_def)
apply wp
apply (auto simp: the_queue_def unat_arith_simps)
done

lemma dequeue_empty:
  "\<lbrace> \<lambda>s. is_queue s \<and> queue_length (the_queue s) = 0 \<and> P s \<rbrace>
   dequeue' x
   \<lbrace> \<lambda>r s. r = 0 \<and> P s \<rbrace>!"
apply (unfold dequeue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def unat_arith_simps)
done

lemma dequeue_not_empty:
  "(\<And>f n s. P (s\<lparr>front_'' := f, length_'' := n\<rparr>) = P s) \<Longrightarrow>
   (\<And>s v. P (s[x := v]) = P s) \<Longrightarrow>
   (\<And>s v. contents_'' (s[x := v]) = contents_'' s) \<Longrightarrow>
   (\<And>s v. front_'' (s[x := v]) = front_'' s) \<Longrightarrow>
   (\<And>s v. length_'' (s[x := v]) = length_'' s) \<Longrightarrow>
   \<lbrace> \<lambda>s. is_queue s \<and>
         q = the_queue s \<and>
         queue_length q > 0 \<and>
         is_valid_w8 s x \<and>
         P s \<rbrace>
   dequeue' x
   \<lbrace> \<lambda>r s. r > 0 \<and>
           dequeue q = (heap_w8 s x, the_queue s) \<and>
           is_queue s \<and>
           P s \<rbrace>!"
apply (unfold dequeue'_def)
apply wp
apply (auto simp add: fun_upd_def is_queue_def the_queue_def
                      gr0_conv_Suc list_array_nth unat_arith_simps
            simp del: word_unat.Rep_inject[symmetric])
done

end
end


theory T39
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory LocalLexingLemmas
imports LocalLexing Limit
begin

context LocalLexing begin

lemma subset_\
Suc: "\
 k u \<subseteq> \
 k (Suc u)"
  by (simp add: subset_setmonotone[OF setmonotone_limit])

lemma subset_fSuc_strict:
  assumes f: "\<And> u. f u \<subseteq> f (Suc u)"
  shows "u < v \<Longrightarrow> f u \<subseteq> f v"
proof (induct v)
  show "u < 0 \<Longrightarrow> f u \<subseteq> f 0"
    by auto
next
  fix v
  assume a:"(u < v \<Longrightarrow> f u \<subseteq> f v)"
  assume b:"u < Suc v"
  from b have c: "f u \<subseteq> f v"
    apply (case_tac "u < v")
    apply (simp add: a)
    apply (case_tac "u = v")
    apply simp
    by auto
  show "f u \<subseteq> f (Suc v)"
    apply (rule subset_trans[OF c])
    by (rule f)
qed

lemma subset_fSuc:
  assumes f: "\<And> u. f u \<subseteq> f (Suc u)"
  shows "u \<le> v \<Longrightarrow> f u \<subseteq> f v"
  apply (case_tac "u < v")
  apply (rule subset_fSuc_strict[where f=f, OF f])
  by auto

lemma subset_\
k: "u \<le> v \<Longrightarrow> \
 k u \<subseteq> \
 k v"
  by (rule subset_fSuc, rule subset_\
Suc)

lemma subset_\
\<Q>k: "\
 k u \<subseteq> \<Q> k" by (auto simp add: natUnion_def)

lemma subset_\<Q>\
Suc: "\<Q> k \<subseteq> \
 (Suc k) u"
proof -
  have a: "\<Q> k \<subseteq> \
 (Suc k) 0" by simp
  show ?thesis
    apply (case_tac "u = 0")
    apply (simp add: a)
    apply (rule subset_trans[OF a subset_\
k])
    by auto
qed

lemma subset_\<Q>Suc: "\<Q> k \<subseteq> \<Q> (Suc k)"
  by (rule subset_trans[OF subset_\<Q>\
Suc subset_\
\<Q>k])

lemma subset_\<Q>: "i \<le> j \<Longrightarrow> \<Q> i \<subseteq> \<Q> j"
  by (rule subset_fSuc[where u=i and v=j and f = \<Q>, OF subset_\<Q>Suc])

lemma empty_\<X>[simp]: "k > length Doc \<Longrightarrow> \<X> k = {}"
  apply (simp add: \<X>_def)
  apply (insert Lex_is_lexer)
  by (simp add: is_lexer_def)

lemma Sel_empty[simp]: "Sel {} {} = {}"
  apply (insert Sel_is_selector)
  by (auto simp add: is_selector_def)

lemma empty_\<Z>[simp]: "k > length Doc \<Longrightarrow> \<Z> k u = {}"
  apply (induct u)
  by (simp_all add: \<Y>_def \<W>_def)

lemma[simp]: "Append {} k = id" by (auto simp add: Append_def)

lemma[simp]: "k > length Doc \<Longrightarrow> \
 k v = \
 k 0"
  by (induct v, simp_all add: \<Y>_def \<W>_def)

lemma \<Q>SucEq: "k \<ge> length Doc \<Longrightarrow> \<Q> (Suc k) = \<Q> k"
  by (simp add: natUnion_def)

lemma \<Q>_converges:
  assumes k: "k \<ge> length Doc"
  shows "\<Q> k = \<PP>"
proof -
  {
    fix n
    have "\<Q> (length Doc + n) = \<PP>"
    proof (induct n)
      show "\<Q> (length Doc + 0) = \<PP>" by (simp add: \<PP>_def)
    next
      fix n
      assume hyp: "\<Q> (length Doc + n) = \<PP>"
      have "\<Q> (Suc (length Doc + n)) = \<PP>"
        by (rule trans[OF \<Q>SucEq hyp], auto)
      then show "\<Q> (length Doc + Suc n) = \<PP>"
        by auto
    qed
  }
  note helper = this
  from k have "\<exists> n. k = length Doc + n" by presburger
  then obtain "n" where n: "k = length Doc + n" by blast
  then show ?thesis
    apply (simp only: n)
    by (rule helper)
qed

lemma \<PP>_covers_\<Q>: "\<Q> k \<subseteq> \<PP>"
proof (case_tac "k \<ge> length Doc")
  assume "k \<ge> length Doc"
  then have \<Q>: "\<Q> k = \<PP>" by (rule \<Q>_converges)
  then show "\<Q> k \<subseteq> \<PP>" by (simp only: \<Q>)
next
  assume "\<not> length Doc \<le> k"
  then have "k < length Doc" by auto
  then show ?thesis
    apply (simp only: \<PP>_def)
    apply (rule subset_\<Q>)
    by auto
qed

lemma Sel_upper_bound: "A \<subseteq> B \<Longrightarrow> Sel A B \<subseteq> B"
  by (metis Sel_is_selector is_selector_def)

lemma Sel_lower_bound: "A \<subseteq> B \<Longrightarrow> A \<subseteq> Sel A B"
  by (metis Sel_is_selector is_selector_def)

lemma \<PP>_covers_\
: "\
 k u \<subseteq> \<PP>"
  by (rule subset_trans[OF subset_\
\<Q>k \<PP>_covers_\<Q>])

lemma \<W>_montone: "P \<subseteq> Q \<Longrightarrow> \<W> P k \<subseteq> \<W> Q k"
  by (auto simp add: \<W>_def)

lemma Sel_precondition:
  "\<Z> k u \<subseteq> \<W> (\
 k u) k"
proof (induct u)
  case 0 thus ?case by simp
next
  case (Suc u)
  have 1: "\<Y> (\<Z> k u) (\
 k u) k \<subseteq> \<W> (\
 k u) k"
    apply (simp add: \<Y>_def)
    apply (rule_tac Sel_upper_bound)
    using Suc by simp
  have 2: "\<W> (\
 k u) k \<subseteq> \<W> (\
 k (Suc u)) k"
    by (metis \<W>_montone subset_\
Suc)
  show ?case
    apply (rule_tac subset_trans[where B="\<W> (\
 k u) k"])
    apply (simp add: 1)
    apply (simp only: 2)
    done
qed

lemma \<W>_bounded_by_\<X>: "\<W> P k \<subseteq> \<X> k"
  by (metis (no_types, lifting) \<W>_def mem_Collect_eq subsetI)

lemma \<Z>_subset_\<X>: "\<Z> k n \<subseteq> \<X> k"
  by (metis Sel_precondition \<W>_bounded_by_\<X> rev_subsetD subsetI)

lemma \<Z>_subset_Suc: "\<Z> k n \<subseteq> \<Z> k (Suc n)"
apply (induct n)
apply simp
by (metis Sel_lower_bound Sel_precondition \<Y>_def \<Z>.simps(2))

lemma \<Y>_upper_bound: "\<Y> (\<Z> k u) (\
 k u) k \<subseteq> \<W>  (\
 k u) k"
  apply (simp add: \<Y>_def)
  by (metis Sel_precondition Sel_upper_bound)

lemma \<PP>_induct[consumes 1, case_names Base Induct]:
  assumes p: "p \<in> \<PP>"
  assumes base: "P []"
  assumes induct: "\<And> p k u. (\<And> q. q \<in> \
 k u \<Longrightarrow> P q) \<Longrightarrow> p \<in> \
 k (Suc u) \<Longrightarrow> P p"
  shows "P p"
proof -
  {
    fix p :: "tokens"
    fix k :: nat
    fix u :: nat
    have "p \<in> \
 k u \<Longrightarrow> P p"
    proof (induct k arbitrary: p u)
      case 0
        have "p \<in> \
 0 u \<Longrightarrow> P p"
        proof (induct u arbitrary: p)
          case 0 thus ?case using base by simp
        next
          case (Suc u) show ?case
            apply (rule induct[OF _ Suc(2)])
            apply (rule Suc(1))
            by simp
        qed
        with 0 show ?case by simp
    next
      case (Suc k)
        have "p \<in> \
 (Suc k) u \<Longrightarrow> P p"
        proof (induct u arbitrary: p)
          case 0 thus ?case
            apply simp
            apply (induct rule: natUnion_decompose)
            using Suc by simp
        next
          case (Suc u) show ?case
            apply (rule induct[OF _ Suc(2)])
            apply (rule Suc(1))
            by simp
        qed
        with Suc show ?case by simp
    qed
  }
  note all = this
  from p show ?thesis
    apply (simp add: \<PP>_def)
    apply (induct rule: natUnion_decompose)
    using all by simp
qed

lemma Append_mono: "U \<subseteq> V \<Longrightarrow> P \<subseteq> Q \<Longrightarrow> Append U k P \<subseteq> Append V k Q"
  by (auto simp add: Append_def)

lemma pointwise_Append: "pointwise (Append T k)"
by (auto simp add: pointwise_def Append_def)

lemma regular_Append: "regular (Append T k)"
proof -
  have "pointwise (Append T k)" using pointwise_Append by blast
  then have "pointbased (Append T k)" using pointwise_implies_pointbased by blast
  then have "continuous (Append T k)" using pointbased_implies_continuous by blast
  moreover have "setmonotone (Append T k)" by (simp add: setmonotone_def Append_def)
  ultimately show ?thesis using regular_def by blast
qed

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_prop_40
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun z :: "bool => bool => bool" where
  "z True y2 = y2"
| "z False y2 = False"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x22) (Z) = False"
| "y (S x22) (S y22) = y x22 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

fun subset :: "Nat list => Nat list => bool" where
  "subset (nil2) y2 = True"
| "subset (cons2 z2 xs) y2 = z (elem z2 y2) (subset xs y2)"

fun union :: "Nat list => Nat list => Nat list" where
  "union (nil2) y2 = y2"
| "union (cons2 z2 xs) y2 =
     (if elem z2 y2 then union xs y2 else cons2 z2 (union xs y2))"

theorem property0 :
  "((subset x2 y2) ==> ((union x2 y2) = y2))"
  oops

end