section "Stack Machine and Compilation"

theory ASM imports AExp begin

subsection "Stack Machine"

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

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

text \<open>Execution of a single instruction is straightforward,
  except for the special case if one tries to execute ADD with
  a stack of less than two elements.
  We leave this case explicitly undefined, where undefined
  is just an ordinary HOL term, but without any additional theorems on it.
  That is, @{term "undefined::'a"} may be every value of type @{typ 'a}, but
  you don't know which one.
\<close>
fun exec1  :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
  "exec1 (LOADI n) _ stk  =  n # stk"
| "exec1 (LOAD x) s stk  =  s(x) # stk"
| "exec1 ADD _ (a#b#stk) = (a+b)#stk"
| "exec1 ADD _ _ = undefined"

text \<open>Executing a list of statements is straightforward\<close>
text_raw{*\snip{ASMexecdef}{1}{2}{% *}
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"
text_raw{*}%endsnip*}

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

lemma exec_append[simp]:
  "exec (is1@is2) s stk = exec is2 s (exec is1 s stk)"
apply(induction is1 arbitrary: stk)
apply (auto)
done

subsection "Compilation"

text \<open>Compilation of expressions to stack-machines is particularly easy:
  Each expression compiles to a program that effectively pushes its result
  to the top of stack.
\<close>
text_raw{*\snip{ASMcompdef}{0}{2}{% *}
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw{*}%endsnip*}

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

text \<open>This theorem intuitively states: When running the compiled program for
  \<open>a\<close>, it will push the value of \<open>a\<close> on the stack, not changing anything on
  the original stack.
\<close>
theorem exec_comp: "exec (comp a) s stk = aval a s # stk"
apply(induction a arbitrary: stk)
apply (auto)
done

text \<open>Special case for starting with an empty stack.
  Note, this theorem cannot be proved by induction directly, but needs
  to be generalized to @{thm exec_comp} first.
\<close>
theorem exec_comp': "exec (comp a) s [] = [aval a s]"
  by (simp add: exec_comp)

end


section \<open>Carter-Wegman Hash Family\label{sec:carter_wegman}\<close>

theory Carter_Wegman_Hash_Family
  imports
    Interpolation_Polynomials_HOL_Algebra.Interpolation_Polynomial_Cardinalities
    Preliminary_Results
begin

text \<open>The Carter-Wegman hash family is a generic method to obtain
$k$-universal hash families for arbitrary $k$. (There are faster solutions, such as tabulation
hashing, which are limited to a specific $k$. See for example \<^cite>\<open>"thorup2010"\<close>.)

The construction was described by Wegman and Carter~\<^cite>\<open>"wegman1981"\<close>, it is a hash
family between the elements of a finite field and works by choosing randomly a polynomial
over the field with degree less than $k$. The hash function is the evaluation of a such a
polynomial.

Using the property that the fraction of polynomials interpolating a given set of $s \leq k$
points is @{term "1/(card (carrier R)^s)"}, which is shown in
\<^cite>\<open>"Interpolation_Polynomials_HOL_Algebra-AFP"\<close>, it is possible to obtain both that
the hash functions are $k$-wise independent and uniformly distributed.

In the following two locales are introduced, the main reason for both is to make the statements
of the theorems and proofs more concise. The first locale @{term "poly_hash_family"} fixes a finite
ring $R$ and the probability space of the polynomials of degree less than $k$. Because the ring is
not a field, the family is not yet $k$-universal, but it is still possible to state a few results such
as the fact that the range of the hash function is a subset of the carrier of the ring.

The second locale @{term "carter_wegman_hash_family"} is an extension of the former with the
assumption that $R$ is a field with which the $k$-universality follows.

The reason for using two separate locales is to support use cases, where the ring is only probably
a field. For example if it is the set of integers modulo an approximate prime, in such a situation a
subset of the properties of an algorithm using approximate primes would need to be verified
even if $R$ is only a ring.\<close>

definition (in ring) "hash x \<omega> = eval \<omega> x"

locale poly_hash_family = ring +
  fixes k :: nat
  assumes finite_carrier[simp]: "finite (carrier R)"
  assumes k_ge_0: "k > 0"
begin

definition space where "space = bounded_degree_polynomials R k"
definition M where "M = measure_pmf (pmf_of_set space)"

lemma finite_space[simp]:"finite space"
    unfolding space_def using fin_degree_bounded finite_carrier by simp

lemma non_empty_bounded_degree_polynomials[simp]:"space \<noteq> {}"
    unfolding space_def using non_empty_bounded_degree_polynomials by simp

text \<open>This is to add @{thm [source] carrier_not_empty} to the simp set in the context of
@{locale "poly_hash_family"}:\<close>

lemma non_empty_carrier[simp]: "carrier R \<noteq> {}"
  by (simp add:carrier_not_empty)

sublocale prob_space "M"
  by (simp add:M_def prob_space_measure_pmf)

lemma hash_range[simp]:
  assumes "\<omega> \<in> space"
  assumes "x \<in> carrier R"
  shows "hash x \<omega> \<in> carrier R"
  using assms unfolding hash_def space_def bounded_degree_polynomials_def
  by (simp, metis eval_in_carrier polynomial_incl univ_poly_carrier)

lemma  hash_range_2:
  assumes "\<omega> \<in> space"
  shows "(\<lambda>x. hash x \<omega>) ` carrier R \<subseteq> carrier R"
  using hash_range assms by auto

lemma integrable_M[simp]:
  fixes f :: "'a list \<Rightarrow> 'c::{banach, second_countable_topology}"
  shows "integrable M f"
    unfolding M_def
    by (rule integrable_measure_pmf_finite, simp)

end

locale carter_wegman_hash_family = poly_hash_family +
  assumes field_R: "field R"
begin
sublocale field
  using field_R by simp

abbreviation "field_size \<equiv> card (carrier R)"

lemma poly_cards:
  assumes "K \<subseteq> carrier R"
  assumes "card K \<le> k"
  assumes "y ` K \<subseteq> (carrier R)"
  shows
    "card {\<omega> \<in> space. (\<forall>k \<in> K. eval \<omega> k = y k)} = field_size^(k-card K)"
  unfolding space_def
  using interpolating_polynomials_card[where n="k-card K" and K="K"] assms
  using finite_carrier finite_subset by fastforce

lemma poly_cards_single:
  assumes "x \<in> carrier R"
  assumes "y \<in> carrier R"
  shows "card {\<omega> \<in> space. eval \<omega> x = y} = field_size^(k-1)"
  using poly_cards[where K="{x}" and y="\<lambda>_. y", simplified] assms k_ge_0 by simp

lemma hash_prob:
  assumes "K \<subseteq> carrier R"
  assumes "card K \<le> k"
  assumes "y ` K \<subseteq> carrier R"
  shows
    "prob {\<omega>. (\<forall>x \<in> K. hash x \<omega> = y x)} = 1/(real field_size)^card K"
proof -
  have "\<zero> \<in> carrier R" by simp

  hence a:"field_size > 0"
    using finite_carrier card_gt_0_iff by blast

  have b:"real (card {\<omega> \<in> space. \<forall>x\<in>K. eval \<omega> x = y x}) / real (card space) =
    1 / real field_size ^ card K"
    using a assms(2)
    apply (simp add: frac_eq_eq poly_cards[OF assms(1,2,3)] power_add[symmetric])
    by (simp add:space_def bounded_degree_polynomials_card)

  show ?thesis
    unfolding M_def
    by (simp add:hash_def measure_pmf_of_set Int_def b)
qed

lemma prob_single:
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "prob {\<omega>. hash x \<omega> = y} = 1/(real field_size)"
  using hash_prob[where K="{x}"] assms finite_carrier k_ge_0 by simp

lemma prob_range:
  assumes [simp]:"x \<in> carrier R"
  shows "prob {\<omega>. hash x \<omega> \<in> A} = card (A \<inter> carrier R) / field_size"
proof -
  have "prob {\<omega>. hash x \<omega> \<in> A} = prob (\<Union>a \<in> A \<inter> carrier R. {\<omega>. hash x \<omega> = a})"
    by (rule measure_pmf_eq, auto simp:M_def)
  also have "... = (\<Sum> a \<in> (A \<inter> carrier R). prob {\<omega>. hash x \<omega> = a})"
    by (rule measure_finite_Union, auto simp:M_def disjoint_family_on_def)
  also have "... = (\<Sum> a \<in> (A \<inter> carrier R). 1/(real field_size))"
    by (rule sum.cong, auto simp:prob_single)
  also have "... = card (A \<inter> carrier R) / field_size"
    by simp
  finally show ?thesis by simp
qed

lemma indep:
  assumes "J \<subseteq> carrier R"
  assumes "card J \<le> k"
  shows "indep_vars (\<lambda>_. discrete) hash J"
proof -
  have "\<zero> \<in> carrier R" by simp
  hence card_R_ge_0:"field_size > 0"
    using card_gt_0_iff finite_carrier by blast

  have fin_J: "finite J"
    using finite_carrier assms(1) finite_subset by blast

  show ?thesis
  proof (rule indep_vars_pmf[OF M_def])
    fix a
    fix J'
    assume a: "J' \<subseteq> J" "finite J'"
    have card_J': "card J' \<le> k"
      by (metis card_mono order_trans a(1) assms(2) fin_J)
    have J'_in_carr: "J' \<subseteq> carrier R" by (metis order_trans a(1) assms(1))

    show "prob {\<omega>. \<forall>x\<in>J'. hash x \<omega> = a x} = (\<Prod>x\<in>J'. prob  {\<omega>. hash x \<omega> = a x})"
    proof (cases "a ` J' \<subseteq> carrier R")
      case True
      have a_carr: "\<And>x. x \<in> J' \<Longrightarrow> a x \<in> carrier R"  using True by force
      have "prob {\<omega>. \<forall>x\<in>J'. hash x \<omega> = a x} =
        real (card {\<omega> \<in> space. \<forall>x\<in>J'. eval \<omega> x = a x}) / real (card space)"
        by (simp add:M_def measure_pmf_of_set Int_def hash_def)
      also have "... = real (field_size ^ (k - card J')) / real (card space)"
        using True by (simp add: poly_cards[OF J'_in_carr card_J'])
      also have
        "... = real field_size ^ (k - card J') / real field_size ^ k"
        by (simp add:space_def bounded_degree_polynomials_card)
      also have
        "... = real field_size ^ ((k - 1) * card J') / real field_size ^ (k * card J')"
        using card_J' by (simp add:power_add[symmetric] power_mult[symmetric]
            diff_mult_distrib frac_eq_eq add.commute)
      also have
        "... = (real field_size ^ (k - 1)) ^ card J' / (real field_size ^ k) ^ card J'"
        by (simp add:power_add power_mult)
      also have
        "... =  (\<Prod>x\<in>J'. real (card {\<omega> \<in> space. eval \<omega> x = a x}) / real (card space))"
        using a_carr poly_cards_single[OF subsetD[OF J'_in_carr]]
        by (simp add:space_def bounded_degree_polynomials_card power_divide)
      also have "... = (\<Prod>x\<in>J'. prob {\<omega>. hash x \<omega> = a x})"
        by (simp add:measure_pmf_of_set M_def Int_def hash_def)
      finally show ?thesis by simp
    next
      case False
      then obtain j where j_def: "j \<in> J'" "a j \<notin> carrier R" by blast
      have "{\<omega> \<in> space. hash j \<omega> = a j} \<subseteq> {\<omega> \<in> space. hash j \<omega> \<notin> carrier R}"
        by (rule subsetI, simp add:j_def)
      also have "... \<subseteq> {}" using j_def(1) J'_in_carr hash_range by blast
      finally have b:"{\<omega> \<in> space. hash j \<omega> = a j} = {}" by simp
      hence "real (card ({\<omega> \<in> space. hash j \<omega> = a j})) = 0" by simp
      hence "(\<Prod>x\<in>J'. real (card {\<omega> \<in> space. hash x \<omega> = a x})) = 0"
        using a(2) prod_zero[OF a(2)] j_def(1) by auto
      moreover have
        "{\<omega> \<in> space. \<forall>x\<in>J'. hash x \<omega> = a x} \<subseteq> {\<omega> \<in> space. hash j \<omega> = a j}"
        using j_def by blast
      hence "{\<omega> \<in> space. \<forall>x\<in>J'. hash x \<omega> = a x} = {}" using b by blast
      ultimately show ?thesis
        by (simp add:measure_pmf_of_set M_def Int_def prod_dividef)
    qed
  qed
qed

lemma k_wise_indep:
  "k_wise_indep_vars k (\<lambda>_. discrete) hash (carrier R)"
  unfolding k_wise_indep_vars_def using indep by simp

lemma inj_if_degree_1:
  assumes "\<omega> \<in> space"
  assumes "degree \<omega> = 1"
  shows "inj_on (\<lambda>x. hash x \<omega>) (carrier R)"
  using assms eval_inj_if_degree_1
  by (simp add:M_def space_def bounded_degree_polynomials_def hash_def)

lemma uniform:
  assumes "i \<in> carrier R"
  shows "uniform_on (hash i) (carrier R)"
proof -
  have a:
    "\<And>a. prob {\<omega>. hash i \<omega> \<in> {a}} = indicat_real (carrier R) a / real field_size"
    by (subst prob_range[OF assms], simp add:indicator_def)
  show ?thesis
    by (rule uniform_onI, use a M_def in auto)
qed

text \<open>This the main result of this section - the Carter-Wegman hash family is $k$-universal.\<close>

theorem k_universal:
  "k_universal k hash (carrier R) (carrier R)"
  using uniform k_wise_indep by (simp add:k_universal_def)

end

lemma poly_hash_familyI:
  assumes "ring R"
  assumes "finite (carrier R)"
  assumes "0 < k"
  shows "poly_hash_family R k"
  using assms
  by (simp add:poly_hash_family_def poly_hash_family_axioms_def)

lemma carter_wegman_hash_familyI:
  assumes "field F"
  assumes "finite (carrier F)"
  assumes "0 < k"
  shows "carter_wegman_hash_family F k"
  using assms field.is_ring[OF assms(1)] poly_hash_familyI
  by (simp add:carter_wegman_hash_family_def carter_wegman_hash_family_axioms_def)

lemma hash_k_wise_indep:
  assumes "field F \<and> finite (carrier F)"
  assumes "1 \<le> n"
  shows
    "prob_space.k_wise_indep_vars (pmf_of_set (bounded_degree_polynomials F n)) n
    (\<lambda>_. pmf_of_set (carrier F)) (ring.hash F) (carrier F)"
proof -
  interpret carter_wegman_hash_family "F" "n"
    using assms carter_wegman_hash_familyI by force
  have "k_wise_indep_vars n (\<lambda>_. pmf_of_set (carrier F)) hash (carrier F)"
    by (rule k_wise_indep_vars_compose[OF k_wise_indep], simp)
  thus ?thesis
    by (simp add:M_def space_def)
qed

lemma hash_prob_single:
  assumes "field F \<and> finite (carrier F)"
  assumes "x \<in> carrier F"
  assumes "1 \<le> n"
  assumes "y \<in> carrier F"
  shows
    "\<P>(\<omega> in pmf_of_set (bounded_degree_polynomials F n). ring.hash F x \<omega> = y)
      = 1/(real (card (carrier F)))"
proof -
  interpret carter_wegman_hash_family "F" "n"
    using assms carter_wegman_hash_familyI by force
  show ?thesis
    using prob_single[OF assms(2,4)] by (simp add:M_def space_def)
qed

end


theory CadeInsa
  imports Main "Relation_Algebra/Relation_Algebra" "Relation_Algebra/Relation_Algebra_Functions"  "Relation_Algebra/Relation_Algebra_Models"

begin

context relation_algebra
begin

(* definitions/predicates *)
definition symmetric :: "'a \<Rightarrow> bool"
  where "symmetric x \<equiv> x=x\<^sup>\<smile>"

definition reflexive :: "'a \<Rightarrow> bool"
  where "reflexive x \<equiv> 1' \<le> x"

definition irreflexive :: "'a \<Rightarrow> bool"
  where "irreflexive x \<equiv> x \<le> -(1')"

(* the used libraries use different notation. We adapted the notions to fit our paper
 in case the definitions are slightly different, we show equivalence *)
definition univalent :: "'a \<Rightarrow> bool"
  where "univalent x \<equiv> x\<^sup>\<smile>;x \<le> 1'"
lemma "univalent x = is_p_fun x"
  by(simp add: univalent_def is_p_fun_def)

definition total :: "'a \<Rightarrow> bool"
  where "total x \<equiv> x;1=1"
lemma total_is_total: "total x = is_total x"
  by (simp add: total_def total_def_var_1)

definition is_function :: "'a \<Rightarrow> bool"
  where "is_function  x \<equiv> univalent x \<and> total x"
lemma "is_function x = is_map x"
  by (simp add: is_function_def is_map_def is_p_fun_def total_def_var_1 total_def univalent_def)

definition injective :: "'a \<Rightarrow> bool"
  where "injective x \<equiv> univalent (x\<^sup>\<smile>)"
lemma "injective x = is_inj x"
  unfolding injective_def is_inj_def univalent_def
  by(simp)

definition surjective :: "'a \<Rightarrow> bool"
  where "surjective x \<equiv> total (x\<^sup>\<smile>)"
lemma "surjective x = is_sur x"
  by(simp add: surjective_def total_is_total is_total_def is_sur_def)

definition coloringProperty
  where "coloringProperty x e \<equiv> x;x\<^sup>\<smile> \<le> -e"

lemmas unfold_defs = symmetric_def reflexive_def irreflexive_def univalent_def total_def is_function_def injective_def surjective_def
                      coloringProperty_def is_p_fun_def is_point_def is_vector_def is_inj_def
(* end definitions *)

(* logical equivalences in the model of relations *)
lemma rel_subset:
  "(\<forall> x y. (x,y) \<in> r \<longrightarrow> (x,y) \<in> s) = (r \<subseteq> s)"
by(auto)

lemma rel_reflexive:
  "(\<forall> x. (x,x) \<in> r) = (Id \<subseteq> r)"
by(simp add: subset_iff)

lemma rel_irreflexive:
  "(\<forall> x y. (x,y) \<in> r \<longrightarrow> x \<noteq> y) = (r \<subseteq> -Id)"
by(auto)

lemma rel_transitive:
  "(\<forall> x y z. ((x,y) \<in> r \<and> (y,z) \<in> r) \<longrightarrow> (x,z) \<in> r) = (r O r \<subseteq> r)"
by(auto)

lemma rel_symmetric:
  "(\<forall> x y. (x,y) \<in> r \<longrightarrow> (y,x) \<in> r) = (r =  r\<inverse>)"
by(auto simp add: subset_iff)

lemma rel_antisymmetric:
  "(\<forall> x y. (x,y) \<in> r \<and> (y,x) \<in> r \<longrightarrow> x=y) = (r \<inter> r\<inverse> \<subseteq> Id)"
by(simp add: subset_iff)

lemma rel_asymmetric:
  "(\<forall> x y. (x,y) \<in> r \<longrightarrow> (y,x) \<notin> r) = (r \<inter> r\<inverse> = {})"
by(auto simp add: subset_iff)

lemma rel_total:
  "(\<forall> x y. (x,y) \<in> r \<or> (y,x) \<in> r) = (UNIV = r \<union> r\<inverse>)"
by(auto simp add: subset_iff)
(*end logical equivalences in the model of relations *)

(* main lemmata of the paper *)
lemma lemma31:
 "univalent 0 \<and> coloringProperty 0 e"
 by(simp add: univalent_def coloringProperty_def)

lemma lemma32:
  assumes "univalent x"
      and "is_point p"
      and "is_point q"
      and "p \<le> -(x;1)"
      shows "univalent(x + p;q\<^sup>\<smile>)"

proof (simp add: unfold_defs distrib_left distrib_right, safe)
(* after unfolding sledgehammer is impressive *)

  from assms(1) show "x\<^sup>\<smile> ; x \<le> 1'"
    by(unfold univalent_def)

  from assms(4) show goal2: "q ; p\<^sup>\<smile> ; x \<le> 1'"
    by (metis compl_bot_eq compl_le_swap1 conv_galois_1 conv_galois_2 conv_one double_compl inf.boundedE inf_compl_bot mult_assoc)

  from goal2 show "x\<^sup>\<smile> ; (p ; q\<^sup>\<smile>) \<le> 1'"
    by (metis conv_contrav conv_invol conv_iso mult_oner)

  from assms(3) and assms(4) show "q;p\<^sup>\<smile>;(p;q\<^sup>\<smile>)  \<le> 1'"
    unfolding unfold_defs
    by (metis dual_order.trans mult_isol mult_isor top_greatest mult_assoc)
qed

lemma lemma33:
  assumes "symmetric e"
      and "irreflexive e"
      and "is_point p"
      and "is_point q"
      and "coloringProperty x e"
      and "q \<le> -(x\<^sup>\<smile> ; e ; p)"
    shows "coloringProperty (x + p;q\<^sup>\<smile>) e"
proof (simp add: unfold_defs distrib_left distrib_right, safe)

  show goal1: "x ; x\<^sup>\<smile> \<le> -e" by (metis assms(5) coloringProperty_def)

  from assms(1) and assms(6)
  show goal3: "p ; q\<^sup>\<smile> ; x\<^sup>\<smile> \<le> - e"
    by (metis symmetric_def comp_anti conv_galois_1 conv_galois_2 double_compl mult_assoc)

  from goal3 show "x ; (q ; p\<^sup>\<smile>) \<le> - e"
    by (metis assms(6) conv_galois_1 conv_galois_2 conv_invol double_compl)

  from assms(2) and assms(3) and assms(4) show "p ; q\<^sup>\<smile> ; (q ; p\<^sup>\<smile>) \<le> -e"
    unfolding unfold_defs
    by (metis dual_order.trans mult_isol mult_isor top_greatest mult_assoc compl_le_swap1)
qed

lemma lemma21:
  "\<lbrakk> is_point p ; is_point q ; (\<forall> x. (x\<noteq>0 \<longrightarrow> 1 ; x ; 1 = 1)) \<rbrakk> \<Longrightarrow> p\<noteq>0 \<and> p;q\<^sup>\<smile> \<noteq> 0"
unfolding unfold_defs
by (metis mult_assoc sur_def_var1 sur_total total_1)

lemma lemma34:
  assumes "is_point p"
      and "is_point q"
      and "x;1\<noteq>1"
      and "p \<le> -(x;1)"
      and "\<forall> x. (x\<noteq>0 \<longrightarrow> 1 ; x ; 1 = 1)"
      shows "x \<le> x + p;q\<^sup>\<smile> \<and> x \<noteq> x + p;q\<^sup>\<smile> "
proof
  show "x \<le> x + p;q\<^sup>\<smile>" by simp

  from assms have temp: "p;q\<^sup>\<smile> \<le> -x"
    unfolding is_point_def is_vector_def is_inj_def
    by (metis comp_anti comp_res_aux compl_bot_eq conv_galois_1 conv_galois_2 double_compl le_iff_inf order_trans top_greatest)
  {
    assume "x = x + p;q\<^sup>\<smile>" (* proof by contradiction *)
     with assms(1) and assms(2) and assms(5) have "False"
     by (metis aux6 inf.orderE inf_compl_bot temp lemma21)
  }
  then show "x \<noteq> x + p;q\<^sup>\<smile>" by blast
qed

end
end


(*  Title:      HOL/Power.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge
*)

section {* Exponentiation *}

theory Power
imports Num Equiv_Relations
begin

subsection {* Powers for Arbitrary Monoids *}

class power = one + times
begin

primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^" 80) where
    power_0: "a ^ 0 = 1"
  | power_Suc: "a ^ Suc n = a * a ^ n"

notation (latex output)
  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)

notation (HTML output)
  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)

text {* Special syntax for squares. *}

abbreviation (xsymbols)
  power2 :: "'a \<Rightarrow> 'a"  ("(_\<^sup>2)" [1000] 999) where
  "x\<^sup>2 \<equiv> x ^ 2"

notation (latex output)
  power2  ("(_\<^sup>2)" [1000] 999)

notation (HTML output)
  power2  ("(_\<^sup>2)" [1000] 999)

end

context monoid_mult
begin

subclass power .

lemma power_one [simp]:
  "1 ^ n = 1"
  by (induct n) simp_all

lemma power_one_right [simp]:
  "a ^ 1 = a"
  by simp

lemma power_commutes:
  "a ^ n * a = a * a ^ n"
  by (induct n) (simp_all add: mult.assoc)

lemma power_Suc2:
  "a ^ Suc n = a ^ n * a"
  by (simp add: power_commutes)

lemma power_add:
  "a ^ (m + n) = a ^ m * a ^ n"
  by (induct m) (simp_all add: algebra_simps)

lemma power_mult:
  "a ^ (m * n) = (a ^ m) ^ n"
  by (induct n) (simp_all add: power_add)

lemma power2_eq_square: "a\<^sup>2 = a * a"
  by (simp add: numeral_2_eq_2)

lemma power3_eq_cube: "a ^ 3 = a * a * a"
  by (simp add: numeral_3_eq_3 mult.assoc)

lemma power_even_eq:
  "a ^ (2 * n) = (a ^ n)\<^sup>2"
  by (subst mult.commute) (simp add: power_mult)

lemma power_odd_eq:
  "a ^ Suc (2*n) = a * (a ^ n)\<^sup>2"
  by (simp add: power_even_eq)

lemma power_numeral_even:
  "z ^ numeral (Num.Bit0 w) = (let w = z ^ (numeral w) in w * w)"
  unfolding numeral_Bit0 power_add Let_def ..

lemma power_numeral_odd:
  "z ^ numeral (Num.Bit1 w) = (let w = z ^ (numeral w) in z * w * w)"
  unfolding numeral_Bit1 One_nat_def add_Suc_right add_0_right
  unfolding power_Suc power_add Let_def mult.assoc ..

lemma funpow_times_power:
  "(times x ^^ f x) = times (x ^ f x)"
proof (induct "f x" arbitrary: f)
  case 0 then show ?case by (simp add: fun_eq_iff)
next
  case (Suc n)
  def g \<equiv> "\<lambda>x. f x - 1"
  with Suc have "n = g x" by simp
  with Suc have "times x ^^ g x = times (x ^ g x)" by simp
  moreover from Suc g_def have "f x = g x + 1" by simp
  ultimately show ?case by (simp add: power_add funpow_add fun_eq_iff mult.assoc)
qed

lemma power_commuting_commutes:
  assumes "x * y = y * x"
  shows "x ^ n * y = y * x ^n"
proof (induct n)
  case (Suc n)
  have "x ^ Suc n * y = x ^ n * y * x"
    by (subst power_Suc2) (simp add: assms ac_simps)
  also have "\<dots> = y * x ^ Suc n"
    unfolding Suc power_Suc2
    by (simp add: ac_simps)
  finally show ?case .
qed simp

end

context comm_monoid_mult
begin

lemma power_mult_distrib [field_simps]:
  "(a * b) ^ n = (a ^ n) * (b ^ n)"
  by (induct n) (simp_all add: ac_simps)

end

context semiring_numeral
begin

lemma numeral_sqr: "numeral (Num.sqr k) = numeral k * numeral k"
  by (simp only: sqr_conv_mult numeral_mult)

lemma numeral_pow: "numeral (Num.pow k l) = numeral k ^ numeral l"
  by (induct l, simp_all only: numeral_class.numeral.simps pow.simps
    numeral_sqr numeral_mult power_add power_one_right)

lemma power_numeral [simp]: "numeral k ^ numeral l = numeral (Num.pow k l)"
  by (rule numeral_pow [symmetric])

end

context semiring_1
begin

lemma zero_power:
  "0 < n \<Longrightarrow> 0 ^ n = 0"
  by (cases n) simp_all

lemma power_zero_numeral [simp]:
  "0 ^ numeral k = 0"
  by (simp add: numeral_eq_Suc)

lemma zero_power2: "0\<^sup>2 = 0" (* delete? *)
  by (rule power_zero_numeral)

lemma one_power2: "1\<^sup>2 = 1" (* delete? *)
  by (rule power_one)

end

context comm_semiring_1
begin

text {* The divides relation *}

lemma le_imp_power_dvd:
  assumes "m \<le> n" shows "a ^ m dvd a ^ n"
proof
  have "a ^ n = a ^ (m + (n - m))"
    using `m \<le> n` by simp
  also have "\<dots> = a ^ m * a ^ (n - m)"
    by (rule power_add)
  finally show "a ^ n = a ^ m * a ^ (n - m)" .
qed

lemma power_le_dvd:
  "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
  by (rule dvd_trans [OF le_imp_power_dvd])

lemma dvd_power_same:
  "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
  by (induct n) (auto simp add: mult_dvd_mono)

lemma dvd_power_le:
  "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
  by (rule power_le_dvd [OF dvd_power_same])

lemma dvd_power [simp]:
  assumes "n > (0::nat) \<or> x = 1"
  shows "x dvd (x ^ n)"
using assms proof
  assume "0 < n"
  then have "x ^ n = x ^ Suc (n - 1)" by simp
  then show "x dvd (x ^ n)" by simp
next
  assume "x = 1"
  then show "x dvd (x ^ n)" by simp
qed

end

context ring_1
begin

lemma power_minus:
  "(- a) ^ n = (- 1) ^ n * a ^ n"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n) then show ?case
    by (simp del: power_Suc add: power_Suc2 mult.assoc)
qed

lemma power_minus_Bit0:
  "(- x) ^ numeral (Num.Bit0 k) = x ^ numeral (Num.Bit0 k)"
  by (induct k, simp_all only: numeral_class.numeral.simps power_add
    power_one_right mult_minus_left mult_minus_right minus_minus)

lemma power_minus_Bit1:
  "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
  by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)

lemma power2_minus [simp]:
  "(- a)\<^sup>2 = a\<^sup>2"
  by (rule power_minus_Bit0)

lemma power_minus1_even [simp]:
  "(- 1) ^ (2*n) = 1"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n) then show ?case by (simp add: power_add power2_eq_square)
qed

lemma power_minus1_odd:
  "(- 1) ^ Suc (2*n) = -1"
  by simp

lemma power_minus_even [simp]:
  "(-a) ^ (2*n) = a ^ (2*n)"
  by (simp add: power_minus [of a])

end

lemma power_eq_0_nat_iff [simp]:
  fixes m n :: nat
  shows "m ^ n = 0 \<longleftrightarrow> m = 0 \<and> n > 0"
  by (induct n) auto

context ring_1_no_zero_divisors
begin

lemma power_eq_0_iff [simp]:
  "a ^ n = 0 \<longleftrightarrow> a = 0 \<and> n > 0"
  by (induct n) auto

lemma field_power_not_zero:
  "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
  by (induct n) auto

lemma zero_eq_power2 [simp]:
  "a\<^sup>2 = 0 \<longleftrightarrow> a = 0"
  unfolding power2_eq_square by simp

lemma power2_eq_1_iff:
  "a\<^sup>2 = 1 \<longleftrightarrow> a = 1 \<or> a = - 1"
  unfolding power2_eq_square by (rule square_eq_1_iff)

end

context idom
begin

lemma power2_eq_iff: "x\<^sup>2 = y\<^sup>2 \<longleftrightarrow> x = y \<or> x = - y"
  unfolding power2_eq_square by (rule square_eq_iff)

end

context division_ring
begin

text {* FIXME reorient or rename to @{text nonzero_inverse_power} *}
lemma nonzero_power_inverse:
  "a \<noteq> 0 \<Longrightarrow> inverse (a ^ n) = (inverse a) ^ n"
  by (induct n)
    (simp_all add: nonzero_inverse_mult_distrib power_commutes field_power_not_zero)

end

context field
begin

lemma nonzero_power_divide:
  "b \<noteq> 0 \<Longrightarrow> (a / b) ^ n = a ^ n / b ^ n"
  by (simp add: divide_inverse power_mult_distrib nonzero_power_inverse)

end

subsection {* Exponentiation on ordered types *}

context linordered_ring (* TODO: move *)
begin

lemma sum_squares_ge_zero:
  "0 \<le> x * x + y * y"
  by (intro add_nonneg_nonneg zero_le_square)

lemma not_sum_squares_lt_zero:
  "\<not> x * x + y * y < 0"
  by (simp add: not_less sum_squares_ge_zero)

end

context linordered_semidom
begin

lemma zero_less_power [simp]:
  "0 < a \<Longrightarrow> 0 < a ^ n"
  by (induct n) simp_all

lemma zero_le_power [simp]:
  "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
  by (induct n) simp_all

lemma power_mono:
  "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
  by (induct n) (auto intro: mult_mono order_trans [of 0 a b])

lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
  using power_mono [of 1 a n] by simp

lemma power_le_one: "\<lbrakk>0 \<le> a; a \<le> 1\<rbrakk> \<Longrightarrow> a ^ n \<le> 1"
  using power_mono [of a 1 n] by simp

lemma power_gt1_lemma:
  assumes gt1: "1 < a"
  shows "1 < a * a ^ n"
proof -
  from gt1 have "0 \<le> a"
    by (fact order_trans [OF zero_le_one less_imp_le])
  have "1 * 1 < a * 1" using gt1 by simp
  also have "\<dots> \<le> a * a ^ n" using gt1
    by (simp only: mult_mono `0 \<le> a` one_le_power order_less_imp_le
        zero_le_one order_refl)
  finally show ?thesis by simp
qed

lemma power_gt1:
  "1 < a \<Longrightarrow> 1 < a ^ Suc n"
  by (simp add: power_gt1_lemma)

lemma one_less_power [simp]:
  "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
  by (cases n) (simp_all add: power_gt1_lemma)

lemma power_le_imp_le_exp:
  assumes gt1: "1 < a"
  shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
proof (induct m arbitrary: n)
  case 0
  show ?case by simp
next
  case (Suc m)
  show ?case
  proof (cases n)
    case 0
    with Suc.prems Suc.hyps have "a * a ^ m \<le> 1" by simp
    with gt1 show ?thesis
      by (force simp only: power_gt1_lemma
          not_less [symmetric])
  next
    case (Suc n)
    with Suc.prems Suc.hyps show ?thesis
      by (force dest: mult_left_le_imp_le
          simp add: less_trans [OF zero_less_one gt1])
  qed
qed

text{*Surely we can strengthen this? It holds for @{text "0<a<1"} too.*}
lemma power_inject_exp [simp]:
  "1 < a \<Longrightarrow> a ^ m = a ^ n \<longleftrightarrow> m = n"
  by (force simp add: order_antisym power_le_imp_le_exp)

text{*Can relax the first premise to @{term "0<a"} in the case of the
natural numbers.*}
lemma power_less_imp_less_exp:
  "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
  by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"]
    power_le_imp_le_exp)

lemma power_strict_mono [rule_format]:
  "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
  by (induct n)
   (auto simp add: mult_strict_mono le_less_trans [of 0 a b])

text{*Lemma for @{text power_strict_decreasing}*}
lemma power_Suc_less:
  "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
  by (induct n)
    (auto simp add: mult_strict_left_mono)

lemma power_strict_decreasing [rule_format]:
  "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
proof (induct N)
  case 0 then show ?case by simp
next
  case (Suc N) then show ?case
  apply (auto simp add: power_Suc_less less_Suc_eq)
  apply (subgoal_tac "a * a^N < 1 * a^n")
  apply simp
  apply (rule mult_strict_mono) apply auto
  done
qed

text{*Proof resembles that of @{text power_strict_decreasing}*}
lemma power_decreasing [rule_format]:
  "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<longrightarrow> a ^ N \<le> a ^ n"
proof (induct N)
  case 0 then show ?case by simp
next
  case (Suc N) then show ?case
  apply (auto simp add: le_Suc_eq)
  apply (subgoal_tac "a * a^N \<le> 1 * a^n", simp)
  apply (rule mult_mono) apply auto
  done
qed

lemma power_Suc_less_one:
  "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
  using power_strict_decreasing [of 0 "Suc n" a] by simp

text{*Proof again resembles that of @{text power_strict_decreasing}*}
lemma power_increasing [rule_format]:
  "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
proof (induct N)
  case 0 then show ?case by simp
next
  case (Suc N) then show ?case
  apply (auto simp add: le_Suc_eq)
  apply (subgoal_tac "1 * a^n \<le> a * a^N", simp)
  apply (rule mult_mono) apply (auto simp add: order_trans [OF zero_le_one])
  done
qed

text{*Lemma for @{text power_strict_increasing}*}
lemma power_less_power_Suc:
  "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
  by (induct n) (auto simp add: mult_strict_left_mono less_trans [OF zero_less_one])

lemma power_strict_increasing [rule_format]:
  "n < N \<Longrightarrow> 1 < a \<longrightarrow> a ^ n < a ^ N"
proof (induct N)
  case 0 then show ?case by simp
next
  case (Suc N) then show ?case
  apply (auto simp add: power_less_power_Suc less_Suc_eq)
  apply (subgoal_tac "1 * a^n < a * a^N", simp)
  apply (rule mult_strict_mono) apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
  done
qed

lemma power_increasing_iff [simp]:
  "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
  by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)

lemma power_strict_increasing_iff [simp]:
  "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
by (blast intro: power_less_imp_less_exp power_strict_increasing)

lemma power_le_imp_le_base:
  assumes le: "a ^ Suc n \<le> b ^ Suc n"
    and ynonneg: "0 \<le> b"
  shows "a \<le> b"
proof (rule ccontr)
  assume "~ a \<le> b"
  then have "b < a" by (simp only: linorder_not_le)
  then have "b ^ Suc n < a ^ Suc n"
    by (simp only: assms power_strict_mono)
  from le and this show False
    by (simp add: linorder_not_less [symmetric])
qed

lemma power_less_imp_less_base:
  assumes less: "a ^ n < b ^ n"
  assumes nonneg: "0 \<le> b"
  shows "a < b"
proof (rule contrapos_pp [OF less])
  assume "~ a < b"
  hence "b \<le> a" by (simp only: linorder_not_less)
  hence "b ^ n \<le> a ^ n" using nonneg by (rule power_mono)
  thus "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
qed

lemma power_inject_base:
  "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
by (blast intro: power_le_imp_le_base antisym eq_refl sym)

lemma power_eq_imp_eq_base:
  "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
  by (cases n) (simp_all del: power_Suc, rule power_inject_base)

lemma power2_le_imp_le:
  "x\<^sup>2 \<le> y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
  unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)

lemma power2_less_imp_less:
  "x\<^sup>2 < y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
  by (rule power_less_imp_less_base)

lemma power2_eq_imp_eq:
  "x\<^sup>2 = y\<^sup>2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
  unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp

end

context linordered_ring_strict
begin

lemma sum_squares_eq_zero_iff:
  "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: add_nonneg_eq_0_iff)

lemma sum_squares_le_zero_iff:
  "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)

lemma sum_squares_gt_zero_iff:
  "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  by (simp add: not_le [symmetric] sum_squares_le_zero_iff)

end

context linordered_idom
begin

lemma power_abs:
  "abs (a ^ n) = abs a ^ n"
  by (induct n) (auto simp add: abs_mult)

lemma abs_power_minus [simp]:
  "abs ((-a) ^ n) = abs (a ^ n)"
  by (simp add: power_abs)

lemma zero_less_power_abs_iff [simp]:
  "0 < abs a ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n) show ?case by (auto simp add: Suc zero_less_mult_iff)
qed

lemma zero_le_power_abs [simp]:
  "0 \<le> abs a ^ n"
  by (rule zero_le_power [OF abs_ge_zero])

lemma zero_le_power2 [simp]:
  "0 \<le> a\<^sup>2"
  by (simp add: power2_eq_square)

lemma zero_less_power2 [simp]:
  "0 < a\<^sup>2 \<longleftrightarrow> a \<noteq> 0"
  by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)

lemma power2_less_0 [simp]:
  "\<not> a\<^sup>2 < 0"
  by (force simp add: power2_eq_square mult_less_0_iff)

lemma power2_less_eq_zero_iff [simp]:
  "a\<^sup>2 \<le> 0 \<longleftrightarrow> a = 0"
  by (simp add: le_less)

lemma abs_power2 [simp]:
  "abs (a\<^sup>2) = a\<^sup>2"
  by (simp add: power2_eq_square abs_mult abs_mult_self)

lemma power2_abs [simp]:
  "(abs a)\<^sup>2 = a\<^sup>2"
  by (simp add: power2_eq_square abs_mult_self)

lemma odd_power_less_zero:
  "a < 0 \<Longrightarrow> a ^ Suc (2*n) < 0"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
    by (simp add: ac_simps power_add power2_eq_square)
  thus ?case
    by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
qed

lemma odd_0_le_power_imp_0_le:
  "0 \<le> a ^ Suc (2*n) \<Longrightarrow> 0 \<le> a"
  using odd_power_less_zero [of a n]
    by (force simp add: linorder_not_less [symmetric])

lemma zero_le_even_power'[simp]:
  "0 \<le> a ^ (2*n)"
proof (induct n)
  case 0
    show ?case by simp
next
  case (Suc n)
    have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
      by (simp add: ac_simps power_add power2_eq_square)
    thus ?case
      by (simp add: Suc zero_le_mult_iff)
qed

lemma sum_power2_ge_zero:
  "0 \<le> x\<^sup>2 + y\<^sup>2"
  by (intro add_nonneg_nonneg zero_le_power2)

lemma not_sum_power2_lt_zero:
  "\<not> x\<^sup>2 + y\<^sup>2 < 0"
  unfolding not_less by (rule sum_power2_ge_zero)

lemma sum_power2_eq_zero_iff:
  "x\<^sup>2 + y\<^sup>2 = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  unfolding power2_eq_square by (simp add: add_nonneg_eq_0_iff)

lemma sum_power2_le_zero_iff:
  "x\<^sup>2 + y\<^sup>2 \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less sum_power2_eq_zero_iff not_sum_power2_lt_zero)

lemma sum_power2_gt_zero_iff:
  "0 < x\<^sup>2 + y\<^sup>2 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  unfolding not_le [symmetric] by (simp add: sum_power2_le_zero_iff)

end

subsection {* Miscellaneous rules *}

lemma self_le_power:
  fixes x::"'a::linordered_semidom"
  shows "1 \<le> x \<Longrightarrow> 0 < n \<Longrightarrow> x \<le> x ^ n"
  using power_increasing[of 1 n x] power_one_right[of x] by auto

lemma power_eq_if: "p ^ m = (if m=0 then 1 else p * (p ^ (m - 1)))"
  unfolding One_nat_def by (cases m) simp_all

lemma (in comm_semiring_1) power2_sum:
  "(x + y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 + 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

lemma (in comm_ring_1) power2_diff:
  "(x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

lemma power_0_Suc [simp]:
  "(0::'a::{power, semiring_0}) ^ Suc n = 0"
  by simp

text{*It looks plausible as a simprule, but its effect can be strange.*}
lemma power_0_left:
  "0 ^ n = (if n = 0 then 1 else (0::'a::{power, semiring_0}))"
  by (induct n) simp_all

lemma (in field) power_diff:
  assumes nz: "a \<noteq> 0"
  shows "n \<le> m \<Longrightarrow> a ^ (m - n) = a ^ m / a ^ n"
  by (induct m n rule: diff_induct) (simp_all add: nz field_power_not_zero)

text{*Perhaps these should be simprules.*}
lemma power_inverse:
  fixes a :: "'a::division_ring_inverse_zero"
  shows "inverse (a ^ n) = inverse a ^ n"
apply (cases "a = 0")
apply (simp add: power_0_left)
apply (simp add: nonzero_power_inverse)
done (* TODO: reorient or rename to inverse_power *)

lemma power_one_over:
  "1 / (a::'a::{field_inverse_zero, power}) ^ n =  (1 / a) ^ n"
  by (simp add: divide_inverse) (rule power_inverse)

lemma power_divide [field_simps, divide_simps]:
  "(a / b) ^ n = (a::'a::field_inverse_zero) ^ n / b ^ n"
apply (cases "b = 0")
apply (simp add: power_0_left)
apply (rule nonzero_power_divide)
apply assumption
done

text {* Simprules for comparisons where common factors can be cancelled. *}

lemmas zero_compare_simps =
    add_strict_increasing add_strict_increasing2 add_increasing
    zero_le_mult_iff zero_le_divide_iff
    zero_less_mult_iff zero_less_divide_iff
    mult_le_0_iff divide_le_0_iff
    mult_less_0_iff divide_less_0_iff
    zero_le_power2 power2_less_0

subsection {* Exponentiation for the Natural Numbers *}

lemma nat_one_le_power [simp]:
  "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
  by (rule one_le_power [of i n, unfolded One_nat_def])

lemma nat_zero_less_power_iff [simp]:
  "x ^ n > 0 \<longleftrightarrow> x > (0::nat) \<or> n = 0"
  by (induct n) auto

lemma nat_power_eq_Suc_0_iff [simp]:
  "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
  by (induct m) auto

lemma power_Suc_0 [simp]:
  "Suc 0 ^ n = Suc 0"
  by simp

text{*Valid for the naturals, but what if @{text"0<i<1"}?
Premises cannot be weakened: consider the case where @{term "i=0"},
@{term "m=1"} and @{term "n=0"}.*}
lemma nat_power_less_imp_less:
  assumes nonneg: "0 < (i\<Colon>nat)"
  assumes less: "i ^ m < i ^ n"
  shows "m < n"
proof (cases "i = 1")
  case True with less power_one [where 'a = nat] show ?thesis by simp
next
  case False with nonneg have "1 < i" by auto
  from power_strict_increasing_iff [OF this] less show ?thesis ..
qed

lemma power_dvd_imp_le:
  "i ^ m dvd i ^ n \<Longrightarrow> (1::nat) < i \<Longrightarrow> m \<le> n"
  apply (rule power_le_imp_le_exp, assumption)
  apply (erule dvd_imp_le, simp)
  done

lemma power2_nat_le_eq_le:
  fixes m n :: nat
  shows "m\<^sup>2 \<le> n\<^sup>2 \<longleftrightarrow> m \<le> n"
  by (auto intro: power2_le_imp_le power_mono)

lemma power2_nat_le_imp_le:
  fixes m n :: nat
  assumes "m\<^sup>2 \<le> n"
  shows "m \<le> n"
proof (cases m)
  case 0 then show ?thesis by simp
next
  case (Suc k)
  show ?thesis
  proof (rule ccontr)
    assume "\<not> m \<le> n"
    then have "n < m" by simp
    with assms Suc show False
      by (auto simp add: algebra_simps) (simp add: power2_eq_square)
  qed
qed

subsubsection {* Cardinality of the Powerset *}

lemma card_UNIV_bool [simp]: "card (UNIV :: bool set) = 2"
  unfolding UNIV_bool by simp

lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
proof (induct rule: finite_induct)
  case empty
    show ?case by auto
next
  case (insert x A)
  then have "inj_on (insert x) (Pow A)"
    unfolding inj_on_def by (blast elim!: equalityE)
  then have "card (Pow A) + card (insert x ` Pow A) = 2 * 2 ^ card A"
    by (simp add: mult_2 card_image Pow_insert insert.hyps)
  then show ?case using insert
    apply (simp add: Pow_insert)
    apply (subst card_Un_disjoint, auto)
    done
qed

subsubsection {* Generalized sum over a set *}

lemma setsum_zero_power [simp]:
  fixes c :: "nat \<Rightarrow> 'a::division_ring"
  shows "(\<Sum>i\<in>A. c i * 0^i) = (if finite A \<and> 0 \<in> A then c 0 else 0)"
apply (cases "finite A")
  by (induction A rule: finite_induct) auto

lemma setsum_zero_power' [simp]:
  fixes c :: "nat \<Rightarrow> 'a::field"
  shows "(\<Sum>i\<in>A. c i * 0^i / d i) = (if finite A \<and> 0 \<in> A then c 0 / d 0 else 0)"
  using setsum_zero_power [of "\<lambda>i. c i / d i" A]
  by auto

subsubsection {* Generalized product over a set *}

lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{comm_monoid_mult})) = y^(card A)"
apply (erule finite_induct)
apply auto
done

lemma setprod_power_distrib:
  fixes f :: "'a \<Rightarrow> 'b::comm_semiring_1"
  shows "setprod f A ^ n = setprod (\<lambda>x. (f x) ^ n) A"
proof (cases "finite A")
  case True then show ?thesis
    by (induct A rule: finite_induct) (auto simp add: power_mult_distrib)
next
  case False then show ?thesis
    by simp
qed

lemma power_setsum:
  "c ^ (\<Sum>a\<in>A. f a) = (\<Prod>a\<in>A. c ^ f a)"
  by (induct A rule: infinite_finite_induct) (simp_all add: power_add)

lemma setprod_gen_delta:
  assumes fS: "finite S"
  shows "setprod (\<lambda>k. if k=a then b k else c) S = (if a \<in> S then (b a ::'a::comm_monoid_mult) * c^ (card S - 1) else c^ card S)"
proof-
  let ?f = "(\<lambda>k. if k=a then b k else c)"
  {assume a: "a \<notin> S"
    hence "\<forall> k\<in> S. ?f k = c" by simp
    hence ?thesis  using a setprod_constant[OF fS, of c] by simp }
  moreover
  {assume a: "a \<in> S"
    let ?A = "S - {a}"
    let ?B = "{a}"
    have eq: "S = ?A \<union> ?B" using a by blast
    have dj: "?A \<inter> ?B = {}" by simp
    from fS have fAB: "finite ?A" "finite ?B" by auto
    have fA0:"setprod ?f ?A = setprod (\<lambda>i. c) ?A"
      apply (rule setprod.cong) by auto
    have cA: "card ?A = card S - 1" using fS a by auto
    have fA1: "setprod ?f ?A = c ^ card ?A"  unfolding fA0 apply (rule setprod_constant) using fS by auto
    have "setprod ?f ?A * setprod ?f ?B = setprod ?f S"
      using setprod.union_disjoint[OF fAB dj, of ?f, unfolded eq[symmetric]]
      by simp
    then have ?thesis using a cA
      by (simp add: fA1 field_simps cong add: setprod.cong cong del: if_weak_cong)}
  ultimately show ?thesis by blast
qed

subsection {* Code generator tweak *}

lemma power_power_power [code]:
  "power = power.power (1::'a::{power}) (op *)"
  unfolding power_def power.power_def ..

declare power.power.simps [code]

code_identifier
  code_module Power \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


(*
  File:     Regexp_Constructions.thy
  Author:   Manuel Eberl <manuel@pruvisto.org>

  Some simple constructions on regular expressions to illustrate closure properties of regular
  languages: reversal, substitution, prefixes, suffixes, subwords ("fragments")
*)
section \<open>Basic constructions on regular expressions\<close>
theory Regexp_Constructions
imports
  Main
  "HOL-Library.Sublist"
  Regular_Exp
begin

subsection \<open>Reverse language\<close>

lemma rev_conc [simp]: "rev ` (A @@ B) = rev ` B @@ rev ` A"
  unfolding conc_def image_def by force

lemma rev_compower [simp]: "rev ` (A ^^ n) = (rev ` A) ^^ n"
  by (induction n) (simp_all add: conc_pow_comm)

lemma rev_star [simp]: "rev ` star A = star (rev ` A)"
  by (simp add: star_def image_UN)

subsection \<open>Substituting characters in a language\<close>

definition subst_word :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "subst_word f xs = concat (map f xs)"

lemma subst_word_Nil [simp]: "subst_word f [] = []"
  by (simp add: subst_word_def)

lemma subst_word_singleton [simp]: "subst_word f [x] = f x"
  by (simp add: subst_word_def)

lemma subst_word_append [simp]: "subst_word f (xs @ ys) = subst_word f xs @ subst_word f ys"
  by (simp add: subst_word_def)

lemma subst_word_Cons [simp]: "subst_word f (x # xs) = f x @ subst_word f xs"
  by (simp add: subst_word_def)

lemma subst_word_conc [simp]: "subst_word f ` (A @@ B) = subst_word f ` A @@ subst_word f ` B"
  unfolding conc_def image_def by force

lemma subst_word_compower [simp]: "subst_word f ` (A ^^ n) = (subst_word f ` A) ^^ n"
  by (induction n) simp_all

lemma subst_word_star [simp]: "subst_word f ` (star A) = star (subst_word f ` A)"
  by (simp add: star_def image_UN)

text \<open>Suffix language\<close>

definition Suffixes :: "'a list set \<Rightarrow> 'a list set" where
  "Suffixes A = {w. \<exists>q. q @ w \<in> A}"

lemma Suffixes_altdef [code]: "Suffixes A = (\<Union>w\<in>A. set (suffixes w))"
  unfolding Suffixes_def set_suffixes_eq suffix_def by blast

lemma Suffixes_empty [simp]: "Suffixes {} = {}"
  by (auto simp: Suffixes_def)

lemma Suffixes_empty_iff [simp]: "Suffixes A = {} \<longleftrightarrow> A = {}"
  by (auto simp: Suffixes_altdef)

lemma Suffixes_singleton [simp]: "Suffixes {xs} = set (suffixes xs)"
  by (auto simp: Suffixes_altdef)

lemma Suffixes_insert: "Suffixes (insert xs A) = set (suffixes xs) \<union> Suffixes A"
  by (simp add: Suffixes_altdef)

lemma Suffixes_conc [simp]: "A \<noteq> {} \<Longrightarrow> Suffixes (A @@ B) = Suffixes B \<union> (Suffixes A @@ B)"
  unfolding Suffixes_altdef conc_def by (force simp: suffix_append)

lemma Suffixes_union [simp]: "Suffixes (A \<union> B) = Suffixes A \<union> Suffixes B"
  by (auto simp: Suffixes_def)

lemma Suffixes_UNION [simp]: "Suffixes (\<Union>(f ` A)) = \<Union>((\<lambda>x. Suffixes (f x)) ` A)"
  by (auto simp: Suffixes_def)

lemma Suffixes_compower:
  assumes "A \<noteq> {}"
  shows   "Suffixes (A ^^ n) = insert [] (Suffixes A @@ (\<Union>k<n. A ^^ k))"
proof (induction n)
  case (Suc n)
  from Suc have "Suffixes (A ^^ Suc n) =
                   insert [] (Suffixes A @@ ((\<Union>k<n. A ^^ k) \<union> A ^^ n))"
    by (simp_all add: assms conc_Un_distrib)
  also have "(\<Union>k<n. A ^^ k) \<union> A ^^ n = (\<Union>k\<in>insert n {..<n}. A ^^ k)"  by blast
  also have "insert n {..<n} = {..<Suc n}" by auto
  finally show ?case .
qed simp_all

lemma Suffixes_star [simp]:
  assumes "A \<noteq> {}"
  shows   "Suffixes (star A) = Suffixes A @@ star A"
proof -
  have "star A = (\<Union>n. A ^^ n)" unfolding star_def ..
  also have "Suffixes \<dots> = (\<Union>x. Suffixes (A ^^ x))" by simp
  also have "\<dots> = (\<Union>n. insert [] (Suffixes A @@ (\<Union>k<n. A ^^ k)))"
    using assms by (subst Suffixes_compower) auto
  also have "\<dots> = insert [] (Suffixes A @@ (\<Union>n. (\<Union>k<n. A ^^ k)))"
    by (simp_all add: conc_UNION_distrib)
  also have "(\<Union>n. (\<Union>k<n. A ^^ k)) = (\<Union>n. A ^^ n)" by auto
  also have "\<dots> = star A" unfolding star_def ..
  also have "insert [] (Suffixes A @@ star A) = Suffixes A @@ star A"
    using assms by auto
  finally show ?thesis .
qed

text \<open>Prefix language\<close>

definition Prefixes :: "'a list set \<Rightarrow> 'a list set" where
  "Prefixes A = {w. \<exists>q. w @ q \<in> A}"

lemma Prefixes_altdef [code]: "Prefixes A = (\<Union>w\<in>A. set (prefixes w))"
  unfolding Prefixes_def set_prefixes_eq prefix_def by blast

lemma Nil_in_Prefixes_iff [simp]: "[] \<in> Prefixes A \<longleftrightarrow> A \<noteq> {}"
  by (auto simp: Prefixes_def)

lemma Prefixes_conc [simp]: "B \<noteq> {} \<Longrightarrow> Prefixes (A @@ B) = Prefixes A \<union> (A @@ Prefixes B)"
  unfolding Prefixes_altdef conc_def by (force simp: prefix_append)

lemma Prefixes_union [simp]: "Prefixes (A \<union> B) = Prefixes A \<union> Prefixes B"
  by (auto simp: Prefixes_def)

lemma Prefixes_UNION [simp]: "Prefixes (\<Union>(f ` A)) = \<Union>((\<lambda>x. Prefixes (f x)) ` A)"
  by (auto simp: Prefixes_def)

lemma Prefixes_rev: "Prefixes (rev ` A) = rev ` Suffixes A"
  by (auto simp: Prefixes_altdef prefixes_rev Suffixes_altdef)

lemma Suffixes_rev: "Suffixes (rev ` A) = rev ` Prefixes A"
  by (auto simp: Prefixes_altdef suffixes_rev Suffixes_altdef)

lemma Prefixes_compower:
  assumes "A \<noteq> {}"
  shows   "Prefixes (A ^^ n) = insert [] ((\<Union>k<n. A ^^ k) @@ Prefixes A)"
proof -
  have "A ^^ n = rev ` ((rev ` A) ^^ n)" by (simp add: image_image)
  also have "Prefixes \<dots> = insert [] ((\<Union>k<n. A ^^ k) @@ Prefixes A)"
    unfolding Prefixes_rev
    by (subst Suffixes_compower) (simp_all add: image_UN image_image Suffixes_rev assms)
  finally show ?thesis .
qed

lemma Prefixes_star [simp]:
  assumes "A \<noteq> {}"
  shows   "Prefixes (star A) = star A @@ Prefixes A"
proof -
  have "star A = rev ` star (rev ` A)" by (simp add: image_image)
  also have "Prefixes \<dots> = star A @@ Prefixes A"
    unfolding Prefixes_rev
    by (subst Suffixes_star) (simp_all add: assms image_image Suffixes_rev)
  finally show ?thesis .
qed

subsection \<open>Subword language\<close>

text \<open>
  The language of all sub-words, i.e. all words that are a contiguous sublist of a word in
  the original language.
\<close>
definition Sublists :: "'a list set \<Rightarrow> 'a list set" where
  "Sublists A = {w. \<exists>q\<in>A. sublist w q}"

lemma Sublists_altdef [code]: "Sublists A = (\<Union>w\<in>A. set (sublists w))"
  by (auto simp: Sublists_def)

lemma Sublists_empty [simp]: "Sublists {} = {}"
  by (auto simp: Sublists_def)

lemma Sublists_singleton [simp]: "Sublists {w} = set (sublists w)"
  by (auto simp: Sublists_altdef)

lemma Sublists_insert: "Sublists (insert w A) = set (sublists w) \<union> Sublists A"
  by (auto simp: Sublists_altdef)

lemma Sublists_Un [simp]: "Sublists (A \<union> B) = Sublists A \<union> Sublists B"
  by (auto simp: Sublists_altdef)

lemma Sublists_UN [simp]: "Sublists (\<Union>(f ` A)) = \<Union>((\<lambda>x. Sublists (f x)) ` A)"
  by (auto simp: Sublists_altdef)

lemma Sublists_conv_Prefixes: "Sublists A = Prefixes (Suffixes A)"
  by (auto simp: Sublists_def Prefixes_def Suffixes_def sublist_def)

lemma Sublists_conv_Suffixes: "Sublists A = Suffixes (Prefixes A)"
  by (auto simp: Sublists_def Prefixes_def Suffixes_def sublist_def)

lemma Sublists_conc [simp]:
  assumes "A \<noteq> {}" "B \<noteq> {}"
  shows   "Sublists (A @@ B) = Sublists A \<union> Sublists B \<union> Suffixes A @@ Prefixes B"
  using assms unfolding Sublists_conv_Suffixes by auto

lemma star_not_empty [simp]: "star A \<noteq> {}"
  by auto

lemma Sublists_star:
  "A \<noteq> {} \<Longrightarrow> Sublists (star A) = Sublists A \<union> Suffixes A @@ star A @@ Prefixes A"
  by (simp add: Sublists_conv_Prefixes)

lemma Prefixes_subset_Sublists: "Prefixes A \<subseteq> Sublists A"
  unfolding Prefixes_def Sublists_def by auto

lemma Suffixes_subset_Sublists: "Suffixes A \<subseteq> Sublists A"
  unfolding Suffixes_def Sublists_def by auto

subsection \<open>Fragment language\<close>

text \<open>
  The following is the fragment language of a given language, i.e. the set of all words that
  are (not necessarily contiguous) sub-sequences of a word in the original language.
\<close>
definition Subseqs where "Subseqs A = (\<Union>w\<in>A. set (subseqs w))"

lemma Subseqs_empty [simp]: "Subseqs {} = {}"
  by (simp add: Subseqs_def)

lemma Subseqs_insert [simp]: "Subseqs (insert xs A) = set (subseqs xs) \<union> Subseqs A"
  by (simp add: Subseqs_def)

lemma Subseqs_singleton [simp]: "Subseqs {xs} = set (subseqs xs)"
  by simp

lemma Subseqs_Un [simp]: "Subseqs (A \<union> B) = Subseqs A \<union> Subseqs B"
  by (simp add: Subseqs_def)

lemma Subseqs_UNION [simp]: "Subseqs (\<Union>(f ` A)) = \<Union>((\<lambda>x. Subseqs (f x)) ` A)"
  by (simp add: Subseqs_def)

lemma Subseqs_conc [simp]: "Subseqs (A @@ B) = Subseqs A @@ Subseqs B"
proof safe
  fix xs assume "xs \<in> Subseqs (A @@ B)"
  then obtain ys zs where *: "ys \<in> A" "zs \<in> B" "subseq xs (ys @ zs)"
    by (auto simp: Subseqs_def conc_def)
  from *(3) obtain xs1 xs2 where "xs = xs1 @ xs2" "subseq xs1 ys" "subseq xs2 zs"
    by (rule subseq_appendE)
  with *(1,2) show "xs \<in> Subseqs A @@ Subseqs B" by (auto simp: Subseqs_def set_subseqs_eq)
next
  fix xs assume "xs \<in> Subseqs A @@ Subseqs B"
  then obtain xs1 xs2 ys zs
    where "xs = xs1 @ xs2" "subseq xs1 ys" "subseq xs2 zs" "ys \<in> A" "zs \<in> B"
    by (auto simp: conc_def Subseqs_def)
  thus "xs \<in> Subseqs (A @@ B)" by (force simp: Subseqs_def conc_def intro: list_emb_append_mono)
qed

lemma Subseqs_compower [simp]: "Subseqs (A ^^ n) = Subseqs A ^^ n"
  by (induction n) simp_all

lemma Subseqs_star [simp]: "Subseqs (star A) = star (Subseqs A)"
  by (simp add: star_def)

lemma Sublists_subset_Subseqs: "Sublists A \<subseteq> Subseqs A"
  by (auto simp: Sublists_def Subseqs_def dest!: sublist_imp_subseq)

subsection \<open>Various regular expression constructions\<close>

text \<open>A construction for language reversal of a regular expression:\<close>

primrec rexp_rev where
  "rexp_rev Zero = Zero"
| "rexp_rev One = One"
| "rexp_rev (Atom x) = Atom x"
| "rexp_rev (Plus r s) = Plus (rexp_rev r) (rexp_rev s)"
| "rexp_rev (Times r s) = Times (rexp_rev s) (rexp_rev r)"
| "rexp_rev (Star r) = Star (rexp_rev r)"

lemma lang_rexp_rev [simp]: "lang (rexp_rev r) = rev ` lang r"
  by (induction r) (simp_all add: image_Un)

text \<open>The obvious construction for a singleton-language regular expression:\<close>

fun rexp_of_word where
  "rexp_of_word [] = One"
| "rexp_of_word [x] = Atom x"
| "rexp_of_word (x#xs) = Times (Atom x) (rexp_of_word xs)"

lemma lang_rexp_of_word [simp]: "lang (rexp_of_word xs) = {xs}"
  by (induction xs rule: rexp_of_word.induct) (simp_all add: conc_def)

lemma size_rexp_of_word [simp]: "size (rexp_of_word xs) = Suc (2 * (length xs - 1))"
  by (induction xs rule: rexp_of_word.induct) auto

text \<open>Character substitution in a regular expression:\<close>

primrec rexp_subst where
  "rexp_subst f Zero = Zero"
| "rexp_subst f One = One"
| "rexp_subst f (Atom x) = rexp_of_word (f x)"
| "rexp_subst f (Plus r s) = Plus (rexp_subst f r) (rexp_subst f s)"
| "rexp_subst f (Times r s) = Times (rexp_subst f r) (rexp_subst f s)"
| "rexp_subst f (Star r) = Star (rexp_subst f r)"

lemma lang_rexp_subst: "lang (rexp_subst f r) = subst_word f ` lang r"
  by (induction r) (simp_all add: image_Un)

text \<open>Suffix language of a regular expression:\<close>

primrec suffix_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "suffix_rexp Zero = Zero"
| "suffix_rexp One = One"
| "suffix_rexp (Atom a) = Plus (Atom a) One"
| "suffix_rexp (Plus r s) = Plus (suffix_rexp r) (suffix_rexp s)"
| "suffix_rexp (Times r s) =
    (if rexp_empty r then Zero else Plus (Times (suffix_rexp r) s) (suffix_rexp s))"
| "suffix_rexp (Star r) =
    (if rexp_empty r then One else Times (suffix_rexp r) (Star r))"

theorem lang_suffix_rexp [simp]:
  "lang (suffix_rexp r) = Suffixes (lang r)"
  by (induction r) (auto simp: rexp_empty_iff)

text \<open>Prefix language of a regular expression:\<close>

primrec prefix_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "prefix_rexp Zero = Zero"
| "prefix_rexp One = One"
| "prefix_rexp (Atom a) = Plus (Atom a) One"
| "prefix_rexp (Plus r s) = Plus (prefix_rexp r) (prefix_rexp s)"
| "prefix_rexp (Times r s) =
    (if rexp_empty s then Zero else Plus (Times r (prefix_rexp s)) (prefix_rexp r))"
| "prefix_rexp (Star r) =
    (if rexp_empty r then One else Times (Star r) (prefix_rexp r))"

theorem lang_prefix_rexp [simp]:
  "lang (prefix_rexp r) = Prefixes (lang r)"
  by (induction r) (auto simp: rexp_empty_iff)

text \<open>Sub-word language of a regular expression\<close>

primrec sublist_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "sublist_rexp Zero = Zero"
| "sublist_rexp One = One"
| "sublist_rexp (Atom a) = Plus (Atom a) One"
| "sublist_rexp (Plus r s) = Plus (sublist_rexp r) (sublist_rexp s)"
| "sublist_rexp (Times r s) =
    (if rexp_empty r \<or> rexp_empty s then Zero else
       Plus (sublist_rexp r) (Plus (sublist_rexp s) (Times (suffix_rexp r) (prefix_rexp s))))"
| "sublist_rexp (Star r) =
    (if rexp_empty r then One else
       Plus (sublist_rexp r) (Times (suffix_rexp r) (Times (Star r) (prefix_rexp r))))"

theorem lang_sublist_rexp [simp]:
  "lang (sublist_rexp r) = Sublists (lang r)"
  by (induction r) (auto simp: rexp_empty_iff Sublists_star)

text \<open>Fragment language of a regular expression:\<close>

primrec subseqs_rexp :: "'a rexp \<Rightarrow> 'a rexp" where
  "subseqs_rexp Zero = Zero"
| "subseqs_rexp One = One"
| "subseqs_rexp (Atom x) = Plus (Atom x) One"
| "subseqs_rexp (Plus r s) = Plus (subseqs_rexp r) (subseqs_rexp s)"
| "subseqs_rexp (Times r s) = Times (subseqs_rexp r) (subseqs_rexp s)"
| "subseqs_rexp (Star r) = Star (subseqs_rexp r)"

lemma lang_subseqs_rexp [simp]: "lang (subseqs_rexp r) = Subseqs (lang r)"
  by (induction r) auto

text \<open>Subword language of a regular expression\<close>

end


section "Some Auxiliary Results"

theory Auxiliary imports Main
begin

lemma disjE3: "P \<or> Q \<or> R \<Longrightarrow> (P \<Longrightarrow> S) \<Longrightarrow> (Q \<Longrightarrow> S) \<Longrightarrow> (R \<Longrightarrow> S) \<Longrightarrow> S" by auto

lemma ge_induct[consumes 1, case_names step]:
  fixes i::nat and j::nat and P::"nat \<Rightarrow> bool"
  shows "i \<le> j \<Longrightarrow> (\<And>n. i \<le> n \<Longrightarrow> ((\<forall>m \<ge> i.  m<n \<longrightarrow> P m) \<Longrightarrow> P n)) \<Longrightarrow> P j"
proof -
  assume a0: "i \<le> j" and a1: "(\<And>n. i \<le> n \<Longrightarrow> ((\<forall>m \<ge> i.  m<n \<longrightarrow> P m) \<Longrightarrow> P n))"
  have "(\<And>n. \<forall>m<n. i \<le> m \<longrightarrow> P m \<Longrightarrow> i \<le> n \<longrightarrow> P n)"
  proof
    fix n
    assume a2: "\<forall>m<n. i \<le> m \<longrightarrow> P m"
    show "i \<le> n \<Longrightarrow> P n"
    proof -
      assume "i \<le> n"
      with a1 have "(\<forall>m \<ge> i.  m<n \<longrightarrow> P m) \<Longrightarrow> P n" by simp
      moreover from a2 have "\<forall>m \<ge> i.  m<n \<longrightarrow> P m" by simp
      ultimately show "P n" by simp
    qed
  qed
  with nat_less_induct[of "\<lambda>j. i \<le> j \<longrightarrow> P j" j] have "i \<le> j \<longrightarrow> P j" .
  with a0 show ?thesis by simp
qed

lemma my_induct[consumes 1, case_names base step]:
  fixes P::"nat\<Rightarrow>bool"
assumes less: "i \<le> j"
    and base: "P j"
    and step: "\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> (\<forall>n'>n. n'\<le>j \<longrightarrow> P n') \<Longrightarrow> P n"
  shows "P i"
proof cases
  assume "j=0"
  thus ?thesis using less base by simp
next
  assume "\<not> j=0"
  have "j - (j - i) \<ge> i \<longrightarrow> P (j - (j - i))"
  proof (rule less_induct[of "\<lambda>n::nat. j-n \<ge> i \<longrightarrow> P (j-n)" "j-i"])
    fix x assume asmp: "\<And>y. y < x \<Longrightarrow> i \<le> j - y \<longrightarrow> P (j - y)"
    show "i \<le> j - x \<longrightarrow> P (j - x)"
    proof cases
      assume "x=0"
      with base show ?thesis by simp
    next
      assume "\<not> x=0"
      with \<open>j \<noteq> 0\<close> have "j - x < j" by simp
      show ?thesis
      proof
        assume "i \<le> j - x"
        moreover have "\<forall>n'>j-x. n'\<le>j \<longrightarrow> P n'"
        proof
          fix n'
          show "n'>j-x \<longrightarrow> n'\<le>j \<longrightarrow> P n'"
          proof (rule HOL.impI[OF HOL.impI])
            assume "j - x < n'" and "n' \<le> j"
            hence "j - n' < x" by simp
            moreover from \<open>i \<le> j - x\<close> \<open>j - x < n'\<close> have "i \<le> n'" using le_less_trans less_imp_le_nat by blast
            with \<open>n' \<le> j\<close> have "i \<le> j - (j - n')" by simp
            ultimately have  "P (j - (j - n'))" using asmp by simp
            moreover from \<open>n' \<le> j\<close> have "j - (j - n') = n'" by simp
            ultimately show "P n'" by simp
          qed
        qed
        ultimately show "P (j - x)" using \<open>j-x<j\<close> step[of "j-x"] by simp
      qed
    qed
  qed
  moreover from less have "j - (j - i) = i" by simp
  ultimately show ?thesis by simp
qed

lemma Greatest_ex_le_nat: assumes "\<exists>k. P k \<and> (\<forall>k'. P k' \<longrightarrow> k' \<le> k)" shows "\<not>(\<exists>n'>Greatest P. P n')"
  by (metis Greatest_equality assms less_le_not_le)

lemma cardEx: assumes "finite A" and "finite B" and "card A > card B" shows "\<exists>x\<in>A. \<not> x\<in>B"
proof cases
  assume "A \<subseteq> B"
  with assms have "card A\<le>card B" using card_mono by blast
  with assms have False by simp
  thus ?thesis by simp
next
  assume "\<not> A \<subseteq> B"
  thus ?thesis by auto
qed

lemma cardshift: "card {i::nat. i>n \<and> i \<le> n' \<and> p (n'' + i)} = card {i. i>(n + n'') \<and> i \<le> (n' + n'') \<and> p i}"
proof -
  let ?f="\<lambda>i. i+n''"
  have "bij_betw ?f {i::nat. i>n \<and> i \<le> n' \<and> p (n'' + i)} {i. i>(n + n'') \<and> i \<le> (n' + n'') \<and> p i}"
  proof (rule bij_betwI')
    fix x y assume "x \<in> {i. n < i \<and> i \<le> n' \<and> p (n'' + i)}" and "y \<in> {i. n < i \<and> i \<le> n' \<and> p (n'' + i)}"
    show "(x + n'' = y + n'') = (x = y)" by simp
  next
    fix x::nat assume "x \<in> {i. n < i \<and> i \<le> n' \<and> p (n'' + i)}"
    hence "n<x" and "x \<le> n'" and "p(n''+x)" by auto
    moreover have "n''+x=x+n''" by simp
    ultimately have "n + n'' < x + n''" and "x + n'' \<le> n' + n''" and "p (x + n'')" by auto
    thus "x + n'' \<in> {i. n + n'' < i \<and> i \<le> n' + n'' \<and> p i}" by auto
  next
    fix y::nat assume "y \<in> {i. n + n'' < i \<and> i \<le> n' + n'' \<and> p i}"
    hence "n+n''<y" and "y\<le>n'+n''" and "p y" by auto
    then obtain x where "x=y-n''" by simp
    with \<open>n+n''<y\<close> have "y=x+n''" by simp
    moreover from \<open>x=y-n''\<close> \<open>n+n''<y\<close> have "x>n" by simp
    moreover from \<open>x=y-n''\<close> \<open>y\<le>n'+n''\<close> have "x\<le>n'" by simp
    moreover from \<open>y=x+n''\<close> have "y=n''+x" by simp
    with \<open>p y\<close> have "p (n'' + x)" by simp
    ultimately show "\<exists>x\<in>{i. n < i \<and> i \<le> n' \<and> p (n'' + i)}. y = x + n''" by auto
  qed
  thus ?thesis using bij_betw_same_card by auto
qed

end


(*
  File: ProductTopology.thy
  Author: Bohua Zhan

  Basic results about product topology.
*)

theory ProductTopology
  imports Topology
begin

section \<open>Product topology\<close>

definition prod_basis :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "prod_basis(X,Y) = (\<Union>U\<in>X. \<Union>V\<in>Y. {U \<times> V})"

lemma prod_basis_iff [rewrite]:
  "W \<in> prod_basis(X,Y) \<longleftrightarrow> (\<exists>U\<in>X. \<exists>V\<in>Y. W = U \<times> V)" by auto2
setup {* del_prfstep_thm @{thm prod_basis_def} *}

lemma prod_basis_is_basis:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> collection_is_basis(prod_basis(open_sets(X),open_sets(Y)))"
@proof
  @let "\<B> = prod_basis(open_sets(X),open_sets(Y))"
  @have "\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. U \<inter> V \<in> \<B>"
@qed
setup {* add_forward_prfstep_cond @{thm prod_basis_is_basis}
  [with_term "prod_basis(open_sets(?X),open_sets(?Y))"] *}

definition product_space :: "i \<Rightarrow> i \<Rightarrow> i"  (infixr "\<times>\<^sub>T" 80) where [rewrite]:
  "product_space(X,Y) = Top(carrier(X)\<times>carrier(Y), top_from_basis(prod_basis(open_sets(X),open_sets(Y))))"

lemma product_space_type [typing]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> product_space(X,Y) \<in> raw_top_spaces(carrier(X)\<times>carrier(Y))" by auto2

lemma product_space_is_top_space [forward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_top_space(X \<times>\<^sub>T Y)" by auto2

lemma product_space_is_openD [backward2]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_open(X \<times>\<^sub>T Y, U) \<Longrightarrow> x \<in> U \<Longrightarrow>
   \<exists>V W. is_open(X,V) \<and> is_open(Y,W) \<and> x \<in> V\<times>W \<and> V\<times>W \<subseteq> U" by auto2

lemma product_space_is_openI [forward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow>
   \<forall>x\<in>U. \<exists>V W. is_open(X,V) \<and> is_open(Y,W) \<and> x \<in> V\<times>W \<and> V\<times>W \<subseteq> U \<Longrightarrow> is_open(X \<times>\<^sub>T Y, U)" by auto2

lemma product_space_is_open_prod [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_open(X,U) \<Longrightarrow> is_open(Y,V) \<Longrightarrow> is_open(X \<times>\<^sub>T Y, U \<times> V)" by auto2

setup {* del_prfstep_thm @{thm product_space_def} *}

lemma product_space_is_closed_prod [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(Y,B) \<Longrightarrow> is_closed(X \<times>\<^sub>T Y, A \<times> B)"
@proof
  @have "is_closed(X \<times>\<^sub>T Y, carrier(X) \<times> B)"
  @have "is_closed(X \<times>\<^sub>T Y, A \<times> carrier(Y))"
  @have "A \<times> B = carrier(X) \<times> B \<inter> A \<times> carrier(Y)"
@qed

lemma product_space_is_closed_prod1 [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_closed(Y,B) \<Longrightarrow> is_closed(X \<times>\<^sub>T Y, carrier(X) \<times> B)" by auto2

lemma product_space_is_closed_prod2 [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(X \<times>\<^sub>T Y, A \<times> carrier(Y))" by auto2

lemma product_space_has_basis [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> top_has_basis(X,\<B>) \<Longrightarrow> top_has_basis(Y,\<C>) \<Longrightarrow>
   top_has_basis(X \<times>\<^sub>T Y, prod_basis(\<B>,\<C>))"
@proof
  @have "\<forall>W\<in>open_sets(X\<times>\<^sub>TY). \<forall>x\<in>W. \<exists>C\<in>prod_basis(\<B>,\<C>). x \<in> C \<and> C \<subseteq> W" @with
    @obtain U V where "is_open(X,U)" "is_open(Y,V)" "x \<in> U\<times>V \<and> U\<times>V \<subseteq> W"
    @obtain "B\<in>\<B>" where "fst(x)\<in>B" "B \<subseteq> U"
    @obtain "C\<in>\<C>" where "snd(x)\<in>C" "C \<subseteq> V"
    @have "B \<times> C \<subseteq> U \<times> V" @end
@qed

(* Commutativity between subspace and product space *)
lemma product_sub_spaces [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> B \<subseteq> carrier(Y) \<Longrightarrow>
   subspace(X \<times>\<^sub>T Y, A \<times> B) = subspace(X,A) \<times>\<^sub>T subspace(Y,B)"
@proof
  @let "\<A> = {A \<inter> U. U \<in> open_sets(X)}"
  @let "\<B> = {B \<inter> U. U \<in> open_sets(Y)}"
  @have "top_has_basis(subspace(X,A), \<A>)"
  @have "top_has_basis(subspace(Y,B), \<B>)"
  @have "top_has_basis(subspace(X,A) \<times>\<^sub>T subspace(Y,B), prod_basis(\<A>,\<B>))"
  @let "\<C> = prod_basis(open_sets(X), open_sets(Y))"
  @have "top_has_basis(X \<times>\<^sub>T Y, \<C>)"
  @have "top_has_basis(subspace(X \<times>\<^sub>T Y, A \<times> B), {(A\<times>B) \<inter> U. U \<in> \<C>})"
@qed

lemma product_sub_spaces1 [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> B \<subseteq> carrier(Y) \<Longrightarrow>
   subspace(X \<times>\<^sub>T Y, carrier(X) \<times> B) = X \<times>\<^sub>T subspace(Y,B)"
@proof
  @let "\<B> = {B \<inter> U. U \<in> open_sets(Y)}"
  @have "top_has_basis(subspace(Y,B), \<B>)"
  @have "top_has_basis(X \<times>\<^sub>T subspace(Y,B), prod_basis(open_sets(X),\<B>))"
  @let "\<C> = prod_basis(open_sets(X), open_sets(Y))"
  @have "top_has_basis(X \<times>\<^sub>T Y, \<C>)"
  @have "top_has_basis(subspace(X \<times>\<^sub>T Y, carrier(X) \<times> B), {(carrier(X)\<times>B) \<inter> U. U \<in> \<C>})"
  @have "prod_basis(open_sets(X),\<B>) = {(carrier(X)\<times>B)\<inter>U. U \<in> \<C>}" @with
    @have "\<forall>U\<in>prod_basis(open_sets(X),\<B>). U \<in> {(carrier(X)\<times>B)\<inter>U. U \<in> \<C>}" @with
      @obtain "V\<in>open_sets(X)" "W\<in>\<B>" where "U = V \<times> W"
      @obtain "W'\<in>open_sets(Y)" where "W = B \<inter> W'"
      @have "U = carrier(X)\<times>B \<inter> V\<times>W'" @end @end
@qed

lemma product_sub_spaces2 [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow>
   subspace(X \<times>\<^sub>T Y, A \<times> carrier(Y)) = subspace(X,A) \<times>\<^sub>T Y"
@proof
  @let "\<A> = {A \<inter> U. U \<in> open_sets(X)}"
  @have "top_has_basis(subspace(X,A), \<A>)"
  @have "top_has_basis(subspace(X,A) \<times>\<^sub>T Y, prod_basis(\<A>,open_sets(Y)))"
  @let "\<C> = prod_basis(open_sets(X), open_sets(Y))"
  @have "top_has_basis(X \<times>\<^sub>T Y, \<C>)"
  @have "top_has_basis(subspace(X \<times>\<^sub>T Y, A \<times> carrier(Y)), {(A\<times>carrier(Y)) \<inter> U. U \<in> \<C>})"
  @have "prod_basis(\<A>,open_sets(Y)) = {(A\<times>carrier(Y))\<inter>U. U \<in> \<C>}" @with
    @have "\<forall>U\<in>prod_basis(\<A>,open_sets(Y)). U \<in> {(A\<times>carrier(Y))\<inter>U. U \<in> \<C>}" @with
      @obtain "V\<in>\<A>" "W\<in>open_sets(Y)" where "U = V \<times> W"
      @obtain "V'\<in>open_sets(X)" where "V = A \<inter> V'"
      @have "U = A\<times>carrier(Y) \<inter> V'\<times>W" @end @end
@qed

section \<open>Continuous functions on product spaces\<close>

definition proj1_top :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "proj1_top(A,B) = Mor(A \<times>\<^sub>T B, A, \<lambda>p. fst(p))"

lemma proj1_top_is_morphism [typing]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> proj1_top(A,B) \<in> A \<times>\<^sub>T B \<rightharpoonup> A" by auto2
lemma proj1_top_eval [rewrite]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> p \<in> source(proj1_top(A,B)) \<Longrightarrow> proj1_top(A,B)`p = fst(p)" by auto2
setup {* del_prfstep_thm @{thm proj1_top_def} *}
setup {* add_rewrite_rule_back @{thm proj1_top_def} *}

lemma proj1_top_continuous [forward]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> continuous(proj1_top(A,B))"
@proof
  @let "f = proj1_top(A,B)"
  @have "\<forall>V\<in>open_sets(A). is_open(A\<times>\<^sub>TB, f -`` V)" @with
    @have "f -`` V = V \<times> carrier(B)" @end
@qed

lemma proj1_top_continuous' [backward]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> C \<subseteq> carrier(A) \<Longrightarrow>
   f = Mor(subspace(A,C) \<times>\<^sub>T B, A, \<lambda>p. fst(p)) \<Longrightarrow> continuous(f)"
@proof @have "f = inj_mor(subspace(A,C),A) \<circ>\<^sub>m proj1_top(subspace(A,C),B)" @qed

definition proj2_top :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "proj2_top(A,B) = Mor(A \<times>\<^sub>T B, B, \<lambda>p. snd(p))"

lemma proj2_top_is_morphism [typing]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> proj2_top(A,B) \<in> A \<times>\<^sub>T B \<rightharpoonup> B" by auto2
lemma proj2_top_eval [rewrite]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> p \<in> source(proj2_top(A,B)) \<Longrightarrow> proj2_top(A,B)`p = snd(p)" by auto2
setup {* del_prfstep_thm @{thm proj2_top_def} *}
setup {* add_rewrite_rule_back @{thm proj2_top_def} *}

lemma proj2_top_continuous [forward]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> continuous(proj2_top(A,B))"
@proof
  @let "f = proj2_top(A,B)"
  @have "\<forall>V\<in>open_sets(B). is_open(A\<times>\<^sub>TB, f -`` V)" @with
    @have "f -`` V = carrier(A) \<times> V" @end
@qed

lemma proj2_top_continuous' [backward]:
  "is_top_space(A) \<Longrightarrow> is_top_space(B) \<Longrightarrow> C \<subseteq> carrier(B) \<Longrightarrow>
   f = Mor(A \<times>\<^sub>T subspace(B,C), B, \<lambda>p. snd(p)) \<Longrightarrow> continuous(f)"
@proof @have "f = inj_mor(subspace(B,C),B) \<circ>\<^sub>m proj2_top(A,subspace(B,C))" @qed

definition diag_top_map :: "i \<Rightarrow> i" where [rewrite]:
  "diag_top_map(A) = Mor(A, A \<times>\<^sub>T A, \<lambda>x. \<langle>x,x\<rangle>)"

lemma diag_top_map_is_morphism [typing]:
  "is_top_space(A) \<Longrightarrow> diag_top_map(A) \<in> A \<rightharpoonup> A \<times>\<^sub>T A" by auto2
lemma diag_top_map_eval [rewrite]:
  "is_top_space(A) \<Longrightarrow> x \<in> source(diag_top_map(A)) \<Longrightarrow> diag_top_map(A)`x = \<langle>x,x\<rangle>" by auto2
setup {* del_prfstep_thm @{thm diag_top_map_def} *}

lemma diag_top_map_continuous [forward]:
  "is_top_space(A) \<Longrightarrow> continuous(diag_top_map(A))"
@proof
  @let "f = diag_top_map(A)"
  @let "\<B> = prod_basis(open_sets(A),open_sets(A))"
  @have "top_has_basis(A \<times>\<^sub>T A, \<B>)"
  @have "\<forall>V\<in>\<B>. is_open(A, f -`` V)" @with
    @obtain "U1\<in>open_sets(A)" "U2\<in>open_sets(A)" where "V = U1 \<times> U2"
    @have "f -`` V = U1 \<inter> U2" @end
@qed

definition prod_top_map :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "prod_top_map(u,v) = Mor(source_str(u) \<times>\<^sub>T source_str(v), target_str(u) \<times>\<^sub>T target_str(v), \<lambda>\<langle>x,y\<rangle>. \<langle>u`x, v`y\<rangle>)"

lemma prod_top_map_is_morphism [typing]:
  "is_morphism_top(u) \<Longrightarrow> is_morphism_top(v) \<Longrightarrow>
   prod_top_map(u,v) \<in> source_str(u) \<times>\<^sub>T source_str(v) \<rightharpoonup> target_str(u) \<times>\<^sub>T target_str(v)" by auto2

lemma prod_top_map_eval [rewrite]:
  "is_morphism_top(u) \<Longrightarrow> is_morphism_top(v) \<Longrightarrow>
   \<langle>x,y\<rangle> \<in> source(prod_top_map(u,v)) \<Longrightarrow> prod_top_map(u,v)`\<langle>x,y\<rangle> = \<langle>u`x, v`y\<rangle>" by auto2
setup {* del_prfstep_thm @{thm prod_top_map_def} *}

lemma prod_top_map_continuous [forward]:
  "continuous(u) \<Longrightarrow> continuous(v) \<Longrightarrow> continuous(prod_top_map(u,v))"
@proof
  @let "f = prod_top_map(u,v)"
  @let "A = source_str(u)" "B = source_str(v)"
  @let "C = target_str(u)" "D = target_str(v)"
  @let "\<B> = prod_basis(open_sets(C), open_sets(D))"
  @have "top_has_basis(C \<times>\<^sub>T D, \<B>)"
  @have "\<forall>V\<in>\<B>. is_open(A \<times>\<^sub>T B, f -`` V)" @with
    @obtain "U1\<in>open_sets(C)" "U2\<in>open_sets(D)" where "V = U1 \<times> U2"
    @have "f -`` V = (u -`` U1) \<times> (v -`` U2)" @end
@qed

definition incl1_top :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "incl1_top(X,Y,x) = Mor(Y, X \<times>\<^sub>T Y, \<lambda>y. \<langle>x,y\<rangle>)"
setup {* register_wellform_data ("incl1_top(X,Y,x)", ["x \<in>. X"]) *}

lemma incl1_top_eval [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in> source(incl1_top(X,Y,x)) \<Longrightarrow>
   incl1_top(X,Y,x)`y = \<langle>x,y\<rangle>" by auto2

lemma incl1_top_continuous [typing]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> x \<in>. X \<Longrightarrow> incl1_top(X,Y,x) \<in> Y \<rightharpoonup>\<^sub>T X \<times>\<^sub>T Y"
@proof
  @let "f = incl1_top(X,Y,x)"
  @let "B = prod_basis(open_sets(X),open_sets(Y))"
  @have "top_has_basis(X \<times>\<^sub>T Y, B)"
  @have "\<forall>W\<in>B. is_open(Y, f -`` W)" @with
    @obtain "U\<in>open_sets(X)" "V\<in>open_sets(Y)" where "W = U \<times> V"
    @case "x \<in> U" @with @have "f -`` W = V" @end
    @case "x \<notin> U" @with @have "f -`` W = \<emptyset>" @end
  @end
@qed
setup {* del_prfstep_thm @{thm incl1_top_def} *}

definition incl2_top :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "incl2_top(X,Y,y) = Mor(X, X \<times>\<^sub>T Y, \<lambda>x. \<langle>x,y\<rangle>)"
setup {* register_wellform_data ("incl2_top(X,Y,y)", ["y \<in>. Y"]) *}

lemma incl2_top_eval [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> y \<in>. Y \<Longrightarrow> x \<in> source(incl2_top(X,Y,y)) \<Longrightarrow>
   incl2_top(X,Y,y)`x = \<langle>x,y\<rangle>" by auto2

lemma incl2_top_continuous [typing]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> y \<in>. Y \<Longrightarrow> incl2_top(X,Y,y) \<in> X \<rightharpoonup>\<^sub>T X \<times>\<^sub>T Y"
@proof
  @let "f = incl2_top(X,Y,y)"
  @let "B = prod_basis(open_sets(X),open_sets(Y))"
  @have "top_has_basis(X \<times>\<^sub>T Y, B)"
  @have "\<forall>W\<in>B. is_open(X, f -`` W)" @with
    @obtain "U\<in>open_sets(X)" "V\<in>open_sets(Y)" where "W = U \<times> V"
    @case "y \<in> V" @with @have "f -`` W = U" @end
    @case "y \<notin> V" @with @have "f -`` W = \<emptyset>" @end
  @end
@qed
setup {* del_prfstep_thm @{thm incl2_top_def} *}

(* Homeomorphisms on product spaces *)
lemma product_slice1 [typing]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> x \<in>. X \<Longrightarrow> A = {x} \<times> carrier(Y) \<Longrightarrow>
   f = mor_restrict_image_top(incl1_top(X,Y,x),A) \<Longrightarrow> f \<in> Y \<cong>\<^sub>T subspace(X \<times>\<^sub>T Y, A)"
@proof
  @let "g = proj2_top(X,Y) \<circ>\<^sub>m inj_mor(subspace(X \<times>\<^sub>T Y, A), X \<times>\<^sub>T Y)"
  @have "inverse_mor_pair(f,g)"
@qed

lemma product_slice1' [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> x \<in>. X \<Longrightarrow> A = {x} \<times> carrier(Y) \<Longrightarrow>
   homeomorphic(Y, subspace(X \<times>\<^sub>T Y, A))"
@proof
  @have "mor_restrict_image_top(incl1_top(X,Y,x),A) \<in> Y \<cong>\<^sub>T subspace(X \<times>\<^sub>T Y, A)"
@qed

lemma product_slice2 [typing]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> y \<in>. Y \<Longrightarrow> A = carrier(X) \<times> {y} \<Longrightarrow>
   f = mor_restrict_image_top(incl2_top(X,Y,y),A) \<Longrightarrow> f \<in> X \<cong>\<^sub>T subspace(X \<times>\<^sub>T Y, A)"
@proof
  @let "g = proj1_top(X,Y) \<circ>\<^sub>m inj_mor(subspace(X \<times>\<^sub>T Y, A), X \<times>\<^sub>T Y)"
  @have "inverse_mor_pair(f,g)"
@qed

lemma product_slice2' [backward]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> y \<in>. Y \<Longrightarrow> A = carrier(X) \<times> {y} \<Longrightarrow>
   homeomorphic(X, subspace(X \<times>\<^sub>T Y, A))"
@proof
  @have "mor_restrict_image_top(incl2_top(X,Y,y),A) \<in> X \<cong>\<^sub>T subspace(X \<times>\<^sub>T Y, A)"
@qed

end


section \<open> Alternating lists \<close>

text \<open>In lists where even and odd elements play different roles, it helps to define functions to
      take out the even elements. We defined the function (l)alternate on (coinductive) lists to
      do exactly this, and define certain properties.\<close>

theory AlternatingLists
  imports MoreCoinductiveList2 (* for notation and lemmas like infinite_small_llength *)
begin

text \<open>The functions ``alternate" and ``lalternate" are our main workhorses:
      they take every other item, so every item at even indices.\<close>

fun alternate where
  "alternate Nil = Nil" |
  "alternate (Cons x xs) = Cons x (alternate (tl xs))"

text \<open>``lalternate" takes every other item from a co-inductive list.\<close>
primcorec lalternate :: "'a llist \<Rightarrow> 'a llist"
  where
    "lalternate xs = (case xs of LNil \<Rightarrow> LNil |
                                 (LCons x xs) \<Rightarrow> LCons x (lalternate (ltl xs)))"

lemma lalternate_ltake:
  "ltake (enat n) (lalternate xs) = lalternate (ltake (2*n) xs)"
proof(induct n arbitrary:xs)
  case 0
  then show ?case by (metis LNil_eq_ltake_iff enat_defs(1) lalternate.ctr(1) lnull_def mult_zero_right)
next
  case (Suc n)
  hence lt:"ltake (enat n) (lalternate (ltl (ltl xs))) = lalternate (ltake (enat (2 * n)) (ltl (ltl xs)))".
  show ?case
  proof(cases "lalternate xs")
    case LNil
    then show ?thesis by(metis lalternate.disc(2) lnull_def ltake_LNil)
  next
    case (LCons x21 x22)
    thus ?thesis unfolding ltake_ltl mult_Suc_right add_2_eq_Suc
      using eSuc_enat lalternate.code lalternate.ctr(1) lhd_LCons_ltl llist.sel(1)
      by (smt (z3) lt ltake_ltl llist.simps(3) llist.simps(5) ltake_eSuc_LCons)
  qed
qed

lemma lalternate_llist_of[simp]:
  "lalternate (llist_of xs) = llist_of (alternate xs)"
proof(induct "alternate xs" arbitrary:xs)
  case Nil
  then show ?case
    by (metis alternate.elims lalternate.ctr(1) list.simps(3) llist_of.simps(1) lnull_llist_of)
next
  case (Cons a xs)
  then show ?case by(cases xs,auto simp: lalternate.ctr)
qed

lemma lalternate_finite_helper: (* The other direction is proved later, added as SIMP rule *)
  assumes "lfinite (lalternate xs)"
  shows "lfinite xs"
using assms proof(induct "lalternate xs" arbitrary:xs rule:lfinite_induct)
  case LNil
  then show ?case unfolding lalternate.code[of xs] by(cases xs;auto)
next
  case (LCons xs)
  then show ?case unfolding lalternate.code[of xs] by(cases "xs";cases "ltl xs";auto)
qed

lemma alternate_list_of: (* Note that this only holds for finite lists,
                    as the other direction is left undefined with arguments (not just undefined) *)
  assumes "lfinite xs"
  shows "alternate (list_of xs) = list_of (lalternate xs)"
  using assms by (metis lalternate_llist_of list_of_llist_of llist_of_list_of)

lemma alternate_length:
  "length (alternate xs) = (1+length xs) div 2"
  by (induct xs rule:induct_list012;simp)

lemma lalternate_llength:
  "llength (lalternate xs) * 2 = (1+llength xs) \<or> llength (lalternate xs) * 2 = llength xs"
proof(cases "lfinite xs")
  case True
  let ?xs = "list_of xs"
  have "length (alternate ?xs) = (1+length ?xs) div 2" using alternate_length by auto
  hence "length (alternate ?xs) * 2 = (1+length ?xs) \<or> length (alternate ?xs) * 2 = length ?xs"
    by auto
  then show ?thesis using alternate_list_of[OF True] lalternate_llist_of True
    length_list_of_conv_the_enat[OF True] llist_of_list_of[OF True]
    by (metis llength_llist_of numeral_One of_nat_eq_enat of_nat_mult of_nat_numeral plus_enat_simps(1))
next
  case False
  have "\<not> lfinite (lalternate xs)" using False lalternate_finite_helper by auto
  hence l1:"llength (lalternate xs) = \<infinity>" by(rule not_lfinite_llength)
  from False have l2:"llength xs = \<infinity>" using not_lfinite_llength by auto
  show ?thesis using l1 l2 by (simp add: mult_2_right)
qed

lemma lalternate_finite[simp]:
  shows "lfinite (lalternate xs) = lfinite xs"
proof(cases "lfinite xs")
  case True
  then show ?thesis
  proof(cases "lfinite (lalternate xs)")
    case False
    hence False using not_lfinite_llength[OF False] True[unfolded lfinite_conv_llength_enat]
                      lalternate_llength[of xs]
                by (auto simp:one_enat_def numeral_eq_enat)
    thus ?thesis by metis
  qed auto
next
  case False
  then show ?thesis using lalternate_finite_helper by blast
qed

lemma nth_alternate:
  assumes "2*n < length xs"
  shows "alternate xs ! n = xs ! (2 * n)"
  using assms proof (induct xs arbitrary:n rule:induct_list012)
  case (3 x y zs)
  then show ?case proof(cases n)
    case (Suc nat)
    show ?thesis using "3.hyps"(1) "3.prems" Suc by force
  qed simp
qed auto

lemma lnth_lalternate:
  assumes "2*n < llength xs"
  shows "lalternate xs $ n = xs $ (2 * n)"
proof -
  let ?xs = "ltake (2*Suc n) xs"
  have "lalternate ?xs $ n = ?xs $ (2 * n)"
    using assms alternate_list_of[of "ltake (2*Suc n) xs"] nth_alternate[of n "list_of ?xs"]
    by (smt (z3) Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) infinite_small_llength lalternate_ltake length_list_of lessI llength_eq_enat_lfiniteD llength_ltake' ltake_all not_less nth_list_of numeral_eq_enat the_enat.simps times_enat_simps(1))
  thus ?thesis
    by (metis Suc_1 Suc_mult_less_cancel1 enat_ord_simps(2) lalternate_ltake lessI lnth_ltake)
qed

lemma lnth_lalternate2[simp]:
  assumes "n < llength (lalternate xs)"
  shows "lalternate xs $ n = xs $ (2 * n)"
proof -
  from assms have "2*enat n < llength xs"
    by (metis enat_numeral lalternate_ltake leI linorder_neq_iff llength_ltake' ltake_all times_enat_simps(1))
  from lnth_lalternate[OF this] show ?thesis.
qed

end


(*  Title:      HOL/Isar_Examples/Knaster_Tarski.thy
    Author:     Makarius

Typical textbook proof example.
*)

section \<open>Textbook-style reasoning: the Knaster-Tarski Theorem\<close>

theory Knaster_Tarski
  imports Main "HOL-Library.Lattice_Syntax"
begin

subsection \<open>Prose version\<close>

text \<open>
  According to the textbook @{cite \<open>pages 93--94\<close> "davey-priestley"}, the
  Knaster-Tarski fixpoint theorem is as follows.\<^footnote>\<open>We have dualized the
  argument, and tuned the notation a little bit.\<close>

  \<^bold>\<open>The Knaster-Tarski Fixpoint Theorem.\<close> Let \<open>L\<close> be a complete lattice and
  \<open>f: L \<rightarrow> L\<close> an order-preserving map. Then \<open>\<Sqinter>{x \<in> L | f(x) \<le> x}\<close> is a fixpoint
  of \<open>f\<close>.

  \<^bold>\<open>Proof.\<close> Let \<open>H = {x \<in> L | f(x) \<le> x}\<close> and \<open>a = \<Sqinter>H\<close>. For all \<open>x \<in> H\<close> we have
  \<open>a \<le> x\<close>, so \<open>f(a) \<le> f(x) \<le> x\<close>. Thus \<open>f(a)\<close> is a lower bound of \<open>H\<close>, whence
  \<open>f(a) \<le> a\<close>. We now use this inequality to prove the reverse one (!) and
  thereby complete the proof that \<open>a\<close> is a fixpoint. Since \<open>f\<close> is
  order-preserving, \<open>f(f(a)) \<le> f(a)\<close>. This says \<open>f(a) \<in> H\<close>, so \<open>a \<le> f(a)\<close>.\<close>

subsection \<open>Formal versions\<close>

text \<open>
  The Isar proof below closely follows the original presentation. Virtually
  all of the prose narration has been rephrased in terms of formal Isar
  language elements. Just as many textbook-style proofs, there is a strong
  bias towards forward proof, and several bends in the course of reasoning.
\<close>

theorem Knaster_Tarski:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof -
    {
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally have "f ?a \<le> x" .
    }
    then have "f ?a \<le> ?a" by (rule Inf_greatest)
    {
      also presume "\<dots> \<le> f ?a"
      finally (order_antisym) show ?thesis .
    }
    from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
    then have "f ?a \<in> ?H" ..
    then show "?a \<le> f ?a" by (rule Inf_lower)
  qed
qed

text \<open>
  Above we have used several advanced Isar language elements, such as explicit
  block structure and weak assumptions. Thus we have mimicked the particular
  way of reasoning of the original text.

  In the subsequent version the order of reasoning is changed to achieve
  structured top-down decomposition of the problem at the outer level, while
  only the inner steps of reasoning are done in a forward manner. We are
  certainly more at ease here, requiring only the most basic features of the
  Isar language.
\<close>

theorem Knaster_Tarski':
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof (rule order_antisym)
    show "f ?a \<le> ?a"
    proof (rule Inf_greatest)
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally show "f ?a \<le> x" .
    qed
    show "?a \<le> f ?a"
    proof (rule Inf_lower)
      from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
      then show "f ?a \<in> ?H" ..
    qed
  qed
qed

end