(* Author: Thiemann *)
section \<open>Combining Spectral Radius Theory with Perron Frobenius theorem\<close>

theory Spectral_Radius_Theory_2
imports
  Spectral_Radius_Largest_Jordan_Block
  Hom_Gauss_Jordan
begin

hide_const(open) Coset.order

lemma jnf_complexity_generic: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  and sr: "\<And> x. poly (char_poly A) x = 0 \<Longrightarrow> cmod x \<le> 1"
  and 1: "\<And> x. poly (char_poly A) x = 0 \<Longrightarrow> cmod x = 1 \<Longrightarrow>
    order x (char_poly A) > d + 1 \<Longrightarrow>
    (\<forall> bsize \<in> fst ` set (compute_set_of_jordan_blocks A x). bsize \<le> d + 1)"
shows "\<exists>c1 c2. \<forall>k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ d)"
proof -
  from char_poly_factorized[OF A] obtain as where cA: "char_poly A = (\<Prod>a\<leftarrow>as. [:- a, 1:])"
    and lenn: "length as = n" by auto
  from jordan_nf_exists[OF A cA] obtain n_xs where jnf: "jordan_nf A n_xs" ..
  have dd: "x ^ d = x ^((d + 1) - 1)" for x by simp
  show ?thesis unfolding dd
  proof (rule jordan_nf_matrix_poly_bound[OF A _ _ jnf])
    fix n x
    assume nx: "(n,x) \<in> set n_xs"
    from jordan_nf_block_size_order_bound[OF jnf nx]
    have no: "n \<le> order x (char_poly A)" by auto
    {
      assume "0 < n"
      with no have "order x (char_poly A) \<noteq> 0" by auto
      hence rt: "poly (char_poly A) x = 0" unfolding order_root by auto
      from sr[OF this] show "cmod x \<le> 1" .
      note rt
    } note sr = this
    assume c1: "cmod x = 1"
    show "n \<le> d + 1"
    proof (rule ccontr)
      assume "\<not> n \<le> d + 1"
      hence lt: "n > d + 1" by auto
      with sr have rt: "poly (char_poly A) x = 0" by auto
      from lt no have ord: "d + 1 < order x (char_poly A)" by auto
      from 1[OF rt c1 ord, unfolded compute_set_of_jordan_blocks[OF jnf]] nx lt
      show False by force
    qed
  qed
qed

lemma norm_bound_complex_to_real: fixes A :: "real mat"
  assumes A: "A \<in> carrier_mat n n"
    and bnd: "\<exists>c1 c2. \<forall>k. norm_bound ((map_mat complex_of_real A) ^\<^sub>m k) (c1 + c2 * of_nat k ^ d)"
  shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> abs a \<le> (c1 + c2 * of_nat k ^ d)"
proof -
  let ?B = "map_mat complex_of_real A"
  from bnd obtain c1 c2 where nb: "\<And> k. norm_bound (?B ^\<^sub>m k) (c1 + c2 * real k ^ d)" by auto
  show ?thesis
  proof (rule exI[of _ c1], rule exI[of _ c2], intro allI impI)
    fix k a
    assume "a \<in> elements_mat (A ^\<^sub>m k)"
    with pow_carrier_mat[OF A] obtain i j where a: "a = (A ^\<^sub>m k) $$ (i,j)" and ij: "i < n" "j < n"
      unfolding elements_mat by force
    from ij nb[of k] A have "norm ((?B ^\<^sub>m k) $$ (i,j)) \<le> c1 + c2 * real k ^ d"
      unfolding norm_bound_def by auto
    also have "(?B ^\<^sub>m k) $$ (i,j) = of_real a"
      unfolding of_real_hom.mat_hom_pow[OF A, symmetric] a using ij A by auto
    also have "norm (complex_of_real a) = abs a" by auto
    finally show "abs a \<le> (c1 + c2 * real k ^ d)" .
  qed
qed

lemma dim_gen_eigenspace_max_jordan_block: assumes jnf: "jordan_nf A n_as"
  shows "dim_gen_eigenspace A l d = order l (char_poly A) \<longleftrightarrow>
    (\<forall> n. (n,l) \<in> set n_as \<longrightarrow> n \<le> d)"
proof -
  let ?list = "[(n, e)\<leftarrow>n_as . e = l]"
  define list where "list = [na\<leftarrow>n_as . snd na = l]"
  have list: "?list = list" unfolding list_def by (induct n_as, force+)
  have id: "(\<forall>n. (n, l) \<in> set n_as \<longrightarrow> n \<le> d) = (\<forall> n \<in> set (map fst list). n \<le> d)"
    unfolding list_def by auto
  define ns where "ns = map fst list"
  show ?thesis
    unfolding dim_gen_eigenspace[OF jnf] jordan_nf_order[OF jnf] list list_def[symmetric] id
    unfolding ns_def[symmetric]
  proof (induct ns)
    case (Cons n ns)
    show ?case
    proof (cases "n \<le> d")
      case True
      thus ?thesis using Cons by auto
    next
      case False
      hence "n > d" by auto
      moreover have "sum_list (map (min d) ns) \<le> sum_list ns" by (induct ns, auto)
      ultimately show ?thesis by auto
    qed
  qed auto
qed

lemma jnf_complexity_1_complex: fixes A :: "complex mat"
  assumes A: "A \<in> carrier_mat n n"
  and nonneg: "real_nonneg_mat A"
  and sr: "\<And> x. poly (char_poly A) x = 0 \<Longrightarrow> cmod x \<le> 1"
  and 1: "poly (char_poly A) 1 = 0 \<Longrightarrow>
    order 1 (char_poly A) > d + 1 \<Longrightarrow>
    dim_gen_eigenspace A 1 (d+1) = order 1 (char_poly A)"
shows "\<exists>c1 c2. \<forall>k. norm_bound (A ^\<^sub>m k) (c1 + c2 * of_nat k ^ d)"
proof -
  from char_poly_factorized[OF A] obtain as where cA: "char_poly A = (\<Prod>a\<leftarrow>as. [:- a, 1:])"
    and lenn: "length as = n" by auto
  from jordan_nf_exists[OF A cA] obtain n_as where jnf: "jordan_nf A n_as" ..
  have dd: "x ^ d = x ^((d + 1) - 1)" for x by simp
  let ?n = n
  show ?thesis unfolding dd
  proof (rule jordan_nf_matrix_poly_bound[OF A _ _ jnf])
    fix n a
    assume na: "(n,a) \<in> set n_as"
    from jordan_nf_root_char_poly[OF jnf na]
    have rt: "poly (char_poly A) a = 0" by auto
    with degree_monic_char_poly[OF A] have n0: "?n > 0"
      by (cases ?n, auto dest: degree0_coeffs)
    from sr[OF rt] show "cmod a \<le> 1" .
    assume a: "cmod a = 1"
    from rt have "a \<in> spectrum A" using A spectrum_root_char_poly by auto
    hence 11: "1 \<in> cmod ` spectrum A" using a by auto
    note spec = spectral_radius_mem_max[OF A n0]
    from spec(2)[OF 11] have le: "1 \<le> spectral_radius A" .
    from spec(1)[unfolded spectrum_root_char_poly[OF A]] sr have "spectral_radius A \<le> 1" by auto
    with le have sr: "spectral_radius A = 1" by auto
    show "n \<le> d + 1"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence nd: "n > d + 1" by auto
      from real_nonneg_mat_spectral_radius_largest_jordan_block[OF nonneg jnf na, unfolded sr a]
      obtain N where N: "N \<ge> n" and mem: "(N, 1) \<in> set n_as" by auto
      from jordan_nf_root_char_poly[OF jnf mem] have rt: "poly (char_poly A) 1 = 0" .
      from jordan_nf_block_size_order_bound[OF jnf mem] have "N \<le> order 1 (char_poly A)" .
      with N nd have "d + 1 < order 1 (char_poly A)" by simp
      from 1[OF rt this, unfolded dim_gen_eigenspace_max_jordan_block[OF jnf]] mem N nd
      show False by force
    qed
  qed
qed

lemma jnf_complexity_1_real: fixes A :: "real mat"
  assumes A: "A \<in> carrier_mat n n"
  and nonneg: "nonneg_mat A"
  and sr: "\<And> x. poly (char_poly A) x = 0 \<Longrightarrow> x \<le> 1"
  and jb: "poly (char_poly A) 1 = 0 \<Longrightarrow>
    order 1 (char_poly A) > d + 1 \<Longrightarrow>
    dim_gen_eigenspace A 1 (d+1) = order 1 (char_poly A)"
shows "\<exists>c1 c2. \<forall>k a. a \<in> elements_mat (A ^\<^sub>m k) \<longrightarrow> \<bar>a\<bar> \<le> c1 + c2 * real k ^ d"
proof -
  let ?c = "complex_of_real"
  let ?A = "map_mat ?c A"
  have A': "?A \<in> carrier_mat n n" using A by auto
  have nn: "real_nonneg_mat ?A" using nonneg A unfolding nonneg_mat_def real_nonneg_mat_def
    by (force simp: elements_mat)
  have 1: "1 = ?c 1" by auto
  note cp = of_real_hom.char_poly_hom[OF A]
  have hom: "map_poly_inj_idom_divide_hom complex_of_real" ..
  show ?thesis
  proof (rule norm_bound_complex_to_real[OF A jnf_complexity_1_complex[OF A' nn]],
      unfold cp of_real_hom.poly_map_poly_1, unfold 1
      of_real_hom.hom_dim_gen_eigenspace[OF A]
      map_poly_inj_idom_divide_hom.order_hom[OF hom], goal_cases)
    case 2
    thus ?case using jb by auto
  next
    case (1 x)
    let ?cp = "char_poly A"
    assume rt: "poly (map_poly ?c ?cp) x = 0"
    with degree_monic_char_poly[OF A', unfolded cp] have n0: "n \<noteq> 0"
      using degree0_coeffs[of ?cp] by (cases n, auto)
    from perron_frobenius_nonneg[OF A nonneg n0]
    obtain sr ks f where sr0: "0 \<le> sr" and ks: "0 \<notin> set ks" "ks \<noteq> []"
      and cp: "?cp = (\<Prod>k\<leftarrow>ks. monom 1 k - [:sr ^ k:]) * f"
      and rtf: "poly (map_poly ?c f) x = 0 \<Longrightarrow> cmod x < sr" by auto
    have sr_rt: "poly ?cp sr = 0" unfolding cp poly_prod_list_zero_iff poly_mult_zero_iff using ks
      by (cases ks, auto simp: poly_monom)
    from sr[OF sr_rt] have sr1: "sr \<le> 1" .
    interpret c: map_poly_comm_ring_hom ?c ..
    from rt[unfolded cp c.hom_mult c.hom_prod_list poly_mult_zero_iff poly_prod_list_zero_iff]
    show "cmod x \<le> 1"
    proof (standard, goal_cases)
      case 2
      with rtf sr1 show ?thesis by auto
    next
      case 1
      from this ks obtain p where p: "p \<in> set ks"
        and rt: "poly (map_poly ?c (monom 1 p - [:sr ^ p:])) x = 0" by auto
      from p ks(1) have p: "p \<noteq> 0" by metis
      from rt have "x^p = (?c sr)^p" unfolding c.hom_minus
        by (simp add: poly_monom of_real_hom.map_poly_pCons_hom)
      hence "cmod x = cmod (?c sr)" using p power_eq_imp_eq_norm by blast
      with sr0 sr1 show "cmod x \<le> 1" by auto
    qed
  qed
qed
end


theory boolean_algebra
  imports Main
begin
(*----------- Technicalities--------*)
declare[[smt_timeout=30]]
declare[[show_types]]
(* declare[[syntax_ambiguity_warning=false]] *)
sledgehammer_params[isar_proof=false]
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3, atoms=a b c d] (*default Nitpick settings*)
(*we hide some Isabelle/HOL notation from the libraries (which we don't use) to avoid overloading*)
hide_const(open) List.list.Nil no_notation List.list.Nil ("[]")  (*We have no use for lists... *)
hide_const(open) Relation.converse no_notation Relation.converse ("(_\<inverse>)" [1000] 999) (*..nor for relations in this work*)
hide_const(open) Fun.comp no_notation Fun.comp (infixl "\<circ>" 55) (*we redefine function composition below*)
hide_const(open) Groups.plus_class.plus no_notation Groups.plus_class.plus (infixl "+" 65) (*we don't use this*)
hide_const(open) Groups.times_class.times no_notation Groups.times_class.times (infixl "*" 70) (*we don't use this*)
hide_const(open) Groups.minus_class.minus no_notation Groups.minus_class.minus (infixl "-" 65) (*we don't use this*)
hide_const(open) Groups.uminus_class.uminus no_notation Groups.uminus_class.uminus ("- _" [81] 80) (*we don't use this*)
(*---------------------------------*)

abbreviation "isEmpty S \<equiv> \<forall>x. \<not>S x"
abbreviation "nonEmpty S \<equiv> \<exists>x. S x"

(**Function composition.*)
definition fun_comp :: "('b \<Rightarrow> 'c) \<Rightarrow> ( 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "\<circ>" 75)
  where "\<phi> \<circ> \<psi> \<equiv> \<lambda>x. \<phi> (\<psi> x)"

(**Inverse projection maps a unary function to a 'projected' binary function wrt. its 1st argument.*)
abbreviation inv_proj::\<open>('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c)\<close> ("(_)\<up>")
  where "D\<up> \<equiv> \<lambda>A B. D A"

(**Image of a mapping  @{text "\<phi>"}, with range as an special case.*)
definition image::"('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)" ("\<lbrakk>_ _\<rbrakk>")
  where "\<lbrakk>\<phi> S\<rbrakk> \<equiv> \<lambda>y. \<exists>x. (S x) \<and> (\<phi> x) = y"
definition range::"('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> bool)" ("\<lbrakk>_'_\<rbrakk>")
  where "\<lbrakk>\<phi> _\<rbrakk> \<equiv> \<lambda>Y. \<exists>x. (\<phi> x) = Y"
lemma range_char1: "\<lbrakk>\<phi> _\<rbrakk> = \<lbrakk>\<phi> (\<lambda>x. True)\<rbrakk>" by (simp add: image_def range_def)
lemma range_char2: "\<lbrakk>\<phi> _\<rbrakk> = (\<lambda>X. \<exists>S. \<lbrakk>\<phi> S\<rbrakk> X)" unfolding range_def image_def by blast

lemma image_comp: "\<lbrakk>(f \<circ> g) S\<rbrakk> = \<lbrakk>f \<lbrakk>g S\<rbrakk>\<rbrakk>" unfolding fun_comp_def image_def by metis

section \<open>Shallow semantical embedding of (a logic of) Boolean algebras\<close>

(**We encode Boolean algebras via their (Stone) representation as algebras of sets ('fields of sets').
This means that each element of (the carrier of) the algebra will be a set of `points'.
Inspired by the 'propositions as sets of worlds' paradigm from modal logic, we can sometimes refer
to points as 'worlds', and thus to the elements of our Boolean algebras as 'propositions'.
However, this is only one possibility, since points can themselves be taken as sets (e.g. of `worlds')
and thus as 'propositions'. In such a case the elements of our Boolean algebras might correspond
to 'theories' (i.e. sets of 'propositions').*)

(**We utilize a particular naming convention: The type parameter @{type "'w"} is employed for the
domain/universe of `points'. We conveniently introduce the (parametric) type-alias @{type "'w \<sigma>"}
as shorthand for @{type "'w\<Rightarrow>bool"}. Hence, the elements of our algebra are objects of type @{type "'w \<sigma>"},
and thus correspond to (characteristic functions of) sets of `points'. Observe that the type parameter
'w can itself correspond to a 'set type', and so elements of our algebras can have type @{type "('w \<sigma>)\<sigma>"}.
Set-valued (set-domain) functions are thus functions that have sets (of points) as their codomain (domain),
they are basically anything with a (parametric) type @{type "'i\<Rightarrow>'w \<sigma>"} (@{type "'w \<sigma>\<Rightarrow>'i"}).*)

type_synonym 'w \<sigma> = \<open>'w \<Rightarrow> bool\<close> (*type for (characteristic functions of) sets (of points)*)

(**In the sequel, we will (try to) enforce the following naming convention:

(i) Upper-case latin letters (A, B, D, M, P, S, X, etc.) denote arbitrary sets (type @{type "'w \<sigma>"}).
We will employ lower-case letters (p, q, x, w, etc.) to denote variables playing the role of 'points'.
In some contexts, the letters S and D will be employed to denote sets/domains of sets (of 'points').

(ii) Greek letters denote arbitrary set-valued functions (type @{type "'i\<Rightarrow>'w \<sigma>"} aliased @{type "('i \<Rightarrow> 'w \<sigma>)"}).
We employ the letters @{text "\<phi>"}, @{text "\<psi>"} and @{text "\<eta>"} to denote arbitrary unary operations
(with type @{type "'w \<sigma> \<Rightarrow> 'w \<sigma>"}); and the letters @{text "\<xi>"} and @{text "\<delta>"} to denote
arbitrary binary operations (with type @{type "'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>"}).

(iii) Upper-case calligraphic letters (\<B>, \<I>, \<C>, \<P>, etc.) are reserved for unary operations that are
intended to act as so-called 'topological operators' in the given context.
*)

subsection \<open>Encoding Boolean operations\<close>

(**Standard inclusion-based order structure on sets.*)
definition subset::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> bool" (infixr "\<preceq>" 45)
  where "A \<preceq> B \<equiv> \<forall>p. A p \<longrightarrow> B p"
definition setequ::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> bool" (infixr "\<approx>" 45)
  where "A \<approx> B \<equiv> \<forall>p. A p \<longleftrightarrow> B p"

named_theorems order (*to group together order-related definitions*)
declare setequ_def[order] subset_def[order]

lemma subset_char1: "(A \<preceq> B) = (\<forall>C. B \<preceq> C \<longrightarrow> A \<preceq> C)" by (metis subset_def)
lemma subset_char2: "(A \<preceq> B) = (\<forall>C. C \<preceq> A \<longrightarrow> C \<preceq> B)" by (metis subset_def)

(**These (trivial) lemmas are intended to help automated tools with equational reasoning.*)
lemma setequ_char: "(A \<approx> B) = (A \<preceq> B \<and> B \<preceq> A)" unfolding order by blast
lemma setequ_ext: "(A \<approx> B) = (A = B)" unfolding order by blast

(**We now encode connectives for (distributive and complemented) bounded lattices, mostly
by reusing their counterpart meta-logical HOL connectives,*)
definition meet::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<and>" 54)
  where "A \<^bold>\<and> B \<equiv> \<lambda>p. (A p) \<and> (B p)" (**intersection*)
definition join::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<or>" 53)
  where "A \<^bold>\<or> B \<equiv> \<lambda>p. (A p) \<or> (B p)" (**union*)
definition top::"'w \<sigma>" ("\<^bold>\<top>")
  where "\<^bold>\<top> \<equiv> \<lambda>w. True"   (**universe*)
definition bottom::"'w \<sigma>" ("\<^bold>\<bottom>")
  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"  (**empty-set*)

(**and introduce further operations to obtain a Boolean algebra (of sets).*)
definition compl::"'w \<sigma> \<Rightarrow> 'w \<sigma>" ("\<^bold>\<midarrow>_"[57]58)
  where "\<^bold>\<midarrow>A  \<equiv> \<lambda>p. \<not>(A p)" (** (set-)complement*)
definition impl::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<rightarrow>" 51)
  where "A \<^bold>\<rightarrow> B \<equiv> \<lambda>p. (A p) \<longrightarrow> (B p)" (** (set-)implication*)
definition diff::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<leftharpoonup>" 51)
  where "A \<^bold>\<leftharpoonup> B \<equiv> \<lambda>p. (A p) \<and> \<not>(B p)" (** (set-)difference*)
definition dimpl::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<leftrightarrow>" 51)
(* definition dimpl (infixr "\<^bold>\<leftrightarrow>" 51)  *)
  where "A \<^bold>\<leftrightarrow> B \<equiv> \<lambda>p. (A p) = (B p)" (** double implication*)
definition sdiff::"'w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>" (infixr "\<^bold>\<triangle>" 51)
(* definition sdiff (infixr "\<^bold>\<triangle>" 51)  *)
  where "A \<^bold>\<triangle> B \<equiv> \<lambda>p. (A p) \<noteq> (B p)" (** symmetric difference (aka. xor) *)

named_theorems conn (*to group together definitions for algebraic connectives*)
declare meet_def[conn] join_def[conn] top_def[conn] bottom_def[conn]
        impl_def[conn] dimpl_def[conn] diff_def[conn] sdiff_def[conn] compl_def[conn]

(**Verify characterization for some connectives.*)
lemma compl_char: "\<^bold>\<midarrow>A = A \<^bold>\<rightarrow> \<^bold>\<bottom>" unfolding conn by simp
lemma impl_char: "A \<^bold>\<rightarrow> B = \<^bold>\<midarrow>A \<^bold>\<or> B" unfolding conn by simp
lemma dimpl_char: "A \<^bold>\<leftrightarrow> B = (A \<^bold>\<rightarrow> B) \<^bold>\<and> (B \<^bold>\<rightarrow> A)" unfolding conn by blast
lemma diff_char1: "A \<^bold>\<leftharpoonup> B = A \<^bold>\<and> \<^bold>\<midarrow>B" unfolding conn by simp
lemma diff_char2: "A \<^bold>\<leftharpoonup> B = \<^bold>\<midarrow>(A \<^bold>\<rightarrow> B)" unfolding conn by simp
lemma sdiff_char1: "A \<^bold>\<triangle> B = (A \<^bold>\<leftharpoonup> B) \<^bold>\<or> (B \<^bold>\<leftharpoonup> A)" unfolding conn by blast
lemma sdiff_char2: "A \<^bold>\<triangle> B = \<^bold>\<midarrow>(A \<^bold>\<leftrightarrow> B)" unfolding conn by simp

(**We can verify that (quite trivially) this algebra satisfies some properties of lattices.*)
lemma L1: "A \<approx> A \<^bold>\<or> A" unfolding conn order by simp
lemma L2: "A \<approx> A \<^bold>\<and> A" unfolding conn order by simp
lemma L3: "A \<preceq> A \<^bold>\<or> B" unfolding conn order by simp
lemma L4: "A \<^bold>\<and> B \<preceq> A" unfolding conn order by simp
lemma L5: "(A \<^bold>\<and> B) \<^bold>\<or> B \<approx> B" unfolding setequ_char conn order by simp
lemma L6: "A \<^bold>\<and> (A \<^bold>\<or> B) \<approx> A" unfolding setequ_char conn order by simp
lemma L7: "A \<preceq> C \<and> B \<preceq> C \<longrightarrow> A \<^bold>\<or> B \<preceq> C" unfolding conn order by simp
lemma L8: "C \<preceq> A \<and> C \<preceq> B \<longrightarrow> C \<preceq> A \<^bold>\<and> B" unfolding conn order by simp
lemma L9:  "A \<preceq> B \<longleftrightarrow> (A \<^bold>\<or> B) \<approx> B" unfolding setequ_char conn order by simp
lemma L10: "B \<preceq> A \<longleftrightarrow> (A \<^bold>\<and> B) \<approx> B" unfolding setequ_char conn order by simp
lemma L11: "A \<preceq> B \<and> C \<preceq> D \<longrightarrow> A \<^bold>\<or> C \<preceq> B \<^bold>\<or> D" unfolding conn order by simp
lemma L12: "A \<preceq> B \<and> C \<preceq> D \<longrightarrow> A \<^bold>\<and> C \<preceq> B \<^bold>\<and> D" unfolding conn order by simp
lemma L13: "A \<^bold>\<and> \<^bold>\<top> \<approx> A" unfolding conn order by simp
lemma L14: "A \<^bold>\<or> \<^bold>\<bottom> \<approx> A" unfolding conn order by simp
lemma L15: "A \<preceq> B \<longleftrightarrow> (\<forall>C. C \<^bold>\<and> A \<preceq> C \<^bold>\<and> B)" by (metis L3 L4 L5 L8 setequ_char subset_char1)
lemma L16: "A \<preceq> B \<longleftrightarrow> (\<forall>C. C \<^bold>\<or> A \<preceq> C \<^bold>\<or> B)" by (metis L11 L4 L5 setequ_char setequ_ext)

(**These properties below hold in particular also for Boolean algebras.*)
lemma BA_impl: "A \<preceq> B \<longleftrightarrow> A \<^bold>\<rightarrow> B \<approx> \<^bold>\<top>" unfolding conn order by simp
lemma BA_distr1: "(A \<^bold>\<and> (B \<^bold>\<or> C)) \<approx> ((A \<^bold>\<and> B) \<^bold>\<or> (A \<^bold>\<and> C))" unfolding setequ_char conn order by simp
lemma BA_distr2: "(A \<^bold>\<or> (B \<^bold>\<and> C)) \<approx> ((A \<^bold>\<or> B) \<^bold>\<and> (A \<^bold>\<or> C))" unfolding conn order by blast
lemma BA_cp: "A \<preceq> B \<longleftrightarrow> \<^bold>\<midarrow>B \<preceq> \<^bold>\<midarrow>A" unfolding conn order by blast
lemma BA_deMorgan1: "\<^bold>\<midarrow>(A \<^bold>\<or> B) \<approx> (\<^bold>\<midarrow>A \<^bold>\<and> \<^bold>\<midarrow>B)" unfolding conn order by simp
lemma BA_deMorgan2: "\<^bold>\<midarrow>(A \<^bold>\<and> B) \<approx> (\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>B)" unfolding conn order by simp
lemma BA_dn: "\<^bold>\<midarrow>\<^bold>\<midarrow>A \<approx> A" unfolding conn order by simp
lemma BA_cmpl_equ: "(\<^bold>\<midarrow>A \<approx> B) = (A \<approx> \<^bold>\<midarrow>B)" unfolding conn order by blast

(**We conveniently introduce these properties of sets of sets (of points).*)
definition meet_closed::"('w \<sigma>)\<sigma> \<Rightarrow> bool"
  where "meet_closed S \<equiv>  \<forall>X Y. (S X \<and> S Y) \<longrightarrow> S(X \<^bold>\<and> Y)"
definition join_closed::"('w \<sigma>)\<sigma> \<Rightarrow> bool"
  where "join_closed S \<equiv>  \<forall>X Y. (S X \<and> S Y) \<longrightarrow> S(X \<^bold>\<or> Y)"

definition upwards_closed::"('w \<sigma>)\<sigma> \<Rightarrow> bool"
  where "upwards_closed S \<equiv> \<forall>X Y. S X \<and> X \<preceq> Y \<longrightarrow> S Y"
definition downwards_closed::"('w \<sigma>)\<sigma> \<Rightarrow> bool"
  where "downwards_closed S \<equiv> \<forall>X Y. S X \<and> Y \<preceq> X \<longrightarrow> S Y"

subsection \<open>Atomicity and primitive equality\<close>

(**We can verify indeed that the algebra is atomic (in three different ways) by relying on the
presence of primitive equality in HOL.*)

lemma atomic1: "\<forall>w. \<exists>Q. Q w \<and> (\<forall>P. P w \<longrightarrow> Q \<preceq> P)" unfolding order using the_sym_eq_trivial by metis

definition "atom A \<equiv> \<not>(A \<approx> \<^bold>\<bottom>) \<and> (\<forall>P. A \<preceq> P \<or> A \<preceq> \<^bold>\<midarrow>P)"

lemma atomic2: "\<forall>w. \<exists>Q. Q w \<and> atom Q" unfolding atom_def order conn using the_sym_eq_trivial by metis
lemma atomic3: "\<forall>P. \<not>(P \<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>Q. atom Q \<and> Q \<preceq> P)" unfolding atom_def order conn by fastforce

(*and now with interactive proof*)
lemma "\<forall>P. \<not>(P \<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>Q. atom Q \<and> Q \<preceq> P)"
proof -
  { fix P::"'w \<sigma>"
    { assume "\<not>(P \<approx> \<^bold>\<bottom>)"
      hence "\<exists>v. P v" unfolding conn order by simp
      then obtain w where 1:"P w" by (rule exE)
      let ?Q="\<lambda>v. v = w" (*using HOL primitive equality*)
      have 2: "atom ?Q" unfolding atom_def unfolding conn order by simp
      have "\<forall>v. ?Q v \<longrightarrow> P v" using 1 by simp
      hence 3: "?Q \<preceq> P" unfolding order by simp
      from 2 3 have "\<exists>Q. atom Q \<and> Q \<preceq> P" by blast
    } hence "\<not>(P \<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>Q. atom Q \<and> Q \<preceq> P)" by (rule impI)
  } thus ?thesis by (rule allI)
qed

end


(* Author: Dmitriy Traytel *)

section "Partial Derivatives-like Normalization"

(*<*)
theory PNormalization
imports Pi_Derivatives
begin
(*>*)

fun pnPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnPlus Zero r = r"
| "pnPlus r Zero = r"
(*<*)
(*
| "pnPlus Full r = Full"
| "pnPlus r Full = Full"
*)
(*>*)
| "pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
| "pnPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if r \<le> s then Plus r (Plus s t)
     else Plus s (pnPlus r t))"
| "pnPlus r s =
     (if r = s then r
      else if r \<le> s then Plus r s
      else Plus s r)"

lemma (in alphabet) wf_pnPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnPlus r s)"
  by (induct r s rule: pnPlus.induct) auto

lemma (in project) lang_pnPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnPlus r s) = lang n (Plus r s)"
  by (induct r s rule: pnPlus.induct) (auto dest!: lang_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])

fun pnTimes :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnTimes Zero r = Zero"
| "pnTimes One r = r"
| "pnTimes (Plus r s) t = pnPlus (pnTimes r t) (pnTimes s t)"
| "pnTimes r s = Times r s"

lemma (in alphabet) wf_pnTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnTimes r s)"
  by (induct r s rule: pnTimes.induct) auto

lemma (in project) lang_pnTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnTimes r s) = lang n (Times r s)"
  by (induct r s rule: pnTimes.induct) auto

fun pnInter :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnInter Zero r = Zero"
| "pnInter r Zero = Zero"
| "pnInter Full r = r"
| "pnInter r Full = r"
| "pnInter (Plus r s) t = pnPlus (pnInter r t) (pnInter s t)"
| "pnInter r (Plus s t) = pnPlus (pnInter r s) (pnInter r t)"
| "pnInter (Inter r s) t = pnInter r (pnInter s t)"
| "pnInter r (Inter s t) =
     (if r = s then Inter s t
     else if r \<le> s then Inter r (Inter s t)
     else Inter s (pnInter r t))"
| "pnInter r s =
     (if r = s then s
      else if r \<le> s then Inter r s
      else Inter s r)"

lemma (in alphabet) wf_pnInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnInter r s)"
  by (induct r s rule: pnInter.induct) auto

lemma (in project) lang_pnInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnInter r s) = lang n (Inter r s)"
  by (induct r s rule: pnInter.induct) (auto, auto dest!: lang_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])

fun pnNot :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnNot (Plus r s) = pnInter (pnNot r) (pnNot s)"
| "pnNot (Inter r s) = pnPlus (pnNot r) (pnNot s)"
| "pnNot Full = Zero"
| "pnNot Zero = Full"
| "pnNot (Not r) = r"
| "pnNot r = Not r"

lemma (in alphabet) wf_pnNot[simp]: "wf n r \<Longrightarrow> wf n (pnNot r)"
  by (induct r rule: pnNot.induct) auto

lemma (in project) lang_pnNot[simp]: "wf n r \<Longrightarrow> lang n (pnNot r) = lang n (Not r)"
  by (induct r rule: pnNot.induct) (auto dest: lang_subset_lists)

fun pnPr :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnPr Zero = Zero"
| "pnPr One = One"
| "pnPr (Plus r s) = pnPlus (pnPr r) (pnPr s)"
| "pnPr r = Pr r"

lemma (in alphabet) wf_pnPr[simp]: "wf (Suc n) r \<Longrightarrow> wf n (pnPr r)"
  by (induct r rule: pnPr.induct) auto

lemma (in project) lang_pnPr[simp]: "wf (Suc n) r \<Longrightarrow> lang n (pnPr r) = lang n (Pr r)"
  by (induct r rule: pnPr.induct) auto

primrec pnorm :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnorm Zero = Zero"
| "pnorm Full = Full"
| "pnorm One = One"
| "pnorm (Atom a) = Atom a"
| "pnorm (Plus r s) = pnPlus (pnorm r) (pnorm s)"
| "pnorm (Times r s) = pnTimes (pnorm r) s"
| "pnorm (Star r) = Star r"
| "pnorm (Inter r s) = pnInter (pnorm r) (pnorm s)"
| "pnorm (Not r) = pnNot (pnorm r)"
| "pnorm (Pr r) = pnPr (pnorm r)"

lemma (in alphabet) wf_pnorm[simp]: "wf n r \<Longrightarrow> wf n (pnorm r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_pnorm[simp]: "wf n r \<Longrightarrow> lang n (pnorm r) = lang n r"
  by (induct r arbitrary: n) auto

(*<*)
end
(*>*)