(*  Title:       Mathematical Preliminaries
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Mathematical Preliminaries \<close>

text \<open>This section adds useful syntax, abbreviations and theorems to the Isabelle distribution. \<close>

theory MTX_Preliminaries
  imports Hybrid_Systems_VCs.HS_Preliminaries

begin

subsection \<open> Syntax \<close>

abbreviation "\<e> k \<equiv> axis k 1"

syntax
  "_ivl_integral" :: "real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> pttrn \<Rightarrow> bool" ("(3\<integral>\<^sub>_\<^sup>_ (_)\<partial>/_)" [0, 0, 10] 10)

translations
  "\<integral>\<^sub>a\<^sup>b f \<partial>x" \<rightleftharpoons> "CONST ivl_integral a b (\<lambda>x. f)"

notation matrix_inv ("_\<^sup>-\<^sup>1" [90])

abbreviation "entries (A::'a^'n^'m) \<equiv> {A $ i $ j | i j. i \<in> UNIV \<and> j \<in> UNIV}"

subsection \<open> Topology and sets \<close>

lemmas compact_imp_bdd_above = compact_imp_bounded[THEN bounded_imp_bdd_above]

lemma comp_cont_image_spec: "continuous_on T f \<Longrightarrow> compact T \<Longrightarrow> compact {f t |t. t \<in> T}"
  using compact_continuous_image by (simp add: Setcompr_eq_image)

lemmas bdd_above_cont_comp_spec = compact_imp_bdd_above[OF comp_cont_image_spec]

lemmas bdd_above_norm_cont_comp = continuous_on_norm[THEN bdd_above_cont_comp_spec]

lemma open_cballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. cball t\<^sub>0 e \<subseteq> T"
  using open_contains_cball by blast

lemma open_ballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. ball t\<^sub>0 e \<subseteq> T"
  using open_contains_ball by blast

lemma funcset_UNIV: "f \<in> A \<rightarrow> UNIV"
  by auto

lemma finite_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b"
  shows "finite {x. \<exists>i. x = f i}"
  using finite_Atleast_Atmost_nat by force

lemma finite_image_of_finite2:
  fixes f :: "'a::finite \<Rightarrow> 'b::finite \<Rightarrow> 'c"
  shows "finite {f x y |x y. P x y}"
proof-
  have "finite (\<Union>x. {f x y|y. P x y})"
    by simp
  moreover have "{f x y|x y. P x y} = (\<Union>x. {f x y|y. P x y})"
    by auto
  ultimately show ?thesis
    by simp
qed

subsection \<open> Functions \<close>

lemma finite_sum_univ_singleton: "(sum g UNIV) = sum g {i::'a::finite} + sum g (UNIV - {i})"
  by (metis add.commute finite_class.finite_UNIV sum.subset_diff top_greatest)

lemma suminfI:
  fixes f :: "nat \<Rightarrow> 'a::{t2_space,comm_monoid_add}"
  shows "f sums k \<Longrightarrow> suminf f = k"
  unfolding sums_iff by simp

lemma suminf_eq_sum:
  fixes f :: "nat \<Rightarrow> ('a::real_normed_vector)"
  assumes "\<And>n. n > m \<Longrightarrow> f n = 0"
  shows "(\<Sum>n. f n) = (\<Sum>n \<le> m. f n)"
  using assms by (meson atMost_iff finite_atMost not_le suminf_finite)

lemma suminf_multr: "summable f \<Longrightarrow> (\<Sum>n. f n * c) = (\<Sum>n. f n) * c" for c::"'a::real_normed_algebra"
  by (rule bounded_linear.suminf [OF bounded_linear_mult_left, symmetric])

lemma sum_if_then_else_simps[simp]:
  fixes q :: "('a::semiring_0)" and i :: "'n::finite"
  shows "(\<Sum>j\<in>UNIV. f j * (if j = i then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. f j * (if i = j then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. (if i = j then q else 0) * f j) = q * f i"
    and "(\<Sum>j\<in>UNIV. (if j = i then q else 0) * f j) = q * f i"
  by (auto simp: finite_sum_univ_singleton[of _ i])

subsection \<open> Suprema \<close>

lemma le_max_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b::linorder"
  shows "(f i) \<le> Max {x. \<exists>i. x = f i}"
  by (rule Max.coboundedI, simp_all) (rule_tac x=i in exI, simp)

lemma cSup_eq:
  fixes c::"'a::conditionally_complete_lattice"
  assumes "\<forall>x \<in> X. x \<le> c" and "\<exists>x \<in> X. c \<le> x"
  shows "Sup X = c"
  by (metis assms cSup_eq_maximum order_class.order.antisym)

lemma cSup_mem_eq:
  "c \<in> X \<Longrightarrow> \<forall>x \<in> X. x \<le> c \<Longrightarrow> Sup X = c" for c::"'a::conditionally_complete_lattice"
  by (rule cSup_eq, auto)

lemma cSup_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Sup X = x" for X::"'a::conditionally_complete_linorder set"
  by (metis (full_types) bdd_finite(1) cSup_upper finite_Sup_less_iff order_less_le)

lemma cMax_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Max X = x" for X::"'a::conditionally_complete_linorder set"
  apply(subst cSup_eq_Max[symmetric])
  using cSup_finite_ex by auto

lemma finite_nat_minimal_witness:
  fixes P :: "('a::finite) \<Rightarrow> nat \<Rightarrow> bool"
  assumes "\<forall>i. \<exists>N::nat. \<forall>n \<ge> N. P i n"
  shows "\<exists>N. \<forall>i. \<forall>n \<ge> N. P i n"
proof-
  let "?bound i" = "(LEAST N. \<forall>n \<ge> N. P i n)"
  let ?N = "Max {?bound i |i. i \<in> UNIV}"
  {fix n::nat and i::'a
    assume "n \<ge> ?N"
    obtain M where "\<forall>n \<ge> M. P i n"
      using assms by blast
    hence obs: "\<forall> m \<ge> ?bound i. P i m"
      using LeastI[of "\<lambda>N. \<forall>n \<ge> N. P i n"] by blast
    have "finite {?bound i |i. i \<in> UNIV}"
      by simp
    hence "?N \<ge> ?bound i"
      using Max_ge by blast
    hence "n \<ge> ?bound i"
      using \<open>n \<ge> ?N\<close> by linarith
    hence "P i n"
      using obs by blast}
  thus "\<exists>N. \<forall>i n. N \<le> n \<longrightarrow> P i n"
    by blast
qed

subsection \<open> Real numbers \<close>

named_theorems field_power_simps "simplification rules for powers to the nth"

declare semiring_normalization_rules(18) [field_power_simps]
    and semiring_normalization_rules(26) [field_power_simps]
    and semiring_normalization_rules(27) [field_power_simps]
    and semiring_normalization_rules(28) [field_power_simps]
    and semiring_normalization_rules(29) [field_power_simps]

text \<open>WARNING: Adding @{thm semiring_normalization_rules(27)} to our tactic makes
its combination with simp to loop infinitely in some proofs.\<close>

lemma sq_le_cancel:
  shows "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> b * a \<Longrightarrow> a \<le> b"
  and "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> a * b \<Longrightarrow> a \<le> b"
   apply (metis less_eq_real_def mult.commute mult_le_cancel_left semiring_normalization_rules(29))
  by (metis less_eq_real_def mult_le_cancel_left semiring_normalization_rules(29))

lemma frac_diff_eq1: "a \<noteq> b \<Longrightarrow> a / (a - b) - b / (a - b) = 1" for a::real
  by (metis (no_types) ab_left_minus add.commute add_left_cancel
      diff_divide_distrib diff_minus_eq_add div_self)

lemma exp_add: "x * y - y * x = 0 \<Longrightarrow> exp (x + y) = exp x * exp y"
  by (rule exp_add_commuting) (simp add: ac_simps)

lemmas mult_exp_exp = exp_add[symmetric]

subsection \<open> Vectors and matrices \<close>

lemma sum_axis[simp]:
  fixes q :: "('a::semiring_0)"
  shows "(\<Sum>j\<in>UNIV. f j * axis i q $ j) = f i * q"
    and "(\<Sum>j\<in>UNIV. axis i q $ j * f j) = q * f i"
  unfolding axis_def by(auto simp: vec_eq_iff)

lemma sum_scalar_nth_axis: "sum (\<lambda>i. (x $ i) *s \<e> i) UNIV = x" for x :: "('a::semiring_1)^'n"
  unfolding vec_eq_iff axis_def by simp

lemma scalar_eq_scaleR[simp]: "c *s x = c *\<^sub>R x"
  unfolding vec_eq_iff by simp

lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma vec_mult_inner: "(A *v v) \<bullet> w = v \<bullet> (transpose A *v w)" for A :: "real ^'n^'n"
  unfolding matrix_vector_mult_def transpose_def inner_vec_def
  apply(simp add: sum_distrib_right sum_distrib_left)
  apply(subst sum.swap)
  apply(subgoal_tac "\<forall>i j. A $ i $ j * v $ j * w $ i = v $ j * (A $ i $ j * w $ i)")
  by presburger simp

lemma uminus_axis_eq[simp]: "- axis i k = axis i (-k)" for k :: "'a::ring"
  unfolding axis_def by(simp add: vec_eq_iff)

lemma norm_axis_eq[simp]: "\<parallel>axis i k\<parallel> = \<parallel>k\<parallel>"
proof(simp add: axis_def norm_vec_def L2_set_def)
  let "?\<delta>\<^sub>K" = "\<lambda>i j k. if i = j then k else 0"
  have "(\<Sum>j\<in>UNIV. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) = (\<Sum>j\<in>{i}. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) + (\<Sum>j\<in>(UNIV-{i}). (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2)"
    using finite_sum_univ_singleton by blast
  also have "... = (\<parallel>k\<parallel>)\<^sup>2"
    by simp
  finally show "sqrt (\<Sum>j\<in>UNIV. (norm (if j = i then k else 0))\<^sup>2) = norm k"
    by simp
qed

lemma matrix_axis_0:
  fixes A :: "('a::idom)^'n^'m"
  assumes "k \<noteq> 0 " and h:"\<forall>i. (A *v (axis i k)) = 0"
  shows "A = 0"
proof-
  {fix i::'n
    have "0 = (\<Sum>j\<in>UNIV. (axis i k) $ j *s column j A)"
      using h matrix_mult_sum[of A "axis i k"] by simp
    also have "... = k *s column i A"
      by (simp add: axis_def vector_scalar_mult_def column_def vec_eq_iff mult.commute)
    finally have "k *s column i A = 0"
      unfolding axis_def by simp
    hence "column i A = 0"
      using vector_mul_eq_0 \<open>k \<noteq> 0\<close> by blast}
  thus "A = 0"
    unfolding column_def vec_eq_iff by simp
qed

lemma scaleR_norm_sgn_eq: "(\<parallel>x\<parallel>) *\<^sub>R sgn x = x"
  by (metis divideR_right norm_eq_zero scale_eq_0_iff sgn_div_norm)

lemma vector_scaleR_commute: "A *v c *\<^sub>R x = c *\<^sub>R (A *v x)" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding scaleR_vec_def matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma scaleR_vector_assoc: "c *\<^sub>R (A *v x) = (c *\<^sub>R A) *v x" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma mult_norm_matrix_sgn_eq:
  fixes x :: "('a::real_normed_algebra_1)^'n"
  shows "(\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>) = \<parallel>A *v x\<parallel>"
proof-
  have "\<parallel>A *v x\<parallel> = \<parallel>A *v ((\<parallel>x\<parallel>) *\<^sub>R sgn x)\<parallel>"
    by(simp add: scaleR_norm_sgn_eq)
  also have "... = (\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>)"
    by(simp add: vector_scaleR_commute)
  finally show ?thesis ..
qed

subsection\<open> Diagonalization \<close>

lemma invertibleI: "A ** B = mat 1 \<Longrightarrow> B ** A = mat 1 \<Longrightarrow> invertible A"
  unfolding invertible_def by auto

lemma invertibleD[simp]:
  assumes "invertible A"
  shows "A\<^sup>-\<^sup>1 ** A = mat 1" and "A ** A\<^sup>-\<^sup>1 = mat 1"
  using assms unfolding matrix_inv_def invertible_def
  by (simp_all add: verit_sko_ex')

lemma matrix_inv_unique:
  assumes "A ** B = mat 1" and "B ** A = mat 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis assms invertibleD(2) invertibleI matrix_mul_assoc matrix_mul_lid)

lemma invertible_matrix_inv: "invertible A \<Longrightarrow> invertible (A\<^sup>-\<^sup>1)"
  using invertibleD invertibleI by blast

lemma matrix_inv_idempotent[simp]: "invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using invertibleD matrix_inv_unique by blast

lemma matrix_inv_matrix_mul:
  assumes "invertible A" and "invertible B"
  shows "(A ** B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1"
proof(rule matrix_inv_unique)
  have "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = A ** (B ** B\<^sup>-\<^sup>1) ** A\<^sup>-\<^sup>1"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = mat 1" .
next
  have "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = B\<^sup>-\<^sup>1 ** (A\<^sup>-\<^sup>1 ** A) ** B"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = mat 1" .
qed

lemma mat_inverse_simps[simp]:
  fixes c :: "'a::division_ring"
  assumes "c \<noteq> 0"
  shows "mat (inverse c) ** mat c = mat 1"
    and "mat c ** mat (inverse c) = mat 1"
  unfolding matrix_matrix_mult_def mat_def by (auto simp: vec_eq_iff assms)

lemma matrix_inv_mat[simp]: "c \<noteq> 0 \<Longrightarrow> (mat c)\<^sup>-\<^sup>1 = mat (inverse c)" for c :: "'a::division_ring"
  by (simp add: matrix_inv_unique)

lemma invertible_mat[simp]: "c \<noteq> 0 \<Longrightarrow> invertible (mat c)" for c :: "'a::division_ring"
  using invertibleI mat_inverse_simps(1) mat_inverse_simps(2) by blast

lemma matrix_inv_mat_1: "(mat (1::'a::division_ring))\<^sup>-\<^sup>1 = mat 1"
  by simp

lemma invertible_mat_1: "invertible (mat (1::'a::division_ring))"
  by simp

definition similar_matrix :: "('a::semiring_1)^'m^'m \<Rightarrow> ('a::semiring_1)^'n^'n \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "similar_matrix A B \<longleftrightarrow> (\<exists> P. invertible P \<and> A = P\<^sup>-\<^sup>1 ** B ** P)"

lemma similar_matrix_refl[simp]: "A \<sim> A" for A :: "'a::division_ring^'n^'n"
  by (unfold similar_matrix_def, rule_tac x="mat 1" in exI, simp)

lemma similar_matrix_simm: "A \<sim> B \<Longrightarrow> B \<sim> A" for A B :: "('a::semiring_1)^'n^'n"
  apply(unfold similar_matrix_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: invertible_matrix_inv)
  by (metis invertible_def matrix_inv_unique matrix_mul_assoc matrix_mul_lid matrix_mul_rid)

lemma similar_matrix_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C" for A B C :: "('a::semiring_1)^'n^'n"
proof(unfold similar_matrix_def, clarsimp)
  fix P Q
  assume "A = P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P" and "B = Q\<^sup>-\<^sup>1 ** C ** Q"
  let ?R = "Q ** P"
  assume inverts: "invertible Q" "invertible P"
  hence "?R\<^sup>-\<^sup>1 = P\<^sup>-\<^sup>1 ** Q\<^sup>-\<^sup>1"
    by (rule matrix_inv_matrix_mul)
  also have "invertible ?R"
    using inverts invertible_mult by blast
  ultimately show "\<exists>R. invertible R \<and> P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P = R\<^sup>-\<^sup>1 ** C ** R"
    by (metis matrix_mul_assoc)
qed

lemma mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> mat c $ i $ j = c"
  "i \<noteq> j \<Longrightarrow> mat c $ i $ j = 0"
  by (simp_all add: mat_def)

definition "diag_mat f = (\<chi> i j. if i = j then f i else 0)"

lemma diag_mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> diag_mat f $ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> diag_mat f $ i $ j = 0"
  unfolding diag_mat_def by simp_all

lemma diag_mat_const_eq[simp]: "diag_mat (\<lambda>i. c) = mat c"
  unfolding mat_def diag_mat_def by simp

lemma matrix_vector_mul_diag_mat: "diag_mat f *v s = (\<chi> i. f i * s$i)"
  unfolding diag_mat_def matrix_vector_mult_def by simp

lemma matrix_vector_mul_diag_axis[simp]: "diag_mat f *v (axis i k) = axis i (f i * k)"
  by (simp add: matrix_vector_mul_diag_mat axis_def fun_eq_iff)

lemma matrix_mul_diag_matl: "diag_mat f ** A = (\<chi> i j. f i * A$i$j)"
  unfolding diag_mat_def matrix_matrix_mult_def by simp

lemma matrix_matrix_mul_diag_matr: "A ** diag_mat f = (\<chi> i j. A$i$j * f j)"
  unfolding diag_mat_def matrix_matrix_mult_def apply(clarsimp simp: fun_eq_iff)
  subgoal for i j
    by (auto simp: finite_sum_univ_singleton[of _ j])
  done

lemma matrix_mul_diag_diag: "diag_mat f ** diag_mat g = diag_mat (\<lambda>i. f i * g i)"
  unfolding diag_mat_def matrix_matrix_mult_def vec_eq_iff by simp

lemma compow_matrix_mul_diag_mat_eq: "((**) (diag_mat f) ^^ n) (mat 1) = diag_mat (\<lambda>i. f i^n)"
  apply(induct n, simp_all add: matrix_mul_diag_matl)
  by (auto simp: vec_eq_iff diag_mat_def)

lemma compow_similar_diag_mat_eq:
  assumes "invertible P"
      and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    shows "((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** (diag_mat (\<lambda>i. f i^n)) ** P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 ** diag_mat f ** P ** (P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P) =
  P\<^sup>-\<^sup>1 ** diag_mat f ** diag_mat (\<lambda>i. f i ^ n) ** P" (is "?lhs = _")
    by (metis (no_types, lifting) assms(1) invertibleD(2) matrix_mul_rid matrix_mul_assoc)
  also have "... = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i * f i ^ n) ** P" (is "_ = ?rhs")
    by (metis (full_types) matrix_mul_assoc matrix_mul_diag_diag)
  finally show "?lhs = ?rhs" .
qed

lemma compow_similar_diag_mat:
  assumes "A \<sim> (diag_mat f)"
  shows "((**) A ^^ n) (mat 1) \<sim> diag_mat (\<lambda>i. f i^n)"
proof(unfold similar_matrix_def)
  obtain P where "invertible P" and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    using assms unfolding similar_matrix_def by blast
  thus "\<exists>P. invertible P \<and> ((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P"
    using compow_similar_diag_mat_eq by blast
qed

no_notation matrix_inv ("_\<^sup>-\<^sup>1" [90])
        and similar_matrix (infixr "\<sim>" 25)

end


(*  Title:      ZF/Univ.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Standard notation for Vset(i) is V(i), but users might want V for a
variable.

NOTE: univ(A) could be a translation; would simplify many proofs!
  But Ind_Syntax.univ refers to the constant "Univ.univ"
*)

section\<open>The Cumulative Hierarchy and a Small Universe for Recursive Types\<close>

theory Univ imports Epsilon Cardinal begin

definition
  Vfrom       :: "[i,i]=>i"  where
    "Vfrom(A,i) == transrec(i, %x f. A \<union> (\<Union>y\<in>x. Pow(f`y)))"

abbreviation
  Vset :: "i=>i" where
  "Vset(x) == Vfrom(0,x)"

definition
  Vrec        :: "[i, [i,i]=>i] =>i"  where
    "Vrec(a,H) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                           H(z, \<lambda>w\<in>Vset(x). g`rank(w)`w)) ` a"

definition
  Vrecursor   :: "[[i,i]=>i, i] =>i"  where
    "Vrecursor(H,a) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                                H(\<lambda>w\<in>Vset(x). g`rank(w)`w, z)) ` a"

definition
  univ        :: "i=>i"  where
    "univ(A) == Vfrom(A,nat)"

subsection\<open>Immediate Consequences of the Definition of @{term "Vfrom(A,i)"}\<close>

text\<open>NOT SUITABLE FOR REWRITING -- RECURSIVE!\<close>
lemma Vfrom: "Vfrom(A,i) = A \<union> (\<Union>j\<in>i. Pow(Vfrom(A,j)))"
by (subst Vfrom_def [THEN def_transrec], simp)

subsubsection\<open>Monotonicity\<close>

lemma Vfrom_mono [rule_format]:
     "A<=B ==> \<forall>j. i<=j \<longrightarrow> Vfrom(A,i) \<subseteq> Vfrom(B,j)"
apply (rule_tac a=i in eps_induct)
apply (rule impI [THEN allI])
apply (subst Vfrom [of A])
apply (subst Vfrom [of B])
apply (erule Un_mono)
apply (erule UN_mono, blast)
done

lemma VfromI: "[| a \<in> Vfrom(A,j);  j<i |] ==> a \<in> Vfrom(A,i)"
by (blast dest: Vfrom_mono [OF subset_refl le_imp_subset [OF leI]])

subsubsection\<open>A fundamental equality: Vfrom does not require ordinals!\<close>

lemma Vfrom_rank_subset1: "Vfrom(A,x) \<subseteq> Vfrom(A,rank(x))"
proof (induct x rule: eps_induct)
  fix x
  assume "\<forall>y\<in>x. Vfrom(A,y) \<subseteq> Vfrom(A,rank(y))"
  thus "Vfrom(A, x) \<subseteq> Vfrom(A, rank(x))"
    by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"],
        blast intro!: rank_lt [THEN ltD])
qed

lemma Vfrom_rank_subset2: "Vfrom(A,rank(x)) \<subseteq> Vfrom(A,x)"
apply (rule_tac a=x in eps_induct)
apply (subst Vfrom)
apply (subst Vfrom, rule subset_refl [THEN Un_mono])
apply (rule UN_least)
txt\<open>expand \<open>rank(x1) = (\<Union>y\<in>x1. succ(rank(y)))\<close> in assumptions\<close>
apply (erule rank [THEN equalityD1, THEN subsetD, THEN UN_E])
apply (rule subset_trans)
apply (erule_tac [2] UN_upper)
apply (rule subset_refl [THEN Vfrom_mono, THEN subset_trans, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (rule Ord_rank [THEN Ord_succ])
apply (erule bspec, assumption)
done

lemma Vfrom_rank_eq: "Vfrom(A,rank(x)) = Vfrom(A,x)"
apply (rule equalityI)
apply (rule Vfrom_rank_subset2)
apply (rule Vfrom_rank_subset1)
done

subsection\<open>Basic Closure Properties\<close>

lemma zero_in_Vfrom: "y:x ==> 0 \<in> Vfrom(A,x)"
by (subst Vfrom, blast)

lemma i_subset_Vfrom: "i \<subseteq> Vfrom(A,i)"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom, blast)
done

lemma A_subset_Vfrom: "A \<subseteq> Vfrom(A,i)"
apply (subst Vfrom)
apply (rule Un_upper1)
done

lemmas A_into_Vfrom = A_subset_Vfrom [THEN subsetD]

lemma subset_mem_Vfrom: "a \<subseteq> Vfrom(A,i) ==> a \<in> Vfrom(A,succ(i))"
by (subst Vfrom, blast)

subsubsection\<open>Finite sets and ordered pairs\<close>

lemma singleton_in_Vfrom: "a \<in> Vfrom(A,i) ==> {a} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma doubleton_in_Vfrom:
     "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> {a,b} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma Pair_in_Vfrom:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> <a,b> \<in> Vfrom(A,succ(succ(i)))"
apply (unfold Pair_def)
apply (blast intro: doubleton_in_Vfrom)
done

lemma succ_in_Vfrom: "a \<subseteq> Vfrom(A,i) ==> succ(a) \<in> Vfrom(A,succ(succ(i)))"
apply (intro subset_mem_Vfrom succ_subsetI, assumption)
apply (erule subset_trans)
apply (rule Vfrom_mono [OF subset_refl subset_succI])
done

subsection\<open>0, Successor and Limit Equations for @{term Vfrom}\<close>

lemma Vfrom_0: "Vfrom(A,0) = A"
by (subst Vfrom, blast)

lemma Vfrom_succ_lemma: "Ord(i) ==> Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule Vfrom [THEN trans])
apply (rule equalityI [THEN subst_context,
                       OF _ succI1 [THEN RepFunI, THEN Union_upper]])
apply (rule UN_least)
apply (rule subset_refl [THEN Vfrom_mono, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (erule Ord_succ)
done

lemma Vfrom_succ: "Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule_tac x1 = "succ (i)" in Vfrom_rank_eq [THEN subst])
apply (rule_tac x1 = i in Vfrom_rank_eq [THEN subst])
apply (subst rank_succ)
apply (rule Ord_rank [THEN Vfrom_succ_lemma])
done

(*The premise distinguishes this from Vfrom(A,0);  allowing X=0 forces
  the conclusion to be Vfrom(A,\<Union>(X)) = A \<union> (\<Union>y\<in>X. Vfrom(A,y)) *)
lemma Vfrom_Union: "y:X ==> Vfrom(A,\<Union>(X)) = (\<Union>y\<in>X. Vfrom(A,y))"
apply (subst Vfrom)
apply (rule equalityI)
txt\<open>first inclusion\<close>
apply (rule Un_least)
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (rule UN_upper, assumption)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] UN_upper,
       subst Vfrom, erule subset_trans [OF UN_upper Un_upper2])
txt\<open>opposite inclusion\<close>
apply (rule UN_least)
apply (subst Vfrom, blast)
done

subsection\<open>@{term Vfrom} applied to Limit Ordinals\<close>

(*NB. limit ordinals are non-empty:
      Vfrom(A,0) = A = A \<union> (\<Union>y\<in>0. Vfrom(A,y)) *)
lemma Limit_Vfrom_eq:
    "Limit(i) ==> Vfrom(A,i) = (\<Union>y\<in>i. Vfrom(A,y))"
apply (rule Limit_has_0 [THEN ltD, THEN Vfrom_Union, THEN subst], assumption)
apply (simp add: Limit_Union_eq)
done

lemma Limit_VfromE:
    "[| a \<in> Vfrom(A,i);  ~R ==> Limit(i);
        !!x. [| x<i;  a \<in> Vfrom(A,x) |] ==> R
     |] ==> R"
apply (rule classical)
apply (rule Limit_Vfrom_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI Limit_is_Ord)
done

lemma singleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  Limit(i) |] ==> {a} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule singleton_in_Vfrom [THEN VfromI])
apply (blast intro: Limit_has_succ)
done

lemmas Vfrom_UnI1 =
    Un_upper1 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]
lemmas Vfrom_UnI2 =
    Un_upper2 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]

text\<open>Hard work is finding a single j:i such that {a,b}<=Vfrom(A,j)\<close>
lemma doubleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> {a,b} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
apply (blast intro:  VfromI [OF doubleton_in_Vfrom]
                     Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma Pair_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> <a,b> \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
txt\<open>Infer that @{term"succ(succ(x \<union> xa)) < i"}\<close>
apply (blast intro: VfromI [OF Pair_in_Vfrom]
                    Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma product_VLimit: "Limit(i) ==> Vfrom(A,i) * Vfrom(A,i) \<subseteq> Vfrom(A,i)"
by (blast intro: Pair_in_VLimit)

lemmas Sigma_subset_VLimit =
     subset_trans [OF Sigma_mono product_VLimit]

lemmas nat_subset_VLimit =
     subset_trans [OF nat_le_Limit [THEN le_imp_subset] i_subset_Vfrom]

lemma nat_into_VLimit: "[| n: nat;  Limit(i) |] ==> n \<in> Vfrom(A,i)"
by (blast intro: nat_subset_VLimit [THEN subsetD])

subsubsection\<open>Closure under Disjoint Union\<close>

lemmas zero_in_VLimit = Limit_has_0 [THEN ltD, THEN zero_in_Vfrom]

lemma one_in_VLimit: "Limit(i) ==> 1 \<in> Vfrom(A,i)"
by (blast intro: nat_into_VLimit)

lemma Inl_in_VLimit:
    "[| a \<in> Vfrom(A,i); Limit(i) |] ==> Inl(a) \<in> Vfrom(A,i)"
apply (unfold Inl_def)
apply (blast intro: zero_in_VLimit Pair_in_VLimit)
done

lemma Inr_in_VLimit:
    "[| b \<in> Vfrom(A,i); Limit(i) |] ==> Inr(b) \<in> Vfrom(A,i)"
apply (unfold Inr_def)
apply (blast intro: one_in_VLimit Pair_in_VLimit)
done

lemma sum_VLimit: "Limit(i) ==> Vfrom(C,i)+Vfrom(C,i) \<subseteq> Vfrom(C,i)"
by (blast intro!: Inl_in_VLimit Inr_in_VLimit)

lemmas sum_subset_VLimit = subset_trans [OF sum_mono sum_VLimit]

subsection\<open>Properties assuming @{term "Transset(A)"}\<close>

lemma Transset_Vfrom: "Transset(A) ==> Transset(Vfrom(A,i))"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom)
apply (blast intro!: Transset_Union_family Transset_Un Transset_Pow)
done

lemma Transset_Vfrom_succ:
     "Transset(A) ==> Vfrom(A, succ(i)) = Pow(Vfrom(A,i))"
apply (rule Vfrom_succ [THEN trans])
apply (rule equalityI [OF _ Un_upper2])
apply (rule Un_least [OF _ subset_refl])
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (erule Transset_Vfrom [THEN Transset_iff_Pow [THEN iffD1]])
done

lemma Transset_Pair_subset: "[| <a,b> \<subseteq> C; Transset(C) |] ==> a: C & b: C"
by (unfold Pair_def Transset_def, blast)

lemma Transset_Pair_subset_VLimit:
     "[| <a,b> \<subseteq> Vfrom(A,i);  Transset(A);  Limit(i) |]
      ==> <a,b> \<in> Vfrom(A,i)"
apply (erule Transset_Pair_subset [THEN conjE])
apply (erule Transset_Vfrom)
apply (blast intro: Pair_in_VLimit)
done

lemma Union_in_Vfrom:
     "[| X \<in> Vfrom(A,j);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A, succ(j))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def, blast)
done

lemma Union_in_VLimit:
     "[| X \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A,i)"
apply (rule Limit_VfromE, assumption+)
apply (blast intro: Limit_has_succ VfromI Union_in_Vfrom)
done

(*** Closure under product/sum applied to elements -- thus Vfrom(A,i)
     is a model of simple type theory provided A is a transitive set
     and i is a limit ordinal
***)

text\<open>General theorem for membership in Vfrom(A,i) when i is a limit ordinal\<close>
lemma in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);
      !!x y j. [| j<i; 1:j; x \<in> Vfrom(A,j); y \<in> Vfrom(A,j) |]
               ==> \<exists>k. h(x,y) \<in> Vfrom(A,k) & k<i |]
   ==> h(a,b) \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption, atomize)
apply (drule_tac x=a in spec)
apply (drule_tac x=b in spec)
apply (drule_tac x="x \<union> xa \<union> 2" in spec)
apply (simp add: Un_least_lt_iff lt_Ord Vfrom_UnI1 Vfrom_UnI2)
apply (blast intro: Limit_has_0 Limit_has_succ VfromI)
done

subsubsection\<open>Products\<close>

lemma prod_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |]
     ==> a*b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma prod_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a*b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: prod_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Disjoint Sums, or Quine Ordered Pairs\<close>

lemma sum_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A);  1:j |]
     ==> a+b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (unfold sum_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: zero_in_Vfrom Pair_in_Vfrom i_subset_Vfrom [THEN subsetD])
done

lemma sum_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a+b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: sum_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Function Space!\<close>

lemma fun_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |] ==>
          a->b \<in> Vfrom(A, succ(succ(succ(succ(j)))))"
apply (unfold Pi_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (rule Collect_subset [THEN subset_trans])
apply (subst Vfrom)
apply (rule subset_trans [THEN subset_trans])
apply (rule_tac [3] Un_upper2)
apply (rule_tac [2] succI1 [THEN UN_upper])
apply (rule Pow_mono)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma fun_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a->b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: fun_in_Vfrom Limit_has_succ)
done

lemma Pow_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A, succ(succ(j)))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (subst Vfrom, blast)
done

lemma Pow_in_VLimit:
     "[| a \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A,i)"
by (blast elim: Limit_VfromE intro: Limit_has_succ Pow_in_Vfrom VfromI)

subsection\<open>The Set @{term "Vset(i)"}\<close>

lemma Vset: "Vset(i) = (\<Union>j\<in>i. Pow(Vset(j)))"
by (subst Vfrom, blast)

lemmas Vset_succ = Transset_0 [THEN Transset_Vfrom_succ]
lemmas Transset_Vset = Transset_0 [THEN Transset_Vfrom]

subsubsection\<open>Characterisation of the elements of @{term "Vset(i)"}\<close>

lemma VsetD [rule_format]: "Ord(i) ==> \<forall>b. b \<in> Vset(i) \<longrightarrow> rank(b) < i"
apply (erule trans_induct)
apply (subst Vset, safe)
apply (subst rank)
apply (blast intro: ltI UN_succ_least_lt)
done

lemma VsetI_lemma [rule_format]:
     "Ord(i) ==> \<forall>b. rank(b) \<in> i \<longrightarrow> b \<in> Vset(i)"
apply (erule trans_induct)
apply (rule allI)
apply (subst Vset)
apply (blast intro!: rank_lt [THEN ltD])
done

lemma VsetI: "rank(x)<i ==> x \<in> Vset(i)"
by (blast intro: VsetI_lemma elim: ltE)

text\<open>Merely a lemma for the next result\<close>
lemma Vset_Ord_rank_iff: "Ord(i) ==> b \<in> Vset(i) \<longleftrightarrow> rank(b) < i"
by (blast intro: VsetD VsetI)

lemma Vset_rank_iff [simp]: "b \<in> Vset(a) \<longleftrightarrow> rank(b) < rank(a)"
apply (rule Vfrom_rank_eq [THEN subst])
apply (rule Ord_rank [THEN Vset_Ord_rank_iff])
done

text\<open>This is rank(rank(a)) = rank(a)\<close>
declare Ord_rank [THEN rank_of_Ord, simp]

lemma rank_Vset: "Ord(i) ==> rank(Vset(i)) = i"
apply (subst rank)
apply (rule equalityI, safe)
apply (blast intro: VsetD [THEN ltD])
apply (blast intro: VsetD [THEN ltD] Ord_trans)
apply (blast intro: i_subset_Vfrom [THEN subsetD]
                    Ord_in_Ord [THEN rank_of_Ord, THEN ssubst])
done

lemma Finite_Vset: "i \<in> nat ==> Finite(Vset(i))"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Vset_succ)
done

subsubsection\<open>Reasoning about Sets in Terms of Their Elements' Ranks\<close>

lemma arg_subset_Vset_rank: "a \<subseteq> Vset(rank(a))"
apply (rule subsetI)
apply (erule rank_lt [THEN VsetI])
done

lemma Int_Vset_subset:
    "[| !!i. Ord(i) ==> a \<inter> Vset(i) \<subseteq> b |] ==> a \<subseteq> b"
apply (rule subset_trans)
apply (rule Int_greatest [OF subset_refl arg_subset_Vset_rank])
apply (blast intro: Ord_rank)
done

subsubsection\<open>Set Up an Environment for Simplification\<close>

lemma rank_Inl: "rank(a) < rank(Inl(a))"
apply (unfold Inl_def)
apply (rule rank_pair2)
done

lemma rank_Inr: "rank(a) < rank(Inr(a))"
apply (unfold Inr_def)
apply (rule rank_pair2)
done

lemmas rank_rls = rank_Inl rank_Inr rank_pair1 rank_pair2

subsubsection\<open>Recursion over Vset Levels!\<close>

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrec: "Vrec(a,H) = H(a, \<lambda>x\<in>Vset(rank(a)). Vrec(x,H))"
apply (unfold Vrec_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs.  NOTE USE OF ==\<close>
lemma def_Vrec:
    "[| !!x. h(x)==Vrec(x,H) |] ==>
     h(a) = H(a, \<lambda>x\<in>Vset(rank(a)). h(x))"
apply simp
apply (rule Vrec)
done

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrecursor:
     "Vrecursor(H,a) = H(\<lambda>x\<in>Vset(rank(a)). Vrecursor(H,x),  a)"
apply (unfold Vrecursor_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs.  NOTE USE OF ==\<close>
lemma def_Vrecursor:
     "h == Vrecursor(H) ==> h(a) = H(\<lambda>x\<in>Vset(rank(a)). h(x),  a)"
apply simp
apply (rule Vrecursor)
done

subsection\<open>The Datatype Universe: @{term "univ(A)"}\<close>

lemma univ_mono: "A<=B ==> univ(A) \<subseteq> univ(B)"
apply (unfold univ_def)
apply (erule Vfrom_mono)
apply (rule subset_refl)
done

lemma Transset_univ: "Transset(A) ==> Transset(univ(A))"
apply (unfold univ_def)
apply (erule Transset_Vfrom)
done

subsubsection\<open>The Set @{term"univ(A)"} as a Limit\<close>

lemma univ_eq_UN: "univ(A) = (\<Union>i\<in>nat. Vfrom(A,i))"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Limit_Vfrom_eq])
done

lemma subset_univ_eq_Int: "c \<subseteq> univ(A) ==> c = (\<Union>i\<in>nat. c \<inter> Vfrom(A,i))"
apply (rule subset_UN_iff_eq [THEN iffD1])
apply (erule univ_eq_UN [THEN subst])
done

lemma univ_Int_Vfrom_subset:
    "[| a \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) \<subseteq> b |]
     ==> a \<subseteq> b"
apply (subst subset_univ_eq_Int, assumption)
apply (rule UN_least, simp)
done

lemma univ_Int_Vfrom_eq:
    "[| a \<subseteq> univ(X);   b \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) = b \<inter> Vfrom(X,i)
     |] ==> a = b"
apply (rule equalityI)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
done

subsection\<open>Closure Properties for @{term "univ(A)"}\<close>

lemma zero_in_univ: "0 \<in> univ(A)"
apply (unfold univ_def)
apply (rule nat_0I [THEN zero_in_Vfrom])
done

lemma zero_subset_univ: "{0} \<subseteq> univ(A)"
by (blast intro: zero_in_univ)

lemma A_subset_univ: "A \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule A_subset_Vfrom)
done

lemmas A_into_univ = A_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Unordered and Ordered Pairs\<close>

lemma singleton_in_univ: "a: univ(A) ==> {a} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: singleton_in_VLimit Limit_nat)
done

lemma doubleton_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> {a,b} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: doubleton_in_VLimit Limit_nat)
done

lemma Pair_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> <a,b> \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Pair_in_VLimit Limit_nat)
done

lemma Union_in_univ:
     "[| X: univ(A);  Transset(A) |] ==> \<Union>(X) \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Union_in_VLimit Limit_nat)
done

lemma product_univ: "univ(A)*univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN product_VLimit])
done

subsubsection\<open>The Natural Numbers\<close>

lemma nat_subset_univ: "nat \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule i_subset_Vfrom)
done

text\<open>n:nat ==> n:univ(A)\<close>
lemmas nat_into_univ = nat_subset_univ [THEN subsetD]

subsubsection\<open>Instances for 1 and 2\<close>

lemma one_in_univ: "1 \<in> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN one_in_VLimit])
done

text\<open>unused!\<close>
lemma two_in_univ: "2 \<in> univ(A)"
by (blast intro: nat_into_univ)

lemma bool_subset_univ: "bool \<subseteq> univ(A)"
apply (unfold bool_def)
apply (blast intro!: zero_in_univ one_in_univ)
done

lemmas bool_into_univ = bool_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Disjoint Union\<close>

lemma Inl_in_univ: "a: univ(A) ==> Inl(a) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inl_in_VLimit [OF _ Limit_nat])
done

lemma Inr_in_univ: "b: univ(A) ==> Inr(b) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inr_in_VLimit [OF _ Limit_nat])
done

lemma sum_univ: "univ(C)+univ(C) \<subseteq> univ(C)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN sum_VLimit])
done

lemmas sum_subset_univ = subset_trans [OF sum_mono sum_univ]

lemma Sigma_subset_univ:
  "[|A \<subseteq> univ(D); \<And>x. x \<in> A \<Longrightarrow> B(x) \<subseteq> univ(D)|] ==> Sigma(A,B) \<subseteq> univ(D)"
apply (simp add: univ_def)
apply (blast intro: Sigma_subset_VLimit del: subsetI)
done

(*Closure under binary union -- use Un_least
  Closure under Collect -- use  Collect_subset [THEN subset_trans]
  Closure under RepFun -- use   RepFun_subset *)

subsection\<open>Finite Branching Closure Properties\<close>

subsubsection\<open>Closure under Finite Powerset\<close>

lemma Fin_Vfrom_lemma:
     "[| b: Fin(Vfrom(A,i));  Limit(i) |] ==> \<exists>j. b \<subseteq> Vfrom(A,j) & j<i"
apply (erule Fin_induct)
apply (blast dest!: Limit_has_0, safe)
apply (erule Limit_VfromE, assumption)
apply (blast intro!: Un_least_lt intro: Vfrom_UnI1 Vfrom_UnI2)
done

lemma Fin_VLimit: "Limit(i) ==> Fin(Vfrom(A,i)) \<subseteq> Vfrom(A,i)"
apply (rule subsetI)
apply (drule Fin_Vfrom_lemma, safe)
apply (rule Vfrom [THEN ssubst])
apply (blast dest!: ltD)
done

lemmas Fin_subset_VLimit = subset_trans [OF Fin_mono Fin_VLimit]

lemma Fin_univ: "Fin(univ(A)) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Fin_VLimit])
done

subsubsection\<open>Closure under Finite Powers: Functions from a Natural Number\<close>

lemma nat_fun_VLimit:
     "[| n: nat;  Limit(i) |] ==> n -> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (erule nat_fun_subset_Fin [THEN subset_trans])
apply (blast del: subsetI
    intro: subset_refl Fin_subset_VLimit Sigma_subset_VLimit nat_subset_VLimit)
done

lemmas nat_fun_subset_VLimit = subset_trans [OF Pi_mono nat_fun_VLimit]

lemma nat_fun_univ: "n: nat ==> n -> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule nat_fun_VLimit [OF _ Limit_nat])
done

subsubsection\<open>Closure under Finite Function Space\<close>

text\<open>General but seldom-used version; normally the domain is fixed\<close>
lemma FiniteFun_VLimit1:
     "Limit(i) ==> Vfrom(A,i) -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule FiniteFun.dom_subset [THEN subset_trans])
apply (blast del: subsetI
             intro: Fin_subset_VLimit Sigma_subset_VLimit subset_refl)
done

lemma FiniteFun_univ1: "univ(A) -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN FiniteFun_VLimit1])
done

text\<open>Version for a fixed domain\<close>
lemma FiniteFun_VLimit:
     "[| W \<subseteq> Vfrom(A,i); Limit(i) |] ==> W -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule subset_trans)
apply (erule FiniteFun_mono [OF _ subset_refl])
apply (erule FiniteFun_VLimit1)
done

lemma FiniteFun_univ:
    "W \<subseteq> univ(A) ==> W -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule FiniteFun_VLimit [OF _ Limit_nat])
done

lemma FiniteFun_in_univ:
     "[| f: W -||> univ(A);  W \<subseteq> univ(A) |] ==> f \<in> univ(A)"
by (erule FiniteFun_univ [THEN subsetD], assumption)

text\<open>Remove \<open>\<subseteq>\<close> from the rule above\<close>
lemmas FiniteFun_in_univ' = FiniteFun_in_univ [OF _ subsetI]

subsection\<open>* For QUniv.  Properties of Vfrom analogous to the "take-lemma" *\<close>

text\<open>Intersecting a*b with Vfrom...\<close>

text\<open>This version says a, b exist one level down, in the smaller set Vfrom(X,i)\<close>
lemma doubleton_in_Vfrom_D:
     "[| {a,b} \<in> Vfrom(X,succ(i));  Transset(X) |]
      ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
by (drule Transset_Vfrom_succ [THEN equalityD1, THEN subsetD, THEN PowD],
    assumption, fast)

text\<open>This weaker version says a, b exist at the same level\<close>
lemmas Vfrom_doubleton_D = Transset_Vfrom [THEN Transset_doubleton_D]

(** Using only the weaker theorem would prove <a,b> \<in> Vfrom(X,i)
      implies a, b \<in> Vfrom(X,i), which is useless for induction.
    Using only the stronger theorem would prove <a,b> \<in> Vfrom(X,succ(succ(i)))
      implies a, b \<in> Vfrom(X,i), leaving the succ(i) case untreated.
    The combination gives a reduction by precisely one level, which is
      most convenient for proofs.
**)

lemma Pair_in_Vfrom_D:
    "[| <a,b> \<in> Vfrom(X,succ(i));  Transset(X) |]
     ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
apply (unfold Pair_def)
apply (blast dest!: doubleton_in_Vfrom_D Vfrom_doubleton_D)
done

lemma product_Int_Vfrom_subset:
     "Transset(X) ==>
      (a*b) \<inter> Vfrom(X, succ(i)) \<subseteq> (a \<inter> Vfrom(X,i)) * (b \<inter> Vfrom(X,i))"
by (blast dest!: Pair_in_Vfrom_D)

ML
\<open>
val rank_ss =
  simpset_of (@{context} addsimps [@{thm VsetI}]
    addsimps @{thms rank_rls} @ (@{thms rank_rls} RLN (2, [@{thm lt_trans}])));
\<close>

end


theory LexerSimp
  imports "Lexer"
begin

section \<open>Lexer including some simplifications\<close>

fun F_RIGHT where
  "F_RIGHT f v = Right (f v)"

fun F_LEFT where
  "F_LEFT f v = Left (f v)"

fun F_ALT where
  "F_ALT f\<^sub>1 f\<^sub>2 (Right v) = Right (f\<^sub>2 v)"
| "F_ALT f\<^sub>1 f\<^sub>2 (Left v) = Left (f\<^sub>1 v)"
| "F_ALT f1 f2 v = v"

fun F_SEQ1 where
  "F_SEQ1 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 Void) (f\<^sub>2 v)"

fun F_SEQ2 where
  "F_SEQ2 f\<^sub>1 f\<^sub>2 v = Seq (f\<^sub>1 v) (f\<^sub>2 Void)"

fun F_SEQ where
  "F_SEQ f\<^sub>1 f\<^sub>2 (Seq v\<^sub>1 v\<^sub>2) = Seq (f\<^sub>1 v\<^sub>1) (f\<^sub>2 v\<^sub>2)"
| "F_SEQ f1 f2 v = v"

fun simp_ALT where
  "simp_ALT (ZERO, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_RIGHT f\<^sub>2)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (ZERO, f\<^sub>2) = (r\<^sub>1, F_LEFT f\<^sub>1)"
| "simp_ALT (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (ALT r\<^sub>1 r\<^sub>2, F_ALT f\<^sub>1 f\<^sub>2)"

fun simp_SEQ where
  "simp_SEQ (ONE, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (r\<^sub>2, F_SEQ1 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (ONE, f\<^sub>2) = (r\<^sub>1, F_SEQ2 f\<^sub>1 f\<^sub>2)"
| "simp_SEQ (ZERO, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (ZERO, undefined)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (ZERO, f\<^sub>2) = (ZERO, undefined)"
| "simp_SEQ (r\<^sub>1, f\<^sub>1) (r\<^sub>2, f\<^sub>2) = (SEQ r\<^sub>1 r\<^sub>2, F_SEQ f\<^sub>1 f\<^sub>2)"

lemma simp_SEQ_simps[simp]:
  "simp_SEQ p1 p2 = (if (fst p1 = ONE) then (fst p2, F_SEQ1 (snd p1) (snd p2))
                    else (if (fst p2 = ONE) then (fst p1, F_SEQ2 (snd p1) (snd p2))
                    else (if (fst p1 = ZERO) then (ZERO, undefined)
                    else (if (fst p2 = ZERO) then (ZERO, undefined)
                    else (SEQ (fst p1) (fst p2), F_SEQ (snd p1) (snd p2))))))"
by (induct p1 p2 rule: simp_SEQ.induct) (auto)

lemma simp_ALT_simps[simp]:
  "simp_ALT p1 p2 = (if (fst p1 = ZERO) then (fst p2, F_RIGHT (snd p2))
                    else (if (fst p2 = ZERO) then (fst p1, F_LEFT (snd p1))
                    else (ALT (fst p1) (fst p2), F_ALT (snd p1) (snd p2))))"
by (induct p1 p2 rule: simp_ALT.induct) (auto)

fun
  simp :: "rexp \<Rightarrow> rexp * (val \<Rightarrow> val)"
where
  "simp (ALT r1 r2) = simp_ALT (simp r1) (simp r2)"
| "simp (SEQ r1 r2) = simp_SEQ (simp r1) (simp r2)"
| "simp r = (r, id)"

fun
  slexer :: "rexp \<Rightarrow> string \<Rightarrow> val option"
where
  "slexer r [] = (if nullable r then Some(mkeps r) else None)"
| "slexer r (c#s) = (let (rs, fr) = simp (der c r) in
                         (case (slexer rs s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c (fr v))))"

lemma slexer_better_simp:
  "slexer r (c#s) = (case (slexer (fst (simp (der c r))) s) of
                            None \<Rightarrow> None
                          | Some(v) \<Rightarrow> Some(injval r c ((snd (simp (der c r))) v)))"
by (auto split: prod.split option.split)

lemma L_fst_simp:
  shows "L(r) = L(fst (simp r))"
by (induct r) (auto)

lemma Posix_simp:
  assumes "s \<in> (fst (simp r)) \<rightarrow> v"
  shows "s \<in> r \<rightarrow> ((snd (simp r)) v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case (ALT r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (ALT r1 r2)) \<rightarrow> v" by fact
  consider (ZERO_ZERO) "fst (simp r1) = ZERO" "fst (simp r2) = ZERO"
         | (ZERO_NZERO) "fst (simp r1) = ZERO" "fst (simp r2) \<noteq> ZERO"
         | (NZERO_ZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) = ZERO"
         | (NZERO_NZERO) "fst (simp r1) \<noteq> ZERO" "fst (simp r2) \<noteq> ZERO" by auto
  then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
    proof(cases)
      case (ZERO_ZERO)
      with as have "s \<in> ZERO \<rightarrow> v" by simp
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" by (rule Posix_elims(1))
    next
      case (ZERO_NZERO)
      with as have "s \<in> fst (simp r2) \<rightarrow> v" by simp
      with IH2 have "s \<in> r2 \<rightarrow> snd (simp r2) v" by simp
      moreover
      from ZERO_NZERO have "fst (simp r1) = ZERO" by simp
      then have "L (fst (simp r1)) = {}" by simp
      then have "L r1 = {}" using L_fst_simp by simp
      then have "s \<notin> L r1" by simp
      ultimately have "s \<in> ALT r1 r2 \<rightarrow> Right (snd (simp r2) v)" by (rule Posix_ALT2)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      using ZERO_NZERO by simp
    next
      case (NZERO_ZERO)
      with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
      with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      then have "s \<in> ALT r1 r2 \<rightarrow> Left (snd (simp r1) v)" by (rule Posix_ALT1)
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_ZERO by simp
    next
      case (NZERO_NZERO)
      with as have "s \<in> ALT (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then consider (Left) v1 where "v = Left v1" "s \<in> (fst (simp r1)) \<rightarrow> v1"
                  | (Right) v2 where "v = Right v2" "s \<in> (fst (simp r2)) \<rightarrow> v2" "s \<notin> L (fst (simp r1))"
                  by (erule_tac Posix_elims(4))
      then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v"
      proof(cases)
        case (Left)
        then have "v = Left v1" "s \<in> r1 \<rightarrow> (snd (simp r1) v1)" using IH1 by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT1)
      next
        case (Right)
        then have "v = Right v2" "s \<in> r2 \<rightarrow> (snd (simp r2) v2)" "s \<notin> L r1" using IH2 L_fst_simp by simp_all
        then show "s \<in> ALT r1 r2 \<rightarrow> snd (simp (ALT r1 r2)) v" using NZERO_NZERO
          by (simp_all add: Posix_ALT2)
      qed
    qed
next
  case (SEQ r1 r2 s v)
  have IH1: "\<And>s v. s \<in> fst (simp r1) \<rightarrow> v \<Longrightarrow> s \<in> r1 \<rightarrow> snd (simp r1) v" by fact
  have IH2: "\<And>s v. s \<in> fst (simp r2) \<rightarrow> v \<Longrightarrow> s \<in> r2 \<rightarrow> snd (simp r2) v" by fact
  have as: "s \<in> fst (simp (SEQ r1 r2)) \<rightarrow> v" by fact
  consider (ONE_ONE) "fst (simp r1) = ONE" "fst (simp r2) = ONE"
         | (ONE_NONE) "fst (simp r1) = ONE" "fst (simp r2) \<noteq> ONE"
         | (NONE_ONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) = ONE"
         | (NONE_NONE) "fst (simp r1) \<noteq> ONE" "fst (simp r2) \<noteq> ONE"
         by auto
  then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v"
  proof(cases)
      case (ONE_ONE)
      with as have b: "s \<in> ONE \<rightarrow> v" by simp
      from b have "s \<in> r1 \<rightarrow> snd (simp r1) v" using IH1 ONE_ONE by simp
      moreover
      from b have c: "s = []" "v = Void" using Posix_elims(2) by auto
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r2) \<rightarrow> Void" using ONE_ONE by simp
      then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "([] @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) Void)"
        using Posix_SEQ by blast
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using c ONE_ONE by simp
    next
      case (ONE_NONE)
      with as have b: "s \<in> fst (simp r2) \<rightarrow> v" by simp
      from b have "s \<in> r2 \<rightarrow> snd (simp r2) v" using IH2 ONE_NONE by simp
      moreover
      have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
      then have "[] \<in> fst (simp r1) \<rightarrow> Void" using ONE_NONE by simp
      then have "[] \<in> r1 \<rightarrow> snd (simp r1) Void" using IH1 by simp
      moreover
      from ONE_NONE(1) have "L (fst (simp r1)) = {[]}" by simp
      then have "L r1 = {[]}" by (simp add: L_fst_simp[symmetric])
      ultimately have "([] @ s) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) Void) (snd (simp r2) v)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using ONE_NONE by simp
    next
      case (NONE_ONE)
        with as have "s \<in> fst (simp r1) \<rightarrow> v" by simp
        with IH1 have "s \<in> r1 \<rightarrow> snd (simp r1) v" by simp
      moreover
        have "[] \<in> ONE \<rightarrow> Void" by (simp add: Posix_ONE)
        then have "[] \<in> fst (simp r2) \<rightarrow> Void" using NONE_ONE by simp
        then have "[] \<in> r2 \<rightarrow> snd (simp r2) Void" using IH2 by simp
      ultimately have "(s @ []) \<in> SEQ r1 r2 \<rightarrow> Seq (snd (simp r1) v) (snd (simp r2) Void)"
        by(rule_tac Posix_SEQ) auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using NONE_ONE by simp
    next
      case (NONE_NONE)
      from as have 00: "fst (simp r1) \<noteq> ZERO" "fst (simp r2) \<noteq> ZERO"
        apply(auto)
        apply(smt Posix_elims(1) fst_conv)
        by (smt NONE_NONE(2) Posix_elims(1) fstI)
      with NONE_NONE as have "s \<in> SEQ (fst (simp r1)) (fst (simp r2)) \<rightarrow> v" by simp
      then obtain s1 s2 v1 v2 where eqs: "s = s1 @ s2" "v = Seq v1 v2"
                     "s1 \<in> (fst (simp r1)) \<rightarrow> v1" "s2 \<in> (fst (simp r2)) \<rightarrow> v2"
                     "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)"
                     by (erule_tac Posix_elims(5)) (auto simp add: L_fst_simp[symmetric])
      then have "s1 \<in> r1 \<rightarrow> (snd (simp r1) v1)" "s2 \<in> r2 \<rightarrow> (snd (simp r2) v2)"
        using IH1 IH2 by auto
      then show "s \<in> SEQ r1 r2 \<rightarrow> snd (simp (SEQ r1 r2)) v" using eqs NONE_NONE 00
        by(auto intro: Posix_SEQ)
    qed
qed (simp_all)

lemma slexer_correctness:
  shows "slexer r s = lexer r s"
proof(induct s arbitrary: r)
  case Nil
  show "slexer r [] = lexer r []" by simp
next
  case (Cons c s r)
  have IH: "\<And>r. slexer r s = lexer r s" by fact
  show "slexer r (c # s) = lexer r (c # s)"
   proof (cases "s \<in> L (der c r)")
     case True
       assume a1: "s \<in> L (der c r)"
       then obtain v1 where a2: "lexer (der c r) s = Some v1" "s \<in> der c r \<rightarrow> v1"
         using lexer_correct_Some by auto
       from a1 have "s \<in> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then obtain v2 where a3: "lexer (fst (simp (der c r))) s = Some v2" "s \<in> (fst (simp (der c r))) \<rightarrow> v2"
          using lexer_correct_Some by auto
       then have a4: "slexer (fst (simp (der c r))) s = Some v2" using IH by simp
       from a3(2) have "s \<in> der c r \<rightarrow> (snd (simp (der c r))) v2" using Posix_simp by simp
       with a2(2) have "v1 = (snd (simp (der c r))) v2" using Posix_determ by simp
       with a2(1) a4 show "slexer r (c # s) = lexer r (c # s)" by (auto split: prod.split)
     next
     case False
       assume b1: "s \<notin> L (der c r)"
       then have "lexer (der c r) s = None" using lexer_correct_None by simp
       moreover
       from b1 have "s \<notin> L (fst (simp (der c r)))" using L_fst_simp[symmetric] by simp
       then have "lexer (fst (simp (der c r))) s = None" using lexer_correct_None by simp
       then have "slexer (fst (simp (der c r))) s = None" using IH by simp
       ultimately show "slexer r (c # s) = lexer r (c # s)"
         by (simp del: slexer.simps add: slexer_better_simp)
   qed
 qed

unused_thms

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Simulations.thy
    Author:     Olaf Müller
*)

section {* Simulations in HOLCF/IOA *}

theory Simulations
imports RefCorrectness
begin

default_sort type

definition
  is_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_simulation R C A =
   ((!s:starts_of C. R``{s} Int starts_of A ~= {}) &
   (!s s' t a. reachable C s &
               s -a--C-> t   &
               (s,s') : R
               --> (? t' ex. (t,t'):R & move A ex s' a t')))"

definition
  is_backward_simulation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_backward_simulation R C A =
   ((!s:starts_of C. R``{s} <= starts_of A) &
   (!s t t' a. reachable C s &
               s -a--C-> t   &
               (t,t') : R
               --> (? ex s'. (s,s'):R & move A ex s' a t')))"

definition
  is_forw_back_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_forw_back_simulation R C A =
   ((!s:starts_of C. ? S'. (s,S'):R & S'<= starts_of A) &
   (!s S' t a. reachable C s &
               s -a--C-> t   &
               (s,S') : R
               --> (? T'. (t,T'):R & (! t':T'. ? s':S'. ? ex. move A ex s' a t'))))"

definition
  is_back_forw_simulation :: "[('s1 * 's2 set)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_back_forw_simulation R C A =
   ((!s:starts_of C. ! S'. (s,S'):R --> S' Int starts_of A ~={}) &
   (!s t T' a. reachable C s &
               s -a--C-> t   &
               (t,T') : R
               --> (? S'. (s,S'):R & (! s':S'. ? t':T'. ? ex. move A ex s' a t'))))"

definition
  is_history_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_history_relation R C A = (is_simulation R C A &
                                is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"

definition
  is_prophecy_relation :: "[('s1 * 's2)set,('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_prophecy_relation R C A = (is_backward_simulation R C A &
                                 is_ref_map (%x.(@y. (x,y):(R^-1))) A C)"

lemma set_non_empty: "(A~={}) = (? x. x:A)"
apply auto
done

lemma Int_non_empty: "(A Int B ~= {}) = (? x. x: A & x:B)"
apply (simp add: set_non_empty)
done

lemma Sim_start_convert:
"(R``{x} Int S ~= {}) = (? y. (x,y):R & y:S)"
apply (unfold Image_def)
apply (simp add: Int_non_empty)
done

declare Sim_start_convert [simp]

lemma ref_map_is_simulation:
"!! f. is_ref_map f C A ==> is_simulation {p. (snd p) = f (fst p)} C A"

apply (unfold is_ref_map_def is_simulation_def)
apply simp
done

end