(*  Title:      HOL/Analysis/Operator_Norm.thy
    Author:     Amine Chaieb, University of Cambridge
    Author:     Brian Huffman
*)

section \<open>Operator Norm\<close>

theory Operator_Norm
imports Complex_Main
begin

text \<open>This formulation yields zero if \<open>'a\<close> is the trivial vector space.\<close>

definition onorm :: "('a::real_normed_vector \<Rightarrow> 'b::real_normed_vector) \<Rightarrow> real"
  where "onorm f = (SUP x. norm (f x) / norm x)"

lemma onorm_bound:
  assumes "0 \<le> b" and "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
  unfolding onorm_def
proof (rule cSUP_least)
  fix x
  show "norm (f x) / norm x \<le> b"
    using assms by (cases "x = 0") (simp_all add: pos_divide_le_eq)
qed simp

text \<open>In non-trivial vector spaces, the first assumption is redundant.\<close>

lemma onorm_le:
  fixes f :: "'a::{real_normed_vector, perfect_space} \<Rightarrow> 'b::real_normed_vector"
  assumes "\<And>x. norm (f x) \<le> b * norm x"
  shows "onorm f \<le> b"
proof (rule onorm_bound [OF _ assms])
  have "{0::'a} \<noteq> UNIV" by (metis not_open_singleton open_UNIV)
  then obtain a :: 'a where "a \<noteq> 0" by fast
  have "0 \<le> b * norm a"
    by (rule order_trans [OF norm_ge_zero assms])
  with \<open>a \<noteq> 0\<close> show "0 \<le> b"
    by (simp add: zero_le_mult_iff)
qed

lemma le_onorm:
  assumes "bounded_linear f"
  shows "norm (f x) / norm x \<le> onorm f"
proof -
  interpret f: bounded_linear f by fact
  obtain b where "0 \<le> b" and "\<forall>x. norm (f x) \<le> norm x * b"
    using f.nonneg_bounded by auto
  then have "\<forall>x. norm (f x) / norm x \<le> b"
    by (clarify, case_tac "x = 0",
      simp_all add: f.zero pos_divide_le_eq mult.commute)
  then have "bdd_above (range (\<lambda>x. norm (f x) / norm x))"
    unfolding bdd_above_def by fast
  with UNIV_I show ?thesis
    unfolding onorm_def by (rule cSUP_upper)
qed

lemma onorm:
  assumes "bounded_linear f"
  shows "norm (f x) \<le> onorm f * norm x"
proof -
  interpret f: bounded_linear f by fact
  show ?thesis
  proof (cases)
    assume "x = 0"
    then show ?thesis by (simp add: f.zero)
  next
    assume "x \<noteq> 0"
    have "norm (f x) / norm x \<le> onorm f"
      by (rule le_onorm [OF assms])
    then show "norm (f x) \<le> onorm f * norm x"
      by (simp add: pos_divide_le_eq \<open>x \<noteq> 0\<close>)
  qed
qed

lemma onorm_pos_le:
  assumes f: "bounded_linear f"
  shows "0 \<le> onorm f"
  using le_onorm [OF f, where x=0] by simp

lemma onorm_zero: "onorm (\<lambda>x. 0) = 0"
proof (rule order_antisym)
  show "onorm (\<lambda>x. 0) \<le> 0"
    by (simp add: onorm_bound)
  show "0 \<le> onorm (\<lambda>x. 0)"
    using bounded_linear_zero by (rule onorm_pos_le)
qed

lemma onorm_eq_0:
  assumes f: "bounded_linear f"
  shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
  using onorm [OF f] by (auto simp: fun_eq_iff [symmetric] onorm_zero)

lemma onorm_pos_lt:
  assumes f: "bounded_linear f"
  shows "0 < onorm f \<longleftrightarrow> \<not> (\<forall>x. f x = 0)"
  by (simp add: less_le onorm_pos_le [OF f] onorm_eq_0 [OF f])

lemma onorm_id_le: "onorm (\<lambda>x. x) \<le> 1"
  by (rule onorm_bound) simp_all

lemma onorm_id: "onorm (\<lambda>x. x::'a::{real_normed_vector, perfect_space}) = 1"
proof (rule antisym[OF onorm_id_le])
  have "{0::'a} \<noteq> UNIV" by (metis not_open_singleton open_UNIV)
  then obtain x :: 'a where "x \<noteq> 0" by fast
  hence "1 \<le> norm x / norm x"
    by simp
  also have "\<dots> \<le> onorm (\<lambda>x::'a. x)"
    by (rule le_onorm) (rule bounded_linear_ident)
  finally show "1 \<le> onorm (\<lambda>x::'a. x)" .
qed

lemma onorm_compose:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (f \<circ> g) \<le> onorm f * onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f * onorm g"
    by (intro mult_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f (g x)) \<le> onorm f * norm (g x)"
    by (rule onorm [OF f])
  also have "onorm f * norm (g x) \<le> onorm f * (onorm g * norm x)"
    by (rule mult_left_mono [OF onorm [OF g] onorm_pos_le [OF f]])
  finally show "norm ((f \<circ> g) x) \<le> onorm f * onorm g * norm x"
    by (simp add: mult.assoc)
qed

lemma onorm_scaleR_lemma:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
proof (rule onorm_bound)
  show "0 \<le> \<bar>r\<bar> * onorm f"
    by (intro mult_nonneg_nonneg onorm_pos_le abs_ge_zero f)
next
  fix x
  have "\<bar>r\<bar> * norm (f x) \<le> \<bar>r\<bar> * (onorm f * norm x)"
    by (intro mult_left_mono onorm abs_ge_zero f)
  then show "norm (r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f * norm x"
    by (simp only: norm_scaleR mult.assoc)
qed

lemma onorm_scaleR:
  assumes f: "bounded_linear f"
  shows "onorm (\<lambda>x. r *\<^sub>R f x) = \<bar>r\<bar> * onorm f"
proof (cases "r = 0")
  assume "r \<noteq> 0"
  show ?thesis
  proof (rule order_antisym)
    show "onorm (\<lambda>x. r *\<^sub>R f x) \<le> \<bar>r\<bar> * onorm f"
      using f by (rule onorm_scaleR_lemma)
  next
    have "bounded_linear (\<lambda>x. r *\<^sub>R f x)"
      using bounded_linear_scaleR_right f by (rule bounded_linear_compose)
    then have "onorm (\<lambda>x. inverse r *\<^sub>R r *\<^sub>R f x) \<le> \<bar>inverse r\<bar> * onorm (\<lambda>x. r *\<^sub>R f x)"
      by (rule onorm_scaleR_lemma)
    with \<open>r \<noteq> 0\<close> show "\<bar>r\<bar> * onorm f \<le> onorm (\<lambda>x. r *\<^sub>R f x)"
      by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
  qed
qed (simp add: onorm_zero)

lemma onorm_scaleR_left_lemma:
  assumes r: "bounded_linear r"
  shows "onorm (\<lambda>x. r x *\<^sub>R f) \<le> onorm r * norm f"
proof (rule onorm_bound)
  fix x
  have "norm (r x *\<^sub>R f) = norm (r x) * norm f"
    by simp
  also have "\<dots> \<le> onorm r * norm x * norm f"
    by (intro mult_right_mono onorm r norm_ge_zero)
  finally show "norm (r x *\<^sub>R f) \<le> onorm r * norm f * norm x"
    by (simp add: ac_simps)
qed (intro mult_nonneg_nonneg norm_ge_zero onorm_pos_le r)

lemma onorm_scaleR_left:
  assumes f: "bounded_linear r"
  shows "onorm (\<lambda>x. r x *\<^sub>R f) = onorm r * norm f"
proof (cases "f = 0")
  assume "f \<noteq> 0"
  show ?thesis
  proof (rule order_antisym)
    show "onorm (\<lambda>x. r x *\<^sub>R f) \<le> onorm r * norm f"
      using f by (rule onorm_scaleR_left_lemma)
  next
    have bl1: "bounded_linear (\<lambda>x. r x *\<^sub>R f)"
      by (metis bounded_linear_scaleR_const f)
    have "bounded_linear (\<lambda>x. r x * norm f)"
      by (metis bounded_linear_mult_const f)
    from onorm_scaleR_left_lemma[OF this, of "inverse (norm f)"]
    have "onorm r \<le> onorm (\<lambda>x. r x * norm f) * inverse (norm f)"
      using \<open>f \<noteq> 0\<close>
      by (simp add: inverse_eq_divide)
    also have "onorm (\<lambda>x. r x * norm f) \<le> onorm (\<lambda>x. r x *\<^sub>R f)"
      by (rule onorm_bound)
        (auto simp: abs_mult bl1 onorm_pos_le intro!: order_trans[OF _ onorm])
    finally show "onorm r * norm f \<le> onorm (\<lambda>x. r x *\<^sub>R f)"
      using \<open>f \<noteq> 0\<close>
      by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
  qed
qed (simp add: onorm_zero)

lemma onorm_neg:
  shows "onorm (\<lambda>x. - f x) = onorm f"
  unfolding onorm_def by simp

lemma onorm_triangle:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "onorm (\<lambda>x. f x + g x) \<le> onorm f + onorm g"
proof (rule onorm_bound)
  show "0 \<le> onorm f + onorm g"
    by (intro add_nonneg_nonneg onorm_pos_le f g)
next
  fix x
  have "norm (f x + g x) \<le> norm (f x) + norm (g x)"
    by (rule norm_triangle_ineq)
  also have "norm (f x) + norm (g x) \<le> onorm f * norm x + onorm g * norm x"
    by (intro add_mono onorm f g)
  finally show "norm (f x + g x) \<le> (onorm f + onorm g) * norm x"
    by (simp only: distrib_right)
qed

lemma onorm_triangle_le:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g \<le> e"
  shows "onorm (\<lambda>x. f x + g x) \<le> e"
  using assms by (rule onorm_triangle [THEN order_trans])

lemma onorm_triangle_lt:
  assumes "bounded_linear f"
  assumes "bounded_linear g"
  assumes "onorm f + onorm g < e"
  shows "onorm (\<lambda>x. f x + g x) < e"
  using assms by (rule onorm_triangle [THEN order_le_less_trans])

end


theory Homework3_template
  imports "HOL-IMP.Hoare_Examples"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
  refl:  "star r x x"
| step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

(* Problem 1 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
  pal0: "palindrome []" |
  palaxsa: "palindrome xs \<Longrightarrow>  palindrome (s # xs @ [s]) "  (* complete definition *)

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindrome.induct )
  by auto  (* replace with proof *)

(* Problem 2 *)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl': "star' r x x"
| step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star_one: "r a b \<Longrightarrow> star r a b"
  (* After applying rule step, ?y appears because Isabelle does
     not know what to instantiate for y in theorem step. *)
  apply (rule step)
  (* apply assumption means looking for an assumption that matches
     the goal. Isabelle will see that r a ?y matches r a b with ?y = b. *)
   apply assumption
  (* The remaining goal is just refl rule. *)
  apply (rule refl)
  done

lemma star_step2_detailed: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  (* Induction on proof trees begin with induction rule followed
     by the name of the induction theorem. Isabelle will figure out
     what need to be proved for induction. Here we show detailed
     application of introduction rules. *)
  apply (induction rule: star.induct)
   apply (rule step)
    apply assumption
   apply (rule refl)
  subgoal for x y z'
    apply (rule step[where y=y])
     apply assumption
    by auto
  done

lemma  "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule:star'.induct)
  apply (rule refl)
  apply (rule star_step2_detailed)
   apply assumption
  apply assumption

lemma "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
  by (auto simp: refl')

   (* replace with proof *)

(* Problem 3 *)

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'') DO (
       ''x'' ::= Plus (V ''x'') (N (-1));;
       ''y'' ::= Plus (V ''y'') (N (-1))
     )
     {\<lambda>t. t ''y'' = y - x}"
apply (rule strengthen_pre)
  prefer 2
  apply (rule While'[where P="\<lambda>s. s ''y'' = y - x + s ''x'' \<and>   0 \<le> s ''x''"])
 prefer 2
   apply simp
  apply (rule Seq)
  prefer 2
  apply (rule Assign)
  apply simp
   apply (rule Assign')
  apply simp
  by auto   (* replace with proof *)

(* Problem 4 *)

(* Hint: use algebra_simps and power2_eq_square *)
thm algebra_simps
thm power2_eq_square

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}                  \<comment> \<open>x = i \<and> 0 \<le> i\<close>
     ''r'' ::= N 0;; ''r2'' ::= N 1;;             \<comment> \<open>r := 0; r2 := 1;\<close>
     WHILE (Not (Less (V ''x'') (V ''r2'')))      \<comment> \<open>while (!x < r2)) {\<close>
     DO (''r'' ::= Plus (V ''r'') (N 1);;         \<comment> \<open>   r := r + 1\<close>
         ''r2'' ::= Plus (V ''r2'')               \<comment> \<open>   r2 := r2 + (r + r + 1)\<close>
            (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"  \<comment> \<open>r ^ 2 \<le> i \<and> i < (r+1) ^ 2\<close>
   (* replace with proof *)
  apply (rule strengthen_pre)
  prefer 2
  apply (rule Seq)
  prefer 2
    apply (rule While'[where P="\<lambda>s. s ''x'' = i \<and> (s ''r'')^2 \<le> i \<and> s ''r2'' = (s ''r''+1)^2"])
     apply (rule Seq)
      apply simp
      prefer 2
      apply (rule Assign)
  apply simp
     apply (rule Assign')
     apply simp
  apply auto
   by (auto simp add: algebra_simps  power2_eq_square)


section\<open>Basics needed\<close>

theory PerfectBasics
imports Main "HOL-Computational_Algebra.Primes" "HOL-Algebra.Exponent"
begin

lemma sum_mono2_nat: "finite (B::nat set) \<Longrightarrow> A <= B \<Longrightarrow> \<Sum> A <= \<Sum> B"
  by (auto simp add: sum_mono2)

(* TODO Move *)
lemma multiplicity_0 [simp]: "multiplicity 0 x = 0"
  by (cases "x = 0") (auto intro: not_dvd_imp_multiplicity_0)

lemma exp_is_max_div:
   assumes m0:"m \<noteq> 0" and p: "prime p"
   shows "~ p dvd (m div (p^(multiplicity p m)))"
proof (rule ccontr)
  assume "~ ~ p dvd (m div (p^(multiplicity p m)))"
  hence a:"p dvd (m div (p^(multiplicity p m)))" by auto
  from m0 have "p^(multiplicity p m) dvd m" by (auto simp add: multiplicity_dvd)
  with a have "p^Suc (multiplicity p m) dvd m"
    by (subst (asm) dvd_div_iff_mult) auto
  with m0 p show False
    by (subst (asm) power_dvd_iff_le_multiplicity) auto
qed

lemma coprime_multiplicity:
  assumes "prime (p::nat)" and "m > 0"
  shows "coprime p (m div (p ^ multiplicity p m))"
proof (rule ccontr)
  assume "\<not> coprime p (m div p ^ multiplicity p m)"
  with \<open>prime p\<close> have "\<exists>q. prime q \<and> q dvd p \<and> q dvd m div p ^ multiplicity p m"
    by (metis dvd_refl prime_imp_coprime)
  with \<open>prime p\<close> have "\<exists>q. q = p \<and> q dvd m div p ^ multiplicity p m"
    by (metis not_prime_1 prime_nat_iff)
  then have "p dvd m div p ^ multiplicity p m"
    by auto
  with assms show False
    by (auto simp add: exp_is_max_div)
qed

lemma add_mult_distrib_three: "(x::nat)*(a+b+c)=x*a+x*b+x*c"
proof -
  have "(x::nat)*(a+b+c) = x*((a+b)+c)" by auto
  hence "x*(a+b+c) = x*(a+b)+x*c" by (simp add: algebra_simps)
  thus "x*(a+b+c) = x*a+x*b+x*c" by (simp add: algebra_simps)
qed

lemma nat_interval_minus_zero: "{0..Suc n} = {0} Un {Suc 0..Suc n}" by auto
lemma nat_interval_minus_zero2:
 assumes "n>0"
 shows "{0..n} = {0} Un {Suc 0..n}" by (auto simp add: nat_interval_minus_zero)

theorem simplify_sum_of_powers: "(x - 1::nat) * (\<Sum>i=0 .. n . x^i)  = x^(n + 1) - 1" (is "?l = ?r")
proof (cases)
  assume "n = 0"
  thus "?l = x^(n+1) - 1" by auto
  next
  assume "n~=0"
  hence n0: "n>0" by auto
  have "?l  = (x::nat)*(\<Sum>i=0 .. n . x^i) - (\<Sum>i=0 .. n . x^i)"
    by (metis diff_mult_distrib nat_mult_1)
  also have "... = (\<Sum>i=0 .. n . x^(Suc i))    - (\<Sum>i=0 .. n . x^i)"
    by (simp add: sum_distrib_left)
  also have "... = (\<Sum>i=Suc 0 .. Suc n . x^i)  - (\<Sum>i=0 .. n . x^i)"
    by (metis sum.shift_bounds_cl_Suc_ivl)
  also with n0
  have "... = ((\<Sum>i=Suc 0 .. n. x^i)+x^(Suc n)) - (x^0 + (\<Sum>i=Suc 0 .. n. x^i))"
    by (auto simp add: sum.union_disjoint nat_interval_minus_zero2)
  finally show "?thesis" by auto
qed

end


(*
  File: Interval.thy
  Author: Bohua Zhan
*)

section \<open>Intervals\<close>

theory Interval
  imports "Auto2_HOL.Auto2_Main"
begin

text \<open>Basic definition of intervals.\<close>

subsection \<open>Definition of interval\<close>

datatype 'a interval = Interval (low: 'a) (high: 'a)
setup \<open>add_simple_datatype "interval"\<close>

instantiation interval :: (linorder) linorder begin

definition int_less: "(a < b) = (low a < low b | (low a = low b \<and> high a < high b))"
definition int_less_eq: "(a \<le> b) = (low a < low b | (low a = low b \<and> high a \<le> high b))"

instance proof
  fix x y z :: "'a interval"
  show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    using int_less int_less_eq by force
  show b: "x \<le> x"
    by (simp add: int_less_eq)
  show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (smt int_less_eq dual_order.trans less_trans)
  show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    using int_less_eq a interval.expand int_less by fastforce
  show e: "x \<le> y \<or> y \<le> x"
    by (meson int_less_eq leI not_less_iff_gr_or_eq)
qed end

definition is_interval :: "('a::linorder) interval \<Rightarrow> bool" where [rewrite]:
  "is_interval it \<longleftrightarrow> (low it \<le> high it)"

subsection \<open>Definition of interval with an index\<close>

datatype 'a idx_interval = IdxInterval (int: "'a interval") (idx: nat)
setup \<open>add_simple_datatype "idx_interval"\<close>

instantiation idx_interval :: (linorder) linorder begin

definition iint_less: "(a < b) = (int a < int b | (int a = int b \<and> idx a < idx b))"
definition iint_less_eq: "(a \<le> b) = (int a < int b | (int a = int b \<and> idx a \<le> idx b))"

instance proof
  fix x y z :: "'a idx_interval"
  show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    using iint_less iint_less_eq by force
  show b: "x \<le> x"
    by (simp add: iint_less_eq)
  show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (smt iint_less_eq dual_order.trans less_trans)
  show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    using a idx_interval.expand iint_less iint_less_eq by auto
  show e: "x \<le> y \<or> y \<le> x"
    by (meson iint_less_eq leI not_less_iff_gr_or_eq)
qed end

lemma interval_less_to_le_low [forward]:
  "(a::('a::linorder idx_interval)) < b \<Longrightarrow> low (int a) \<le> low (int b)"
  by (metis eq_iff iint_less int_less less_imp_le)

subsection \<open>Overlapping intervals\<close>

definition is_overlap :: "('a::linorder) interval \<Rightarrow> 'a interval \<Rightarrow> bool" where [rewrite]:
  "is_overlap x y \<longleftrightarrow> (high x \<ge> low y \<and> high y \<ge> low x)"

definition has_overlap :: "('a::linorder) idx_interval set \<Rightarrow> 'a interval \<Rightarrow> bool" where [rewrite]:
  "has_overlap xs y \<longleftrightarrow> (\<exists>x\<in>xs. is_overlap (int x) y)"

end


theory Alexander
  imports
    Simplicial_complex
begin

section\<open>Definition of the Alexander dual of a simplicial complex\<close>

context simplicial_complex
begin

abbreviation "univ_n == {..<n}"

definition simplex_complement
  where "simplex_complement s == univ_n - s"

subsubsection \<open>Set complement\<close>

lemma
  simplex_complement_simplex:
  assumes v: "v \<in> simplices"
  shows "simplex_complement v \<in> simplices"
  using v
  by (simp add: atLeast0LessThan simplex_complement_def simplices_def)

lemma
  simplex_Compl_in:
  assumes s: "s \<in> simplices" and c: "c \<in> s"
  shows "c \<notin> simplex_complement s"
  using s c
  unfolding simplices_def
  unfolding simplex_complement_def by simp

lemma
  simplex_Compl_notin:
  assumes s: "s \<in> simplices" and c: "c \<in> simplex_complement s"
  shows "c \<notin> s"
  using s c
  unfolding simplices_def
  unfolding simplex_complement_def by simp

lemma
  simplex_Compl_iff [simp]:
  assumes s: "s \<in> simplices" and c: "c < n"
  shows "c \<in> simplex_complement s \<longleftrightarrow> c \<notin> s"
  unfolding simplex_complement_def
  using s c unfolding simplices_def by simp

lemma
  simplex_complement_idempotent:
  assumes "x \<in> simplices"
  shows "x = simplex_complement (simplex_complement x)"
  using assms atLeast0LessThan simplex_complement_def simplices_def by auto

lemma
  simplice_complement:
  assumes "x \<in> simplices"
  obtains vx where "x = simplex_complement vx"
proof -
  have "simplex_complement (simplex_complement x) = x"
    using assms atLeast0LessThan simplex_complement_def simplices_def by auto
  then show ?thesis
    using that by blast
qed

text\<open>We define the complement or the ``no faces'' of a simplicial complex
  as the simplices in @{term "{..n::nat}"} that are not in the simplicial
  complex. Note that the set obtained is not a simplicial complex (except
  for particular cases such as the empty set or the total set).\<close>

definition nofaces_simplicial_complex
  where "nofaces_simplicial_complex s = {v. v \<in> simplices \<and> v \<notin> s}"

lemma simpl_compl_not_in [simp]:
  assumes "v \<in> nofaces_simplicial_complex s"
  shows "v \<notin> s"
  using assms nofaces_simplicial_complex_def by fastforce

lemma simpl_compl_simplice [simp]:
  assumes "v \<in> nofaces_simplicial_complex s"
  shows "v \<in> simplices"
  by (metis (no_types, lifting) assms mem_Collect_eq nofaces_simplicial_complex_def)

definition Alexander_dual
  where "Alexander_dual s =
            {v. \<exists>x. v = simplex_complement x \<and> x \<in> nofaces_simplicial_complex s}"

lemma Alexander_dual_empty: "Alexander_dual {} = Pow {..<n}"
  unfolding Alexander_dual_def
  unfolding nofaces_simplicial_complex_def
  unfolding simplex_complement_def
  unfolding simplices_def
  by auto

subsection\<open>The Alexander dual of a simplicial complex is a simplicial complex\<close>

lemma
  simplicial_complex_Alexander_dual:
  assumes "simplicial_complex s"
  shows "simplicial_complex (Alexander_dual s)"
proof (unfold simplicial_complex_def, standard, intro conjI)
  fix \<sigma> :: "nat set"
  assume sigma: "\<sigma> \<in> Alexander_dual s"
  show sigma_simplice: "\<sigma> \<in> simplices"
    using sigma unfolding Alexander_dual_def using simplex_complement_simplex [OF ]
    by fastforce
  show "Pow \<sigma> \<subseteq> Alexander_dual s"
  proof
    fix x :: "nat set"
    assume x: "x \<in> Pow \<sigma>"
    show "x \<in> Alexander_dual s"
    proof (rule ccontr)
      assume xnin: "x \<notin> Alexander_dual s"
      from x have x_in_sigma: "x \<subseteq> \<sigma>" and x_simplice: "x \<in> simplices"
        using sigma_simplice
        apply simp
        using sigma_simplice simplices_def x by force
      from sigma obtain v
        where sigma_complement: "\<sigma> = simplex_complement v"
          and v_noface: "v \<in> nofaces_simplicial_complex s"
        unfolding Alexander_dual_def by auto
      from x_simplice
      obtain vx where x_complement: "x = simplex_complement vx" and vx_simplice: "vx \<in> simplices"
        using simplice_complement [OF x_simplice]
        using simplex_complement_simplex [OF x_simplice]
        by (metis PowD Pow_top atLeast0LessThan double_diff simplex_complement_def simplices_def)
      show False
      proof (cases "vx \<in> nofaces_simplicial_complex s")
        case True
        hence "x \<in> Alexander_dual s" using x_complement unfolding Alexander_dual_def by auto
        thus ?thesis using xnin by contradiction
      next
        case False
        hence vx_in_s: "vx \<in> s"
          by (metis (mono_tags, lifting) mem_Collect_eq nofaces_simplicial_complex_def vx_simplice)
        have "v \<subseteq> vx"
          using sigma_complement x_complement x_in_sigma
          by (smt (verit, ccfv_threshold) Diff_iff PowD atLeast0LessThan simplices_def simplicial_complex.simpl_compl_simplice simplicial_complex.simplex_complement_def subset_eq v_noface)
        hence "v \<in> s" using assms vx_in_s unfolding simplicial_complex_def by auto
        thus ?thesis using v_noface by simp
      qed
    qed
  qed
qed

end

section\<open>Definition of the Alexander dual of a Boolean function\<close>

context boolean_functions
begin

text\<open>The notion of @{const simplicial_complex.nofaces_simplicial_complex}
  in simplicial complexes becomes now in boolean functions just the
  @{const HOL.Not} boolean operator.\<close>

(*definition nofaces_boolean_function
  where "nofaces_boolean_function f = {b. b \<in> carrier_vec n \<and> \<not> f b}"

lemma nofaces_not [simp]:
  assumes "b \<in> nofaces_boolean_function f"
  shows "\<not> f b"
  using assms nofaces_boolean_function_def by fastforce

lemma nofaces_carrier_vec [simp]:
  assumes "b \<in> nofaces_boolean_function f"
  shows "b \<in> carrier_vec n"
  using assms nofaces_boolean_function_def by auto

lemma "nofaces_boolean_function f \<union> {b. b \<in> carrier_vec n \<and> f b}
  = carrier_vec n"
  unfolding nofaces_boolean_function_def by auto*)

text\<open>The notion of @{const simplicial_complex.simplex_complement}
  becomes now in boolean functions the negation, or the complement in base
  @{term "2::nat"}, of each @{typ "bool vec"}.\<close>

definition not :: "bool vec \<Rightarrow> bool vec"  (*"\<not> _" [20] 20*)
  where "not v = vec (dim_vec v) (\<lambda>n. \<not> v $ n)"

lemma
  dim_vec_not:
  assumes d: "dim_vec v = k"
  shows "dim_vec (not v) = k"
  using d unfolding not_def by simp

lemma
  assumes d: "k < dim_vec v"
  shows "v $ k \<longleftrightarrow> \<not> (not v $ k)"
  using d unfolding not_def by simp

lemma
  not_v_in_carrier:
  assumes "v \<in> carrier_vec k"
  shows "not v \<in> carrier_vec k"
  using assms not_def by fastforce

lemma
  assumes d: "k < dim_vec v"
  shows "\<not> v $ k \<longleftrightarrow> (not v $ k)"
  using d unfolding not_def by simp

text\<open>The operation @{const not} is ``antimonotone'', in the sense that
  for every @{term x}, @{term y} such that @{term "x \<le> y"},
  then @{term "not y \<le> not x"}.\<close>

lemma
  not_vec_antimono:
  assumes rs: "r \<le> s"
  shows "not s \<le> not r"
  using rs
  unfolding not_def
  unfolding less_eq_vec_def by auto

text\<open>The operation @{const HOL.Not} is ``antimonotone'', in the sense that
  for every @{term x}, @{term y} such that @{term "x \<le> y"},
  and @{term f} such that @{term "monotone_bool_fun f"},
  then @{term "HOL.Not (f y) \<le> HOL.Not (f x)"}.\<close>

lemma
  not_antimono:
  assumes m: "monotone_bool_fun f"
  and x: "x \<in> carrier_vec n" and y: "y \<in> carrier_vec n"
  and xy: "x \<le> y"
  shows "(\<not> f y) \<le> (\<not> f x)"
  by (metis (mono_tags, opaque_lifting) le_boolE le_boolI' m mono_on_def monotone_bool_fun_def x xy y)

text\<open>The definition of the Alexander dual now for a Boolean function @{term f}
  becomes just the negation of @{term f} over the ``complement'' of every vector.\<close>

definition "Alexander_dual f = (\<lambda>x. \<not> f (not x))"

lemma Alexander_dual_False:
  "boolean_functions.Alexander_dual (\<lambda>x. False) =
   (\<lambda>x. True)"
  unfolding Alexander_dual_def
  by simp

subsection\<open>The Alexander dual of a \emph{monotone} Boolean function
  is a \emph{monotone} Boolean function\<close>

lemma
  monotone_boolean_function_Alexander_dual:
  assumes f: "monotone_bool_fun f"
  shows "monotone_bool_fun (Alexander_dual f)"
proof (unfold monotone_bool_fun_def, unfold mono_on_def, intro allI, safe)
  fix r s :: "bool vec"
  assume r: "r \<in> carrier_vec n" and s: "s \<in> carrier_vec n" and r_le_s: "r \<le> s"
  have nr: "not r \<in> carrier_vec n" and ns: "not s \<in> carrier_vec n" and ns_le_nr: "not s \<le> not r"
    using not_v_in_carrier [OF r]
        and not_v_in_carrier [OF s]
        and not_vec_antimono [OF r_le_s] by simp_all
  show "Alexander_dual f r \<le> Alexander_dual f s"
    unfolding Alexander_dual_def using not_antimono [OF f ns nr ns_le_nr] by simp
qed

end

lemmas [code] = boolean_functions.not_def boolean_functions.Alexander_dual_def

end


theory Ex1_6
  imports Main
begin

primrec sum :: "nat list \<Rightarrow> nat" where
  "sum [] = 0"|
  "sum (x#xs) = x + sum xs"

primrec flatten :: "'a list list \<Rightarrow> 'a list" where
  "flatten [] = []"|
  "flatten (x#xs) = x @ flatten xs"

lemma "sum [2::nat ,4,8] = 14" by simp

lemma "flatten [[2::nat, 3], [4,5], [7,9]] = [2,3,4,5,7,9]" by simp

lemma "length (flatten xs) = sum (map length xs)" by (induct xs; simp)

lemma sum_append : "sum (xs @ ys) = sum xs + sum ys" by (induct xs; simp)

lemma flatten_append : "flatten (xs @ ys) = flatten xs @ flatten ys" by (induct xs; simp)

lemma "flatten (map rev (rev xs)) = rev (flatten xs)" by (induct xs; simp add : flatten_append)

lemma "flatten (rev (map rev xs)) = rev (flatten xs)" by (induct xs; simp add : flatten_append)

lemma "list_all (list_all P) xs = list_all P (flatten xs)" by (induct xs; simp)

(*lemma "flatten (rev xs) = flatten xs" quickcheck *)

lemma "flatten (rev [[1::nat,2],[3::nat,4]]) = flatten [[1::nat,2],[3::nat,4]] \<Longrightarrow> False" by simp

lemma "sum (rev xs) = sum xs" by (induct xs; simp add : sum_append)

lemma "list_all (op \<le> 1) xs \<longrightarrow> length xs \<le> sum xs" by (induct xs; auto)

primrec list_exists :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)" where
  "list_exists _ [] = False"|
  "list_exists P (x#xs) = (P x \<or> list_exists P xs)"

lemma "list_exists (\<lambda>n .  n < 3 ) [4::nat , 3, 7] = False" by simp

lemma "list_exists (\<lambda>n .  n < 4 ) [4::nat , 3, 7] = True" by simp

lemma list_exists_append : "list_exists P (xs @ ys) = (list_exists P xs \<or> list_exists P ys)" by (induct xs; simp)

lemma "list_exists (list_exists P) xs = list_exists P (flatten xs)" by (induct xs; simp add : list_exists_append)

definition "list_exists2 P ls = (\<not> (list_all (\<lambda>x . \<not>(P x))) ls)"

lemma "list_exists P xs = list_exists2 P xs" by (induct xs; simp add : list_exists2_def)


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Functions\<close>
theory Binary_Relation_Functions
  imports
    HOL.HOL
begin

paragraph \<open>Summary\<close>
text \<open>Basic functions on binary relations.\<close>

definition "rel_comp R S x y \<equiv> \<exists>z. R x z \<and> S z y"

bundle rel_comp_syntax begin notation rel_comp (infixl "\<circ>\<circ>" 55) end
bundle no_rel_comp_syntax begin no_notation rel_comp (infixl "\<circ>\<circ>" 55) end
unbundle rel_comp_syntax

lemma rel_compI [intro]:
  assumes "R x y"
  and "S y z"
  shows "(R \<circ>\<circ> S) x z"
  using assms unfolding rel_comp_def by blast

lemma rel_compE [elim]:
  assumes "(R \<circ>\<circ> S) x y"
  obtains z where "R x z" "S z y"
  using assms unfolding rel_comp_def by blast

lemma rel_comp_assoc: "R \<circ>\<circ> (S \<circ>\<circ> T) = (R \<circ>\<circ> S) \<circ>\<circ> T"
  by (intro ext) blast

definition rel_inv :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool"
  where "rel_inv R x y \<equiv> R y x"

bundle rel_inv_syntax begin notation rel_inv ("(_\<inverse>)" [1000]) end
bundle no_rel_inv_syntax begin no_notation rel_inv ("(_\<inverse>)" [1000]) end
unbundle rel_inv_syntax

lemma rel_invI [intro]:
  assumes "R x y"
  shows "R\<inverse> y x"
  using assms unfolding rel_inv_def .

lemma rel_invD [dest]:
  assumes "R\<inverse> x y"
  shows "R y x"
  using assms unfolding rel_inv_def .

lemma rel_inv_iff_rel [simp]: "R\<inverse> x y \<longleftrightarrow> R y x"
  by blast

lemma rel_inv_comp_eq [simp]: "(R \<circ>\<circ> S)\<inverse> = S\<inverse> \<circ>\<circ> R\<inverse>"
  by (intro ext) blast

lemma rel_inv_inv_eq_self [simp]: "R\<inverse>\<inverse> = R"
  by blast

lemma rel_inv_eq_iff_eq [iff]: "R\<inverse> = S\<inverse> \<longleftrightarrow> R = S"
  by (blast dest: fun_cong)

definition "in_dom R x \<equiv> \<exists>y. R x y"

lemma in_domI [intro]:
  assumes "R x y"
  shows "in_dom R x"
  using assms unfolding in_dom_def by blast

lemma in_domE [elim]:
  assumes "in_dom R x"
  obtains y where "R x y"
  using assms unfolding in_dom_def by blast

lemma in_dom_if_in_dom_rel_comp:
  assumes "in_dom (R \<circ>\<circ> S) x"
  shows "in_dom R x"
  using assms by blast

definition "in_codom R y \<equiv> \<exists>x. R x y"

lemma in_codomI [intro]:
  assumes "R x y"
  shows "in_codom R y"
  using assms unfolding in_codom_def by blast

lemma in_codomE [elim]:
  assumes "in_codom R y"
  obtains x where "R x y"
  using assms unfolding in_codom_def by blast

lemma in_codom_if_in_codom_rel_comp:
  assumes "in_codom (R \<circ>\<circ> S) y"
  shows "in_codom S y"
  using assms by blast

lemma in_codom_rel_inv_eq_in_dom [simp]: "in_codom (R\<inverse>) = in_dom R"
  by (intro ext) blast

lemma in_dom_rel_inv_eq_in_codom [simp]: "in_dom (R\<inverse>) = in_codom R"
  by (intro ext) blast

definition "in_field R x \<equiv> in_dom R x \<or> in_codom R x"

lemma in_field_if_in_dom:
  assumes "in_dom R x"
  shows "in_field R x"
  unfolding in_field_def using assms by blast

lemma in_field_if_in_codom:
  assumes "in_codom R x"
  shows "in_field R x"
  unfolding in_field_def using assms by blast

lemma in_fieldE [elim]:
  assumes "in_field R x"
  obtains (in_dom) x' where "R x x'" | (in_codom) x' where "R x' x"
  using assms unfolding in_field_def by blast

lemma in_fieldE':
  assumes "in_field R x"
  obtains (in_dom) "in_dom R x" | (in_codom) "in_codom R x"
  using assms by blast

lemma in_fieldI [intro]:
  assumes "R x y"
  shows "in_field R x" "in_field R y"
  using assms by (auto intro: in_field_if_in_dom in_field_if_in_codom)

lemma in_field_iff_in_dom_or_in_codom:
  "in_field L x \<longleftrightarrow> in_dom L x \<or> in_codom L x"
  by blast

lemma in_field_rel_inv_eq [simp]: "in_field R\<inverse> = in_field R"
  by (intro ext) auto

lemma in_field_compE [elim]:
  assumes "in_field (R \<circ>\<circ> S) x"
  obtains (in_dom) "in_dom R x" | (in_codom) "in_codom S x"
  using assms by blast

lemma in_field_eq_in_dom_if_in_codom_eq_in_dom:
  assumes "in_codom R = in_dom R"
  shows "in_field R = in_dom R"
  using assms by (intro ext) (auto elim: in_fieldE')

definition "rel_if B R x y \<equiv> B \<longrightarrow> R x y"

bundle rel_if_syntax begin notation (output) rel_if (infixl "\<longrightarrow>" 50) end
bundle no_rel_if_syntax begin no_notation (output) rel_if (infixl "\<longrightarrow>" 50) end
unbundle rel_if_syntax

lemma rel_if_if_impI [intro]:
  assumes "B \<Longrightarrow> R x y"
  shows "(rel_if B R) x y"
  unfolding rel_if_def using assms by blast

lemma rel_if_if_notI [simp]:
  assumes "\<not>B"
  shows "(rel_if B R) x y"
  unfolding rel_if_def using assms by blast

lemma rel_ifE [elim]:
  assumes "(rel_if B R) x y"
  obtains "\<not>B" | "B" "R x y"
  using assms unfolding rel_if_def by blast

lemma rel_ifD:
  assumes "(rel_if B R) x y"
  and "B"
  shows "R x y"
  using assms by blast

lemma rel_if_eq_if_pred [simp]:
  assumes "B"
  shows "(rel_if B R) x y = R x y"
  using assms by blast

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

definition "restrict_right R P \<equiv> (restrict_left R\<inverse> P)\<inverse>"

overloading
  restrict_left_pred \<equiv> "restrict_left :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
begin
  definition "restrict_left_pred R P x y \<equiv> P x \<and> R x y"
end

bundle restrict_syntax
begin
notation restrict_left ("(_)\<restriction>(\<^bsub>_\<^esub>)" [1000])
notation restrict_right ("(_)\<upharpoonleft>(\<^bsub>_\<^esub>)" [1000])
end
bundle no_restrict_syntax
begin
no_notation restrict_left ("(_)\<restriction>(\<^bsub>_\<^esub>)" [1000])
no_notation restrict_right ("(_)\<upharpoonleft>(\<^bsub>_\<^esub>)" [1000])
end
unbundle restrict_syntax

lemma restrict_leftI [intro]:
  assumes "R x y"
  and "P x"
  shows "R\<restriction>\<^bsub>P\<^esub> x y"
  using assms unfolding restrict_left_pred_def by blast

lemma restrict_leftE [elim]:
  assumes "R\<restriction>\<^bsub>P\<^esub> x y"
  obtains "P x" "R x y"
  using assms unfolding restrict_left_pred_def by blast

lemma restrict_right_eq: "R\<upharpoonleft>\<^bsub>P\<^esub> = ((R\<inverse>)\<restriction>\<^bsub>P\<^esub>)\<inverse>"
  unfolding restrict_right_def ..

lemma rel_inv_restrict_right_rel_inv_eq_restrict_left [simp]: "((R\<inverse>)\<upharpoonleft>\<^bsub>P\<^esub>)\<inverse> = R\<restriction>\<^bsub>P\<^esub>"
  by (simp add: restrict_right_eq)

lemma restrict_right_iff_restrict_left: "R\<upharpoonleft>\<^bsub>P\<^esub> x y = (R\<inverse>)\<restriction>\<^bsub>P\<^esub> y x"
  unfolding restrict_right_eq by simp

lemma restrict_rightI [intro]:
  assumes "R x y"
  and "P y"
  shows "R\<upharpoonleft>\<^bsub>P\<^esub> x y"
  using assms by (auto iff: restrict_right_iff_restrict_left)

lemma restrict_rightE [elim]:
  assumes "R\<upharpoonleft>\<^bsub>P\<^esub> x y"
  obtains "P y" "R x y"
  using assms by (auto iff: restrict_right_iff_restrict_left)

lemma rel_inv_restrict_left_inv_restrict_left_eq:
  fixes R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool" and Q :: "'b \<Rightarrow> bool"
  shows "(((R\<restriction>\<^bsub>P\<^esub>)\<inverse>)\<restriction>\<^bsub>Q\<^esub>)\<inverse> = (((R\<inverse>)\<restriction>\<^bsub>Q\<^esub>)\<inverse>)\<restriction>\<^bsub>P\<^esub>"
  by (intro ext iffI restrict_leftI rel_invI) auto

lemma restrict_left_right_eq_restrict_right_left:
  fixes R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool" and Q :: "'b \<Rightarrow> bool"
  shows "R\<restriction>\<^bsub>P\<^esub>\<upharpoonleft>\<^bsub>Q\<^esub> = R\<upharpoonleft>\<^bsub>Q\<^esub>\<restriction>\<^bsub>P\<^esub>"
  unfolding restrict_right_eq
  by (fact rel_inv_restrict_left_inv_restrict_left_eq)

lemma in_dom_restrict_leftI [intro]:
  assumes "R x y"
  and "P x"
  shows "in_dom R\<restriction>\<^bsub>P\<^esub> x"
  using assms by blast

lemma in_dom_restrict_left_if_in_dom:
  assumes "in_dom R x"
  and "P x"
  shows "in_dom R\<restriction>\<^bsub>P\<^esub> x"
  using assms by blast

lemma in_dom_restrict_leftE [elim]:
  assumes "in_dom R\<restriction>\<^bsub>P\<^esub> x"
  obtains y where "P x" "R x y"
  using assms by blast

lemma in_codom_restrict_leftI [intro]:
  assumes "R x y"
  and "P x"
  shows "in_codom R\<restriction>\<^bsub>P\<^esub> y"
  using assms by blast

lemma in_codom_restrict_leftE [elim]:
  assumes "in_codom R\<restriction>\<^bsub>P\<^esub> y"
  obtains x where "P x" "R x y"
  using assms by blast

definition "rel_bimap f g (R :: 'a \<Rightarrow> 'b \<Rightarrow> bool) x y \<equiv> R (f x) (g y)"

lemma rel_bimap_eq [simp]: "rel_bimap f g R x y = R (f x) (g y)"
  unfolding rel_bimap_def by simp

definition "rel_map f R \<equiv> rel_bimap f f R"

lemma rel_bimap_self_eq_rel_map [simp]: "rel_bimap f f R = rel_map f R"
  unfolding rel_map_def by simp

lemma rel_map_eq [simp]: "rel_map f R x y = R (f x) (f y)"
  by (simp only: rel_bimap_self_eq_rel_map[symmetric] rel_bimap_eq)

end


section "Integer Paritions"

theory Integer_Partitions
  imports
    "HOL-Library.Multiset"
    Common_Lemmas
    Card_Number_Partitions.Card_Number_Partitions
begin

subsection"Definition"

definition integer_partitions :: "nat \<Rightarrow> nat multiset set" where
  "integer_partitions i = {A. sum_mset A = i \<and> 0 \<notin># A}"
text \<open>Cardinality: \<open>Partition i\<close> (from \<open>Card_Number_Partitions.Card_Number_Partitions\<close> \cite{AFPnumpat})\<close>
text "Example: \<open>integer_partitions 4 = {{4}, {3,1}, {2,2} {2,1,1}, {1,1,1,1}}\<close>"

subsection"Algorithm"

fun integer_partitions_enum_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat list list" where
  "integer_partitions_enum_aux 0 m = [[]]"
| "integer_partitions_enum_aux n m =
  [h#r . h \<leftarrow> [1..< Suc (min n m)], r \<leftarrow> integer_partitions_enum_aux (n-h) h]"

fun integer_partitions_enum :: "nat \<Rightarrow> nat list list" where
 "integer_partitions_enum n = integer_partitions_enum_aux n n"

subsection"Verification"

subsubsection"Correctness"

lemma integer_partitions_empty: "[] \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> n = 0"
  by(induct n) auto

lemma integer_partitions_enum_aux_first:
  "x # xs \<in> set (integer_partitions_enum_aux n m)
    \<Longrightarrow> xs \<in> set (integer_partitions_enum_aux (n-x) x)"
  by(induct n) auto

lemma integer_partitions_enum_aux_max_n:
  "x#xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> x \<le> n"
  by (induct n) auto

lemma integer_partitions_enum_aux_max_head:
  "x#xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> x \<le> m"
  by (induct n) auto

(*not used, but nice to have nonetheless*)
lemma integer_partitions_enum_aux_max:
  "xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<le> m"
proof(induct xs arbitrary: n m x)
  case Nil
  then show ?case using integer_partitions_enum_aux_max_head by simp
next
  case (Cons y xs)
  then show ?case
    using integer_partitions_enum_aux_max_head integer_partitions_enum_aux_first
    by fastforce
qed

lemma integer_partitions_enum_aux_sum:
  "xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> sum_list xs = n"
proof(induct xs arbitrary: n m)
  case Nil
  then show ?case using integer_partitions_empty by simp
next
  case (Cons x xs)
  then have "\<lbrakk>xs \<in> set (integer_partitions_enum_aux (n-x) x)\<rbrakk> \<Longrightarrow> sum_list xs = (n-x)"
    by simp
  moreover have "xs \<in> set (integer_partitions_enum_aux (n-x) x)"
    using Cons integer_partitions_enum_aux_first by simp
  moreover have "x \<le> n"
    using Cons integer_partitions_enum_aux_max_n by simp
  ultimately show ?case
    by simp
qed

lemma integer_partitions_enum_aux_not_null_aux:
  "x#xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> x \<noteq> 0"
  by (induct n) auto

lemma integer_partitions_enum_aux_not_null:
  "xs \<in> set (integer_partitions_enum_aux n m) \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<noteq> 0"
proof(induct xs arbitrary: x n m)
  case Nil
  then show ?case by simp
next
  case (Cons y xs)
  show ?case proof(cases "y = x")
    case True
    then show ?thesis
      using Cons integer_partitions_enum_aux_not_null_aux by simp
  next
    case False
    then show ?thesis
       using Cons integer_partitions_enum_aux_not_null_aux integer_partitions_enum_aux_first
       by fastforce
  qed
qed

lemma integer_partitions_enum_aux_head_minus:
     "h \<le> m \<Longrightarrow> h > 0 \<Longrightarrow> n \<ge> h \<Longrightarrow>
  ys \<in> set (integer_partitions_enum_aux (n-h) h)\<Longrightarrow> h#ys \<in> set (integer_partitions_enum_aux n m)"
proof(induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have 1: "1 \<le> m" by simp

  have 2: "(\<exists>x. (x = min (Suc n) m \<or> Suc 0 \<le> x \<and> x < Suc n \<and> x < m) \<and> h # ys
      \<in> (#) x ` set (integer_partitions_enum_aux (Suc n - x) x))"
    unfolding image_def using Suc by auto

  from 1 2 have "Suc 0 \<le> m \<and>(\<exists>x. (x = min (Suc n) m \<or> Suc 0 \<le> x \<and> x < Suc n \<and> x < m)
         \<and> h # ys \<in> (#) x ` set (integer_partitions_enum_aux (Suc n - x) x))"
    by simp

  then show ?case by auto
qed

lemma integer_partitions_enum_aux_head_plus:
  "h \<le> m \<Longrightarrow> h > 0 \<Longrightarrow> ys \<in> set (integer_partitions_enum_aux n h)
    \<Longrightarrow> h#ys \<in> set (integer_partitions_enum_aux (h + n) m)"
  using integer_partitions_enum_aux_head_minus by simp

lemma integer_partitions_enum_correct_aux1:
  assumes "0 \<notin># A "
  and "\<forall>x \<in># A. x \<le> m"
shows" \<exists>xs\<in>set (integer_partitions_enum_aux (\<Sum>\<^sub># A) m). A = mset xs"
using assms proof(induct A arbitrary: m rule: multiset_induct_max)
  case empty
  then show ?case by simp
next
  case (add h A)
  have hc1: "h \<le> m"
    using add by simp

  have hc2: "h > 0"
    using add by simp

  obtain ys where o1: "ys \<in> set (integer_partitions_enum_aux (\<Sum>\<^sub># A) h)" and o2: " A = mset ys"
    using add by force

  have "h#ys \<in> set (integer_partitions_enum_aux (h + \<Sum>\<^sub># A) m)"
    using integer_partitions_enum_aux_head_plus hc1 o1 hc2 by blast

  then show ?case
    using o2 by force
qed

theorem integer_partitions_enum_correct:
  "set (map mset (integer_partitions_enum n)) = integer_partitions n"
proof(standard)
  have "\<lbrakk>xs \<in> set (integer_partitions_enum_aux n n)\<rbrakk> \<Longrightarrow> \<Sum>\<^sub># (mset xs) = n" for xs
    by (simp add: integer_partitions_enum_aux_sum sum_mset_sum_list)
  moreover have "xs \<in> set (integer_partitions_enum_aux n n) \<Longrightarrow> 0 \<notin># mset xs" for xs
    using integer_partitions_enum_aux_not_null by auto
  ultimately show "set (map mset (integer_partitions_enum n)) \<subseteq> integer_partitions n"
    unfolding integer_partitions_def by auto
next
  have "0 \<notin># A \<Longrightarrow> A \<in> mset ` set (integer_partitions_enum_aux (\<Sum>\<^sub># A) (\<Sum>\<^sub># A))" for A
    unfolding image_def
    using integer_partitions_enum_correct_aux1 by (simp add: sum_mset.remove)
  then show "integer_partitions n \<subseteq> set (map mset (integer_partitions_enum n))"
    unfolding integer_partitions_def by auto
qed

subsubsection"Distinctness"

lemma integer_partitions_enum_aux_distinct:
  "distinct (integer_partitions_enum_aux n m)"
proof(induct n m rule:integer_partitions_enum_aux.induct)
  case (1 m)
  then show ?case by simp
next
  case (2 n m)
  have "distinct [h#r . h \<leftarrow> [1..< Suc (min (Suc n) m)], r \<leftarrow> integer_partitions_enum_aux ((Suc n)-h) h]"
    apply(subst Cons_distinct_concat_map_function)
    using 2 by auto
  then show ?case by simp
qed

theorem integer_partitions_enum_distinct:
  "distinct (integer_partitions_enum n)"
  using integer_partitions_enum_aux_distinct by simp

subsubsection"Cardinality"

lemma partitions_bij_betw_count:
  "bij_betw count {N. count N partitions n} {p. p partitions n}"
  by (rule bij_betw_byWitness[where f'="Abs_multiset"]) (auto simp: partitions_imp_finite_elements)

lemma card_partitions_count_partitions:
  "card {p. p partitions n} = card {N. count N partitions n}"
  using bij_betw_same_card partitions_bij_betw_count by metis

text"this sadly is not proven in \<open>Card_Number_Partitions.Card_Number_Partitions\<close>"
lemma card_partitions_number_partition:
  "card {p. p partitions n} = card {N. number_partition n N}"
  using card_partitions_count_partitions count_partitions_iff by simp

lemma integer_partitions_number_partition_eq:
  "integer_partitions n = {N. number_partition n N}"
  using integer_partitions_def number_partition_def by auto

lemma integer_partitions_cardinality_aux:
  "card (integer_partitions n) = (\<Sum>k\<le>n. Partition n k)"
  using card_partitions_number_partition integer_partitions_number_partition_eq card_partitions
  by simp

theorem integer_partitions_cardinality:
  "card (integer_partitions n) = Partition (2*n) n"
  using integer_partitions_cardinality_aux Partition_sum_Partition_diff add_implies_diff le_add1 mult_2
  by simp

end


(* Author: Bernhard Stöckl *)

theory Selectivities
  imports Complex_Main "HOL-Library.Multiset"
begin

section \<open>Selectivities\<close>

type_synonym 'a selectivity = "'a \<Rightarrow> 'a \<Rightarrow> real"

definition sel_symm :: "'a selectivity \<Rightarrow> bool" where
  "sel_symm sel = (\<forall>x y. sel x y = sel y x)"

definition sel_reasonable :: "'a selectivity \<Rightarrow> bool" where
  "sel_reasonable sel = (\<forall>x y. sel x y \<le> 1 \<and> sel x y > 0)"

subsection \<open>Selectivity Functions\<close>

fun list_sel_aux :: "'a selectivity \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> real" where
  "list_sel_aux sel x [] = 1"
| "list_sel_aux sel x (y#ys) = sel x y * list_sel_aux sel x ys"

fun list_sel :: "'a selectivity \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> real" where
  "list_sel sel [] y = 1"
| "list_sel sel (x#xs) y = list_sel_aux sel x y * list_sel sel xs y"

fun list_sel_aux' :: "'a selectivity \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> real" where
  "list_sel_aux' sel [] y = 1"
| "list_sel_aux' sel (x#xs) y = sel x y * list_sel_aux' sel xs y"

fun list_sel':: "'a selectivity \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> real" where
  "list_sel' sel x [] = 1"
| "list_sel' sel x (y#ys) = list_sel_aux' sel x y * list_sel' sel x ys"

definition set_sel_aux :: "'a selectivity \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> real" where
  "set_sel_aux sel x Y = (\<Prod>y \<in> Y. sel x y)"

definition set_sel :: "'a selectivity \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> real" where
  "set_sel sel X Y = (\<Prod>x \<in> X. set_sel_aux sel x Y)"

definition set_sel_aux' :: "'a selectivity \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> real" where
  "set_sel_aux' sel X y = (\<Prod>x \<in> X. sel x y)"

definition set_sel' :: "'a selectivity \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> real" where
  "set_sel' sel X Y = (\<Prod>y \<in> Y. set_sel_aux' sel X y)"

fun ldeep_s :: "'a selectivity \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> real" where
  "ldeep_s f [] = (\<lambda>_. 1)"
| "ldeep_s f (x#xs) = (\<lambda>a. if a=x then list_sel_aux' f xs a else ldeep_s f xs a)"

subsection \<open>Proofs\<close>

lemma distinct_alt: "(\<forall>x\<in># mset xs. count (mset xs) x = 1) \<longleftrightarrow> distinct xs"
  by(induction xs) auto

lemma mset_y_eq_list_sel_aux_eq: "mset y = mset z \<Longrightarrow> list_sel_aux f x y = list_sel_aux f x z"
proof(induction "length y" arbitrary: y z)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "length y > 0" by auto
  then obtain y' ys where y_def[simp]: "y=y'#ys" using list.exhaust_sel by blast
  have "length z > 0" using Suc by auto
  then obtain z' zs where z_def[simp]: "z=z'#zs" using list.exhaust_sel by blast
  then have "length zs = n" using Suc by (metis length_Cons mset_eq_length nat.inject)
  then show ?case
  proof(cases "y'=z'")
    case True
    then show ?thesis using Suc by simp
  next
    case False
    have "y' \<in># mset y" by simp
    moreover have "z' \<in># mset y" using Suc by simp
    ultimately have "\<exists>c. mset y = mset (y'#z'#c)"
      using False ex_mset in_set_member multi_member_split set_mset_mset
      by (metis (mono_tags, opaque_lifting) member_rec(1) mset.simps(2))
    then obtain c where c_def[simp]: "mset y = mset (y'#z'#c)" by blast
    then have 0: "mset ys = mset (z'#c)" by simp
    then have 1: "mset zs = mset (y'#c)" using Suc.prems by simp
    have "list_sel_aux f x y = list_sel_aux f x (y' # ys)" by simp
    also have "\<dots> = f x y' * list_sel_aux f x ys" by simp
    also have "\<dots> = f x y' * list_sel_aux f x (z'#c)" using Suc.hyps 0 by fastforce
    also have "\<dots> = f x z' * list_sel_aux f x (y'#c)" by simp
    also have "\<dots> = f x z' * list_sel_aux f x zs"
      using 1 Suc.hyps(1) \<open>length zs = n\<close> by presburger
    finally show ?thesis by simp
  qed
qed

lemma mset_y_eq_list_sel_eq: "mset y = mset y' \<Longrightarrow> list_sel f x y = list_sel f x y'"
  apply(induction x)
   apply(auto)[2]
  using mset_y_eq_list_sel_aux_eq by fast

lemma mset_x_eq_list_sel_eq: "mset x = mset z \<Longrightarrow> list_sel f x y = list_sel f z y"
proof(induction "length x" arbitrary: x z)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have "length x > 0" by auto
  then obtain x' xs where y_def[simp]: "x=x'#xs" using list.exhaust_sel by blast
  have "length z > 0" using Suc by auto
  then obtain z' zs where z_def[simp]: "z=z'#zs" using list.exhaust_sel by blast
  then have "length zs = n" using Suc by (metis length_Cons mset_eq_length nat.inject)
  then show ?case
  proof(cases "x'=z'")
    case True
    then show ?thesis using Suc by simp
  next
    case False
    have "x' \<in># mset x" by simp
    moreover have "z' \<in># mset x" using Suc by simp
    ultimately have "\<exists>c. mset x = mset (x'#z'#c)"
      using False ex_mset in_set_member multi_member_split set_mset_mset
      by (metis (mono_tags, opaque_lifting) member_rec(1) mset.simps(2))
    then obtain c where c_def[simp]: "mset x = mset (x'#z'#c)" by blast
    then have 0: "mset xs = mset (z'#c)" by simp
    then have 1: "mset zs = mset (x'#c)" using Suc.prems by simp
    have "list_sel f x y = list_sel f (x'#xs) y" by simp
    also have "\<dots> = list_sel_aux f x' y * list_sel f xs y" by simp
    also have "\<dots> = list_sel_aux f x' y * list_sel f (z'#c) y" using Suc.hyps 0 by fastforce
    also have "\<dots> = list_sel_aux f z' y * list_sel f (x'#c) y" by simp
    also have "\<dots> = list_sel_aux f z' y * list_sel f zs y"
      using 1 Suc.hyps(1) \<open>length zs = n\<close> by presburger
    finally show ?thesis by simp
  qed
qed

lemma list_sel_empty: "list_sel f x [] = 1"
  by(induction x) auto

lemma list_sel'_empty: "list_sel' f [] y = 1"
  by(induction y) auto

lemma list_sel_symm_app:
    "sel_symm f \<Longrightarrow> list_sel_aux f x y * list_sel f y xs = list_sel f y (x # xs)"
  by(induction y) (auto simp: sel_symm_def)

lemma list_sel_symm: "sel_symm f \<Longrightarrow> list_sel f x y = list_sel f y x"
  by(induction x) (auto simp: sel_symm_def list_sel_empty list_sel_symm_app)

lemma list_sel_symm_aux_eq': "sel_symm f \<Longrightarrow> list_sel_aux f x y = list_sel_aux' f y x"
  by(induction y) (auto simp: sel_symm_def)

lemma list_sel_sing_aux': "list_sel f x [y] = list_sel_aux' f x y"
  by(induction x) auto

lemma list_sel_sing_aux: "list_sel f [x] y = list_sel_aux f x y"
  by(induction y) auto

lemma list_sel'_sing_aux': "list_sel' f x [y] = list_sel_aux' f x y"
  by(induction x) auto

lemma list_sel'_sing_aux: "list_sel' f [x] y = list_sel_aux f x y"
  by(induction y) auto

lemma list_sel'_split_aux: "list_sel' f (x#xs) y = list_sel_aux f x y * list_sel' f xs y"
  by(induction y) auto

lemma list_sel_eq': "list_sel f x y = list_sel' f x y"
  by(induction x) (auto simp: list_sel'_empty list_sel'_split_aux)

lemma mset_x_eq_list_sel_aux'_eq: "mset x = mset z \<Longrightarrow> list_sel_aux' f x y = list_sel_aux' f z y"
  using list_sel_sing_aux' mset_x_eq_list_sel_eq by metis

lemma foldl_acc_extr: "foldl (\<lambda>a b. a * f x b) z y = z * foldl (\<lambda>a b. a * f x b) (1::real) y"
proof(induction y arbitrary: z)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  have "foldl (\<lambda>a b. a * f x b) z (y # ys) = foldl (\<lambda>a b. a * f x b) (z * f x y) ys" by simp
  also have "\<dots> =  (z * f x y) * foldl (\<lambda>a b. a * f x b) 1 ys" using Cons by blast
  also have "\<dots> = z * foldl (\<lambda>a b. a * f x b) 1 (y#ys)"
    by (smt (verit, ccfv_SIG) Cons.IH foldl_Cons mult.assoc mult.left_commute)
  finally show ?case .
qed

lemma list_sel_aux_eq_foldl: "list_sel_aux f x y = foldl (\<lambda>a b. a * f x b) 1 y"
  apply(induction y)
   apply(auto)[2]
  using foldl_acc_extr by metis

lemma list_sel_eq_foldl: "list_sel f x y = foldl (\<lambda>a b. a * list_sel_aux f b y) 1 x"
  apply(induction x)
   apply(auto)[2]
  using foldl_acc_extr by metis

corollary list_sel_eq_foldl2: "list_sel f x y = foldl (\<lambda>a x. a * foldl (\<lambda>a b. a * f x b) 1 y) 1 x"
  by (simp add: list_sel_aux_eq_foldl list_sel_eq_foldl)

lemma list_sel_aux_eq_foldr: "list_sel_aux f x y = foldr (\<lambda>b a. a * f x b) y 1"
  by(induction y) auto

lemma sel_foldl_eq_foldr:
  "foldl (\<lambda>a b. a * f x b) 1 y = foldr (\<lambda>b a. a * (f::'a selectivity) x b) y 1"
  using list_sel_aux_eq_foldl list_sel_aux_eq_foldr by metis

lemma list_sel_eq_foldr: "list_sel f x y = foldr (\<lambda>b a. a * list_sel_aux f b y) x 1"
  by(induction x) auto

lemma list_sel_eq_foldr2: "list_sel f x y = foldr (\<lambda>x a. a * foldr (\<lambda>b a. a * f x b) y 1) x 1"
  by (simp add: list_sel_aux_eq_foldr list_sel_eq_foldr)

lemma list_sel_aux_reasonable:
    "sel_reasonable f \<Longrightarrow> list_sel_aux f x y \<le> 1 \<and> list_sel_aux f x y > 0"
  by(induction y) (auto simp: sel_reasonable_def mult_le_one)

lemma list_sel_aux'_reasonable:
    "sel_reasonable f \<Longrightarrow> list_sel_aux' f x y \<le> 1 \<and> list_sel_aux' f x y > 0"
  by(induction x) (auto simp: sel_reasonable_def mult_le_one)

lemma list_sel_reasonable: "sel_reasonable f \<Longrightarrow> list_sel f x y \<le> 1 \<and> list_sel f x y > 0"
  by(induction x) (auto simp: sel_reasonable_def mult_le_one list_sel_aux_reasonable)

lemma list_sel'_reasonable: "sel_reasonable f \<Longrightarrow> list_sel' f x y \<le> 1 \<and> list_sel' f x y > 0"
  using list_sel_eq' list_sel_reasonable by metis

lemma list_sel_aux_eq_set_sel_aux:
  "distinct ys \<Longrightarrow> list_sel_aux f x ys = set_sel_aux f x (set ys)"
  by(induction ys) (auto simp: set_sel_aux_def)

lemma list_sel_eq_set_sel:
  "\<lbrakk>distinct xs; distinct ys\<rbrakk> \<Longrightarrow> list_sel f xs ys = set_sel f (set xs) (set ys)"
  by(induction xs) (auto simp: set_sel_def list_sel_aux_eq_set_sel_aux list_sel_empty)

lemma list_sel'_eq_set_sel:
  "\<lbrakk>distinct xs; distinct ys\<rbrakk> \<Longrightarrow> list_sel' f xs ys = set_sel f (set xs) (set ys)"
  by (auto simp add: list_sel_eq' dest: list_sel_eq_set_sel)

lemma set_sel_symm_if_finite: "\<lbrakk>finite X; finite Y; sel_symm f\<rbrakk> \<Longrightarrow> set_sel f X Y = set_sel f Y X"
  using finite_distinct_list list_sel_symm list_sel_eq_set_sel by metis

lemma set_sel_aux_1_if_notfin: "\<not>finite Y \<Longrightarrow> set_sel_aux f x Y = 1"
  unfolding set_sel_aux_def by simp

lemma set_sel_1_if_notfin1: "\<not>finite X \<Longrightarrow> set_sel f X Y = 1"
  unfolding set_sel_def set_sel_aux_def by simp

lemma set_sel_1_if_notfin2: "\<not>finite Y \<Longrightarrow> set_sel f X Y = 1"
  unfolding set_sel_def set_sel_aux_def by simp

lemma set_sel_symm: "sel_symm f \<Longrightarrow> set_sel f X Y = set_sel f Y X"
  using set_sel_symm_if_finite[of X Y]
  by (fastforce simp: set_sel_1_if_notfin1 set_sel_1_if_notfin2)

lemma list_sel_aux'_eq_set_sel_aux':
  "distinct xs \<Longrightarrow> list_sel_aux' f xs x = set_sel_aux' f (set xs) x"
  by(induction xs) (auto simp: set_sel_aux'_def)

lemma list_sel'_eq_set_sel':
  "\<lbrakk>distinct xs; distinct ys\<rbrakk> \<Longrightarrow> list_sel' f xs ys = set_sel' f (set xs) (set ys)"
  by(induction ys) (auto simp: set_sel'_def list_sel_aux'_eq_set_sel_aux' list_sel_empty)

lemma list_sel_eq_set_sel':
  "\<lbrakk>distinct xs; distinct ys\<rbrakk> \<Longrightarrow> list_sel f xs ys = set_sel' f (set xs) (set ys)"
  by (simp add: list_sel'_eq_set_sel' list_sel_eq')

lemma set_sel'_symm_if_finite: "\<lbrakk>finite X; finite Y; sel_symm f\<rbrakk> \<Longrightarrow> set_sel' f X Y = set_sel' f Y X"
  using finite_distinct_list list_sel_symm list_sel_eq_set_sel' by metis

lemma set_sel_aux'_1_if_notfin: "\<not>finite X \<Longrightarrow> set_sel_aux' f X y = 1"
  unfolding set_sel_aux'_def by simp

lemma set_sel'_1_if_notfin1: "\<not>finite X \<Longrightarrow> set_sel' f X Y = 1"
  unfolding set_sel'_def set_sel_aux'_def by simp

lemma set_sel'_1_if_notfin2: "\<not>finite Y \<Longrightarrow> set_sel' f X Y = 1"
  unfolding set_sel'_def set_sel_aux'_def by simp

lemma set_sel'_symm: "sel_symm f \<Longrightarrow> set_sel' f X Y = set_sel' f Y X"
  using set_sel'_symm_if_finite[of X Y]
  by (fastforce simp: set_sel'_1_if_notfin1 set_sel'_1_if_notfin2)

lemma set_sel'_eq_set_sel: "set_sel' f X Y = set_sel f X Y"
  unfolding set_sel_def set_sel_aux_def set_sel'_def set_sel_aux'_def using prod.swap by fast

lemma set_sel_aux_reasonable_fin:
  "\<lbrakk>finite y; sel_reasonable f\<rbrakk> \<Longrightarrow> set_sel_aux f x y \<le> 1 \<and> set_sel_aux f x y > 0"
  unfolding set_sel_aux_def
  by(induction y rule: finite_induct) (auto simp: sel_reasonable_def mult_le_one)

lemma set_sel_aux_reasonable:
  "sel_reasonable f \<Longrightarrow> set_sel_aux f x y \<le> 1 \<and> set_sel_aux f x y > 0"
  by(cases "finite y") (auto simp: set_sel_aux_reasonable_fin set_sel_aux_1_if_notfin)

lemma set_sel_aux'_reasonable_fin:
  "\<lbrakk>finite x; sel_reasonable f\<rbrakk> \<Longrightarrow> set_sel_aux' f x y \<le> 1 \<and> set_sel_aux' f x y > 0"
  unfolding set_sel_aux'_def
  by(induction x rule: finite_induct) (auto simp: sel_reasonable_def mult_le_one)

lemma set_sel_aux'_reasonable:
  "sel_reasonable f \<Longrightarrow> set_sel_aux' f x y \<le> 1 \<and> set_sel_aux' f x y > 0"
  by(cases "finite x") (auto simp: set_sel_aux'_reasonable_fin set_sel_aux'_1_if_notfin)

lemma set_sel_reasonable_fin:
  "\<lbrakk>finite x; sel_reasonable f\<rbrakk> \<Longrightarrow> set_sel f x y \<le> 1 \<and> set_sel f x y > 0"
  unfolding set_sel_def
  apply(induction x rule: finite_induct)
   using set_sel_aux'_reasonable_fin apply(simp)
  by (smt (verit) prod_le_1 prod_pos set_sel_aux_reasonable)

lemma set_sel_reasonable: "sel_reasonable f \<Longrightarrow> set_sel f x y \<le> 1 \<and> set_sel f x y > 0"
  by(cases "finite x") (auto simp: set_sel_reasonable_fin set_sel_1_if_notfin1)

lemma set_sel'_reasonable_fin:
  "\<lbrakk>finite y; sel_reasonable f\<rbrakk> \<Longrightarrow> set_sel' f x y \<le> 1 \<and> set_sel' f x y > 0"
  unfolding set_sel'_def
  apply(induction y rule: finite_induct)
   using set_sel_aux'_reasonable_fin apply(simp)
  by (smt (verit) prod_le_1 prod_pos set_sel_aux'_reasonable)

lemma set_sel'_reasonable: "sel_reasonable f \<Longrightarrow> set_sel' f x y \<le> 1 \<and> set_sel' f x y > 0"
  by (cases "finite y") (auto simp: set_sel'_reasonable_fin set_sel'_1_if_notfin2)

lemma ldeep_s_pos: "sel_reasonable f \<Longrightarrow> ldeep_s f xs x > 0"
  by (induction xs) (auto simp: list_sel_aux'_reasonable)

lemma distinct_app_trans_r: "distinct (ys@xs) \<Longrightarrow> distinct xs"
  by simp

lemma distinct_app_trans_l: "distinct (ys@xs) \<Longrightarrow> distinct ys"
  by simp

lemma ldeep_s_reasonable: "sel_reasonable f \<Longrightarrow> ldeep_s f xs y \<le> 1 \<and> ldeep_s f xs y > 0"
  by (induction xs) (auto simp: list_sel_aux'_reasonable)

lemma ldeep_s_eq_list_sel_aux'_split:
  "y \<in> set xs \<Longrightarrow> \<exists>as bs. as @ y # bs = xs \<and> ldeep_s sel xs y = list_sel_aux' sel bs y"
proof(induction xs)
  case (Cons x xs)
  then show ?case
  proof(cases "x = y")
    case False
    then obtain as bs where as_def: "as @ y # bs = xs" "ldeep_s sel xs y = list_sel_aux' sel bs y"
      using Cons by auto
    then have "(x#as) @ y # bs = x#xs" by simp
    then show ?thesis using False as_def(2) by fastforce
  qed(auto)
qed(simp)

lemma distinct_ldeep_s_eq_aux:
  "distinct xs \<Longrightarrow> \<exists>xs'. xs'@y#ys=xs \<Longrightarrow> ldeep_s f xs y = list_sel_aux' f ys y"
proof(induction xs arbitrary: ys)
  case (Cons x xs)
  then show ?case
  proof(cases "x=y \<and> ys=xs")
    case True
    then show ?thesis using Cons.prems by simp
  next
    case False
    then have "\<exists>xs'. xs'@y#ys=x#xs \<and> xs' \<noteq> []" using Cons.prems by auto
    then have 0: "\<exists>xs''. x#xs''@y#ys=x#xs" by (metis list.sel(3) tl_append2)
    have 1: "distinct xs" using Cons.prems(1) by fastforce
    then show ?thesis
    proof(cases "x=y")
      case True
      then have "count (mset (x#xs)) x \<ge> 2" using 0 by auto
      then show ?thesis using Cons.prems by simp
    next
      case False
      then have "ldeep_s f (x # xs) y
              = (\<lambda>a. if a=x then list_sel_aux' f xs a else ldeep_s f xs a) y" by simp
      also have "\<dots> =  ldeep_s f xs y" using False by simp
      finally show ?thesis using Cons.IH 0 1 by simp
    qed
  qed
qed(simp)

lemma distinct_ldeep_s_eq_aux':
  "\<lbrakk>distinct xs; as @ y # bs = xs\<rbrakk> \<Longrightarrow> ldeep_s sel xs y = list_sel_aux' sel bs y"
  using distinct_ldeep_s_eq_aux by fast

lemma ldeep_s_last1_if_distinct: "distinct xs \<Longrightarrow> ldeep_s sel xs (last xs) = 1"
  by (induction xs) auto

lemma ldeep_s_revhd1_if_distinct: "distinct xs \<Longrightarrow> ldeep_s sel (rev xs) (hd xs) = 1"
  using ldeep_s_last1_if_distinct[of "rev xs"] by (simp add: last_rev)

lemma ldeep_s_1_if_nelem: "x \<notin> set xs \<Longrightarrow> ldeep_s sel xs x = 1"
  by (induction xs) auto

lemma distinct_xs_not_ys: "distinct (xs@ys) \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<notin> set ys"
  by auto

lemma distinct_ys_not_xs: "distinct (xs@ys) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<notin> set xs"
  by auto

lemma distinct_change_order_first_eq_nempty:
  assumes "distinct (xs@ys@zs@rs)"
      and "ys \<noteq> []"
      and "zs \<noteq> []"
      and "take 1 (xs@ys@zs@rs) = take 1 (xs@zs@ys@rs)"
    shows "xs \<noteq> []"
proof
  assume "xs = []"
  then have "take 1 (ys@zs@rs) = take 1 (zs@ys@rs)" using assms(4) by simp
  then have "\<exists>r rs1 rs2. ys@zs@rs = r#rs1 \<and> zs@ys@rs = r#rs2"
    by (metis append_Cons append_take_drop_id assms(3) neq_Nil_conv take_eq_Nil zero_neq_one)
  then obtain r rs1 rs2 where r_def: "ys@zs@rs = r#rs1 \<and> zs@ys@rs = r#rs2" by blast
  then have 0: "r \<in> set ys \<and> r \<in> set zs"
    using assms(2,3) by (metis Cons_eq_append_conv list.set_intros(1))
  then show False using 0 assms(1) by auto
qed

lemma distinct_change_order_first_elem:
  "\<lbrakk>distinct (xs@ys@zs@rs); ys \<noteq> []; zs \<noteq> []; take 1 (xs@ys@zs@rs) = take 1 (xs@zs@ys@rs)\<rbrakk>
    \<Longrightarrow> take 1 (xs@ys@zs@rs) = take 1  xs"
  by (cases xs) (fastforce dest!: distinct_change_order_first_eq_nempty)+

lemma take1_singleton_app: "take 1 xs = [r] \<Longrightarrow> take 1 (xs@ys) = [r]"
  by (induction xs) (auto)

lemma hd_eq_take1: "take 1 xs = [r] \<Longrightarrow> hd xs = r"
  using hd_take[of 1 xs] by simp

lemma take1_eq_hd: "\<lbrakk>xs \<noteq> []; hd xs = r\<rbrakk> \<Longrightarrow> take 1 xs = [r]"
  by (simp add: take_Suc)

lemma nempty_if_take1: "take 1 xs = [r] \<Longrightarrow> xs \<noteq> []"
  by force

end


(*<*) theory ex1_7 imports Main begin (*>*)

text {* Finite sets can obviously be implemented by lists.  In the
following, you will be asked to implement the set operations union,
intersection and difference and to show that these implementations are
correct.  Thus, for a function *}
primrec exists ::"'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "exists x [] = False"|
"exists x (y#ys) = ((x=y) \<or>exists x ys)"

primrec  list_union :: "['a list, 'a list] \<Rightarrow> 'a list"
  where "list_union [] y = y"
  |"list_union (x#xs) y = (if x: set y then list_union xs y else x#(list_union xs y))"

text {* to be defined by you it has to be shown that *}

lemma "set (list_union xs ys) = set xs \<union> set ys"
  apply (induct xs)
  apply auto
done

text {* In addition, the functions should be space efficient in the
sense that one obtains lists without duplicates (@{text "distinct"})
whenever the parameters of the functions are duplicate-free.  Thus, for
example, *}
lemma l1:"\<lbrakk>a \<notin> set ys; a \<notin> set xs\<rbrakk> \<Longrightarrow>  a \<notin> set (list_union xs ys)"
  apply(induct xs)
   apply auto
  done
lemma [rule_format]:
  "distinct xs \<longrightarrow> distinct ys \<longrightarrow> (distinct (list_union xs ys))"
  apply (induct xs)
   apply (auto simp add: l1)
  done

text {* \emph{Hint:} @{text "distinct"} is defined in @{text List.thy}. *}

subsubsection {* Quantification over Sets *}

text {* Define a (non-trivial) set @{text S} such that the following
proposition holds: *}

lemma "((\<forall> x \<in> A. P x) \<and> (\<forall> x \<in> B. P x)) \<longrightarrow> (\<forall> x \<in> (A \<union> B). P x)"
  apply auto
  done

text {* Define a (non-trivial) predicate @{text P} such that *}

lemma "\<forall> x \<in> A. Q (f x) \<Longrightarrow>  \<forall> y \<in> f ` A. Q y"
  apply auto
  done

(*<*) end (*>*)


(*
   Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

chapter \<open>Formalizing Rasiowa's Axioms for Propositional Logic\<close>

theory System_R imports Main begin

text \<open>All references are to Alonzo Church (1956): Introduction to Mathematical Logic\<close>

section \<open>Syntax / Axiomatics / Semantics\<close>

datatype form = Pro nat | Neg form | Dis form form (infix \<open>\<Or>\<close> 0)

abbreviation Imp (infix \<open>\<rightarrow>\<close> 0) where \<open>(p \<rightarrow> q) \<equiv> (Neg p \<Or> q)\<close>

text \<open>Rasiowa 1949 building on Russell 1908, Bernays 1926 and Götlind 1947 [Church page 157]\<close>

inductive Axiomatics (\<open>\<turnstile>\<close>) where
  \<open>\<turnstile> q\<close> if \<open>\<turnstile> p\<close> and \<open>\<turnstile> (p \<rightarrow> q)\<close> |
  \<open>\<turnstile> ((p \<Or> p) \<rightarrow> p)\<close> |
  \<open>\<turnstile> (p \<rightarrow> (p \<Or> q))\<close> |
  \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((r \<Or> p) \<rightarrow> (q \<Or> r)))\<close>

abbreviation Truth (\<open>\<top>\<close>) where \<open>\<top> \<equiv> (undefined \<rightarrow> undefined)\<close>

theorem \<open>\<turnstile> \<top>\<close> using Axiomatics.intros by metis

primrec semantics (infix \<open>\<Turnstile>\<close> 0) where
  \<open>(I \<Turnstile> Pro n) = I n\<close> |
  \<open>(I \<Turnstile> Neg p) = (if I \<Turnstile> p then False else True)\<close> |
  \<open>(I \<Turnstile> (p \<Or> q)) = (if I \<Turnstile> p then True else (I \<Turnstile> q))\<close>

theorem \<open>I \<Turnstile> p\<close> if \<open>\<turnstile> p\<close> using that by induct auto

definition \<open>valid p \<equiv> \<forall>I. (I \<Turnstile> p)\<close>

theorem \<open>valid p = \<turnstile> p\<close> oops \<comment> \<open>Proof at end\<close>

abbreviation Falsity (\<open>\<bottom>\<close>) where \<open>\<bottom> \<equiv> Neg \<top>\<close>

theorem \<open>\<turnstile> (\<bottom> \<rightarrow> p)\<close> using Axiomatics.intros by metis

lemmas MP = Axiomatics.intros(1)
lemmas Idem = Axiomatics.intros(2)
lemmas AddR = Axiomatics.intros(3)
lemmas Swap = Axiomatics.intros(4)

section \<open>Soundness\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: Axiomatics.induct) auto

section \<open>Derived Rules\<close>

proposition alternative_axiom: \<open>\<turnstile> (p \<rightarrow> (p \<Or> q))\<close> if \<open>\<And>p q. \<turnstile> (p \<rightarrow> (q \<Or> p))\<close>
  by (metis MP Idem Swap that)

lemma AddL: \<open>\<turnstile> (p \<rightarrow> (q \<Or> p))\<close>
  by (metis MP Idem Swap AddR)

lemma Perm: \<open>\<turnstile> ((p \<Or> q) \<rightarrow> (q \<Or> p))\<close>
  by (metis Idem AddL AddR Swap MP)

lemma SwapCon: \<open>\<turnstile> ((p \<rightarrow> (q \<Or> r)) \<rightarrow> (p \<rightarrow> (r \<Or> q)))\<close>
  by (meson MP Perm Swap)

lemma SubR: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((r \<Or> p) \<rightarrow> (r \<Or> q)))\<close>
  by (meson MP SwapCon Swap)

text \<open>Russell 1908 and Bernays 1926 [Church page 157]\<close>

inductive RB (\<open>\<tturnstile>\<close>) where
  \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  \<open>\<tturnstile> ((p \<Or> p) \<rightarrow> p)\<close> |
  \<open>\<tturnstile> (p \<rightarrow> (q \<Or> p))\<close> |
  \<open>\<tturnstile> ((p \<Or> q) \<rightarrow> (q \<Or> p))\<close> |
  \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((r \<Or> p) \<rightarrow> (r \<Or> q)))\<close>

theorem Axiomatics_RB: \<open>\<turnstile> p \<longleftrightarrow> \<tturnstile> p\<close>
proof
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by induct (use SubR Axiomatics.intros in meson)+
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (use RB.intros in meson)+
qed

lemma SwapAnte: \<open>\<turnstile> (((p \<Or> q) \<rightarrow> r) \<rightarrow> ((q \<Or> p) \<rightarrow> r))\<close>
  by (metis AddR Idem MP Perm Swap)

lemma SubL: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((p \<Or> r) \<rightarrow> (q \<Or> r)))\<close>
  by (meson MP SwapAnte Swap)

lemma AddM: \<open>\<turnstile> ((p \<Or> q) \<rightarrow> ((p \<Or> r) \<Or> q))\<close>
  by (meson SubL MP AddR)

lemma Church1: \<open>\<turnstile> ((p \<Or> (p \<Or> q)) \<rightarrow> (p \<Or> q))\<close>
  by (meson Idem MP SubL SubR AddR)

lemma Church2: \<open>\<turnstile> (p \<Or> ((p \<Or> q) \<rightarrow> q))\<close>
  by (metis Church1 MP Swap AddL AddM)

lemma Imp1: \<open>\<turnstile> (p \<rightarrow> p)\<close>
  by (metis Idem AddL AddR Swap MP)

lemma Neg': \<open>\<turnstile> ((p \<Or> q) \<rightarrow> (Neg q \<rightarrow> p))\<close>
  using Imp1 MP Swap by blast

lemma Tran: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Neg' SubL MP)

lemma Church3: \<open>\<turnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  by (meson Church2 Tran MP)

lemma Neg: \<open>\<turnstile> ((p \<rightarrow> \<bottom>) \<rightarrow> Neg p)\<close>
  by (metis Church3 Imp1 MP Perm)

lemma ImpER: \<open>\<turnstile> ((p \<Or> (q \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<Or> r)))\<close>
  using SubR by (metis Church2 MP)

lemma SubR': \<open>\<turnstile> ((p \<Or> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<Or> r)))\<close>
  using SubR Church3 MP by blast

lemma SubL': \<open>\<turnstile> ((p \<Or> q) \<rightarrow> ((p \<rightarrow> r) \<rightarrow> (r \<Or> q)))\<close>
  using SubL Church3 MP by blast

lemma FalsityE': \<open>\<turnstile> ((p \<Or> q) \<rightarrow> ((Neg p \<Or> q) \<rightarrow> q))\<close>
  by (meson SubR SubL' MP Idem)

lemma FalsityE'': \<open>\<turnstile> ((Neg p \<Or> r) \<rightarrow> ((p \<Or> q) \<rightarrow> (q \<Or> r)))\<close>
  by (meson ImpER MP SubR' SwapAnte)

lemma FalsityEImpER: \<open>\<turnstile> ((Neg p \<Or> r) \<rightarrow> ((p \<Or> q) \<rightarrow> ((Neg q \<Or> r) \<rightarrow> r)))\<close>
  using FalsityE'' FalsityE' by (meson SubR MP)

lemma DisE: \<open>\<turnstile> ((p \<rightarrow> r) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> ((p \<Or> q) \<rightarrow> r)))\<close>
  using FalsityEImpER by (meson MP ImpER Tran)

lemma Imp2: \<open>\<turnstile> ((p \<Or> (q \<rightarrow> r)) \<rightarrow> ((p \<Or> q) \<rightarrow> (p \<Or> r)))\<close>
  using DisE SubR MP AddL AddR by metis

lemma Imp2': \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> (p \<rightarrow> r)))\<close>
  by (metis AddL Imp2 Tran MP)

primrec imply :: \<open>form list \<Rightarrow> form \<Rightarrow> form\<close> where
  \<open>imply [] q = q\<close>
| \<open>imply (p # ps) q = (p \<rightarrow> imply ps q)\<close>

lemma imply_head: \<open>\<turnstile> (imply (p # ps) p)\<close>
  by (induct ps) (simp add: Imp1, metis AddL Imp2 MP imply.simps(2))

lemma imply_Cons: \<open>\<turnstile> (imply ps q) \<Longrightarrow> \<turnstile> (imply (p # ps) q)\<close>
  by (metis AddL MP imply.simps(2))

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  using imply_head imply_Cons by (induct ps) auto

lemma imply_MP: \<open>\<turnstile> (imply ps p \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q))\<close>
proof (induct ps)
  case Nil
  then show ?case
    by (simp add: Church2)
next
  case (Cons r ps)
  then show ?case
  proof -
    have \<open>\<turnstile> ((r \<rightarrow> imply ps p) \<rightarrow> (r \<rightarrow> (imply ps (p \<rightarrow> q) \<rightarrow> imply ps q)))\<close>
      by (meson Cons.hyps AddL Imp2 MP)
    then have \<open>\<turnstile> ((r \<rightarrow> imply ps p) \<rightarrow> ((r \<rightarrow> imply ps (p \<rightarrow> q)) \<rightarrow> (r \<rightarrow> imply ps q)))\<close>
      by (meson Imp2' Church3 Tran MP)
    then show ?thesis
      by simp
  qed
qed

lemma imply_mp': \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply ps (p \<rightarrow> q)) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_MP by (meson MP)

lemma add_imply: \<open>\<turnstile> q \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using imply_Cons by (induct ps) simp_all

lemma imply_append: \<open>imply (ps @ qs) r = imply ps (imply qs r)\<close>
  by (induct ps) simp_all

lemma imply_swap: \<open>\<turnstile> (imply (ps @ qs) r) \<Longrightarrow> \<turnstile> (imply (qs @ ps) r)\<close>
proof (induct qs arbitrary: ps)
  case (Cons q qs)
  then show ?case
    by (metis imply_Cons imply_head imply_mp' imply.simps(2) imply_append)
qed simp

lemma deduct: \<open>\<turnstile> (imply (p # ps) q) \<longleftrightarrow> \<turnstile> (imply ps (p \<rightarrow> q))\<close>
  using imply_swap by (metis imply.simps(1-2) imply_append)

theorem imply_weaken: \<open>\<turnstile> (imply ps q) \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> \<turnstile> (imply ps' q)\<close>
proof (induct ps arbitrary: q)
  case (Cons p ps)
  note \<open>\<turnstile> (imply (p # ps) q)\<close>
  then have \<open>\<turnstile> (imply ps (p \<rightarrow> q))\<close>
    using deduct by blast
  then have \<open>\<turnstile> (imply ps' (p \<rightarrow> q))\<close>
    using Cons by simp
  then show ?case
    using Cons(3) by (meson imply_mem imply_mp' list.set_intros(1) subset_code(1))
qed (simp add: add_imply)

lemma cut: \<open>\<turnstile> (imply ps p) \<Longrightarrow> \<turnstile> (imply (p # ps) q) \<Longrightarrow> \<turnstile> (imply ps q)\<close>
  using deduct imply_mp' by blast

lemma imply4: \<open>\<turnstile> (imply (p # q # ps) r) \<Longrightarrow> \<turnstile> (imply (q # p # ps) r)\<close>
  by (metis ImpER MP imply.simps(2))

lemma cut': \<open>\<turnstile> (imply (p # ps) r) \<Longrightarrow> \<turnstile> (imply (q # ps) p) \<Longrightarrow> \<turnstile> (imply (q # ps) r)\<close>
  using imply_Cons cut imply4 by blast

lemma imply_lift: \<open>\<turnstile> (p \<rightarrow> q) \<Longrightarrow> \<turnstile> (imply ps p \<rightarrow> imply ps q)\<close>
  by (metis Imp1 add_imply imply.simps(2) imply_mp')

lemma DNeg: \<open>\<turnstile> (Neg (Neg p) \<rightarrow> p)\<close>
  by (metis Idem AddR Swap MP)

lemma imply_DNeg: \<open>\<turnstile> (imply ps (Neg (Neg p)) \<rightarrow> imply ps p)\<close>
  using DNeg imply_lift by simp

lemma Boole: \<open>\<turnstile> (imply ((Neg p) # ps) \<bottom>) \<Longrightarrow> \<turnstile> (imply ps p)\<close>
  by (meson Neg MP imply_DNeg deduct imply_lift)

lemma imply_front: \<open>\<turnstile> (imply S p) \<Longrightarrow> set S - {q} \<subseteq> set S' \<Longrightarrow> \<turnstile> (imply (q # S') p)\<close>
  by (metis Diff_single_insert imply_weaken list.set(2))

lemma FalsityE: \<open>\<turnstile> (p \<rightarrow> (Neg p \<rightarrow> q))\<close>
  using AddM Imp1 MP Perm by blast

section \<open>Consistent\<close>

definition consistent :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile> (imply S' \<bottom>)\<close>

lemma UN_finite_bound:
  assumes \<open>finite p\<close> \<open>p \<subseteq> (\<Union>n. f n)\<close>
  shows \<open>\<exists>m :: nat. p \<subseteq> (\<Union>n \<le> m. f n)\<close>
  using assms
proof (induct rule: finite_induct)
  case (insert x p)
  then obtain m where \<open>p \<subseteq> (\<Union>n \<le> m. f n)\<close>
    by fast
  then have \<open>p \<subseteq> (\<Union>n \<le> (m + k). f n)\<close> for k
    by fastforce
  moreover obtain m' where \<open>x \<in> f m'\<close>
    using insert(4) by blast
  ultimately have \<open>{x} \<union> p \<subseteq> (\<Union>n \<le> m + m'. f n)\<close>
    by auto
  then show ?case
    by blast
qed simp

section \<open>Extension\<close>

primrec extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> nat \<Rightarrow> form set\<close> where
  \<open>extend S f 0 = S\<close>
| \<open>extend S f (Suc n) =
    (if consistent ({f n} \<union> extend S f n)
     then {f n} \<union> extend S f n
     else extend S f n)\<close>

definition Extend :: \<open>form set \<Rightarrow> (nat \<Rightarrow> form) \<Rightarrow> form set\<close> where
  \<open>Extend S f \<equiv> \<Union>n. extend S f n\<close>

lemma Extend_subset: \<open>S \<subseteq> Extend S f\<close>
  unfolding Extend_def by (metis Union_upper extend.simps(1) range_eqI)

lemma extend_bound: \<open>(\<Union>n \<le> m. extend S f n) = extend S f m\<close>
  by (induct m) (simp_all add: atMost_Suc)

lemma consistent_extend: \<open>consistent S \<Longrightarrow> consistent (extend S f n)\<close>
  by (induct n) simp_all

lemma consistent_Extend:
  assumes \<open>consistent S\<close>
  shows \<open>consistent (Extend S f)\<close>
  unfolding Extend_def
proof (rule ccontr)
  assume \<open>\<not> consistent (\<Union>n. extend S f n)\<close>
  then obtain S' where \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> (\<Union>n. extend S f n)\<close>
    unfolding consistent_def by blast
  then obtain m where \<open>set S' \<subseteq> (\<Union>n \<le> m. extend S f n)\<close>
    using UN_finite_bound by (metis List.finite_set)
  then have \<open>set S' \<subseteq> extend S f m\<close>
    using extend_bound by blast
  moreover have \<open>consistent (extend S f m)\<close>
    using assms consistent_extend by blast
  ultimately show False
    unfolding consistent_def using \<open>\<turnstile> (imply S' \<bottom>)\<close> by blast
qed

section \<open>Maximal\<close>

definition maximal :: \<open>form set \<Rightarrow> bool\<close> where
  \<open>maximal S \<equiv> \<forall>p. p \<notin> S \<longrightarrow> \<not> consistent ({p} \<union> S)\<close>

lemma maximal_Extend:
  assumes \<open>surj f\<close>
  shows \<open>maximal (Extend S f)\<close>
proof (rule ccontr)
  assume \<open>\<not> maximal (Extend S f)\<close>
  then obtain p where \<open>p \<notin> Extend S f\<close> \<open>consistent ({p} \<union> Extend S f)\<close>
    unfolding maximal_def using assms consistent_Extend by blast
  obtain k where n: \<open>f k = p\<close>
    using \<open>surj f\<close> unfolding surj_def by metis
  then have \<open>p \<notin> extend S f (Suc k)\<close>
    using \<open>p \<notin> Extend S f\<close> unfolding Extend_def by blast
  then have \<open>\<not> consistent ({p} \<union> extend S f k)\<close>
    using n by fastforce
  moreover have \<open>{p} \<union> extend S f k \<subseteq> {p} \<union> Extend S f\<close>
    unfolding Extend_def by blast
  ultimately have \<open>\<not> consistent ({p} \<union> Extend S f)\<close>
    unfolding consistent_def by fastforce
  then show False
    using \<open>consistent ({p} \<union> Extend S f)\<close> by blast
qed

section \<open>Hintikka\<close>

locale Hintikka =
  fixes H :: \<open>form set\<close>
  assumes
    NoFalsity: \<open>\<bottom> \<notin> H\<close> and
    ProP: \<open>Pro n \<in> H \<Longrightarrow> (Neg (Pro n)) \<notin> H\<close> and
    DisP: \<open>(p \<Or> q) \<in> H \<Longrightarrow> p \<in> H \<or> q \<in> H\<close> and
    DisN: \<open>(Neg (p \<Or> q)) \<in> H \<Longrightarrow> (Neg p) \<in> H \<and> (Neg q) \<in> H\<close> and
    NegN: \<open>(Neg (Neg p)) \<in> H \<Longrightarrow> p \<in> H\<close>

abbreviation (input) \<open>model H n \<equiv> Pro n \<in> H\<close>

lemma Hintikka_model:
  \<open>Hintikka H \<Longrightarrow> (p \<in> H \<longrightarrow> (model H \<Turnstile> p)) \<and> ((Neg p) \<in> H \<longrightarrow> \<not> (model H \<Turnstile> p))\<close>
  by (induct p) (simp; unfold Hintikka_def, blast)+

lemma inconsistent_head:
  assumes \<open>maximal S\<close> \<open>consistent S\<close> \<open>p \<notin> S\<close>
  shows \<open>\<exists>S'. \<turnstile> (imply (p # S') \<bottom>) \<and> set S' \<subseteq> S\<close>
proof -
  obtain S' where S': \<open>\<turnstile> (imply S' \<bottom>)\<close> \<open>set S' \<subseteq> {p} \<union> S\<close> \<open>p \<in> set S'\<close>
    using assms unfolding maximal_def consistent_def by fast
  then obtain S'' where S'': \<open>\<turnstile> (imply (p # S'') \<bottom>)\<close> \<open>set S'' = set S' - {p}\<close>
    by (metis imply_front set_removeAll subset_refl)
  then show ?thesis
    using S'(2) by fast
qed

lemma Hintikka_Extend:
  assumes \<open>maximal S\<close> \<open>consistent S\<close>
  shows \<open>Hintikka S\<close>
proof
  show \<open>\<bottom> \<notin> S\<close>
    using assms(2) imply_head imply_mem unfolding consistent_def
    by (metis List.set_insert empty_set insert_Diff insert_is_Un singletonI sup.cobounded1)
next
  fix n
  assume \<open>Pro n \<in> S\<close>
  moreover have \<open>\<turnstile> (imply [Pro n, Neg (Pro n)] \<bottom>)\<close>
    by (simp add: FalsityE)
  ultimately show \<open>(Neg (Pro n)) \<notin> S\<close>
    using assms(2) unfolding consistent_def
    by (metis bot.extremum empty_set insert_subset list.set(2))
next
  fix p q
  assume *: \<open>(p \<Or> q) \<in> S\<close>
  show \<open>p \<in> S \<or> q \<in> S\<close>
  proof (rule disjCI, rule ccontr)
    assume **: \<open>q \<notin> S\<close>
    then obtain Sq' where Sq': \<open>\<turnstile> (imply (q # Sq') \<bottom>)\<close> \<open>set Sq' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    assume \<open>p \<notin> S\<close>
    then obtain Sp' where Sp': \<open>\<turnstile> (imply (p # Sp') \<bottom>)\<close> \<open>set Sp' \<subseteq> S\<close>
      using assms inconsistent_head by blast
    obtain S' where S': \<open>set S' = set Sp' \<union> set Sq'\<close> \<open>set S' \<subseteq> S\<close>
      using Sq'(2) Sp'(2) by (metis le_sup_iff set_union)
    then have \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>\<turnstile> (imply (q # S') \<bottom>)\<close>
      using Sq' Sp' deduct imply_weaken by simp_all
    then have \<open>\<turnstile> (imply ((p \<Or> q) # S') \<bottom>)\<close>
      by (metis DisE MP imply.simps(2))
    moreover have \<open>set ((p \<Or> q) # S') \<subseteq> S\<close>
      using * S' Sp'(2) Sq'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p q
  assume *: \<open>(Neg (p \<Or> q)) \<in> S\<close>
  show \<open>(Neg p) \<in> S \<and> (Neg q) \<in> S\<close>
  proof (rule conjI; rule ccontr)
    assume \<open>(Neg p) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply ((Neg p) # S') \<bottom>)\<close> \<open>set S' \<subseteq> S - {Neg p}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((Neg (p \<Or> q)) # S') (Neg p))\<close>
      using Idem AddR Tran add_imply deduct MP by metis
    ultimately have \<open>\<turnstile> (imply ((Neg (p \<Or> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((Neg (p \<Or> q)) # S') \<subseteq> S\<close>
      using * S'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  next
    assume \<open>(Neg q) \<notin> S\<close>
    then obtain S' where S': \<open>\<turnstile> (imply ((Neg q) # S') \<bottom>)\<close> \<open>set S' \<subseteq> S - {Neg q}\<close>
      using assms inconsistent_head by blast
    moreover have \<open>\<turnstile> (imply ((Neg (p \<Or> q)) # S') (Neg q))\<close>
      using Idem AddR AddL Tran add_imply deduct MP Neg' by metis
    ultimately have \<open>\<turnstile> (imply ((Neg (p \<Or> q)) # S') \<bottom>)\<close>
      using cut' by blast
    moreover have \<open>set ((Neg (p \<Or> q)) # S') \<subseteq> S\<close>
      using *(1) S'(2) by auto
    ultimately show False
      using assms unfolding consistent_def by blast
  qed
next
  fix p
  assume *: \<open>(Neg (Neg p)) \<in> S\<close>
  show \<open>p \<in> S\<close>
  proof (rule ccontr)
    assume \<open>p \<notin> S\<close>
    then obtain SNA where SNA: \<open>\<turnstile> (imply (p # SNA) \<bottom>)\<close> \<open>set SNA \<subseteq> S\<close>
      using assms inconsistent_head by blast
    from * obtain SA where SA: \<open>\<turnstile> (imply SA p)\<close> \<open>set SA \<subseteq> S\<close>
      using imply_DNeg MP
      by (metis empty_set empty_subsetI imply_head insert_absorb insert_mono list.simps(15))
    obtain S' where S': \<open>set S' = set SA \<union> set SNA\<close> \<open>set S' \<subseteq> S\<close>
      using SA(2) SNA(2) by (metis Un_subset_iff set_union)
    with SNA SA have \<open>\<turnstile> (imply (p # S') \<bottom>)\<close> \<open>\<turnstile> (imply S' p)\<close>
      using deduct imply_weaken by simp_all
    with S' assms show \<open>False\<close> unfolding consistent_def
      using cut by meson
  qed
qed

section \<open>Countable Formulas\<close>

primrec diag :: \<open>nat \<Rightarrow> (nat \<times> nat)\<close> where
  \<open>diag 0 = (0, 0)\<close>
| \<open>diag (Suc n) =
     (let (x, y) = diag n
      in case y of
          0 \<Rightarrow> (0, Suc x)
        | Suc y \<Rightarrow> (Suc x, y))\<close>

theorem diag_le1: \<open>fst (diag (Suc n)) < Suc n\<close>
  by (induct n) (simp_all add: Let_def split_def split: nat.split)

theorem diag_le2: \<open>snd (diag (Suc (Suc n))) < Suc (Suc n)\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc _)
    then show ?case
      using diag_le1 by (simp add: Let_def split_def split: nat.split)
  qed
qed

theorem diag_le3: \<open>fst (diag n) = Suc x \<Longrightarrow> snd (diag n) < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then show ?case
  proof (induct n')
    case 0
    then show ?case by simp
  next
    case (Suc n'')
    then show ?case using diag_le2 by simp
  qed
qed

theorem diag_le4: \<open>fst (diag n) = Suc x \<Longrightarrow> x < n\<close>
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n')
  then have \<open>fst (diag (Suc n')) < Suc n'\<close>
    using diag_le1 by blast
  then show ?case using Suc by simp
qed

function undiag :: \<open>nat \<times> nat \<Rightarrow> nat\<close> where
  \<open>undiag (0, 0) = 0\<close>
| \<open>undiag (0, Suc y) = Suc (undiag (y, 0))\<close>
| \<open>undiag (Suc x, y) = Suc (undiag (x, Suc y))\<close>
  by pat_completeness auto
termination
  by (relation \<open>measure (\<lambda>(x, y). ((x + y) * (x + y + 1)) div 2 + x)\<close>) auto

theorem diag_undiag [simp]: \<open>diag (undiag (x, y)) = (x, y)\<close>
  by (induct rule: undiag.induct) simp_all

datatype btree = Leaf nat | Branch btree btree

function diag_btree :: \<open>nat \<Rightarrow> btree\<close> where
  \<open>diag_btree n = (case fst (diag n) of
       0 \<Rightarrow> Leaf (snd (diag n))
     | Suc x \<Rightarrow> Branch (diag_btree x) (diag_btree (snd (diag n))))\<close>
  by auto
termination
  by (relation \<open>measure id\<close>) (auto intro: diag_le3 diag_le4)

primrec undiag_btree :: \<open>btree \<Rightarrow> nat\<close> where
  \<open>undiag_btree (Leaf n) = undiag (0, n)\<close>
| \<open>undiag_btree (Branch t1 t2) = undiag (Suc (undiag_btree t1), undiag_btree t2)\<close>

theorem diag_undiag_btree [simp]: \<open>diag_btree (undiag_btree t) = t\<close>
  by (induct t) simp_all

declare diag_btree.simps [simp del] undiag_btree.simps [simp del]

fun form_of_btree :: \<open>btree \<Rightarrow> form\<close> where
  \<open>form_of_btree (Leaf n) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Leaf n)) = Pro n\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Branch t1 t2)) =
     Dis (form_of_btree t1) (form_of_btree t2)\<close>
| \<open>form_of_btree (Branch (Leaf 0) (Branch t _)) = Neg (form_of_btree t)\<close>
| \<open>form_of_btree (Branch (Leaf (Suc 0)) (Leaf _)) = undefined\<close>
| \<open>form_of_btree (Branch (Leaf (Suc (Suc _))) _) = undefined\<close>
| \<open>form_of_btree (Branch (Branch _ _) _) = undefined\<close>

primrec btree_of_form :: \<open>form \<Rightarrow> btree\<close> where
  \<open>btree_of_form (Pro n) = Branch (Leaf 0) (Leaf n)\<close>
| \<open>btree_of_form (Neg p) = Branch (Leaf 0) (Branch (btree_of_form p) (Leaf 0))\<close>
| \<open>btree_of_form (Dis p q) = Branch (Leaf (Suc 0))
     (Branch (btree_of_form p) (btree_of_form q))\<close>

definition diag_form :: \<open>nat \<Rightarrow> form\<close> where
  \<open>diag_form n = form_of_btree (diag_btree n)\<close>

definition undiag_form :: \<open>form \<Rightarrow> nat\<close> where
  \<open>undiag_form p = undiag_btree (btree_of_form p)\<close>

theorem diag_undiag_form [simp]: \<open>diag_form (undiag_form p) = p\<close>
  unfolding diag_form_def undiag_form_def by (induct p) simp_all

abbreviation \<open>from_nat \<equiv> diag_form\<close>
abbreviation \<open>to_nat \<equiv> undiag_form\<close>

lemma surj_from_nat: \<open>surj from_nat\<close>
  by (metis diag_undiag_form surj_def)

section \<open>Completeness\<close>

lemma imply_completeness:
  assumes valid: \<open>\<forall>I s. list_all (\<lambda>q. (I \<Turnstile> q)) ps \<longrightarrow> (I \<Turnstile> p)\<close>
  shows \<open>\<turnstile> (imply ps p)\<close>
proof (rule ccontr)
  assume \<open>\<not> \<turnstile> (imply ps p)\<close>
  then have *: \<open>\<not> \<turnstile> (imply ((Neg p) # ps) \<bottom>)\<close>
    using Boole by blast

  let ?S = \<open>set ((Neg p) # ps)\<close>
  let ?H = \<open>Extend ?S from_nat\<close>

  have \<open>consistent ?S\<close>
    unfolding consistent_def using * imply_weaken by blast
  then have \<open>consistent ?H\<close> \<open>maximal ?H\<close>
    using consistent_Extend maximal_Extend surj_from_nat by blast+
  then have \<open>Hintikka ?H\<close>
    using Hintikka_Extend by blast

  have \<open>model ?H \<Turnstile> p\<close> if \<open>p \<in> ?S\<close> for p
    using that Extend_subset Hintikka_model \<open>Hintikka ?H\<close> by blast
  then have \<open>model ?H \<Turnstile> (Neg p)\<close> \<open>list_all (\<lambda>p. (model ?H \<Turnstile> p)) ps\<close>
    unfolding list_all_def by fastforce+
  then have \<open>model ?H \<Turnstile> p\<close>
    using valid by blast
  then show False
    using \<open>model ?H \<Turnstile> (Neg p)\<close> by simp
qed

theorem completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<turnstile> p\<close>
  using imply_completeness[where ps=\<open>[]\<close>] by simp

section \<open>Main Result\<close>

theorem main: \<open>valid p = \<turnstile> p\<close>
proof
  assume \<open>valid p\<close>
  with completeness show \<open>\<turnstile> p\<close>
    unfolding valid_def .
next
  assume \<open>\<turnstile> p\<close>
  with soundness show \<open>valid p\<close>
    unfolding valid_def by (intro allI)
qed

section \<open>Using Unnecessary Axiom in Principia Mathematica (PM) by Whitehead and Russell 1910\<close>

text \<open>First appeared in Russell 1908 and derived from the other axioms in Bernays 1926 (system RB)\<close>

inductive PM (\<open>\<then>\<close>) where
  \<open>\<then> q\<close> if \<open>\<then> p\<close> and \<open>\<then> (p \<rightarrow> q)\<close> |
  \<open>\<then> ((p \<Or> p) \<rightarrow> p)\<close> |
  \<open>\<then> (p \<rightarrow> (q \<Or> p))\<close> |
  \<open>\<then> ((p \<Or> q) \<rightarrow> (q \<Or> p))\<close> |
  \<open>\<then> ((p \<Or> (q \<Or> r)) \<rightarrow> (q \<Or> (p \<Or> r)))\<close> |
  \<open>\<then> ((p \<rightarrow> q) \<rightarrow> ((r \<Or> p) \<rightarrow> (r \<Or> q)))\<close>

proposition PM_extends_RB: \<open>\<tturnstile> p \<Longrightarrow> \<then> p\<close>
  by (induct rule: RB.induct) (auto intro: PM.intros)

theorem equivalence: \<open>\<then> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have *: \<open>\<turnstile> ((p \<Or> (q \<Or> r)) \<rightarrow> (q \<Or> (p \<Or> r)))\<close> for p q r
    using completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<then> p\<close>
    using that by induct (use * SubR Axiomatics.intros in meson)+
  show \<open>\<then> p\<close> if \<open>\<turnstile> p\<close>
    using that by induct (use PM.intros in meson)+
qed

corollary associativity:
  \<open>\<then> (((p \<Or> q) \<Or> r) \<rightarrow> (p \<Or> (q \<Or> r)))\<close>
  \<open>\<then> ((p \<Or> (q \<Or> r)) \<rightarrow> ((p \<Or> q) \<Or> r))\<close>
  using equivalence completeness by simp_all

end