(*
  File:   Prime_Harmonic.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

  A lower bound for the partial sums of the prime harmonic series, and a proof of its divergence.
  (#81 on the list of 100 mathematical theorems)
*)

section \<open>The Prime Harmonic Series\<close>
theory Prime_Harmonic
imports
  "HOL-Analysis.Analysis"
  "HOL-Number_Theory.Number_Theory"
  Prime_Harmonic_Misc
  Squarefree_Nat
begin

subsection \<open>Auxiliary equalities and inequalities\<close>

text \<open>
  First of all, we prove the following result about rearranging a product over a set into a sum
  over all subsets of that set.
\<close>
lemma prime_harmonic_aux1:
  fixes A :: "'a :: field set"
  shows "finite A \<Longrightarrow> (\<Prod>x\<in>A. 1 + 1 / x) = (\<Sum>x\<in>Pow A. 1 / \<Prod>x)"
proof (induction rule: finite_induct)
  fix a :: 'a and A :: "'a set"
  assume a: "a \<notin> A" and fin: "finite A"
  assume IH: "(\<Prod>x\<in>A. 1 + 1 / x) = (\<Sum>x\<in>Pow A. 1 / \<Prod>x)"
  from a and fin have "(\<Prod>x\<in>insert a A. 1 + 1 / x) = (1 + 1 / a) * (\<Prod>x\<in>A. 1 + 1 / x)" by simp
  also from fin have "\<dots> = (\<Sum>x\<in>Pow A. 1 / \<Prod>x) + (\<Sum>x\<in>Pow A. 1 / (a * \<Prod>x))"
    by (subst IH) (auto simp add: algebra_simps sum_divide_distrib)
  also from fin a have "(\<Sum>x\<in>Pow A. 1 / (a * \<Prod>x)) = (\<Sum>x\<in>Pow A. 1 / \<Prod>(insert a x))"
    by (intro sum.cong refl, subst prod.insert) (auto dest: finite_subset)
  also from a have "\<dots> = (\<Sum>x\<in>insert a ` Pow A. 1 / \<Prod>x)"
    by (subst sum.reindex) (auto simp: inj_on_def)
  also from fin a have "(\<Sum>x\<in>Pow A. 1 / \<Prod>x) + \<dots> = (\<Sum>x\<in>Pow A \<union> insert a ` Pow A. 1 / \<Prod>x)"
    by (intro sum.union_disjoint [symmetric]) (simp, simp, blast)
  also have "Pow A \<union> insert a ` Pow A = Pow (insert a A)" by (simp only: Pow_insert)
  finally show " (\<Prod>x\<in>insert a A. 1 + 1 / x) = (\<Sum>x\<in>Pow (insert a A). 1 / \<Prod>x)" .
qed simp

text \<open>
  Next, we prove a simple and reasonably accurate upper bound for the sum of the squares of any
  subset of the natural numbers, derived by simple telescoping. Our upper bound is approximately
  1.67; the exact value is $\frac{\pi^2}{6} \approx 1.64$. (cf. Basel problem)
\<close>
lemma prime_harmonic_aux2:
  assumes "finite (A :: nat set)"
  shows   "(\<Sum>k\<in>A. 1 / (real k ^ 2)) \<le> 5/3"
proof -
  define n where "n = max 2 (Max A)"
  have n: "n \<ge> Max A" "n \<ge> 2" by (auto simp: n_def)
  with assms have "A \<subseteq> {0..n}" by (auto intro: order.trans[OF Max_ge])
  hence "(\<Sum>k\<in>A. 1 / (real k ^ 2)) \<le> (\<Sum>k=0..n. 1 / (real k ^ 2))" by (intro sum_mono2) auto
  also from n have "\<dots> = 1 + (\<Sum>k=Suc 1..n. 1 / (real k ^ 2))" by (simp add: sum.atLeast_Suc_atMost)
  also have "(\<Sum>k=Suc 1..n. 1 / (real k ^ 2)) \<le>
          (\<Sum>k=Suc 1..n. 1 / (real k ^ 2 - 1/4))" unfolding power2_eq_square
    by (intro sum_mono divide_left_mono mult_pos_pos)
       (linarith, simp_all add: field_simps less_1_mult)
  also have "\<dots> = (\<Sum>k=Suc 1..n. 1 / (real k - 1/2) - 1 / (real (Suc k) - 1/2))"
    by (intro sum.cong refl) (simp_all add: field_simps power2_eq_square)
  also from n have "\<dots> = 2 / 3 - 1 / (1 / 2 + real n)"
    by (subst sum_telescope') simp_all
  also have "1 + \<dots> \<le> 5/3" by simp
  finally show ?thesis by - simp
qed

subsection \<open>Estimating the partial sums of the Prime Harmonic Series\<close>

text \<open>
  We are now ready to show our main result: the value of the partial prime harmonic sum over
  all primes no greater than $n$ is bounded from below by the $n$-th harmonic number
  $H_n$ minus some constant.

  In our case, this constant will be $\frac{5}{3}$. As mentioned before, using a
  proof of the Basel problem can improve this to $\frac{\pi^2}{6}$, but the improvement is very
  small and the proof of the Basel problem is a very complex one.

  The exact asymptotic behaviour of the partial sums is actually $\ln (\ln n) + M$, where $M$
  is the Meissel--Mertens constant (approximately 0.261).
\<close>
theorem prime_harmonic_lower:
  assumes n: "n \<ge> 2"
  shows "(\<Sum>p\<leftarrow>primes_upto n. 1 / real p) \<ge> ln (harm n) - ln (5/3)"
proof -
  \<comment> \<open>the set of primes that we will allow in the squarefree part\<close>
  define P where "P n = set (primes_upto n)" for n
  {
    fix n :: nat
    have "finite (P n)" by (simp add: P_def)
  } note [simp] = this

  \<comment> \<open>The function that combines the squarefree part and the square part\<close>
  define f where "f = (\<lambda>(R, s :: nat). \<Prod>R * s^2)"

  \<comment> \<open>@{term f} is injective if the squarefree part contains only primes
      and the square part is positive.\<close>
  have inj: "inj_on f (Pow (P n)\<times>{1..n})"
  proof (rule inj_onI, clarify, rule conjI)
    fix A1 A2 :: "nat set" and s1 s2 :: nat
    assume A: "A1 \<subseteq> P n" "A2 \<subseteq> P n" "s1 \<in> {1..n}" "s2 \<in> {1..n}" "f (A1, s1) = f (A2, s2)"
    have fin: "finite A1" "finite A2" by (rule A(1,2)[THEN finite_subset], simp)+
    show "A1 = A2" "s1 = s2"
      by ((rule squarefree_decomposition_unique2'[of A1 s1 A2 s2],
          insert A fin, auto simp: f_def P_def set_primes_upto)[])+
  qed

  \<comment> \<open>@{term f} hits every number between @{term "1::nat"} and @{term "n"}. It also hits a lot
      of other numbers, but we do not care about those, since we only need a lower bound.\<close>
  have surj: "{1..n} \<subseteq> f ` (Pow (P n)\<times>{1..n})"
  proof
    fix x assume x: "x \<in> {1..n}"
    have "x = f (squarefree_part x, square_part x)" by (simp add: f_def squarefree_decompose)
    moreover have "squarefree_part x \<in> Pow (P n)" using squarefree_part_subset[of x] x
      by (auto simp: P_def set_primes_upto intro: order.trans[OF squarefree_part_le[of _ x]])
    moreover have "square_part x \<in> {1..n}" using x
      by (auto simp: Suc_le_eq intro: order.trans[OF square_part_le[of x]])
    ultimately show "x \<in> f ` (Pow (P n)\<times>{1..n})" by simp
  qed

  \<comment> \<open>We now show the main result by rearranging the sum over all primes to a product over all
      all squarefree parts times a sum over all square parts, and then applying some simple-minded
      approximation\<close>
  have "harm n = (\<Sum>n=1..n. 1 / real n)" by (simp add: harm_def field_simps)
  also from surj have "\<dots> \<le> (\<Sum>n\<in>f ` (Pow (P n)\<times>{1..n}). 1 / real n)"
    by (intro sum_mono2 finite_imageI finite_cartesian_product) simp_all
  also from inj have "\<dots> = (\<Sum>x\<in>Pow (P n)\<times>{1..n}. 1 / real (f x))"
    by (subst sum.reindex) simp_all
  also have "\<dots> = (\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) * (\<Sum>k=1..n. 1 / (real k)^2)" unfolding f_def
    by (subst sum_product, subst sum.cartesian_product) (simp add: case_prod_beta)
  also have "\<dots> \<le> (\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) * (5/3)"
    by (intro mult_left_mono prime_harmonic_aux2 sum_nonneg)
       (auto simp: P_def intro!: prod_nonneg)
  also have "(\<Sum>A\<in>Pow (P n). 1 / real (\<Prod>A)) = (\<Sum>A\<in>((`) real) ` Pow (P n). 1 / \<Prod>A)"
    by (subst sum.reindex) (auto simp: inj_on_def inj_image_eq_iff prod.reindex)
  also have "((`) real) ` Pow (P n) = Pow (real ` P n)" by (intro image_Pow_surj refl)
  also have "(\<Sum>A\<in>Pow (real ` P n). 1 / \<Prod>A) = (\<Prod>x\<in>real ` P n. 1 + 1 / x)"
    by (intro prime_harmonic_aux1 [symmetric] finite_imageI) simp_all
  also have "\<dots> = (\<Prod>i\<in>P n. 1 + 1 / real i)" by (subst prod.reindex) (auto simp: inj_on_def)
  also have "\<dots> \<le> (\<Prod>i\<in>P n. exp (1 / real i))" by (intro prod_mono) auto
  also have "\<dots> = exp (\<Sum>i\<in>P n. 1 / real i)" by (simp add: exp_sum)
  finally have "ln (harm n) \<le> ln (\<dots> * (5/3))" using n
    by (subst ln_le_cancel_iff) simp_all
  hence "ln (harm n) - ln (5/3) \<le> (\<Sum>i\<in>P n. 1 / real i)"
    by (subst (asm) ln_mult) (simp_all add: algebra_simps)
  thus ?thesis unfolding P_def
    by (subst (asm) sum.distinct_set_conv_list) simp_all
qed

text \<open>
  We can use the inequality $\ln (n + 1) \le H_n$ to estimate the asymptotic growth of the partial
  prime harmonic series. Note that $H_n \sim \ln n + \gamma$ where $\gamma$ is the
  Euler--Mascheroni constant (approximately 0.577), so we lose some accuracy here.
\<close>
corollary prime_harmonic_lower':
  assumes n: "n \<ge> 2"
  shows "(\<Sum>p\<leftarrow>primes_upto n. 1 / real p) \<ge> ln (ln (n + 1)) - ln (5/3)"
proof -
  from assms ln_le_harm[of n] have "ln (ln (real n + 1)) \<le> ln (harm n)" by simp
  also from assms have "\<dots> - ln (5/3) \<le> (\<Sum>p\<leftarrow>primes_upto n. 1 / real p)"
    by (rule prime_harmonic_lower)
  finally show ?thesis by - simp
qed

(* TODO: Not needed in Isabelle 2016 *)
lemma Bseq_eventually_mono:
  assumes "eventually (\<lambda>n. norm (f n) \<le> norm (g n)) sequentially" "Bseq g"
  shows   "Bseq f"
proof -
  from assms(1) obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> norm (f n) \<le> norm (g n)"
    by (auto simp: eventually_at_top_linorder)
  from assms(2) obtain K where K: "\<And>n. norm (g n) \<le> K" by (blast elim!: BseqE)
  {
    fix n :: nat
    have "norm (f n) \<le> max K (Max {norm (f n) |n. n < N})"
      apply (cases "n < N")
      apply (rule max.coboundedI2, rule Max.coboundedI, auto) []
      apply (rule max.coboundedI1, force intro: order.trans[OF N K])
      done
  }
  thus ?thesis by (blast intro: BseqI')
qed

lemma Bseq_add:
  assumes "Bseq (f :: nat \<Rightarrow> 'a :: real_normed_vector)"
  shows   "Bseq (\<lambda>x. f x + c)"
proof -
  from assms obtain K where K: "\<And>x. norm (f x) \<le> K" unfolding Bseq_def by blast
  {
    fix x :: nat
    have "norm (f x + c) \<le> norm (f x) + norm c" by (rule norm_triangle_ineq)
    also have "norm (f x) \<le> K" by (rule K)
    finally have "norm (f x + c) \<le> K + norm c" by simp
  }
  thus ?thesis by (rule BseqI')
qed

lemma convergent_imp_Bseq: "convergent f \<Longrightarrow> Bseq f"
  by (simp add: Cauchy_Bseq convergent_Cauchy)

(* END TODO *)

text \<open>
  We now use our last estimate to show that the prime harmonic series diverges. This is obvious,
  since it is bounded from below by $\ln (\ln (n + 1))$ minus some constant, which obviously
  tends to infinite.

  Directly using the divergence of the harmonic series would also be possible and shorten this
  proof a bit..
\<close>
corollary prime_harmonic_series_unbounded:
  "\<not>Bseq (\<lambda>n. \<Sum>p\<leftarrow>primes_upto n. 1 / p)" (is "\<not>Bseq ?f")
proof
  assume "Bseq ?f"
  hence "Bseq (\<lambda>n. ?f n + ln (5/3))" by (rule Bseq_add)
  have "Bseq (\<lambda>n. ln (ln (n + 1)))"
  proof (rule Bseq_eventually_mono)
    from eventually_ge_at_top[of "2::nat"]
      show "eventually (\<lambda>n. norm (ln (ln (n + 1))) \<le> norm (?f n + ln (5/3))) sequentially"
    proof eventually_elim
      fix n :: nat assume n: "n \<ge> 2"
      hence "norm (ln (ln (real n + 1))) = ln (ln (real n + 1))"
        using ln_ln_nonneg[of "real n + 1"] by simp
      also have "\<dots> \<le> ?f n + ln (5/3)" using prime_harmonic_lower'[OF n]
        by (simp add: algebra_simps)
      also have "?f n + ln (5/3) \<ge> 0" by (intro add_nonneg_nonneg sum_list_nonneg) simp_all
      hence "?f n + ln (5/3) = norm (?f n + ln (5/3))" by simp
      finally show "norm (ln (ln (n + 1))) \<le> norm (?f n + ln (5/3))"
        by (simp add: add_ac)
    qed
  qed fact
  then obtain k where k: "k > 0" "\<And>n. norm (ln (ln (real (n::nat) + 1))) \<le> k"
    by (auto elim!: BseqE simp: add_ac)

  define N where "N = nat \<lceil>exp (exp k)\<rceil>"
  have N_pos: "N > 0" unfolding N_def by simp
  have "real N + 1 > exp (exp k)" unfolding N_def by linarith
  hence "ln (real N + 1) > ln (exp (exp k))" by (subst ln_less_cancel_iff) simp_all
  with N_pos have "ln (ln (real N + 1)) > ln (exp k)" by (subst ln_less_cancel_iff) simp_all
  hence "k < ln (ln (real N + 1))" by simp
  also have "\<dots> \<le> norm (ln (ln (real N + 1)))" by simp
  finally show False using k(2)[of N] by simp
qed

corollary prime_harmonic_series_diverges:
  "\<not>convergent (\<lambda>n. \<Sum>p\<leftarrow>primes_upto n. 1 / p)"
  using prime_harmonic_series_unbounded convergent_imp_Bseq by blast

end


section "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end


(* Title:      L2 Norm Integral
   Author:     Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
   Maintainer: Omar A. Jasim <oajasim1@sheffield.ac.uk>, Sandor M. Veres <s.veres@sheffield.ac.uk>
*)

theory L2Norm_Integral
imports
"~~/src/HOL/Probability/Set_Integral"
"~~/Minkowski_Integral_Inequality"
begin

definition L2norm:: "real measure \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> real set \<Rightarrow> real" where
  "L2norm M f A = sqrt (LINT  t:A|M. (f t)\<^sup>2)"

lemma L2norm_cong1:
  "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> L2norm M f A = L2norm M g B"
  unfolding L2norm_def by (metis indicator_simps(2) mult_zero_left real_scaleR_def)

lemma strong_L2norm_cong:
  "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> L2norm M f A = L2norm M g B"
  unfolding L2norm_def simp_implies_def by (metis (full_types) L2norm_cong1 L2norm_def)

lemma L2norm_nonneg:
  shows "L2norm M f A \<ge> 0"
proof -
  have "\<forall>t. (f t)\<^sup>2 \<ge> 0"
    by simp
  then have "(LINT  t:A|M. (f t)\<^sup>2) \<ge> 0"
    by (simp add: integral_nonneg_AE)
  then have "sqrt (LINT  t:A|M. (f t)\<^sup>2) \<ge> 0"
    by simp
  from this L2norm_def show ?thesis
    by metis
qed

lemma L2norm_zero: "\<forall>t\<in>A. f t = 0 \<Longrightarrow> L2norm M f A = 0" unfolding L2norm_def
proof -
  assume "\<forall>t\<in>A. f t = 0"
  then have "\<And>t. indicator A t *\<^sub>R (f t)\<^sup>2 = 0"
    by auto
  then show "sqrt (LINT t:A|M. (f t)\<^sup>2) = 0"
    by (simp add: integral_eq_zero_AE)
qed

lemma L2norm_right_distrib:
  fixes M a b c and f :: "real \<Rightarrow> real"
  assumes "0 \<le> c" "set_integrable M A f"
  shows "c * L2norm M f A = L2norm M (\<lambda>t. c * f t) A"
proof -
  have "c* (sqrt(LINT t:A|M. (f t)\<^sup>2)) = sqrt(c\<^sup>2 *(LINT t:A|M. (f t)\<^sup>2))"
    by (simp add: assms real_sqrt_mult_distrib2)
  then have "c * sqrt(LINT t:A|M. (f t)\<^sup>2) = sqrt(LINT t:A|M. c\<^sup>2 * (f t)\<^sup>2)"
    by (metis (no_types) set_integral_mult_right)
  then have "c * sqrt(LINT t:A|M. (f t)\<^sup>2) = sqrt(LINT t:A|M. (c * f t)\<^sup>2)"
    by (simp add: power_mult_distrib)
  thus ?thesis
    by (metis L2norm_def)
qed

lemma L2norm_left_distrib:
  fixes M a b c and f :: "real \<Rightarrow> real"
  assumes "0 \<le> c"  "set_integrable M A f"
  shows "L2norm M f A * c = L2norm M (\<lambda>t. f t * c) A"
proof -
  have "sqrt (LINT t:A|M. (f t)\<^sup>2) * c = sqrt((LINT t:A|M. (f t)\<^sup>2) * c\<^sup>2)"
    by (simp add: assms real_sqrt_mult_distrib2)
  then have "sqrt(LINT t:A|M. (f t)\<^sup>2) * c = sqrt((LINT t:A|M. (f t)\<^sup>2 * c\<^sup>2))"
    by (metis (no_types) set_integral_mult_left)
  then have "sqrt (LINT t:A|M. (f t)\<^sup>2) * c = sqrt((LINT t:A|M. (f t*c)\<^sup>2 ))"
    by (simp add: power_mult_distrib)
  thus ?thesis
    by (metis L2norm_def)
qed

lemma L2norm_empty [simp]: "L2norm M f {} = 0"
  unfolding L2norm_def by simp

lemma L2norm_neq: "L2norm M (\<lambda>t. - f t) A = L2norm M (\<lambda>t. f t) A"
  unfolding L2norm_def by fastforce

lemma L2norm_neq1: "L2norm M (-f) A = L2norm M (\<lambda>t. f t) A"
  unfolding L2norm_def by fastforce

lemma L2norm_triangle_ineq:
  fixes f g ::  "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g"
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "L2norm M (\<lambda>t. f t + g t) A \<le> L2norm M f A + L2norm M g A"
proof -
  have "sqrt(LINT t:A|M. (f t + g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2)"
    using minkowski_integral_ineq assms by blast
  thus ?thesis unfolding L2norm_def
    by blast
qed

lemma L2norm_triangle_ineq_nq:
  fixes f g ::  "real \<Rightarrow> real"
  assumes "\<And>t. t \<in> A"
          "set_integrable M A f"
          "set_integrable M A g"
          "set_integrable M A (\<lambda>t. (f t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. (g t)\<^sup>2)"
          "set_integrable M A (\<lambda>t. f t * g t)"
          "(LINT t:A|M. (g t)\<^sup>2) > 0"
  shows "L2norm M (\<lambda>t. f t - g t) A \<le> L2norm M f A + L2norm M g A"
proof -
  have "sqrt(LINT t:A|M. (f t - g t)\<^sup>2) \<le> sqrt(LINT t:A|M. (f t)\<^sup>2) + sqrt(LINT t:A|M. (g t)\<^sup>2)"
    using assms minkowski_integral_ineq_ng mult_minus_right by blast
  thus ?thesis unfolding L2norm_def
    using L2norm_neq by fastforce
qed

end


(*
  Title:    PMF_OF_List.thy
  Author:   Manuel Eberl, TU München

  Creating PMFs from lists
*)

section \<open>Creating PMFs from lists\<close>

theory PMF_Of_List
imports Complex_Main "~~/src/HOL/Probability/Probability"
begin

(* TODO Move *)
lemma listsum_nonneg: "(\<And>x. x \<in> set xs \<Longrightarrow> (x :: 'a :: linordered_idom) \<ge> 0) \<Longrightarrow> listsum xs \<ge> 0"
  by (induction xs) simp_all

lemma listsum_map_filter:
  "listsum (map f (filter P xs)) = listsum (map (\<lambda>x. if P x then f x else 0) xs)"
  by (induction xs) simp_all

lemma listsum_cong:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = g x"
  shows    "listsum (map f xs) = listsum (map g xs)"
  using assms by (induction xs) simp_all

lemma ereal_listsum: "listsum (map (\<lambda>x. ereal (f x)) xs) = ereal (listsum (map f xs))"
  by (induction xs) simp_all
(* END TODO *)

definition pmf_of_list ::" ('a \<times> real) list \<Rightarrow> 'a pmf" where
  "pmf_of_list xs = embed_pmf (\<lambda>x. listsum (map snd (filter (\<lambda>z. fst z = x) xs)))"

definition pmf_of_list_wf where
  "pmf_of_list_wf xs \<longleftrightarrow> (\<forall>x\<in>set (map snd xs) . x \<ge> 0) \<and> listsum (map snd xs) = 1"

lemma pmf_of_list_wfI:
  "(\<And>x. x \<in> set (map snd xs) \<Longrightarrow> x \<ge> 0) \<Longrightarrow> listsum (map snd xs) = 1 \<Longrightarrow> pmf_of_list_wf xs"
  unfolding pmf_of_list_wf_def by simp

lemma pmf_of_list_aux:
  assumes "\<And>x. x \<in> set (map snd xs) \<Longrightarrow> x \<ge> 0"
  assumes "listsum (map snd xs) = 1"
  shows "(\<integral>\<^sup>+ x. ereal (listsum (map snd [z\<leftarrow>xs . fst z = x])) \<partial>count_space UNIV) = 1"
proof -
  have "(\<integral>\<^sup>+ x. ereal (listsum (map snd (filter (\<lambda>z. fst z = x) xs))) \<partial>count_space UNIV) =
            (\<integral>\<^sup>+ x. ereal (listsum (map (\<lambda>(x',p). indicator {x'} x * p) xs)) \<partial>count_space UNIV)"
    by (intro nn_integral_cong, subst listsum_map_filter) (auto intro: listsum_cong)
  also have "\<dots> = (\<Sum>(x',p)\<leftarrow>xs. (\<integral>\<^sup>+ x. ereal (indicator {x'} x * p) \<partial>count_space UNIV))"
    using assms(1)
  proof (induction xs)
    case (Cons x xs)
    have "(\<integral>\<^sup>+ y. ereal (\<Sum>(x', p)\<leftarrow>x # xs. indicator {x'} y * p) \<partial>count_space UNIV) =
            (\<integral>\<^sup>+ y. ereal (indicator {fst x} y * snd x) +
            ereal (\<Sum>(x', p)\<leftarrow>xs. indicator {x'} y * p) \<partial>count_space UNIV)"
      by (simp add: plus_ereal.simps [symmetric] case_prod_unfold del: plus_ereal.simps)
    also have "\<dots> = (\<integral>\<^sup>+ y. ereal (indicator {fst x} y * snd x) \<partial>count_space UNIV) +
                      (\<integral>\<^sup>+ y. ereal (\<Sum>(x', p)\<leftarrow>xs. indicator {x'} y * p) \<partial>count_space UNIV)"
      by (intro nn_integral_add)
         (force intro!: listsum_nonneg AE_I2 intro: Cons simp: indicator_def)+
    also have "(\<integral>\<^sup>+ y. ereal (\<Sum>(x', p)\<leftarrow>xs. indicator {x'} y * p) \<partial>count_space UNIV) =
               (\<Sum>(x', p)\<leftarrow>xs. (\<integral>\<^sup>+ y. ereal (indicator {x'} y * p) \<partial>count_space UNIV))"
      using Cons(1) by (intro Cons) simp_all
    finally show ?case by (simp add: case_prod_unfold)
  qed simp
  also have "\<dots> = (\<Sum>(x',p)\<leftarrow>xs. ereal p * (\<integral>\<^sup>+ x. indicator {x'} x \<partial>count_space UNIV))"
    using assms(1)
    by (intro listsum_cong, simp only: case_prod_unfold, subst nn_integral_cmult [symmetric])
       (auto intro!: assms(1) simp: max_def times_ereal.simps [symmetric] mult_ac ereal_indicator
             simp del: times_ereal.simps)+
  also have "\<dots> = listsum (map snd xs)" by (simp add: case_prod_unfold ereal_listsum)
  also have "\<dots> = 1" using assms(2) by simp
  finally show ?thesis .
qed

lemma pmf_pmf_of_list:
  assumes "pmf_of_list_wf xs"
  shows   "pmf (pmf_of_list xs) x = listsum (map snd (filter (\<lambda>z. fst z = x) xs))"
  using assms pmf_of_list_aux[of xs] unfolding pmf_of_list_def pmf_of_list_wf_def
  by (subst pmf_embed_pmf) (auto intro!: listsum_nonneg)+

lemma set_pmf_of_list:
  assumes "pmf_of_list_wf xs"
  shows   "set_pmf (pmf_of_list xs) \<subseteq> set (map fst xs)"
proof clarify
  fix x assume A: "x \<in> set_pmf (pmf_of_list xs)"
  show "x \<in> set (map fst xs)"
  proof (rule ccontr)
    assume "x \<notin> set (map fst xs)"
    hence "[z\<leftarrow>xs . fst z = x] = []" by (auto simp: filter_empty_conv)
    with A assms show False by (simp add: pmf_pmf_of_list set_pmf_eq)
  qed
qed

lemma finite_set_pmf_of_list:
  assumes "pmf_of_list_wf xs"
  shows   "finite (set_pmf (pmf_of_list xs))"
  using assms by (rule finite_subset[OF set_pmf_of_list]) simp_all

lemma emeasure_Int_set_pmf:
  "emeasure (measure_pmf p) (A \<inter> set_pmf p) = emeasure (measure_pmf p) A"
  by (rule emeasure_eq_AE) (auto simp: AE_measure_pmf_iff)

lemma measure_Int_set_pmf:
  "measure (measure_pmf p) (A \<inter> set_pmf p) = measure (measure_pmf p) A"
  using emeasure_Int_set_pmf[of p A] by (simp add: Sigma_Algebra.measure_def)

lemma measure_pmf_of_list:
  assumes "pmf_of_list_wf xs"
  shows   "measure (pmf_of_list xs) A = listsum (map snd (filter (\<lambda>x. fst x \<in> A) xs))"
proof -
  have "emeasure (pmf_of_list xs) A = nn_integral (measure_pmf (pmf_of_list xs)) (indicator A)"
    by simp
  also have "\<dots> = ereal (\<Sum>x\<in>set_pmf (pmf_of_list xs). indicator A x * pmf (pmf_of_list xs) x)"
    (is "_ = ereal ?S") using assms
    by (subst nn_integral_measure_pmf_finite)
       (simp_all add: finite_set_pmf_of_list ereal_indicator [symmetric] pmf_pmf_of_list)
  also have "?S = (\<Sum>x\<in>set (map fst xs). indicator A x * pmf (pmf_of_list xs) x)"
    using assms by (intro setsum.mono_neutral_left set_pmf_of_list) (auto simp: set_pmf_eq)
  also have "\<dots> = (\<Sum>x\<in>set (map fst xs). indicator A x *
                      listsum (map snd (filter (\<lambda>z. fst z = x) xs)))"
    using assms by (simp add: pmf_pmf_of_list)
  also have "\<dots> = (\<Sum>x\<in>set (map fst xs). listsum (map snd (filter (\<lambda>z. fst z = x \<and> x \<in> A) xs)))"
    by (intro setsum.cong) (auto simp: indicator_def)
  also have "\<dots> = (\<Sum>x\<in>set (map fst xs). (\<Sum>xa = 0..<length xs.
                     if fst (xs ! xa) = x \<and> x \<in> A then snd (xs ! xa) else 0))"
    by (intro setsum.cong refl, subst listsum_map_filter, subst listsum_setsum_nth) simp
  also have "\<dots> = (\<Sum>xa = 0..<length xs. (\<Sum>x\<in>set (map fst xs).
                     if fst (xs ! xa) = x \<and> x \<in> A then snd (xs ! xa) else 0))"
    by (rule setsum.commute)
  also have "\<dots> = (\<Sum>xa = 0..<length xs. if fst (xs ! xa) \<in> A then
                     (\<Sum>x\<in>set (map fst xs). if x = fst (xs ! xa) then snd (xs ! xa) else 0) else 0)"
    by (auto intro!: setsum.cong setsum.neutral)
  also have "\<dots> = (\<Sum>xa = 0..<length xs. if fst (xs ! xa) \<in> A then snd (xs ! xa) else 0)"
    by (intro setsum.cong refl) (simp_all add: setsum.delta)
  also have "\<dots> = listsum (map snd (filter (\<lambda>x. fst x \<in> A) xs))"
    by (subst listsum_map_filter, subst listsum_setsum_nth) simp_all
  finally show ?thesis by (simp add: Sigma_Algebra.measure_def)
qed

end


theory Simplicial_complex
  imports
    Boolean_functions
begin

section\<open>Simplicial Complexes\<close>

lemma Pow_singleton: "Pow {a} = {{},{a}}" by auto

lemma Pow_pair: "Pow {a,b} = {{},{a},{b},{a,b}}" by auto

locale simplicial_complex
  = fixes n::"nat"
begin

text\<open>A simplex (in $n$ vertexes) is any set of vertexes,
  including the empty set.\<close>

definition simplices :: "nat set set"
  where "simplices = Pow {0..<n}"

lemma "{} \<in> simplices"
  unfolding simplices_def by simp

lemma "{0..<n} \<in> simplices"
  unfolding simplices_def by simp

text\<open>A simplicial complex (in $n$ vertexes) is a collection of
  sets of vertexes such that every subset of
  a set of vertexes also belongs to the simplicial complex.\<close>

definition simplicial_complex :: "nat set set => bool"
  where "simplicial_complex K \<equiv>  (\<forall>\<sigma>\<in>K. (\<sigma> \<in> simplices) \<and> (Pow \<sigma>) \<subseteq> K)"

lemma simplicial_complex_empty_set: "simplicial_complex {}"
  unfolding simplicial_complex_def
  unfolding simplices_def by simp

lemma simplicial_complex_contains_empty_set: "simplicial_complex {{}}"
  unfolding simplicial_complex_def
  unfolding simplices_def by simp

lemma simplicial_complex_either_empty_or_contains_empty:
  fixes K::"nat set set"
  assumes k: "simplicial_complex K"
  shows "K = {} \<or> {} \<in> K" using k unfolding simplicial_complex_def Pow_def by auto

lemma
  finite_simplicial_complex:
  assumes "simplicial_complex K"
  shows "finite K"
  by (metis assms finite_Pow_iff finite_atLeastLessThan rev_finite_subset simplices_def simplicial_complex_def subsetI)

lemma finite_simplices:
  assumes "simplicial_complex K"
  and "v \<in> K"
shows "finite v"
  using assms finite_simplex simplicial_complex.simplicial_complex_def by blast

definition simplicial_complex_set :: "nat set set set"
  where "simplicial_complex_set = (Collect simplicial_complex)"

lemma
  simplicial_complex_monotone:
  fixes K::"nat set set"
  assumes k: "simplicial_complex K" and s: "s \<in> K" and rs: "r \<subseteq> s"
  shows "r \<in> K"
  using k rs s
  unfolding simplicial_complex_def Pow_def by auto

text\<open>One example of simplicial complex with four simplices.\<close>

lemma
  assumes three: "(3::nat) < n"
  shows "simplicial_complex {{},{0},{1},{2},{3}}"
  apply (simp_all add: Pow_singleton simplicial_complex_def simplices_def)
  using Suc_lessD three by presburger

lemma "\<not> simplicial_complex {{0,1},{1}}"
  by (simp add: Pow_pair simplicial_complex_def)

text\<open>Another example of simplicial complex with five simplices.\<close>

lemma
  assumes three: "(3::nat) < n"
  shows "simplicial_complex {{},{0},{1},{2},{3},{0,1}}"
  apply (simp add: Pow_pair Pow_singleton simplicial_complex_def simplices_def)
  using Suc_lessD three by presburger

text\<open>Another example of simplicial complex with ten simplices.\<close>

lemma
  assumes three: "(3::nat) < n"
  shows "simplicial_complex
    {{2,3},{1,3},{1,2},{0,3},{0,2},{3},{2},{1},{0},{}}"
  apply (simp add: Pow_pair Pow_singleton simplicial_complex_def simplices_def)
  using Suc_lessD three by presburger

end

section\<open>Simplicial complex induced by a monotone Boolean function\<close>

text\<open>In this section we introduce the definition of the
  simplicial complex induced by a monotone Boolean function,
  following the definition in Scoville~\cite[Def. 6.9]{SC19}.\<close>

text\<open>First we introduce the set of tuples for which
  a Boolean function is @{term False}.\<close>

definition ceros_of_boolean_input :: "bool vec => nat set"
  where "ceros_of_boolean_input v = {x. x < dim_vec v \<and> vec_index v x = False}"

lemma
  ceros_of_boolean_input_l_dim:
  assumes a: "a \<in> ceros_of_boolean_input v"
  shows "a < dim_vec v"
  using a unfolding ceros_of_boolean_input_def by simp

lemma "ceros_of_boolean_input v = {x. x < dim_vec v \<and> \<not> vec_index v x}"
  unfolding ceros_of_boolean_input_def by simp

lemma
  ceros_of_boolean_input_complementary:
  shows "ceros_of_boolean_input v = {x. x < dim_vec v} - {x. vec_index v x}"
  unfolding ceros_of_boolean_input_def by auto

lemma (in simplicial_complex) vec_in_simplices:
  assumes "v \<in> carrier_vec n"
  shows "ceros_of_boolean_input v \<in> simplices"
  using assms unfolding carrier_vec_def simplices_def ceros_of_boolean_input_def
  by auto

(*lemma ceros_in_UNIV: "ceros_of_boolean_input f \<subseteq> (UNIV::nat set)"
  using subset_UNIV .*)

lemma monotone_ceros_of_boolean_input:
  fixes r and s::"bool vec"
  assumes r_le_s: "r \<le> s"
  shows "ceros_of_boolean_input s \<subseteq> ceros_of_boolean_input r"
proof (intro subsetI, unfold ceros_of_boolean_input_def, intro CollectI, rule conjI)
  fix x
  assume "x \<in> {x. x < dim_vec s \<and> vec_index s x = False}"
  hence xl: "x < dim_vec s" and nr: "vec_index s x = False" by simp_all
  show "vec_index r x = False"
    using r_le_s nr xl unfolding less_eq_vec_def
    by auto
  show "x < dim_vec r"
  using r_le_s xl unfolding less_eq_vec_def
    by auto
qed

text\<open>We introduce here instantiations of the typ\<open>bool\<close>
  type for the type classes class\<open>zero\<close> and class\<open>one\<close>
  that will simplify notation at some points:\<close>

instantiation bool :: "{zero,one}"
begin

definition
 zero_bool_def: "0 == False"

definition
 one_bool_def: "1 == True"

instance  proof  qed

end

text\<open>Definition of the simplicial complex induced
  by a Boolean function \<open>f\<close> in dimension \<open>n\<close>.\<close>

definition
  simplicial_complex_induced_by_monotone_boolean_function
    :: "nat => (bool vec => bool) => nat set set"
  where "simplicial_complex_induced_by_monotone_boolean_function n f =
        {y. \<exists>x. dim_vec x = n \<and> f x \<and> ceros_of_boolean_input x = y}"

text\<open>The simplicial complex induced by a Boolean function
  is a subset of the powerset of the set of vertexes.\<close>

lemma
  simplicial_complex_induced_by_monotone_boolean_function_subset:
  "simplicial_complex_induced_by_monotone_boolean_function n (v::bool vec => bool)
    \<subseteq> Pow (({0..n}::nat set))"
  using ceros_of_boolean_input_def
   simplicial_complex_induced_by_monotone_boolean_function_def
  by force

corollary
  "simplicial_complex_induced_by_monotone_boolean_function n (v::bool vec => bool)
    \<subseteq> Pow ((UNIV::nat set))" by simp

text\<open>The simplicial complex induced by a
  monotone Boolean function is a simplicial complex.
  This result is proven in Scoville as part of the
  proof of Proposition 6.16~\cite[Prop. 6.16]{SC19}.\<close>

context simplicial_complex
begin

lemma
  monotone_bool_fun_induces_simplicial_complex:
  assumes mon: "boolean_functions.monotone_bool_fun n f"
  shows "simplicial_complex (simplicial_complex_induced_by_monotone_boolean_function n f)"
  unfolding simplicial_complex_def
proof (rule, unfold simplicial_complex_induced_by_monotone_boolean_function_def, safe)
    fix \<sigma> :: "nat set" and x :: "bool vec"
    assume fx: "f x" and dim_vec_x: "n = dim_vec x"
    show "ceros_of_boolean_input x \<in> simplicial_complex.simplices (dim_vec x)"
      using ceros_of_boolean_input_def dim_vec_x simplices_def by force
  next
    fix \<sigma> :: "nat set" and x :: "bool vec" and \<tau> :: "nat set"
    assume fx: "f x" and dim_vec_x: "n = dim_vec x" and tau_def: "\<tau> \<subseteq> ceros_of_boolean_input x"
    show "\<exists>xb. dim_vec xb = dim_vec x \<and> f xb \<and> ceros_of_boolean_input xb = \<tau>"
    proof (rule exI [of _ "vec n (\<lambda>i. if i \<in> \<tau> then False else True)"], intro conjI)
     show "dim_vec (vec n (\<lambda>i. if i \<in> \<tau> then False else True)) = dim_vec x"
      unfolding dim_vec using dim_vec_x .
     from mon have mono: "mono_on f (carrier_vec n)"
      unfolding boolean_functions.monotone_bool_fun_def .
     show "f (vec n (\<lambda>i. if i \<in> \<tau> then False else True))"
     proof -
      have "f x \<le> f (vec n (\<lambda>i. if i \<in> \<tau> then False else True))"
      proof (rule mono_onD [OF mono])
        show "x \<in> carrier_vec n" using dim_vec_x by simp
        show "vec n (\<lambda>i. if i \<in> \<tau> then False else True) \<in> carrier_vec n" by simp
        show "x \<le> vec n (\<lambda>i. if i \<in> \<tau> then False else True)"
          using tau_def dim_vec_x unfolding ceros_of_boolean_input_def
          using less_eq_vec_def by fastforce
      qed
      thus ?thesis using fx by simp
    qed
    show "ceros_of_boolean_input (vec n (\<lambda>i. if i \<in> \<tau> then False else True)) = \<tau>"
      using \<open>\<tau> \<subseteq> ceros_of_boolean_input x\<close> ceros_of_boolean_input_def dim_vec_x by auto
  qed
qed

end

text\<open>Example 6.10 in Scoville, the threshold function
  for $2$ in dimension $4$ (with vertexes $0$,$1$,$2$,$3$)\<close>

definition bool_fun_threshold_2_3 :: "bool vec => bool"
  where "bool_fun_threshold_2_3 = (\<lambda>v. if 2 \<le> count_true v then True else False)"

lemma set_list_four: shows "{0..<4} = set [0,1,2,3::nat]" by auto

lemma comp_fun_commute_lambda:
  "comp_fun_commute_on UNIV ((+)
  \<circ> (\<lambda>i. if vec 4 f $ i then 1 else (0::nat)))"
  unfolding comp_fun_commute_on_def by auto

lemma "bool_fun_threshold_2_3
          (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False)) = True"
  unfolding bool_fun_threshold_2_3_def
  unfolding count_true_def
  unfolding dim_vec
  unfolding sum.eq_fold
  using index_vec [of _ 4]
  apply auto
  unfolding set_list_four
  unfolding comp_fun_commute_on.fold_set_fold_remdups [OF comp_fun_commute_lambda, simplified]
  by simp

lemma
  "0 \<notin> ceros_of_boolean_input (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False))"
  and "1 \<notin> ceros_of_boolean_input (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False))"
  and "2 \<in> ceros_of_boolean_input (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False))"
  and "3 \<in> ceros_of_boolean_input (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False))"
  and "{2,3} \<subseteq> ceros_of_boolean_input (vec 4 (\<lambda>i. if i = 0 \<or> i = 1 then True else False))"
  unfolding ceros_of_boolean_input_def by simp_all

lemma "bool_fun_threshold_2_3 (vec 4 (\<lambda>i. if i = 3 then True else False)) = False"
  unfolding bool_fun_threshold_2_3_def
  unfolding count_true_def
  unfolding dim_vec
  unfolding sum.eq_fold
  using index_vec [of _ 4]
  apply auto
  unfolding set_list_four
  unfolding comp_fun_commute_on.fold_set_fold_remdups [OF comp_fun_commute_lambda, simplified]
  by simp

lemma "bool_fun_threshold_2_3 (vec 4 (\<lambda>i. if i = 0 then False else True))"
  unfolding bool_fun_threshold_2_3_def
  unfolding count_true_def
  unfolding dim_vec
  unfolding sum.eq_fold
  using index_vec [of _ 4]
  apply auto
  unfolding set_list_four
  unfolding comp_fun_commute_on.fold_set_fold_remdups [OF comp_fun_commute_lambda, simplified]
  by simp

section\<open>The simplicial complex induced by the threshold function\<close>

lemma
  empty_set_in_simplicial_complex_induced:
  "{} \<in> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3"
  unfolding simplicial_complex_induced_by_monotone_boolean_function_def
  unfolding bool_fun_threshold_2_3_def
  apply rule
  apply (rule exI [of _ "vec 4 (\<lambda>x. True)"])
  unfolding count_true_def ceros_of_boolean_input_def by auto

lemma singleton_in_simplicial_complex_induced:
  assumes x: "x < 4"
  shows "{x} \<in> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3"
  (is "?A \<in> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3")
proof (unfold simplicial_complex_induced_by_monotone_boolean_function_def, rule,
      rule exI [of _ "vec 4 (\<lambda>i. if i \<in> ?A then False else True)"],
      intro conjI)
  show "dim_vec (vec 4 (\<lambda>i. if i \<in> {x} then False else True)) = 4" by simp
  show "bool_fun_threshold_2_3 (vec 4 (\<lambda>i. if i \<in> ?A then False else True))"
    unfolding bool_fun_threshold_2_3_def
    unfolding count_true_def
    unfolding dim_vec
    unfolding sum.eq_fold
    using index_vec [of _ 4]
    apply auto
    unfolding set_list_four
    unfolding comp_fun_commute_on.fold_set_fold_remdups [OF comp_fun_commute_lambda, simplified]
    by simp
  show "ceros_of_boolean_input (vec 4 (\<lambda>i. if i \<in> ?A then False else True)) = ?A"
    unfolding ceros_of_boolean_input_def using x by auto
qed

lemma pair_in_simplicial_complex_induced:
  assumes x: "x < 4" and y: "y < 4"
  shows "{x,y} \<in> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3"
  (is "?A \<in> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3")
proof (unfold simplicial_complex_induced_by_monotone_boolean_function_def, rule,
      rule exI [of _ "vec 4 (\<lambda>i. if i \<in> ?A then False else True)"],
      intro conjI)
  show "dim_vec (vec 4 (\<lambda>i. if i \<in> {x, y} then False else True)) = 4" by simp
  show "bool_fun_threshold_2_3 (vec 4 (\<lambda>i. if i \<in> ?A then False else True))"
    unfolding bool_fun_threshold_2_3_def
    unfolding count_true_def
    unfolding dim_vec
    unfolding sum.eq_fold
    using index_vec [of _ 4]
    apply auto
    unfolding set_list_four
    unfolding comp_fun_commute_on.fold_set_fold_remdups [OF comp_fun_commute_lambda, simplified]
    by simp
  show "ceros_of_boolean_input (vec 4 (\<lambda>i. if i \<in> ?A then False else True)) = ?A"
    unfolding ceros_of_boolean_input_def using x y by auto
qed

lemma finite_False: "finite {x. x < dim_vec a \<and> vec_index (a::bool vec) x = False}" by auto

lemma finite_True: "finite {x. x < dim_vec a \<and> vec_index (a::bool vec) x = True}" by auto

lemma UNIV_disjoint: "{x. x < dim_vec a \<and> vec_index (a::bool vec) x = True}
  \<inter> {x. x < dim_vec a \<and> vec_index (a::bool vec) x = False} = {}"
  by auto

lemma UNIV_union: "{x. x < dim_vec a \<and> vec_index (a::bool vec) x = True}
  \<union> {x. x < dim_vec a \<and> vec_index (a::bool vec) x = False} = {x. x < dim_vec a}"
  by auto

lemma card_UNIV_union:
  "card {x. x < dim_vec a \<and> vec_index (a::bool vec) x = True}
  + card {x. x < dim_vec a \<and> vec_index (a::bool vec) x = False}
  = card {x. x < dim_vec a}"
  (is "card ?true + card ?false = _")
proof -
  have "card ?true + card ?false = card (?true \<union> ?false) + card (?true \<inter> ?false)"
    using card_Un_Int [OF finite_True [of a] finite_False [of a]] .
  also have "... = card {x. x < dim_vec a}"
    unfolding UNIV_union UNIV_disjoint by simp
  finally show ?thesis by simp
qed

lemma card_complementary:
  "card (ceros_of_boolean_input v)
    + card {x. x < (dim_vec v) \<and> (vec_index v x = True)} = (dim_vec v)"
  unfolding ceros_of_boolean_input_def
  using card_UNIV_union [of v] by simp

corollary
  card_ceros_of_boolean_input:
  shows "card (ceros_of_boolean_input a) \<le> dim_vec a"
 using card_complementary [of a] by simp

lemma
  vec_fun:
  assumes "v \<in> carrier_vec n"
  shows "\<exists>f. v = vec n f" using assms unfolding carrier_vec_def by fastforce

corollary
  assumes "dim_vec v = n"
  shows "\<exists>f. v = vec n f"
  using carrier_vecI [OF assms] unfolding carrier_vec_def by fastforce

lemma
  vec_l_eq:
  assumes "i < n"
  shows "vec (Suc n) f $ i = vec n f $ i"
  by (simp add: assms less_SucI)

lemma
  card_boolean_function:
  assumes d: "v \<in> carrier_vec n"
  shows "card {x. x < n  \<and> v $ x = True} = (\<Sum>i = 0..<n. if v $ i then 1 else (0::nat))"
using d proof (induction n arbitrary: v rule: nat_less_induct)
  case (1 n)
  assume hyp: "\<forall>m<n. \<forall>x. x \<in> carrier_vec m \<longrightarrow>
      card {xa. xa < m \<and> x $ xa = True} = (\<Sum>i = 0..<m. if x $ i then 1 else 0)"
    and d: "v \<in> carrier_vec n"
  show "card {x. x < n \<and> v $ x = True} = (\<Sum>i = 0..<n. if v $ i then 1 else 0)"
  using d proof (cases n)
    case 0
    then show ?thesis by simp
  next
    case (Suc m)
    assume v: "v \<in> carrier_vec n"
    obtain f :: "nat => bool" where v_f: "v = vec n f" using vec_fun [OF v] by auto
    have "card {x. x < m \<and> (vec m f) $ x = True} = (\<Sum>i = 0..<m. if (vec m f) $ i then 1 else 0)"
      using hyp v Suc by simp
    show ?thesis unfolding v_f unfolding Suc
    proof (cases "vec (Suc m) f $ m = True")
      case True
      have one: "{x. x < Suc m \<and> vec (Suc m) f $ x = True} =
          ({x. x < m \<and> vec (Suc m) f $ x = True} \<union> {x. x = m \<and> (vec (Suc m) f) $ x = True})"
        by auto
      have two: "disjnt {x. x < m \<and> vec (Suc m) f $ x = True} {x. x = m \<and> (vec (Suc m) f) $ x = True}"
        using disjnt_iff by blast
      have "card {x. x < Suc m \<and> vec (Suc m) f $ x = True}
            = card {x. x < m \<and> (vec (Suc m) f) $ x = True} + card {x. x = m \<and> (vec (Suc m) f) $ x = True}"
        unfolding one
        by (rule card_Un_disjnt [OF _ _ two], simp_all)
      also have "... = card {x. x < m \<and> (vec  m f) $ x = True} + 1"
      proof -
        have one: "{x. x < m \<and> vec (Suc m) f $ x = True} = {x. x < m \<and> vec m f $ x = True}"
          using vec_l_eq [of _ m] by auto
        have eq: "{x. x = m \<and> vec (Suc m) f $ x = True} = {m}" using True by auto
        hence two: "card {x. x = m \<and> vec (Suc m) f $ x = True} = 1" by simp
        show ?thesis using one two by simp
      qed
      finally have lhs: "card {x. x < Suc m \<and> vec (Suc m) f $ x = True} = card {x. x < m \<and> vec m f $ x = True} + 1" .
      have "(\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0) =
           (\<Sum>i = 0..<m. if vec (Suc m) f $ i then 1 else 0) + (if vec (Suc m) f $ m then 1 else 0)"
        by simp
      also have "... = (\<Sum>i = 0..<m. if vec m f $ i then 1 else 0) + 1"
        using vec_l_eq [of _ m] True by simp
      finally have rhs: "(\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0) =
        (\<Sum>i = 0..<m. if vec m f $ i then 1 else 0) + 1" .
      show "card {x. x < Suc m \<and> vec (Suc m) f $ x = True} =
        (\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0)"
        unfolding lhs rhs using hyp Suc by simp
    next
      case False
      have one: "{x. x < Suc m \<and> vec (Suc m) f $ x = True} =
          ({x. x < m \<and> vec (Suc m) f $ x = True} \<union> {x. x = m \<and> (vec (Suc m) f) $ x = True})"
        by auto
      have two: "disjnt {x. x < m \<and> vec (Suc m) f $ x = True} {x. x = m \<and> (vec (Suc m) f) $ x = True}"
        using disjnt_iff by blast
      have "card {x. x < Suc m \<and> vec (Suc m) f $ x = True}
            = card {x. x < m \<and> (vec (Suc m) f) $ x = True} + card {x. x = m \<and> (vec (Suc m) f) $ x = True}"
        unfolding one
        by (rule card_Un_disjnt [OF _ _ two], simp_all)
      also have "... = card {x. x < m \<and> (vec  m f) $ x = True} + 0"
      proof -
        have one: "{x. x < m \<and> vec (Suc m) f $ x = True} = {x. x < m \<and> vec m f $ x = True}"
          using vec_l_eq [of _ m] by auto
        have eq: "{x. x = m \<and> vec (Suc m) f $ x = True} = {}" using False by auto
        hence two: "card {x. x = m \<and> vec (Suc m) f $ x = True} = 0" by simp
        show ?thesis using one two by simp
      qed
      finally have lhs: "card {x. x < Suc m \<and> vec (Suc m) f $ x = True} = card {x. x < m \<and> vec m f $ x = True} + 0" .
      have "(\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0) =
           (\<Sum>i = 0..<m. if vec (Suc m) f $ i then 1 else 0) + (if vec (Suc m) f $ m then 1 else 0)"
        by simp
      also have "... = (\<Sum>i = 0..<m. if vec m f $ i then 1 else 0)"
        using vec_l_eq [of _ m] False by simp
      finally have rhs: "(\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0) =
        (\<Sum>i = 0..<m. if vec m f $ i then 1 else 0)" .
      show "card {x. x < Suc m \<and> vec (Suc m) f $ x = True} =
        (\<Sum>i = 0..<Suc m. if vec (Suc m) f $ i then 1 else 0)"
        unfolding lhs rhs using hyp Suc by simp
    qed
  qed
qed

lemma card_ceros_count_UNIV:
  shows "card (ceros_of_boolean_input a) + count_true ((a::bool vec)) = dim_vec a"
  using card_complementary [of a]
  using card_boolean_function
  unfolding ceros_of_boolean_input_def
  unfolding count_true_def by simp

text\<open>We calculate the carrier set of the @{const ceros_of_boolean_input}
  function for dimensions $2$, $3$ and $4$.\<close>

text\<open>Vectors of dimension $2$.\<close>

lemma
  dim_vec_2_cases:
  assumes dx: "dim_vec x = 2"
  shows "(x $ 0 = x $ 1 = True) \<or> (x $ 0 = False \<and> x $ 1 = True)
       \<or> (x $ 0 = True \<and> x $ 1 = False) \<or> (x $ 0 = x $ 1 = False)"
  by auto

lemma tt_2: assumes dx: "dim_vec x = 2"
  and be: "x $ 0 = True \<and> x $ 1 = True"
  shows "ceros_of_boolean_input x = {}"
  using dx be unfolding ceros_of_boolean_input_def using less_2_cases by auto

lemma tf_2: assumes dx: "dim_vec x = 2"
  and be: "x $ 0 = True \<and> x $ 1 = False"
  shows "ceros_of_boolean_input x = {1}"
  using dx be unfolding ceros_of_boolean_input_def using less_2_cases by auto

lemma ft_2: assumes dx: "dim_vec x = 2"
  and be: "x $ 0 = False \<and> x $ 1 = True"
  shows "ceros_of_boolean_input x = {0}"
  using dx be unfolding ceros_of_boolean_input_def using less_2_cases by auto

lemma ff_2: assumes dx: "dim_vec x = 2"
  and be: "x $ 0 = False \<and> x $ 1 = False"
  shows "ceros_of_boolean_input x = {0,1}"
  using dx be unfolding ceros_of_boolean_input_def using less_2_cases by auto

lemma
  assumes dx: "dim_vec x = 2"
  shows "ceros_of_boolean_input x \<in> {{},{0},{1},{0,1}}"
  using dim_vec_2_cases [OF ]
  using tt_2 [OF dx] tf_2 [OF dx] ft_2 [OF dx] ff_2 [OF dx]
  by (metis insertCI)

text\<open>Vectors of dimension $3$.\<close>

lemma less_3_cases:
  assumes n: "n < 3" shows "n = 0 \<or> n = 1 \<or> n = (2::nat)"
  using n by linarith

lemma
  dim_vec_3_cases:
  assumes dx: "dim_vec x = 3"
  shows "(x $ 0 = x $ 1 = x $ 2 = False) \<or> (x $ 0 = x $ 1 = False \<and> x $ 2 = True)
       \<or> (x $ 0 = x $ 2 = False \<and> x $ 1 = True) \<or> (x $ 0 = False \<and> x $ 1 = x $ 2 = True)
       \<or> (x $ 0 = True \<and> x $ 1 = x $ 2 = False) \<or> (x $ 0 = x $ 2 = True \<and> x $ 1 = False)
       \<or> (x $ 0 = x $ 1 = True \<and> x $ 2 = False) \<or> (x $ 0 = x $ 1 = x $ 2 = True)"
  by auto

lemma fff_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = False"
  shows "ceros_of_boolean_input x = {0,1,2}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma fft_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = True"
  shows "ceros_of_boolean_input x = {0,1}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma ftf_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = False"
  shows "ceros_of_boolean_input x = {0,2}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by fastforce

lemma ftt_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = True"
  shows "ceros_of_boolean_input x = {0}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma tff_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = False"
  shows "ceros_of_boolean_input x = {1,2}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma tft_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = True"
  shows "ceros_of_boolean_input x = {1}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma ttf_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = False"
  shows "ceros_of_boolean_input x = {2}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by fastforce

lemma ttt_3: assumes dx: "dim_vec x = 3"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = True"
  shows "ceros_of_boolean_input x = {}"
  using dx be unfolding ceros_of_boolean_input_def
  using less_3_cases by auto

lemma
  assumes dx: "dim_vec x = 3"
  shows "ceros_of_boolean_input x \<in> {{},{0},{1},{2},{0,1},{0,2},{1,2},{0,1,2}}"
  using dim_vec_3_cases [OF ]
  using fff_3 [OF dx] fft_3 [OF dx] ftf_3 [OF dx] ftt_3 [OF dx]
  using tff_3 [OF dx] tft_3 [OF dx] ttf_3 [OF dx] ttt_3 [OF dx]
  by (smt (z3) insertCI)

text\<open>Vectors of dimension $4$.\<close>

lemma less_4_cases:
  assumes n: "n < 4"
  shows "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = (3::nat)"
  using n by linarith

lemma
  dim_vec_4_cases:
  assumes dx: "dim_vec x = 4"
  shows "(x $ 0 = x $ 1 = x $ 2 = x $ 3 = False) \<or> (x $ 0 = x $ 1 = x $ 2 = False \<and> x $ 3 = True)
       \<or> (x $ 0 = x $ 1 = x $ 3 = False \<and> x $ 2 = True) \<or> (x $ 0 = x $ 1 = False \<and> x $ 2 = x $ 3 = True)
       \<or> (x $ 0 = x $ 2 = x $ 3 = False \<and> x $ 1 = True) \<or> (x $ 0 = x $ 2 = False \<and> x $ 1 = x $ 3 = True)
       \<or> (x $ 0 = x $ 3 = False \<and> x $ 1 = x $ 2 = True) \<or> (x $ 0 = False \<and> x $ 1 = x $ 2 = x $ 3 = True)
       \<or> (x $ 0 = True \<and> x $ 1 = x $ 2 = x $ 3 = False) \<or> (x $ 0 = x $ 3 = True \<and> x $ 1 = x $ 2 = False)
       \<or> (x $ 0 = x $ 2 = True \<and> x $ 1 = x $ 3 = False) \<or> (x $ 0 = x $ 2 = x $ 3 = True \<and> x $ 1 = False)
       \<or> (x $ 0 = x $ 1 = True \<and> x $ 2 = x $ 3 = False) \<or> (x $ 0 = x $ 1 = x $ 3 = True \<and> x $ 2 = False)
       \<or> (x $ 0 = x $ 1 = x $ 2 = True \<and> x $ 3 = False) \<or> (x $ 0 = x $ 1 = x $ 2 = x $ 3 = True)"
  by blast

lemma ffff_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = False \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {0,1,2,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma ffft_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = False \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {0,1,2}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma fftf_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = True \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {0,1,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma fftt_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = False \<and> x $ 2 = True \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {0,1}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma ftff_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = False \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {0,2,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma ftft_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = False \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {0,2}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma fttf_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = True \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {0,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma fttt_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = False \<and> x $ 1 = True \<and> x $ 2 = True \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {0}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tfff_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = False \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {1,2,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tfft_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = False \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {1,2}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tftf_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = True \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {1,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tftt_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = False \<and> x $ 2 = True \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {1}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma ttff_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = False \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {2,3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma ttft_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = False \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {2}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tttf_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = True \<and> x $ 3 = False"
  shows "ceros_of_boolean_input x = {3}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma tttt_4: assumes dx: "dim_vec x = 4"
  and be: "x $ 0 = True \<and> x $ 1 = True \<and> x $ 2 = True \<and> x $ 3 = True"
  shows "ceros_of_boolean_input x = {}"
  using dx be
  unfolding ceros_of_boolean_input_def
  using less_4_cases by auto

lemma
  ceros_of_boolean_input_set:
  assumes dx: "dim_vec x = 4"
  shows "ceros_of_boolean_input x \<in> {{},{0},{1},{2},{3},{0,1},{0,2},{0,3},{1,2},{1,3},{2,3},
    {0,1,2},{0,1,3},{0,2,3},{1,2,3},{0,1,2,3}}"
  using dim_vec_4_cases [OF ]
  using ffff_4 [OF dx] ffft_4 [OF dx] fftf_4 [OF dx] fftt_4 [OF dx]
  using ftff_4 [OF dx] ftft_4 [OF dx] fttf_4 [OF dx] fttt_4 [OF dx]
  using tfff_4 [OF dx] tfft_4 [OF dx] tftf_4 [OF dx] tftt_4 [OF dx]
  using ttff_4 [OF dx] ttft_4 [OF dx] tttf_4 [OF dx] tttt_4 [OF dx]
  by (smt (z3) insertCI)

context simplicial_complex
begin

text\<open>The simplicial complex induced by the monotone Boolean function
  @{const bool_fun_threshold_2_3} has the following explicit expression.\<close>

lemma
  simplicial_complex_induced_by_monotone_boolean_function_4_bool_fun_threshold_2_3 [symmetric, code]:
  shows "{{},{0},{1},{2},{3},{0,1},{0,2},{0,3},{1,2},{1,3},{2,3}}
    = simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3"
  (is "{{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j} = _")
proof (rule)
  show "{{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j}
    \<subseteq> simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3"
    by (simp add:
        empty_set_in_simplicial_complex_induced
        singleton_in_simplicial_complex_induced pair_in_simplicial_complex_induced)+
  show "simplicial_complex_induced_by_monotone_boolean_function 4 bool_fun_threshold_2_3
    \<subseteq> {{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j}"
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding bool_fun_threshold_2_3_def
    proof
    fix y::"nat set"
    assume y: "y \<in> {y. \<exists>x. dim_vec x = 4 \<and> (if 2 \<le> count_true x then True else False) \<and> ceros_of_boolean_input x = y}"
      then obtain x::"bool vec"
        where ct_ge_2: "(if 2 \<le> count_true x then True else False)"
          and cx: "ceros_of_boolean_input x = y" and dx: "dim_vec x = 4" by auto
      have "count_true x + card (ceros_of_boolean_input x) = dim_vec x"
       using card_ceros_count_UNIV [of x] by simp
      hence "card (ceros_of_boolean_input x) \<le> 2"
        using ct_ge_2
        using card_boolean_function
        using dx by presburger
      hence card_le: "card y \<le> 2" using cx by simp
      have "y \<in> {{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j}"
      proof (rule ccontr)
        assume "y \<notin> {{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j}"
        then have y_nin: "y \<notin> set [{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j]" by simp
        have "y \<in> set [{0,1,2},{0,1,3},{0,2,3},{1,2,3},{0,1,2,3}]"
          using ceros_of_boolean_input_set [OF dx] y_nin
          unfolding cx by simp
        hence "card y \<ge> 3" by auto
        thus False using card_le by simp
      qed
      then show "y \<in> {{},?a,?b,?c,?d,?e,?f,?g,?h,?i,?j}"
      by simp
  qed
qed

end

end


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

section \<open>Dioids\<close>

theory Dioid
imports Signatures
begin

subsection \<open>Join Semilattices\<close>

text \<open>Join semilattices can be axiomatised order-theoretically or
algebraically. A join semilattice (or upper semilattice) is either a
poset in which every pair of elements has a join (or least upper
bound), or a set endowed with an associative, commutative, idempotent
binary operation. It is well known that the order-theoretic definition
induces the algebraic one and vice versa. We start from the algebraic
axiomatisation because it is easily expandable to dioids, using
Isabelle's type class mechanism.

In Isabelle/HOL, a type class @{class semilattice_sup} is available.
Alas, we cannot use this type class because we need the symbol~\<open>+\<close> for the join operation in the dioid expansion and subclass
proofs in Isabelle/HOL require the two type classes involved to have
the same fixed signature.

Using {\em add\_assoc} as a name for the first assumption in class
{\em join\_semilattice} would lead to name clashes: we will later
define classes that inherit from @{class semigroup_add}, which
provides its own assumption {\em add\_assoc}, and prove that these are
subclasses of {\em join\_semilattice}. Hence the primed name.
\<close>

class join_semilattice = plus_ord +
  assumes add_assoc' [ac_simps]: "(x + y) + z = x + (y + z)"
  and add_comm [ac_simps] : "x + y = y + x"
  and add_idem [simp]: "x + x = x"
begin

lemma add_left_comm [ac_simps]: "y + (x + z) = x + (y + z)"
  using local.add_assoc' local.add_comm by auto

lemma add_left_idem [ac_simps]: "x + (x + y) = x + y"
  unfolding add_assoc' [symmetric] by simp

text \<open>The definition @{term "x \<le> y \<longleftrightarrow> x + y = y"} of the order is
hidden in class @{class plus_ord}.

We show some simple order-based properties of semilattices. The
first one states that every semilattice is a partial order.\<close>

subclass order
proof
  fix x y z :: 'a
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    using local.add_comm local.less_def local.less_eq_def by force
  show "x \<le> x"
    by (simp add: local.less_eq_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (metis add_assoc' less_eq_def)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (simp add: local.add_comm local.less_eq_def)
qed

text \<open>Next we show that joins are least upper bounds.\<close>

sublocale join: semilattice_sup "(+)"
  by (unfold_locales; simp add: ac_simps local.less_eq_def)

text \<open>Next we prove that joins are isotone (order preserving).\<close>

lemma add_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  using join.sup_mono by blast

text \<open>
  The next lemma links the definition of order as @{term "x \<le> y \<longleftrightarrow> x + y = y"}
  with a perhaps more conventional one known, e.g., from arithmetics.
\<close>

lemma order_prop: "x \<le> y \<longleftrightarrow> (\<exists>z. x + z = y)"
proof
  assume "x \<le> y"
  hence "x + y = y"
    by (simp add: less_eq_def)
  thus "\<exists>z. x + z = y"
    by auto
next
  assume "\<exists>z. x + z = y"
  then obtain c where "x + c = y"
    by auto
  hence "x + c \<le> y"
    by simp
  thus "x \<le> y"
    by simp
qed

end (* join_semilattice *)

subsection \<open>Join Semilattices with an Additive Unit\<close>

text \<open>We now expand join semilattices by an additive unit~$0$. Is
the least element with respect to the order, and therefore often
denoted by~\<open>\<bottom>\<close>. Semilattices with a least element are often
called \emph{bounded}.\<close>

class join_semilattice_zero = join_semilattice + zero +
  assumes add_zero_l [simp]: "0 + x = x"

begin

subclass comm_monoid_add
  by (unfold_locales, simp_all add: add_assoc') (simp add: add_comm)

sublocale join: bounded_semilattice_sup_bot "(+)" "(\<le>)" "(<)" 0
  by unfold_locales (simp add: local.order_prop)

lemma no_trivial_inverse: "x \<noteq> 0 \<Longrightarrow> \<not>(\<exists>y. x + y = 0)"
  by (metis local.add_0_right local.join.sup_left_idem)

end (* join_semilattice_zero *)

subsection \<open>Near Semirings\<close>

text \<open>\emph{Near semirings} (also called seminearrings) are
generalisations of near rings to the semiring case. They have been
studied, for instance, in G.~Pilz's book~\cite{pilz83nearrings} on
near rings. According to his definition, a near semiring consists of
an additive and a multiplicative semigroup that interact via a single
distributivity law (left or right). The additive semigroup is not
required to be commutative. The definition is influenced by partial
transformation semigroups.

We only consider near semirings in which addition is commutative, and
in which the right distributivity law holds. We call such near
semirings \emph{abelian}.\<close>

class ab_near_semiring = ab_semigroup_add + semigroup_mult +
  assumes distrib_right' [simp]: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"

subclass (in semiring) ab_near_semiring
  by (unfold_locales, metis distrib_right)

class ab_pre_semiring = ab_near_semiring +
  assumes subdistl_eq: "z \<cdot> x + z \<cdot> (x + y) = z \<cdot> (x + y)"

subsection \<open>Variants of Dioids\<close>

text \<open>A \emph{near dioid} is an abelian near semiring in which
addition is idempotent. This generalises the notion of (additively)
idempotent semirings by dropping one distributivity law. Near dioids
are a starting point for process algebras.

By modelling variants of dioids as variants of semirings in which
addition is idempotent we follow the tradition of
Birkhoff~\cite{birkhoff67lattices}, but deviate from the definitions
in Gondran and Minoux's book~\cite{gondran10graphs}.\<close>

class near_dioid = ab_near_semiring + plus_ord +
  assumes add_idem' [simp]: "x + x = x"

begin

text \<open>Since addition is idempotent, the additive (commutative)
semigroup reduct of a near dioid is a semilattice. Near dioids are
therefore ordered by the semilattice order.\<close>

subclass join_semilattice
  by unfold_locales (auto simp add: add.commute add.left_commute)

text \<open>It follows that multiplication is right-isotone (but not
necessarily left-isotone).\<close>

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
proof -
  assume "x \<le> y"
  hence "x + y = y"
    by (simp add: less_eq_def)
  hence "(x + y) \<cdot> z = y \<cdot> z"
    by simp
  thus "x \<cdot> z \<le> y \<cdot> z"
    by (simp add: less_eq_def)
qed

lemma "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  (* nitpick [expect=genuine] -- "3-element counterexample" *)
oops

text \<open>The next lemma states that, in every near dioid, left
isotonicity and left subdistributivity are equivalent.\<close>

lemma mult_isol_equiv_subdistl:
  "(\<forall>x y z. x \<le> y \<longrightarrow> z \<cdot> x \<le> z \<cdot> y) \<longleftrightarrow> (\<forall>x y z. z \<cdot> x \<le> z \<cdot> (x + y))"
  by (metis local.join.sup_absorb2 local.join.sup_ge1)

text \<open>The following lemma is relevant to propositional Hoare logic.\<close>

lemma phl_cons1: "x \<le> w \<Longrightarrow> w \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x \<cdot> y \<le> y \<cdot> z"
  using dual_order.trans mult_isor by blast

end (* near_dioid *)

text \<open>We now make multiplication in near dioids left isotone, which
is equivalent to left subdistributivity, as we have seen. The
corresponding structures form the basis of probabilistic Kleene
algebras~\cite{mciverweber05pka} and game
algebras~\cite{venema03gamealgebra}. We are not aware that these
structures have a special name, so we baptise them \emph{pre-dioids}.

We do not explicitly define pre-semirings since we have no application
for them.\<close>

class pre_dioid = near_dioid +
  assumes subdistl: "z \<cdot> x \<le> z \<cdot> (x + y)"

begin

text \<open>Now, obviously, left isotonicity follows from left subdistributivity.\<close>

lemma subdistl_var: "z \<cdot> x + z \<cdot> y \<le> z \<cdot> (x + y)"
  using local.mult_isol_equiv_subdistl local.subdistl by auto

subclass ab_pre_semiring
  apply unfold_locales
  by (simp add: local.join.sup_absorb2 local.subdistl)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
proof -
  assume "x \<le> y"
  hence "x + y = y"
    by (simp add: less_eq_def)
  also have "z \<cdot> x + z \<cdot> y \<le> z \<cdot> (x + y)"
    using subdistl_var by blast
  moreover have "... = z \<cdot> y"
    by (simp add: calculation)
  ultimately show "z \<cdot> x \<le> z \<cdot> y"
    by auto
qed

lemma mult_isol_var: "u \<le> x \<Longrightarrow> v \<le> y \<Longrightarrow> u \<cdot> v \<le> x \<cdot> y"
  by (meson local.dual_order.trans local.mult_isor mult_isol)

lemma mult_double_iso: "x \<le> y \<Longrightarrow> w \<cdot> x \<cdot> z \<le> w \<cdot> y \<cdot> z"
  by (simp add: local.mult_isor mult_isol)

text \<open>The following lemmas are relevant to propositional Hoare logic.\<close>

lemma phl_cons2: "w \<le> x \<Longrightarrow> z \<cdot> y \<le> y \<cdot> w \<Longrightarrow> z \<cdot> y \<le> y \<cdot> x"
  using local.order_trans mult_isol by blast

lemma phl_seq:
assumes "p \<cdot> x \<le> x \<cdot> r"
and "r \<cdot> y \<le> y \<cdot> q"
shows "p \<cdot> (x \<cdot> y) \<le> x \<cdot> y \<cdot> q"
proof -
  have "p \<cdot> x \<cdot> y \<le> x \<cdot> r \<cdot> y"
    using assms(1) mult_isor by blast
  thus ?thesis
    by (metis assms(2) order_prop order_trans subdistl mult_assoc)
qed

lemma phl_cond:
assumes "u \<cdot> v \<le> v \<cdot> u \<cdot> v" and "u \<cdot> w \<le> w \<cdot> u \<cdot> w"
and "\<And>x y. u \<cdot> (x + y) \<le> u \<cdot> x + u \<cdot> y"
and "u \<cdot> v \<cdot> x \<le> x \<cdot> z" and "u \<cdot> w \<cdot> y \<le> y \<cdot> z"
shows "u \<cdot> (v \<cdot> x + w \<cdot> y) \<le> (v \<cdot> x + w \<cdot> y) \<cdot> z"
proof -
  have a: "u \<cdot> v \<cdot> x \<le> v \<cdot> x \<cdot> z" and b: "u \<cdot> w \<cdot> y \<le> w \<cdot> y \<cdot> z"
    by (metis assms mult_assoc phl_seq)+
  have  "u \<cdot> (v \<cdot> x + w \<cdot> y) \<le> u \<cdot> v \<cdot> x + u \<cdot> w \<cdot> y"
    using assms(3) mult_assoc by auto
  also have "... \<le> v \<cdot> x \<cdot> z + w \<cdot> y \<cdot> z"
    using a b join.sup_mono by blast
  finally show ?thesis
    by simp
qed

lemma phl_export1:
assumes "x \<cdot> y \<le> y \<cdot> x \<cdot> y"
and "(x \<cdot> y) \<cdot> z \<le> z \<cdot> w"
shows "x \<cdot> (y \<cdot> z) \<le> (y \<cdot> z) \<cdot> w"
proof -
  have "x \<cdot> y \<cdot> z \<le> y \<cdot> x \<cdot> y \<cdot> z"
    by (simp add: assms(1) mult_isor)
  thus ?thesis
    using assms(1) assms(2) mult_assoc phl_seq by auto
qed

end (* pre_dioid *)

text \<open>By adding a full left distributivity law we obtain semirings
(which are already available in Isabelle/HOL as @{class semiring})
from near semirings, and dioids from near dioids. Dioids are therefore
idempotent semirings.\<close>

class dioid = near_dioid + semiring

subclass (in dioid) pre_dioid
  by unfold_locales (simp add: local.distrib_left)

subsection \<open>Families of Nearsemirings with a Multiplicative Unit\<close>

text \<open>Multiplicative units are important, for instance, for defining
an operation of finite iteration or Kleene star on dioids. We do not
introduce left and right units separately since we have no application
for this.\<close>

class ab_near_semiring_one = ab_near_semiring + one +
  assumes mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"

begin

subclass monoid_mult
  by (unfold_locales, simp_all)

end (* ab_near_semiring_one *)

class ab_pre_semiring_one = ab_near_semiring_one + ab_pre_semiring

class near_dioid_one = near_dioid + ab_near_semiring_one

begin

text \<open>The following lemma is relevant to propositional Hoare logic.\<close>

lemma phl_skip: "x \<cdot> 1 \<le> 1 \<cdot> x"
  by simp

end

text \<open>For near dioids with one, it would be sufficient to require
$1+1=1$. This implies @{term "x+x=x"} for arbitray~@{term x} (but that
would lead to annoying redundant proof obligations in mutual
subclasses of @{class near_dioid_one} and @{class near_dioid} later).
\<close>

class pre_dioid_one = pre_dioid + near_dioid_one

class dioid_one = dioid + near_dioid_one

subclass (in dioid_one) pre_dioid_one ..

subsection \<open>Families of Nearsemirings with Additive Units\<close>

text \<open>
We now axiomatise an additive unit~$0$ for nearsemirings. The zero is
usually required to satisfy annihilation properties with respect to
multiplication. Due to applications we distinguish a zero which is
only a left annihilator from one that is also a right annihilator.
More briefly, we call zero either a left unit or a unit.

Semirings and dioids with a right zero only can be obtained from those
with a left unit by duality.
\<close>

class ab_near_semiring_one_zerol = ab_near_semiring_one + zero +
  assumes add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"

begin

text \<open>Note that we do not require~$0 \neq 1$.\<close>

lemma add_zeror [simp]: "x + 0 = x"
  by (subst add_commute) simp

end (* ab_near_semiring_one_zerol *)

class ab_pre_semiring_one_zerol = ab_near_semiring_one_zerol + ab_pre_semiring

begin

text \<open>The following lemma shows that there is no point defining pre-semirings separately from dioids.\<close>

lemma "1 + 1 = 1"
proof -
  have "1 + 1 = 1 \<cdot> 1 + 1 \<cdot> (1 + 0)"
    by simp
  also have "... = 1 \<cdot> (1 + 0)"
    using subdistl_eq by presburger
  finally show ?thesis
    by simp
qed

end (* ab_pre_semiring_one_zerol *)

class near_dioid_one_zerol = near_dioid_one + ab_near_semiring_one_zerol

subclass (in near_dioid_one_zerol) join_semilattice_zero
  by (unfold_locales, simp)

class pre_dioid_one_zerol = pre_dioid_one + ab_near_semiring_one_zerol

subclass (in pre_dioid_one_zerol) near_dioid_one_zerol ..

class semiring_one_zerol = semiring + ab_near_semiring_one_zerol

class dioid_one_zerol = dioid_one + ab_near_semiring_one_zerol

subclass (in dioid_one_zerol) pre_dioid_one_zerol ..

text \<open>We now make zero also a right annihilator.\<close>

class ab_near_semiring_one_zero = ab_near_semiring_one_zerol +
  assumes annir [simp]: "x \<cdot> 0 = 0"

class semiring_one_zero = semiring + ab_near_semiring_one_zero

class near_dioid_one_zero = near_dioid_one_zerol + ab_near_semiring_one_zero

class pre_dioid_one_zero = pre_dioid_one_zerol + ab_near_semiring_one_zero

subclass (in pre_dioid_one_zero) near_dioid_one_zero ..

class dioid_one_zero = dioid_one_zerol + ab_near_semiring_one_zero

subclass (in dioid_one_zero) pre_dioid_one_zero ..

subclass (in dioid_one_zero) semiring_one_zero ..

subsection \<open>Duality by Opposition\<close>

text \<open>
Swapping the order of multiplication in a semiring (or dioid) gives
another semiring (or dioid), called its \emph{dual} or
\emph{opposite}.
\<close>

definition (in times) opp_mult (infixl "\<odot>" 70)
  where "x \<odot> y \<equiv> y \<cdot> x"

lemma (in semiring_1) dual_semiring_1:
  "class.semiring_1 1 (\<odot>) (+) 0"
  by unfold_locales (auto simp add: opp_mult_def mult.assoc distrib_right distrib_left)

lemma (in dioid_one_zero) dual_dioid_one_zero:
  "class.dioid_one_zero (+) (\<odot>) 1 0 (\<le>) (<)"
  by unfold_locales (auto simp add: opp_mult_def mult.assoc distrib_right distrib_left)

subsection \<open>Selective Near Semirings\<close>

text \<open>In this section we briefly sketch a generalisation of the
notion of \emph{dioid}. Some important models, e.g. max-plus and
min-plus semirings, have that property.\<close>

class selective_near_semiring = ab_near_semiring + plus_ord +
  assumes select: "x + y = x \<or> x + y = y"

begin

lemma select_alt: "x + y \<in> {x,y}"
  by (simp add: local.select)

text \<open>It follows immediately that every selective near semiring is a near dioid.\<close>

subclass near_dioid
  by (unfold_locales, meson select)

text \<open>Moreover, the order in a selective near semiring is obviously linear.\<close>

subclass linorder
  by (unfold_locales, metis add.commute join.sup.orderI select)

end (*selective_near_semiring*)

class selective_semiring = selective_near_semiring + semiring_one_zero

begin

subclass dioid_one_zero ..

end (* selective_semiring *)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Bijection\<close>
theory Functions_Bijection
  imports
    Functions_Inverse
    Functions_Monotone
begin

consts bijection_on :: "'a \<Rightarrow> 'b \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> 'c) \<Rightarrow> bool"

overloading
  bijection_on_pred \<equiv> "bijection_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "bijection_on_pred P P' f g \<equiv>
    ([P] \<Rrightarrow>\<^sub>m P') f \<and>
    ([P'] \<Rrightarrow>\<^sub>m P) g \<and>
    inverse_on P f g \<and>
    inverse_on P' g f"
end

lemma bijection_onI [intro]:
  assumes "([P] \<Rrightarrow>\<^sub>m P') f"
  and "([P'] \<Rrightarrow>\<^sub>m P) g"
  and "inverse_on P f g"
  and "inverse_on P' g f"
  shows "bijection_on P P' f g"
  using assms unfolding bijection_on_pred_def by blast

lemma bijection_onE:
  assumes "bijection_on P P' f g"
  obtains "([P] \<Rrightarrow>\<^sub>m P') f" "([P'] \<Rrightarrow>\<^sub>m P) g"
    "inverse_on P f g" "inverse_on P' g f"
  using assms unfolding bijection_on_pred_def by blast

context
  fixes P :: "'a \<Rightarrow> bool"
  and P' :: "'b \<Rightarrow> bool"
  and f :: "'a \<Rightarrow> 'b"
begin

lemma mono_wrt_pred_if_bijection_on_left:
  assumes "bijection_on P P' f g"
  shows "([P] \<Rrightarrow>\<^sub>m P') f"
  using assms by (elim bijection_onE)

lemma mono_wrt_pred_if_bijection_on_right:
  assumes "bijection_on P P' f g"
  shows "([P'] \<Rrightarrow>\<^sub>m P) g"
  using assms by (elim bijection_onE)

lemma bijection_on_pred_right:
  assumes "bijection_on P P' f g"
  and "P x"
  shows "P' (f x)"
  using assms by (blast elim: bijection_onE)

lemma bijection_on_pred_left:
  assumes "bijection_on P P' f g"
  and "P' y"
  shows "P (g y)"
  using assms by (blast elim: bijection_onE)

lemma inverse_on_if_bijection_on_left_right:
  assumes "bijection_on P P' f g"
  shows "inverse_on P f g"
  using assms by (elim bijection_onE)

lemma inverse_on_if_bijection_on_right_left:
  assumes "bijection_on P P' f g"
  shows "inverse_on P' g f"
  using assms by (elim bijection_onE)

lemma bijection_on_left_right_eq_self:
  assumes "bijection_on P P' f g"
  and "P x"
  shows "g (f x) = x"
  using assms inverse_on_if_bijection_on_left_right
  by (intro inverse_onD)

lemma bijection_on_right_left_eq_self':
  assumes "bijection_on P P' f g"
  and "P' y"
  shows "f (g y) = y"
  using assms inverse_on_if_bijection_on_right_left by (intro inverse_onD)

lemma bijection_on_right_left_if_bijection_on_left_right:
  assumes "bijection_on P P' f g"
  shows "bijection_on P' P g f"
  using assms by (auto elim: bijection_onE)

lemma injective_on_if_bijection_on_left:
  assumes "bijection_on P P' f g"
  shows "injective_on P f"
  using assms
  by (intro injective_on_if_inverse_on inverse_on_if_bijection_on_left_right)

lemma injective_on_if_bijection_on_right:
  assumes "bijection_on P P' f g"
  shows "injective_on P' g"
  by (intro injective_on_if_inverse_on)
  (fact inverse_on_if_bijection_on_right_left[OF assms])

end

definition "bijection (f :: 'a \<Rightarrow> 'b) \<equiv> bijection_on (\<top> :: 'a \<Rightarrow> bool) (\<top> :: 'b \<Rightarrow> bool) f"

lemma bijection_eq_bijection_on:
  "bijection (f :: 'a \<Rightarrow> 'b) = bijection_on (\<top> :: 'a \<Rightarrow> bool) (\<top> :: 'b \<Rightarrow> bool) f"
  unfolding bijection_def ..

lemma bijectionI [intro]:
  assumes "inverse f g"
  and "inverse g f"
  shows "bijection f g"
  unfolding bijection_eq_bijection_on using assms
  by (intro bijection_onI inverse_on_if_inverse dep_mono_wrt_predI) simp_all

lemma bijectionE [elim]:
  assumes "bijection f g"
  obtains "inverse f g" "inverse g f"
  using assms unfolding bijection_eq_bijection_on inverse_eq_inverse_on
  by (blast elim: bijection_onE)

lemma inverse_if_bijection_left_right:
  assumes "bijection f g"
  shows "inverse f g"
  using assms by (elim bijectionE)

lemma inverse_if_bijection_right_left:
  assumes "bijection f g"
  shows "inverse g f"
  using assms by (elim bijectionE)

lemma bijection_right_left_if_bijection_left_right:
  assumes "bijection f g"
  shows "bijection g f"
  using assms by auto

paragraph \<open>Instantiations\<close>

lemma bijection_on_self_id:
  fixes P :: "'a \<Rightarrow> bool"
  shows "bijection_on P P (id :: 'a \<Rightarrow> _) id"
  by (intro bijection_onI inverse_onI dep_mono_wrt_predI) simp_all

end


(*  Title:      FOL/ex/First_Order_Logic.thy
    Author:     Markus Wenzel, TU Munich
*)

section {* A simple formulation of First-Order Logic *}

theory First_Order_Logic imports Pure begin

text {*
  The subsequent theory development illustrates single-sorted
  intuitionistic first-order logic with equality, formulated within
  the Pure framework.  Actually this is not an example of
  Isabelle/FOL, but of Isabelle/Pure.
*}

subsection {* Syntax *}

typedecl i
typedecl o

judgment
  Trueprop :: "o \<Rightarrow> prop"    ("_" 5)

subsection {* Propositional logic *}

axiomatization
  false :: o  ("\<bottom>") and
  imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25) and
  conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35) and
  disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
where
  falseE [elim]: "\<bottom> \<Longrightarrow> A" and

  impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B" and
  mp [dest]: "A \<longrightarrow> B \<Longrightarrow> A \<Longrightarrow> B" and

  conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B" and
  conjD1: "A \<and> B \<Longrightarrow> A" and
  conjD2: "A \<and> B \<Longrightarrow> B" and

  disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C" and
  disjI1 [intro]: "A \<Longrightarrow> A \<or> B" and
  disjI2 [intro]: "B \<Longrightarrow> A \<or> B"

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from `A \<and> B` show A by (rule conjD1)
  from `A \<and> B` show B by (rule conjD2)
qed

definition
  true :: o  ("\<top>") where
  "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

definition
  not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40) where
  "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

definition
  iff :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longleftrightarrow>" 25) where
  "A \<longleftrightarrow> B \<equiv> (A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"

theorem trueI [intro]: \<top>
proof (unfold true_def)
  show "\<bottom> \<longrightarrow> \<bottom>" ..
qed

theorem notI [intro]: "(A \<Longrightarrow> \<bottom>) \<Longrightarrow> \<not> A"
proof (unfold not_def)
  assume "A \<Longrightarrow> \<bottom>"
  then show "A \<longrightarrow> \<bottom>" ..
qed

theorem notE [elim]: "\<not> A \<Longrightarrow> A \<Longrightarrow> B"
proof (unfold not_def)
  assume "A \<longrightarrow> \<bottom>" and A
  then have \<bottom> .. then show B ..
qed

theorem iffI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> (B \<Longrightarrow> A) \<Longrightarrow> A \<longleftrightarrow> B"
proof (unfold iff_def)
  assume "A \<Longrightarrow> B" then have "A \<longrightarrow> B" ..
  moreover assume "B \<Longrightarrow> A" then have "B \<longrightarrow> A" ..
  ultimately show "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)" ..
qed

theorem iff1 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> A \<Longrightarrow> B"
proof (unfold iff_def)
  assume "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
  then have "A \<longrightarrow> B" ..
  then show "A \<Longrightarrow> B" ..
qed

theorem iff2 [elim]: "A \<longleftrightarrow> B \<Longrightarrow> B \<Longrightarrow> A"
proof (unfold iff_def)
  assume "(A \<longrightarrow> B) \<and> (B \<longrightarrow> A)"
  then have "B \<longrightarrow> A" ..
  then show "B \<Longrightarrow> A" ..
qed

subsection {* Equality *}

axiomatization
  equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infixl "=" 50)
where
  refl [intro]: "x = x" and
  subst: "x = y \<Longrightarrow> P x \<Longrightarrow> P y"

theorem trans [trans]: "x = y \<Longrightarrow> y = z \<Longrightarrow> x = z"
  by (rule subst)

theorem sym [sym]: "x = y \<Longrightarrow> y = x"
proof -
  assume "x = y"
  from this and refl show "y = x" by (rule subst)
qed

subsection {* Quantifiers *}

axiomatization
  All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10) and
  Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
where
  allI [intro]: "(\<And>x. P x) \<Longrightarrow> \<forall>x. P x" and
  allD [dest]: "\<forall>x. P x \<Longrightarrow> P a" and
  exI [intro]: "P a \<Longrightarrow> \<exists>x. P x" and
  exE [elim]: "\<exists>x. P x \<Longrightarrow> (\<And>x. P x \<Longrightarrow> C) \<Longrightarrow> C"

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then show "\<exists>y. P y"
  proof
    fix x assume "P (f x)"
    then show ?thesis ..
  qed
qed

lemma "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
proof
  assume "\<exists>x. \<forall>y. R x y"
  then show "\<forall>y. \<exists>x. R x y"
  proof
    fix x assume a: "\<forall>y. R x y"
    show ?thesis
    proof
      fix y from a have "R x y" ..
      then show "\<exists>x. R x y" ..
    qed
  qed
qed

end


(*
  File:     Complex_Roots_Of_Unity.thy
  Authors:  Rodrigo Raya, EPFL; Manuel Eberl, TUM

  Complex roots of unity (exp(2i\<pi>/n)) and sums over them.
*)
theory Complex_Roots_Of_Unity
imports
  "HOL-Analysis.Analysis"
  Periodic_Arithmetic
begin

section \<open>Complex roots of unity\<close>

definition
  "unity_root k n = cis (2 * pi * of_int n / of_nat k)"

lemma
  unity_root_k_0 [simp]: "unity_root k 0 = 1" and
  unity_root_0_n [simp]: "unity_root 0 n = 1"
  unfolding unity_root_def by simp+

lemma unity_root_conv_exp:
  "unity_root k n = exp (of_real (2*pi*n/k) * \<i>)"
  unfolding unity_root_def
  by (subst cis_conv_exp,subst mult.commute,blast)

lemma unity_root_mod:
  "unity_root k (n mod int k) = unity_root k n"
proof (cases "k = 0")
  case True then show ?thesis by simp
next
  case False
  obtain q :: int where q_def: "n = q*k + (n mod k)"
    using div_mult_mod_eq[symmetric] by blast
  have "n / k = q + (n mod k) / k"
  proof (auto simp add: divide_simps False)
    have "real_of_int n = real_of_int (q*k + (n mod k))"
      using q_def by simp
    also have "\<dots> = real_of_int q * real k + real_of_int (n mod k)"
      using of_int_add of_int_mult by simp
    finally show "real_of_int n = real_of_int q * real k + real_of_int (n mod k)"
      by blast
  qed
  then have "(2*pi*n/k) = 2*pi*q + (2*pi*(n mod k)/k)"
    using False by (auto simp add: field_simps)
  then have "(2*pi*n/k)*\<i> = 2*pi*q*\<i> + (2*pi*(n mod k)/k)*\<i>" (is "?l = ?r1 + ?r2")
    by (auto simp add: algebra_simps)
  then have "exp ?l = exp ?r2"
    using exp_plus_2pin by (simp add: exp_add mult.commute)
  then show ?thesis
    using unity_root_def unity_root_conv_exp by simp
qed

lemma unity_root_cong:
  assumes "[m = n] (mod int k)"
  shows   "unity_root k m = unity_root k n"
proof -
  from assms have "m mod int k = n mod int k"
    by (auto simp: cong_def)
  hence "unity_root k (m mod int k) = unity_root k (n mod int k)"
    by simp
  thus ?thesis by (simp add: unity_root_mod)
qed

lemma unity_root_mod_nat:
  "unity_root k (nat (n mod int k)) = unity_root k n"
proof (cases k)
  case (Suc l)
  then have "n mod int k \<ge> 0" by auto
  show ?thesis
    unfolding int_nat_eq
    by (simp add: \<open>n mod int k \<ge> 0\<close> unity_root_mod)
qed auto

lemma unity_root_eqD:
 assumes gr: "k > 0"
 assumes eq: "unity_root k i = unity_root k j"
 shows "i mod k = j mod k"
proof -
  let ?arg1 = "(2*pi*i/k)* \<i>"
  let ?arg2 = "(2*pi*j/k)* \<i>"
  from eq unity_root_conv_exp have "exp ?arg1 = exp ?arg2" by simp
  from this exp_eq
  obtain n :: int where "?arg1 = ?arg2 +(2*n*pi)*\<i>" by blast
  then have e1: "?arg1 - ?arg2 = 2*n*pi*\<i>" by simp
  have e2: "?arg1 - ?arg2 = 2*(i-j)*(1/k)*pi*\<i>"
    by (auto simp add: algebra_simps)
  from e1 e2 have "2*n*pi*\<i> = 2*(i-j)*(1/k)*pi*\<i>" by simp
  then have "2*n*k*pi*\<i> = 2*(i-j)*pi*\<i>"
    by (simp add: divide_simps \<open>k > 0\<close>)(simp add: field_simps)
  then have "2*n*k = 2*(i-j)"
    by (meson complex_i_not_zero mult_cancel_right of_int_eq_iff of_real_eq_iff pi_neq_zero)
  then have "n*k = i-j" by auto
  then show ?thesis by Groebner_Basis.algebra
qed

lemma unity_root_eq_1_iff:
  fixes k n :: nat
  assumes "k > 0"
  shows "unity_root k n = 1 \<longleftrightarrow> k dvd n"
proof -
  have "unity_root k n = exp ((2*pi*n/k) * \<i>)"
    by (simp add: unity_root_conv_exp)
  also have "exp ((2*pi*n/k)* \<i>) = 1 \<longleftrightarrow> k dvd n"
    using complex_root_unity_eq_1[of k n] assms
    by (auto simp add: algebra_simps)
  finally show ?thesis by simp
qed

lemma unity_root_pow: "unity_root k n ^ m = unity_root k (n * m)"
  using unity_root_def
  by (simp add: Complex.DeMoivre mult.commute algebra_split_simps(6))

lemma unity_root_add: "unity_root k (m + n) = unity_root k m * unity_root k n"
  by (simp add: unity_root_conv_exp add_divide_distrib algebra_simps exp_add)

lemma unity_root_uminus: "unity_root k (-m) = cnj (unity_root k m)"
  unfolding unity_root_conv_exp exp_cnj by simp

lemma inverse_unity_root: "inverse (unity_root k m) = cnj (unity_root k m)"
  unfolding unity_root_conv_exp exp_cnj by (simp add: field_simps exp_minus)

lemma unity_root_diff: "unity_root k (m - n) = unity_root k m * cnj (unity_root k n)"
  using unity_root_add[of k m "-n"] by (simp add: unity_root_uminus)

lemma unity_root_eq_1_iff_int:
  fixes k :: nat and n :: int
  assumes "k > 0"
  shows "unity_root k n = 1 \<longleftrightarrow> k dvd n"
proof (cases "n \<ge> 0")
  case True
  obtain n' where "n = int n'"
    using zero_le_imp_eq_int[OF True] by blast
  then show ?thesis
    using unity_root_eq_1_iff[OF \<open>k > 0\<close>, of n'] of_nat_dvd_iff by blast
next
  case False
  then have "-n \<ge> 0" by auto
  have "unity_root k n = inverse (unity_root k (-n))"
    unfolding inverse_unity_root by (simp add: unity_root_uminus)
  then have "(unity_root k n = 1) = (unity_root k (-n) = 1)"
    by simp
  also have "(unity_root k (-n) = 1) = (k dvd (-n))"
    using unity_root_eq_1_iff[of k "nat (-n)",OF \<open>k > 0\<close>] False
          int_dvd_int_iff[of k "nat (-n)"] nat_0_le[OF \<open>-n \<ge> 0\<close>] by auto
  finally show ?thesis by simp
qed

lemma unity_root_eq_1 [simp]: "int k dvd n \<Longrightarrow> unity_root k n = 1"
  by (cases "k = 0") (auto simp: unity_root_eq_1_iff_int)

lemma unity_periodic_arithmetic:
  "periodic_arithmetic (unity_root k) k"
  unfolding periodic_arithmetic_def
proof
  fix n
  have "unity_root k (n + k) = unity_root k ((n+k) mod k)"
    using unity_root_mod[of k] zmod_int by presburger
  also have "unity_root k ((n+k) mod k) = unity_root k n"
    using unity_root_mod zmod_int by auto
  finally show "unity_root k (n + k) = unity_root k n" by simp
qed

lemma unity_periodic_arithmetic_mult:
  "periodic_arithmetic (\<lambda>n. unity_root k (m * int n)) k"
  unfolding periodic_arithmetic_def
proof
  fix n
  have "unity_root k (m * int (n + k)) =
        unity_root k (m*n + m*k)"
    by (simp add: algebra_simps)
  also have "\<dots> = unity_root k (m*n)"
    using unity_root_mod[of k "m * int n"] unity_root_mod[of k "m * int n + m * int k"]
          mod_mult_self3 by presburger
  finally show "unity_root k (m * int (n + k)) =
             unity_root k (m * int n)" by simp
qed

lemma unity_root_periodic_arithmetic_mult_minus:
  shows "periodic_arithmetic (\<lambda>i. unity_root k (-int i*int m)) k"
  unfolding periodic_arithmetic_def
proof
  fix n
  have "unity_root k (-(n + k) * m) = cnj (unity_root k (n*m+k*m))"
    by (simp add: ring_distribs unity_root_diff unity_root_add unity_root_uminus)
  also have "\<dots> = cnj (unity_root k (n*m))"
    using mult_period[of "unity_root k" k m] unity_periodic_arithmetic[of k]
    unfolding periodic_arithmetic_def by presburger
  also have "\<dots> = unity_root k (-n*m)"
    by (simp add: unity_root_uminus)
  finally show "unity_root k (-(n + k) * m) = unity_root k (-n*m)"
    by simp
qed

lemma unity_div:
 fixes a :: int and d :: nat
 assumes "d dvd k"
 shows "unity_root k (a*d) = unity_root (k div d) a"
proof -
  have 1: "(2*pi*(a*d)/k) = (2*pi*a)/(k div d)"
    using Suc_pred assms by (simp add: divide_simps, fastforce)
  have "unity_root k (a*d) = exp ((2*pi*(a*d)/k)* \<i>)"
    using unity_root_conv_exp by simp
  also have "\<dots> = exp (((2*pi*a)/(k div d))* \<i>)"
    using 1 by simp
  also have "\<dots> = unity_root (k div d) a"
    using unity_root_conv_exp by simp
  finally show ?thesis by simp
qed

lemma unity_div_num:
  assumes "k > 0" "d > 0" "d dvd k"
  shows "unity_root k (x * (k div d)) = unity_root d x"
  using assms dvd_div_mult_self unity_div by auto

section \<open>Geometric sums of roots of unity\<close>

text\<open>
  Apostol calls these `geometric sums', which is a bit too generic. We therefore decided
  to refer to them as `sums of roots of unity'.
\<close>
definition "unity_root_sum k n = (\<Sum>m<k. unity_root k (n * of_nat m))"

lemma unity_root_sum_0_left [simp]: "unity_root_sum 0 n = 0" and
      unity_root_sum_0_right [simp]: "k > 0 \<Longrightarrow> unity_root_sum k 0 = k"
  unfolding unity_root_sum_def by simp_all

text \<open>Theorem 8.1\<close>
theorem unity_root_sum:
  fixes k :: nat and n :: int
  assumes gr: "k \<ge> 1"
  shows "k dvd n \<Longrightarrow> unity_root_sum k n = k"
    and "\<not>k dvd n \<Longrightarrow> unity_root_sum k n = 0"
proof -
  assume dvd: "k dvd n"
  let ?x = "unity_root k n"
  have unit: "?x = 1" using dvd gr unity_root_eq_1_iff_int by auto
  have exp: "?x^m = unity_root k (n*m)" for m using unity_root_pow by simp
  have "unity_root_sum k n = (\<Sum>m<k. unity_root k (n*m))"
    using unity_root_sum_def by simp
  also have "\<dots> = (\<Sum>m<k. ?x^m)" using exp by auto
  also have "\<dots> = (\<Sum>m<k. 1)" using unit by simp
  also have "\<dots> = k" using gr by (induction k, auto)
  finally show "unity_root_sum k n = k" by simp
next
  assume dvd: "\<not>k dvd n"
  let ?x = "unity_root k n"
  have "?x \<noteq> 1" using dvd gr unity_root_eq_1_iff_int by auto
  have "(?x^k - 1)/(?x - 1) = (\<Sum>m<k. ?x^m)"
    using geometric_sum[of ?x k, OF \<open>?x \<noteq> 1\<close>] by auto
  then have sum: "unity_root_sum k n = (?x^k - 1)/(?x - 1)"
    using unity_root_sum_def unity_root_pow by simp
  have "?x^k = 1"
    using gr unity_root_eq_1_iff_int unity_root_pow by simp
  then show "unity_root_sum k n = 0" using sum by auto
qed

corollary unity_root_sum_periodic_arithmetic:
 "periodic_arithmetic (unity_root_sum k) k"
  unfolding periodic_arithmetic_def
proof
  fix n
  show "unity_root_sum k (n + k) = unity_root_sum k n"
    by (cases "k = 0"; cases "k dvd n") (auto simp add: unity_root_sum)
qed

lemma unity_root_sum_nonzero_iff:
  fixes r :: int
  assumes "k \<ge> 1" and "r \<in> {-k<..<k}"
  shows "unity_root_sum k r \<noteq> 0 \<longleftrightarrow> r = 0"
proof
  assume "unity_root_sum k r \<noteq> 0"
  then have "k dvd r" using unity_root_sum assms by blast
  then show "r = 0" using assms(2)
    using dvd_imp_le_int by force
next
  assume "r = 0"
  then have "k dvd r" by auto
  then have "unity_root_sum k r = k"
    using assms(1) unity_root_sum by blast
  then show "unity_root_sum k r \<noteq> 0" using assms(1) by simp
qed

end