section \<open>Lagrange Interpolation\<close>

text \<open>This section introduces the function @{term "interpolate"}, which constructs the Lagrange
interpolation polynomials for a given set of points, followed by a theorem of its correctness.\<close>

theory Lagrange_Interpolation
  imports "HOL-Algebra.Polynomial_Divisibility"
begin

text \<open>A finite product in a domain is $0$ if and only if at least one factor is. This could be added
to @{theory "HOL-Algebra.FiniteProduct"} or @{theory "HOL-Algebra.Ring"}.\<close>
lemma (in domain) finprod_zero_iff:
  assumes "finite A"
  assumes "\<And>a. a \<in> A \<Longrightarrow> f a \<in> carrier R"
  shows "finprod R f A = \<zero> \<longleftrightarrow> (\<exists>x \<in> A. f x = \<zero>)"
  using assms
proof (induct A rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert y F)
  moreover have "f \<in> F \<rightarrow> carrier R" using insert by blast
  ultimately show ?case by (simp add:integral_iff)
qed

lemma (in ring) poly_of_const_in_carrier:
  assumes "s \<in> carrier R"
  shows "poly_of_const s \<in> carrier (poly_ring R)"
  using poly_of_const_def assms
  by (simp add:univ_poly_carrier[symmetric] polynomial_def)

lemma (in ring) eval_poly_of_const:
  assumes "x \<in> carrier R"
  shows "eval (poly_of_const x) y = x"
  using assms by (simp add:poly_of_const_def)

lemma (in ring) eval_in_carrier_2:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "y \<in> carrier R"
  shows "eval x y \<in> carrier R"
  using eval_in_carrier univ_poly_carrier polynomial_incl assms by blast

lemma (in domain) poly_mult_degree_le_1:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "y \<in> carrier (poly_ring R)"
  shows "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) \<le> degree x + degree y"
proof -
  have "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) = (if x = [] \<or> y = [] then 0 else degree x + degree y)"
    unfolding univ_poly_mult
    by (metis univ_poly_carrier assms(1,2) carrier_is_subring poly_mult_degree_eq)
  thus ?thesis by (metis nat_le_linear zero_le)
qed

lemma (in domain) poly_mult_degree_le:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "y \<in> carrier (poly_ring R)"
  assumes "degree x \<le> n"
  assumes "degree y \<le> m"
  shows "degree (x \<otimes>\<^bsub>poly_ring R\<^esub> y) \<le> n + m"
  using poly_mult_degree_le_1 assms add_mono by force

lemma (in domain) poly_add_degree_le:
  assumes "x \<in> carrier (poly_ring R)" "degree x \<le> n"
  assumes "y \<in> carrier (poly_ring R)" "degree y \<le> n"
  shows "degree (x \<oplus>\<^bsub>poly_ring R\<^esub> y) \<le> n"
  using assms poly_add_degree
  by (metis dual_order.trans max.bounded_iff univ_poly_add)

lemma (in domain) poly_sub_degree_le:
  assumes "x \<in> carrier (poly_ring R)" "degree x \<le> n"
  assumes "y \<in> carrier (poly_ring R)" "degree y \<le> n"
  shows "degree (x \<ominus>\<^bsub>poly_ring R\<^esub> y) \<le> n"
proof -
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  show ?thesis
    unfolding a_minus_def
    using assms univ_poly_a_inv_degree carrier_is_subring poly_add_degree_le x.a_inv_closed
    by simp
qed

lemma (in domain) poly_sum_degree_le:
  assumes "finite A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> degree (f x) \<le> n"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (poly_ring R)"
  shows "degree (finsum (poly_ring R) f A) \<le> n"
  using assms
proof (induct A rule:finite_induct)
  case empty
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
  show ?case using empty by (simp add:univ_poly_zero)
next
  case (insert x F)
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
  have a: "degree (f x \<oplus>\<^bsub>poly_ring R\<^esub> finsum (poly_ring R) f F) \<le> n"
    using insert poly_add_degree_le x.finsum_closed by auto
  show ?case using insert a by auto
qed

definition (in ring) lagrange_basis_polynomial_aux where
  "lagrange_basis_polynomial_aux S =
    (\<Otimes>\<^bsub>poly_ring R\<^esub> s \<in> S. X \<ominus>\<^bsub>poly_ring R\<^esub> (poly_of_const s))"

lemma (in domain) lagrange_aux_eval:
  assumes "finite S"
  assumes "S \<subseteq> carrier R"
  assumes "x \<in> carrier R"
  shows "(eval (lagrange_basis_polynomial_aux S) x) = (\<Otimes>s \<in> S. x \<ominus> s)"
proof -
  interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
    by (rule eval_cring_hom[OF carrier_is_subring assms(3)])

  have "\<And>a. a \<in> S \<Longrightarrow> X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const a \<in> carrier (poly_ring R)"
    by (meson poly_of_const_in_carrier carrier_is_subring assms(2) cring.cring_simprules(4)
        domain_def subsetD univ_poly_is_domain var_closed(1))

  moreover have "\<And>s. s \<in> S \<Longrightarrow> eval (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const s) x = x \<ominus> s"
    using assms var_closed carrier_is_subring poly_of_const_in_carrier subsetD[OF assms(2)]
    by (simp add:eval_var eval_poly_of_const)

  moreover have "a_minus R x \<in> S \<rightarrow> carrier R"
    using assms by blast

  ultimately show ?thesis
    by (simp add:lagrange_basis_polynomial_aux_def x.hom_finprod cong:finprod_cong')
qed

lemma (in domain) lagrange_aux_poly:
  assumes "finite S"
  assumes "S \<subseteq> carrier R"
  shows "lagrange_basis_polynomial_aux S \<in> carrier (poly_ring R)"
proof -
  have a:"subring (carrier R) R"
    using carrier_is_subring assms by blast

  have b: "\<And>a. a \<in> S \<Longrightarrow> X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const a \<in> carrier (poly_ring R)"
    by (meson poly_of_const_in_carrier a assms(2) cring.cring_simprules(4) domain_def subsetD
        univ_poly_is_domain var_closed(1))

  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  show ?thesis
    using lagrange_basis_polynomial_aux_def b x.finprod_closed[OF Pi_I] by simp
qed

lemma (in domain) poly_prod_degree_le:
  assumes "finite A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (poly_ring R)"
  shows "degree (finprod (poly_ring R) f A) \<le> (\<Sum>x \<in> A. degree (f x))"
  using assms
proof (induct A rule:finite_induct)
  case empty
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
  show ?case by (simp add:univ_poly_one)
next
  case (insert x F)
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto
  have a:"f \<in> F \<rightarrow> carrier (poly_ring R)"
    using insert by blast
  have b:"f x \<in> carrier (poly_ring R)"
    using insert by blast
  have "degree (finprod (poly_ring R) f (insert x F)) = degree (f x \<otimes>\<^bsub>poly_ring R\<^esub> finprod (poly_ring R) f F)"
    using a b insert by simp
  also have "... \<le> degree (f x) + degree (finprod (poly_ring R) f F)"
    using poly_mult_degree_le x.finprod_closed[OF a] b by auto
  also have "... \<le> degree (f x) + (\<Sum>y \<in> F. degree (f y))"
    using insert(3) a add_mono by auto
  also have "... = (\<Sum>y \<in> (insert x F). degree (f y))" using insert by simp
  finally show ?case by simp
qed

lemma (in domain) lagrange_aux_degree:
  assumes "finite S"
  assumes "S \<subseteq> carrier R"
  shows "degree (lagrange_basis_polynomial_aux S) \<le> card S"
proof -
  interpret x:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  have "degree X \<le> 1" by (simp add:var_def)
  moreover have "\<And>y. y\<in> S \<Longrightarrow> degree (poly_of_const y) \<le> 1" by (simp add:poly_of_const_def)
  ultimately have a: "\<And>y. y\<in> S \<Longrightarrow> degree (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y) \<le> 1"
    by (meson assms(2) in_mono poly_of_const_in_carrier poly_sub_degree_le var_closed[OF carrier_is_subring])

  have b:"\<And>y. y \<in> S \<Longrightarrow> (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y) \<in> carrier (poly_ring R)"
    by (meson subsetD x.minus_closed var_closed(1)[OF carrier_is_subring] poly_of_const_in_carrier assms(2))

  have "degree (lagrange_basis_polynomial_aux S) \<le> (\<Sum>y \<in> S. degree (X \<ominus>\<^bsub>poly_ring R\<^esub> poly_of_const y))"
    using lagrange_basis_polynomial_aux_def b poly_prod_degree_le[OF assms(1)] by auto
  also have "... \<le> (\<Sum>y \<in> S. 1)"
    using sum_mono a by force
  also have "... = card S" by simp
  finally show ?thesis by simp
qed

definition (in ring) lagrange_basis_polynomial where
  "lagrange_basis_polynomial S x = lagrange_basis_polynomial_aux S
    \<otimes>\<^bsub>poly_ring R\<^esub> (poly_of_const (inv\<^bsub>R\<^esub> (\<Otimes>s \<in> S. x \<ominus> s)))"

lemma (in field)
  assumes "finite S"
  assumes "S \<subseteq> carrier R"
  assumes "x \<in> carrier R - S"
  shows
    lagrange_one: "eval (lagrange_basis_polynomial S x) x = \<one>" and
    lagrange_degree: "degree (lagrange_basis_polynomial S x) \<le> card S" and
    lagrange_zero: "\<And>s. s \<in> S \<Longrightarrow> eval (lagrange_basis_polynomial S x) s = \<zero>" and
    lagrange_poly: "lagrange_basis_polynomial S x \<in> carrier (poly_ring R)"
proof -
  interpret x:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p x)"
    using assms carrier_is_subring eval_cring_hom by blast

  define p where "p = lagrange_basis_polynomial_aux S"
  have a:"eval p x = (\<Otimes>s \<in> S. x \<ominus> s)"
    using assms by (simp add:p_def lagrange_aux_eval)

  have b:"p \<in> carrier (poly_ring R)" using assms
    by (simp add:p_def lagrange_aux_poly)

  have "\<And>y. y \<in> S \<Longrightarrow> a_minus R x y \<in> carrier R"
    using assms by blast

  hence c:"finprod R (a_minus R x) S \<in> Units R"
    using finprod_closed[OF Pi_I] assms
    by (auto simp add:field_Units finprod_zero_iff)

  have "eval (lagrange_basis_polynomial S x) x =
    (\<Otimes>s \<in> S. x \<ominus> s) \<otimes> eval (poly_of_const (inv finprod R (a_minus R x) S)) x"
    using poly_of_const_in_carrier Units_inv_closed c p_def[symmetric]
    by (simp add: lagrange_basis_polynomial_def x.hom_mult[OF b] a)
  also have "... =  \<one>"
    using poly_of_const_in_carrier Units_inv_closed c eval_poly_of_const by simp
  finally show "eval (lagrange_basis_polynomial S x) x = \<one>" by simp

  have "degree (lagrange_basis_polynomial S x) \<le> degree p + degree (poly_of_const (inv finprod R (a_minus R x) S))"
    unfolding lagrange_basis_polynomial_def p_def[symmetric]
    using poly_mult_degree_le[OF b] poly_of_const_in_carrier Units_inv_closed c by auto
  also have "... \<le> card S + 0"
    using add_mono lagrange_aux_degree[OF assms(1) assms(2)] p_def poly_of_const_def by auto
  finally show "degree (lagrange_basis_polynomial S x) \<le> card S" by simp

  show "\<And>s. s \<in> S \<Longrightarrow> eval (lagrange_basis_polynomial S x) s = \<zero>"
  proof -
    fix s
    assume d:"s \<in> S"

    interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p s)"
      using eval_cring_hom carrier_is_subring assms d by blast

    have "eval p s = finprod R (a_minus R s) S"
      using subsetD[OF assms(2) d] assms
      by (simp add:p_def lagrange_aux_eval)
    also have "... = \<zero>"
      using subsetD[OF assms(2)] d assms by (simp add: finprod_zero_iff)
    finally have "eval p s = \<zero>\<^bsub>R\<^esub>" by simp

    moreover have "eval (poly_of_const (inv finprod R (a_minus R x) S)) s \<in> carrier R"
      using s.hom_closed poly_of_const_in_carrier  Units_inv_closed c by blast

    ultimately show "eval (lagrange_basis_polynomial S x) s = \<zero>"
      using poly_of_const_in_carrier Units_inv_closed c
      by (simp add:lagrange_basis_polynomial_def Let_def p_def[symmetric] s.hom_mult[OF b])
  qed

  interpret r:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  show "lagrange_basis_polynomial S x \<in> carrier (poly_ring R)"
    using lagrange_basis_polynomial_def p_def[symmetric] poly_of_const_in_carrier Units_inv_closed
      a b c by simp
qed

definition (in ring) interpolate where
  "interpolate S f =
   (\<Oplus>\<^bsub>poly_ring R\<^esub>s \<in> S. lagrange_basis_polynomial (S - {s}) s \<otimes>\<^bsub>poly_ring R\<^esub> (poly_of_const (f s)))"

text \<open>Let @{term "f"} be a function and @{term "S"} be a finite subset of the domain of the field.
Then @{term "interpolate S f"} will return a polynomial with degree less than @{term "card S"}
interpolating @{term "f"} on @{term "S"}.\<close>

theorem (in field)
  assumes "finite S"
  assumes "S \<subseteq> carrier R"
  assumes "f ` S \<subseteq> carrier R"
  shows
    interpolate_poly: "interpolate S f \<in> carrier (poly_ring R)" and
    interpolate_degree: "degree (interpolate S f) \<le> card S - 1" and
    interpolate_eval: "\<And>s. s \<in> S \<Longrightarrow> eval (interpolate S f) s = f s"
proof -
  interpret r:cring "poly_ring R"
    using carrier_is_subring domain.univ_poly_is_cring domain_axioms by auto

  have a:"\<And>x. x \<in> S \<Longrightarrow> lagrange_basis_polynomial (S - {x}) x \<in> carrier (poly_ring R)"
    by (meson lagrange_poly assms Diff_iff finite_Diff in_mono insertI1 subset_insertI2 subset_insert_iff)

  have b:"\<And>x. x \<in> S \<Longrightarrow> f x \<in> carrier R" using assms by blast

  have c:"\<And>x. x \<in> S \<Longrightarrow> degree (lagrange_basis_polynomial (S - {x}) x) \<le> card S - 1"
    by (metis (full_types) lagrange_degree  DiffI Diff_insert_absorb assms(1) assms(2)
        card_Diff_singleton finite_insert insert_subset mk_disjoint_insert)

  have d: "\<And>x. x \<in> S \<Longrightarrow>
    degree (lagrange_basis_polynomial (S - {x}) x \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f x)) \<le> (card S - 1) + 0"
    using poly_of_const_in_carrier[OF b] poly_mult_degree_le[OF a] c poly_of_const_def by fastforce

  show "interpolate S f \<in> carrier (poly_ring R)"
    using interpolate_def poly_of_const_in_carrier a b by simp

  show "degree (interpolate S f) \<le> card S - 1"
    using poly_sum_degree_le[OF assms(1) d] poly_of_const_in_carrier[OF b] interpolate_def a by simp

  have e:"subring (carrier R) R"
    using carrier_is_subring assms by blast

  show "\<And>s. s \<in> S \<Longrightarrow> eval (interpolate S f) s = f s"
  proof -
    fix s
    assume f:"s \<in> S"
    interpret s:ring_hom_cring "poly_ring R" "R" "(\<lambda>p. eval p s)"
      using eval_cring_hom[OF e] assms f by blast
    have g:"\<And>i. i \<in> S \<Longrightarrow>
         eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
         (if s = i then f s else \<zero>)"
    proof -
      fix i
      assume i_in_S: "i \<in> S"
      have "eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
        eval (lagrange_basis_polynomial (S - {i}) i) s \<otimes> f i"
        using b i_in_S poly_of_const_in_carrier
        by (simp add: s.hom_mult[OF a] eval_poly_of_const)
      also have "... = (if s = i then f s else \<zero>)"
        using b i_in_S poly_of_const_in_carrier assms f
        apply (cases "s=i", simp, subst lagrange_one, auto)
        by (subst lagrange_zero, auto)
      finally show
        "eval (lagrange_basis_polynomial (S - {i}) i \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f i)) s =
         (if s = i then f s else \<zero>)" by simp
    qed

    have "eval (interpolate S f) s =
    (\<Oplus>x\<in>S. eval (lagrange_basis_polynomial (S - {x}) x \<otimes>\<^bsub>poly_ring R\<^esub> poly_of_const (f x)) s)"
      using  poly_of_const_in_carrier[OF b] a e
      by (simp add: interpolate_def s.hom_finsum[OF Pi_I] comp_def)
    also have "... =  (\<Oplus>x\<in>S. if s = x then f s else \<zero>)"
      using b g by (simp cong: finsum_cong)
    also have "... = f s"
      using finsum_singleton[OF f assms(1)] f assms by auto
    finally show "eval (interpolate S f) s = f s" by simp
  qed
qed

end


\<^marker>\<open>creator "Simon Wimmer"\<close>
theory Submission
  imports "HOL-Library.Sublist" Defs
begin

definition all_subseq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "all_subseq xs ys \<longleftrightarrow> (\<forall>xs'. xs' \<sqsubseteq> xs \<longrightarrow> xs' \<sqsubseteq> ys)"

lemma subseq_id:
  "subseq = Sublist.subseq"
  apply (intro ext)
  apply safe
  subgoal premises prems
    using prems by induction auto
  subgoal premises prems
    using prems by induction auto
    done

lemma proper_subseq_id:
  "proper_subseq = strict_subseq"
  unfolding proper_subseq_def strict_subseq_def subseq_id ..

lemmas subseq_ids = subseq_id proper_subseq_id

lemmas [termination_simp] = length_dropWhile_le

lemma subseq_empty_iff:
  "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
  unfolding subseq_ids by auto

lemma [simp]:
  "all_subseq (x # xs) (y # ys) \<longleftrightarrow> all_subseq (x # xs) ys" if "x \<noteq> y"
  using that by (auto simp: all_subseq_def subseq_ids)

lemma [simp]:
  "all_subseq (x # xs) (x # ys) \<longleftrightarrow> all_subseq xs ys"
  apply (auto simp: all_subseq_def subseq_ids)
  by (meson subseq_Cons2 subseq_order.dual_order.trans subseq_order.order_refl)

lemma aux_correct:
  "aux xs ys \<longleftrightarrow> all_subseq xs ys"
  by (induction rule: aux.induct; simp)

lemma strict_subseq_ConsE:
  assumes "a # as \<sqsubset> bs"
  obtains xs ys where "bs = xs @ a # ys" "xs \<noteq> []" "as \<sqsubseteq> ys" | ys where "bs = a # ys" "as \<sqsubset> ys"
  by (metis (full_types) assms list_emb_ConsD self_append_conv2 subseq_order.antisym_conv2
        subseq_order.dual_order.strict_implies_order subseq_ids)

lemma strict_subseqE:
  assumes "xs \<sqsubset> ys"
  obtains as x bs where "ys = as @ x # bs" and "xs \<sqsubseteq> as @ bs"
  using assms unfolding subseq_ids
  apply (induction xs arbitrary: ys)
  subgoal for ys
    apply (cases ys; force)
    done
  apply (erule strict_subseq_ConsE[unfolded subseq_ids])
   apply (metis append_Cons append_Nil list.exhaust list_emb_append2 subseq_Cons2_iff)
  by (metis append.simps(2) subseq_Cons2)

lemma all_proper_subseq_subdivide:
  "all_proper_subseq xs ys \<longleftrightarrow> (\<forall>as x bs. xs = as @ x # bs \<longrightarrow> all_subseq (as @ bs) ys)"
unfolding all_proper_subseq_def all_subseq_def subseq_ids
  apply auto
  apply (meson list_emb_Cons not_Cons_self2 same_append_eq subseq_append_iff
          subseq_order.dual_order.order_iff_strict subseq_order.le_less_trans)
  subgoal
    by (erule strict_subseqE[unfolded subseq_ids]) auto
  done

lemma aux2_iff:
  "aux2 ys acc xs \<longleftrightarrow> (\<forall>as x bs. xs = as @ x # bs \<longrightarrow> aux (acc @ as @ bs) ys)"
  apply (induction xs arbitrary: acc)
   apply auto
  subgoal
    by (smt Nil_is_append_conv append_eq_append_conv2 hd_Cons_tl hd_append2 list.sel(1) list.sel(3)
          tl_append2)
  apply force
  by (metis append_Cons)

lemma aux2_correct:
  "aux2 ys [] xs \<longleftrightarrow> all_proper_subseq xs ys"
  unfolding aux2_iff all_proper_subseq_subdivide aux_correct by simp

theorem judge1_correct: "judge1 xs ys \<longleftrightarrow> all_proper_subseq xs ys"
  unfolding judge1_def aux2_correct by auto

definition
  "judge2 xs ys \<longleftrightarrow> judge1 xs ys"

theorem judge2_correct:
  "judge2 xs ys \<longleftrightarrow> all_proper_subseq xs ys"
  unfolding judge2_def by (rule judge1_correct)

theorem judge2_is_executable:
  "judge2 ''ab'' ''ab'' \<longleftrightarrow> True"
  "judge2 ''ba'' ''ab'' \<longleftrightarrow> True"
  "judge2 ''abcd'' ''cdabc'' \<longleftrightarrow> False"
  by eval+

end


(*
  File:     Matroid.thy
  Author:   Jonas Keinholz
*)
section \<open>Matroids\<close>
theory Matroid
  imports Indep_System
begin

lemma card_subset_ex:
  assumes "finite A" "n \<le> card A"
  shows "\<exists>B \<subseteq> A. card B = n"
using assms
proof (induction A arbitrary: n rule: finite_induct)
  case (insert x A)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis using card_empty by blast
  next
    case (Suc k)
    then have "\<exists>B \<subseteq> A. card B = k" using insert by auto
    then obtain B where "B \<subseteq> A" "card B = k" by auto
    moreover from this have "finite B" using insert.hyps finite_subset by auto
    ultimately have "card (insert x B) = n"
      using Suc insert.hyps card_insert_disjoint by fastforce
    then show ?thesis using \<open>B \<subseteq> A\<close> by blast
  qed
qed auto

locale matroid = indep_system +
  assumes augment_aux:
    "indep X \<Longrightarrow> indep Y \<Longrightarrow> card X = Suc (card Y) \<Longrightarrow> \<exists>x \<in> X - Y. indep (insert x Y)"
begin

lemma augment:
  assumes "indep X" "indep Y" "card Y < card X"
  shows "\<exists>x \<in> X - Y. indep (insert x Y)"
proof -
  obtain X' where "X' \<subseteq> X" "card X' = Suc (card Y)"
    using assms card_subset_ex[of X "Suc (card Y)"] indep_finite by auto
  then obtain x where "x \<in> X' - Y"  "indep (insert x Y)"
    using assms augment_aux[of X' Y] indep_subset by auto
  then show ?thesis using \<open>X' \<subseteq> X\<close> by auto
qed

lemma augment_psubset:
  assumes "indep X" "indep Y" "Y \<subset> X"
  shows "\<exists>x \<in> X - Y. indep (insert x Y)"
  using assms augment psubset_card_mono indep_finite by blast

subsection \<open>Minors\<close>

text \<open>
  A subset of the ground set induces a matroid.
\<close>

lemma matroid_subset [simp, intro]:
  assumes "\<E> \<subseteq> carrier"
  shows "matroid \<E> (indep_in \<E>)"
  unfolding matroid_def matroid_axioms_def
proof (safe, goal_cases indep_system augment)
  case indep_system
  then show ?case using indep_system_subset[OF assms] .
next
  case (augment X Y)
  then show ?case using augment_aux[of X Y] unfolding indep_in_def by auto
qed

context
  fixes \<E>
  assumes "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using \<open>\<E> \<subseteq> carrier\<close> by auto

lemmas augment_aux_indep_in = \<E>.augment_aux
lemmas augment_indep_in = \<E>.augment
lemmas augment_psubset_indep_in = \<E>.augment_psubset

end

subsection \<open>Bases\<close>

lemma basis_card:
  assumes "basis B\<^sub>1"
  assumes "basis B\<^sub>2"
  shows "card B\<^sub>1 = card B\<^sub>2"
proof (rule ccontr, goal_cases False)
  case False
  then have "card B\<^sub>1 < card B\<^sub>2 \<or> card B\<^sub>2 < card B\<^sub>1" by auto
  moreover {
    fix B\<^sub>1 B\<^sub>2
    assume "basis B\<^sub>1" "basis B\<^sub>2" "card B\<^sub>1 < card B\<^sub>2"
    then obtain x where "x \<in> B\<^sub>2 - B\<^sub>1" "indep (insert x B\<^sub>1)"
      using augment basisD by blast
    then have "x \<in> carrier - B\<^sub>1"
      using \<open>basis B\<^sub>1\<close> basisD indep_subset_carrier by blast
    then have "\<not> indep (insert x B\<^sub>1)" using \<open>basis B\<^sub>1\<close> basisD by auto
    then have "False" using \<open>indep (insert x B\<^sub>1)\<close> by auto
  }
  ultimately show ?case using assms by auto
qed

lemma basis_indep_card:
  assumes "indep X"
  assumes "basis B"
  shows "card X \<le> card B"
proof -
  obtain B' where "basis B'" "X \<subseteq> B'" using assms indep_imp_subset_basis by auto
  then show ?thesis using assms basis_finite basis_card[of B B'] by (auto intro: card_mono)
qed

lemma basis_augment:
  assumes "basis B\<^sub>1" "basis B\<^sub>2" "x \<in> B\<^sub>1 - B\<^sub>2"
  shows "\<exists>y \<in> B\<^sub>2 - B\<^sub>1. basis (insert y (B\<^sub>1 - {x}))"
proof -
  let ?B\<^sub>1 = "B\<^sub>1 - {x}"
  have "card ?B\<^sub>1 < card B\<^sub>2"
    using assms basis_card[of B\<^sub>1 B\<^sub>2] card_Diff1_less[OF basis_finite, of B\<^sub>1] by auto
  moreover have "indep ?B\<^sub>1" using assms basis_indep[of B\<^sub>1] indep_subset[of B\<^sub>1 ?B\<^sub>1] by auto
  ultimately obtain y where y: "y \<in> B\<^sub>2 - ?B\<^sub>1" "indep (insert y ?B\<^sub>1)"
    using assms augment[of B\<^sub>2 ?B\<^sub>1] basis_indep by auto
  let ?B\<^sub>1' = "insert y ?B\<^sub>1"
  have "basis ?B\<^sub>1'" using \<open>indep ?B\<^sub>1'\<close>
  proof (rule basisI, goal_cases "insert")
    case (insert x)
    have "card (insert x ?B\<^sub>1') > card B\<^sub>1"
    proof -
      have "card (insert x ?B\<^sub>1') = Suc (card ?B\<^sub>1')"
        using insert card_insert[OF indep_finite, of ?B\<^sub>1'] y by auto
      also have "\<dots> = Suc (Suc (card ?B\<^sub>1))"
        using card_insert[OF indep_finite, of ?B\<^sub>1] \<open>indep ?B\<^sub>1\<close> y by auto
      also have "\<dots> = Suc (card B\<^sub>1)"
        using assms basis_finite[of B\<^sub>1] card.remove[of B\<^sub>1] by auto
      finally show ?thesis by auto
    qed
    then have "\<not>indep (insert x (insert y ?B\<^sub>1))"
      using assms basis_indep_card[of "insert x (insert y ?B\<^sub>1)" B\<^sub>1] by auto
    moreover have "insert x (insert y ?B\<^sub>1) \<subseteq> carrier"
      using assms insert y basis_finite indep_subset_carrier by auto
    ultimately show ?case by auto
  qed
  then show ?thesis using assms y by auto
qed

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using \<open>\<E> \<subseteq> carrier\<close> by auto

lemmas basis_in_card = \<E>.basis_card[OF basis_inD_aux[OF *] basis_inD_aux[OF *]]
lemmas basis_in_indep_in_card = \<E>.basis_indep_card[OF _ basis_inD_aux[OF *]]

lemma basis_in_augment:
  assumes "basis_in \<E> B\<^sub>1" "basis_in \<E> B\<^sub>2" "x \<in> B\<^sub>1 - B\<^sub>2"
  shows "\<exists>y \<in> B\<^sub>2 - B\<^sub>1. basis_in \<E> (insert y (B\<^sub>1 - {x}))"
  using assms \<E>.basis_augment unfolding basis_in_def by auto

end

subsection \<open>Circuits\<close>

lemma circuit_elim:
  assumes "circuit C\<^sub>1" "circuit C\<^sub>2" "C\<^sub>1 \<noteq> C\<^sub>2" "x \<in> C\<^sub>1 \<inter> C\<^sub>2"
  shows "\<exists>C\<^sub>3 \<subseteq> (C\<^sub>1 \<union> C\<^sub>2) - {x}. circuit C\<^sub>3"
proof -
  let ?C = "(C\<^sub>1 \<union> C\<^sub>2) - {x}"
  let ?carrier = "C\<^sub>1 \<union> C\<^sub>2"

  have assms': "circuit_in carrier C\<^sub>1" "circuit_in carrier C\<^sub>2"
    using assms circuit_imp_circuit_in by auto

  have "?C \<subseteq> carrier" using assms circuit_subset_carrier by auto
  show ?thesis
  proof (cases "indep ?C")
    case False
    then show ?thesis using dep_iff_supset_circuit \<open>?C \<subseteq> carrier\<close> by auto
  next
    case True
    then have "indep_in ?carrier ?C" using \<open>?C \<subseteq> carrier\<close> by (auto intro: indep_inI)

    have *: "?carrier \<subseteq> carrier" using assms circuit_subset_carrier by auto
    obtain y where y: "y \<in> C\<^sub>2" "y \<notin> C\<^sub>1" using assms circuit_subset_eq by blast
    then have "indep_in ?carrier (C\<^sub>2 - {y})"
      using assms' circuit_in_min_dep_in[OF * circuit_in_supI[OF *, of C\<^sub>2]] by auto
    then obtain B where B: "basis_in ?carrier B" "C\<^sub>2 - {y} \<subseteq> B"
      using * assms indep_in_imp_subset_basis_in[of ?carrier "C\<^sub>2 - {y}"] by auto

    have "y \<notin> B"
    proof (rule ccontr, goal_cases False)
      case False
      then have "C\<^sub>2 \<subseteq> B" using B by auto
      moreover have "circuit_in ?carrier C\<^sub>2" using * assms' circuit_in_supI by auto
      ultimately have "\<not> indep_in ?carrier B"
        using B basis_in_subset_carrier[OF *] supset_circuit_in_imp_dep_in[OF *] by auto
      then show False using assms B basis_in_indep_in[OF *] by auto
    qed

    have "C\<^sub>1 - B \<noteq> {}"
    proof (rule ccontr, goal_cases False)
      case False
      then have "C\<^sub>1 - (C\<^sub>1 \<inter> B) = {}" by auto
      then have "C\<^sub>1 = C\<^sub>1 \<inter> B" using assms circuit_subset_eq by auto
      moreover have "indep (C\<^sub>1 \<inter> B)"
        using assms B basis_in_indep_in[OF *] indep_in_subset[OF *, of B "C\<^sub>1 \<inter> B"] indep_in_indep
        by auto
      ultimately show ?case using assms circuitD by auto
    qed
    then obtain z where z: "z \<in> C\<^sub>1" "z \<notin> B" by auto

    have "y \<noteq> z" using y z by auto
    have "x \<in> C\<^sub>1" "x \<in> C\<^sub>2" using assms by auto

    have "finite ?carrier" using assms carrier_finite finite_subset by auto
    have "card B \<le> card (?carrier - {y, z})"
    proof (rule card_mono)
      show "finite (C\<^sub>1 \<union> C\<^sub>2 - {y, z})" using \<open>finite ?carrier\<close> by auto
    next
      show "B \<subseteq> C\<^sub>1 \<union> C\<^sub>2 - {y, z}"
        using B basis_in_subset_carrier[OF *, of B] \<open>y \<notin> B\<close> \<open>z \<notin> B\<close> by auto
    qed
    also have "\<dots> = card ?carrier - 2"
      using \<open>finite ?carrier\<close> \<open>y \<in> C\<^sub>2\<close> \<open>z \<in> C\<^sub>1\<close> \<open>y \<noteq> z\<close> card_Diff_subset_Int by auto
    also have "\<dots> < card ?carrier - 1"
    proof -
      have "card ?carrier = card C\<^sub>1 + card C\<^sub>2 - card (C\<^sub>1 \<inter> C\<^sub>2)"
        using assms \<open>finite ?carrier\<close> card_Un_Int[of C\<^sub>1 C\<^sub>2] by auto
      also have "\<dots> = card C\<^sub>1 + (card C\<^sub>2 - card (C\<^sub>1 \<inter> C\<^sub>2))"
        using assms \<open>finite ?carrier\<close> card_mono[of C\<^sub>2] by auto
      also have "\<dots> = card C\<^sub>1 + card (C\<^sub>2 - C\<^sub>1)"
      proof -
        have "card (C\<^sub>2 - C\<^sub>1) = card C\<^sub>2 - card (C\<^sub>2 \<inter> C\<^sub>1)"
          using assms \<open>finite ?carrier\<close> card_Diff_subset_Int[of C\<^sub>2 C\<^sub>1] by auto
        also have "\<dots> = card C\<^sub>2 - card (C\<^sub>1 \<inter> C\<^sub>2)" by (simp add: inf_commute)
        finally show ?thesis by auto
      qed
      finally have "card (C\<^sub>1 \<union> C\<^sub>2) = card C\<^sub>1 + card (C\<^sub>2 - C\<^sub>1)" .
      moreover have "card C\<^sub>1 > 0" using assms circuit_nonempty \<open>finite ?carrier\<close> by auto
      moreover have "card (C\<^sub>2 - C\<^sub>1) > 0" using assms \<open>finite ?carrier\<close> \<open>y \<in> C\<^sub>2\<close> \<open>y \<notin> C\<^sub>1\<close> by auto
      ultimately show ?thesis by auto
    qed
    also have "\<dots> = card ?C"
      using \<open>finite ?carrier\<close> card_Diff_singleton \<open>x \<in> C\<^sub>1\<close> \<open>x \<in> C\<^sub>2\<close> by auto
    finally have "card B < card ?C" .
    then have False
      using basis_in_indep_in_card[OF *, of ?C B] B \<open>indep_in ?carrier ?C\<close> by auto
    then show ?thesis by auto
  qed
qed

lemma min_dep_imp_supset_circuit:
  assumes "indep X"
  assumes "circuit C"
  assumes "C \<subseteq> insert x X"
  shows "x \<in> C"
proof (rule ccontr)
  assume "x \<notin> C"
  then have "C \<subseteq> X" using assms by auto
  then have "indep C" using assms indep_subset by auto
  then show False using assms circuitD by auto
qed

lemma min_dep_imp_ex1_supset_circuit:
  assumes "x \<in> carrier"
  assumes "indep X"
  assumes "\<not> indep (insert x X)"
  shows "\<exists>!C. circuit C \<and> C \<subseteq> insert x X"
proof -
  obtain C where C: "circuit C" "C \<subseteq> insert x X"
    using assms indep_subset_carrier dep_iff_supset_circuit by auto

  show ?thesis
  proof (rule ex1I, goal_cases ex unique)
    show "circuit C \<and> C \<subseteq> insert x X" using C by auto
  next
    {
      fix C'
      assume C': "circuit C'" "C' \<subseteq> insert x X"
      have "C' = C"
      proof (rule ccontr)
        assume "C' \<noteq> C"
        moreover have "x \<in> C' \<inter> C" using C C' assms min_dep_imp_supset_circuit by auto
        ultimately have "\<not> indep (C' \<union> C - {x})"
          using circuit_elim[OF C(1) C'(1), of x] supset_circuit_imp_dep[of _ "C' \<union> C - {x}"] by auto
        moreover have "C' \<union> C - {x} \<subseteq> X" using C C' by auto
        ultimately show False using assms indep_subset by auto
      qed
    }
    then show "\<And>C'. circuit C' \<and> C' \<subseteq> insert x X \<Longrightarrow> C' = C"
      by auto
  qed
qed

lemma basis_ex1_supset_circuit:
  assumes "basis B"
  assumes "x \<in> carrier - B"
  shows "\<exists>!C. circuit C \<and> C \<subseteq> insert x B"
  using assms min_dep_imp_ex1_supset_circuit basisD by auto

definition fund_circuit :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "fund_circuit x B \<equiv> (THE C. circuit C \<and> C \<subseteq> insert x B)"

lemma circuit_iff_fund_circuit:
  "circuit C \<longleftrightarrow> (\<exists>x B. x \<in> carrier - B \<and> basis B \<and> C = fund_circuit x B)"
proof (safe, goal_cases LTR RTL)
  case LTR
  then obtain x where "x \<in> C" using circuit_nonempty by auto
  then have "indep (C - {x})" using LTR unfolding circuit_def by auto
  then obtain B where B: "basis B" "C - {x} \<subseteq> B" using indep_imp_subset_basis by auto
  then have "x \<in> carrier" using LTR circuit_subset_carrier \<open>x \<in> C\<close> by auto
  moreover have "x \<notin> B"
  proof (rule ccontr, goal_cases False)
    case False
    then have "C \<subseteq> B" using \<open>C - {x} \<subseteq> B\<close> by auto
    then have "\<not> indep B" using LTR B basis_subset_carrier supset_circuit_imp_dep by auto
    then show ?case using B basis_indep by auto
  qed
  ultimately show ?case
    unfolding fund_circuit_def
    using LTR B theI_unique[OF basis_ex1_supset_circuit[of B x], of C] by auto
next
  case (RTL x B)
  then have "\<exists>!C. circuit C \<and> C \<subseteq> insert x B"
    using min_dep_imp_ex1_supset_circuit basisD[of B] by auto
  then show ?case
    unfolding fund_circuit_def
    using theI[of "\<lambda>C. circuit C \<and> C \<subseteq> insert x B"] by fastforce
qed

lemma fund_circuitI:
  assumes "basis B"
  assumes "x \<in> carrier - B"
  assumes "circuit C"
  assumes "C \<subseteq> insert x B"
  shows "fund_circuit x B = C"
  unfolding fund_circuit_def
  using assms theI_unique[OF basis_ex1_supset_circuit, of B x C] by auto

definition fund_circuit_in where "fund_circuit_in \<E> x B \<equiv> matroid.fund_circuit \<E> (indep_in \<E>) x B"

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using \<open>\<E> \<subseteq> carrier\<close> by auto

lemma fund_circuit_inI_aux: "\<E>.fund_circuit x B = fund_circuit_in \<E> x B"
  unfolding fund_circuit_in_def by auto

lemma circuit_in_elim:
  assumes "circuit_in \<E> C\<^sub>1" "circuit_in \<E> C\<^sub>2" "C\<^sub>1 \<noteq> C\<^sub>2" "x \<in> C\<^sub>1 \<inter> C\<^sub>2"
  shows "\<exists>C\<^sub>3 \<subseteq> (C\<^sub>1 \<union> C\<^sub>2) - {x}. circuit_in \<E> C\<^sub>3"
  using assms \<E>.circuit_elim unfolding circuit_in_def by auto

lemmas min_dep_in_imp_supset_circuit_in = \<E>.min_dep_imp_supset_circuit[OF _ circuit_inD_aux[OF *]]

lemma min_dep_in_imp_ex1_supset_circuit_in:
  assumes "x \<in> \<E>"
  assumes "indep_in \<E> X"
  assumes "\<not> indep_in \<E> (insert x X)"
  shows "\<exists>!C. circuit_in \<E> C \<and> C \<subseteq> insert x X"
  using assms \<E>.min_dep_imp_ex1_supset_circuit unfolding circuit_in_def by auto

lemma basis_in_ex1_supset_circuit_in:
  assumes "basis_in \<E> B"
  assumes "x \<in> \<E> - B"
  shows "\<exists>!C. circuit_in \<E> C \<and> C \<subseteq> insert x B"
  using assms \<E>.basis_ex1_supset_circuit unfolding circuit_in_def basis_in_def by auto

lemma fund_circuit_inI:
  assumes "basis_in \<E> B"
  assumes "x \<in> \<E> - B"
  assumes "circuit_in \<E> C"
  assumes "C \<subseteq> insert x B"
  shows "fund_circuit_in \<E> x B = C"
  using assms \<E>.fund_circuitI
  unfolding basis_in_def circuit_in_def fund_circuit_in_def by auto

end

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using \<open>\<E> \<subseteq> carrier\<close> by auto

lemma fund_circuit_in_sub_cong:
  assumes "\<E>' \<subseteq> \<E>"
  assumes "x \<in> \<E>' - B"
  assumes "basis_in \<E>' B"
  shows "\<E>.fund_circuit_in \<E>' x B = fund_circuit_in \<E>' x B"
proof -
  obtain C where C: "circuit_in \<E>' C" "C \<subseteq> insert x B"
    using * assms basis_in_ex1_supset_circuit_in[of \<E>' B x] by auto
  then have "fund_circuit_in \<E>' x B = C"
    using * assms fund_circuit_inI by auto
  also have "\<dots> = \<E>.fund_circuit_in \<E>' x B"
    using * assms C \<E>.fund_circuit_inI basis_in_sub_cong[of \<E>] circuit_in_sub_cong[of \<E>] by auto
  finally show ?thesis by auto
qed

end

subsection \<open>Ranks\<close>

abbreviation rank_of where "rank_of \<equiv> lower_rank_of"

lemmas rank_of_def = lower_rank_of_def
lemmas rank_of_sub_cong = lower_rank_of_sub_cong
lemmas rank_of_le = lower_rank_of_le

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using * by auto

lemma lower_rank_of_eq_upper_rank_of: "lower_rank_of \<E> = upper_rank_of \<E>"
proof -
  obtain B where "basis_in \<E> B" using basis_in_ex[OF *] by auto
  then have "{card B | B. basis_in \<E> B} = {card B}"
    by safe (auto dest: basis_in_card[OF *])
  then show ?thesis unfolding lower_rank_of_def upper_rank_of_def by auto
qed

lemma rank_of_eq_card_basis_in:
  assumes "basis_in \<E> B"
  shows "rank_of \<E> = card B"
proof -
  have "{card B | B. basis_in \<E> B} = {card B}" using assms by safe (auto dest: basis_in_card[OF *])
  then show ?thesis unfolding rank_of_def by auto
qed

lemma rank_of_indep_in_le:
  assumes "indep_in \<E> X"
  shows "card X \<le> rank_of \<E>"
proof -
  {
    fix B
    assume "basis_in \<E> B"
    moreover obtain B' where "basis_in \<E> B'" "X \<subseteq> B'"
      using assms indep_in_imp_subset_basis_in[OF *] by auto
    ultimately have "card X \<le> card B"
      using card_mono[OF basis_in_finite[OF *]] basis_in_card[OF *, of B B'] by auto
  }
  moreover have "finite {card B | B. basis_in \<E> B}"
    using collect_basis_in_finite[OF *] by auto
  ultimately show ?thesis
    unfolding rank_of_def using basis_in_ex[OF *] by auto
qed

end

lemma rank_of_mono:
  assumes "X \<subseteq> Y"
  assumes "Y \<subseteq> carrier"
  shows "rank_of X \<le> rank_of Y"
proof -
  obtain B\<^sub>X where B\<^sub>X: "basis_in X  B\<^sub>X" using assms basis_in_ex[of X] by auto
  moreover obtain B\<^sub>Y where B\<^sub>Y: "basis_in Y B\<^sub>Y" using assms basis_in_ex[of Y] by auto
  moreover have "card B\<^sub>X \<le> card B\<^sub>Y"
    using assms basis_in_indep_in_card[OF _ _ B\<^sub>Y] basis_in_indep_in[OF _ B\<^sub>X] indep_in_subI_subset
    by auto
  ultimately show ?thesis using assms rank_of_eq_card_basis_in by auto
qed

lemma rank_of_insert_le:
  assumes "X \<subseteq> carrier"
  assumes "x \<in> carrier"
  shows "rank_of (insert x X) \<le> Suc (rank_of X)"
proof -
  obtain B where B: "basis_in X B" using assms basis_in_ex[of X] by auto
  have "basis_in (insert x X) B \<or> basis_in (insert x X) (insert x B)"
  proof -
    obtain B' where B': "B' \<subseteq> insert x X - X" "basis_in (insert x X) (B \<union> B')"
      using assms B basis_in_subI[of "insert x X" X B] by auto
    then have "B' = {} \<or> B' = {x}" by auto
    then show ?thesis
    proof
      assume "B' = {}"
      then have "basis_in (insert x X) B" using B' by auto
      then show ?thesis by auto
    next
      assume "B' = {x}"
      then have "basis_in (insert x X) (insert x B)" using B' by auto
      then show ?thesis by auto
    qed
  qed
  then show ?thesis
  proof
    assume "basis_in (insert x X) B"
    then show ?thesis
      using assms B rank_of_eq_card_basis_in by auto
  next
    assume "basis_in (insert x X) (insert x B)"
    then have "rank_of (insert x X) = card (insert x B)"
      using assms rank_of_eq_card_basis_in by auto
    also have "\<dots> = Suc (card (B - {x}))"
      using assms card_insert[of B x] using B basis_in_finite by auto
    also have "\<dots> \<le> Suc (card B)"
      using assms B basis_in_finite card_Diff1_le[of B] by auto
    also have "\<dots> = Suc (rank_of X)"
      using assms B rank_of_eq_card_basis_in by auto
    finally show ?thesis .
  qed
qed

lemma rank_of_Un_Int_le:
  assumes "X \<subseteq> carrier"
  assumes "Y \<subseteq> carrier"
  shows "rank_of (X \<union> Y) + rank_of (X \<inter> Y) \<le> rank_of X + rank_of Y"
proof -
  obtain B_Int where B_Int: "basis_in (X \<inter> Y) B_Int" using assms basis_in_ex[of "X \<inter> Y"] by auto
  then have "indep_in (X \<union> Y) B_Int"
    using assms indep_in_subI_subset[OF _ basis_in_indep_in[of "X \<inter> Y" B_Int], of "X \<union> Y"] by auto
  then obtain B_Un where B_Un: "basis_in (X \<union> Y) B_Un" "B_Int \<subseteq> B_Un"
    using assms indep_in_imp_subset_basis_in[of "X \<union> Y" B_Int] by auto

  have "card (B_Un \<inter> (X \<union> Y)) + card (B_Un \<inter> (X \<inter> Y)) = card ((B_Un \<inter> X) \<union> (B_Un \<inter> Y)) + card ((B_Un \<inter> X) \<inter> (B_Un \<inter> Y))"
    by (simp add: inf_assoc inf_left_commute inf_sup_distrib1)
  also have "\<dots> = card (B_Un \<inter> X) + card (B_Un \<inter> Y)"
  proof -
    have "finite (B_Un \<inter> X)" "finite (B_Un \<inter> Y)"
      using assms finite_subset[OF _ carrier_finite] by auto
    then show ?thesis using card_Un_Int[of "B_Un \<inter> X" "B_Un \<inter> Y"] by auto
  qed
  also have "\<dots> \<le> rank_of X + rank_of Y"
  proof -
    have "card (B_Un \<inter> X) \<le> rank_of X"
    proof -
      have "indep_in X (B_Un \<inter> X)" using assms basis_in_indep_in[OF _ B_Un(1)] indep_in_subI by auto
      then show ?thesis using assms rank_of_indep_in_le by auto
    qed
    moreover have "card (B_Un \<inter> Y) \<le> rank_of Y"
    proof -
      have "indep_in Y (B_Un \<inter> Y)" using assms basis_in_indep_in[OF _ B_Un(1)] indep_in_subI by auto
      then show ?thesis using assms rank_of_indep_in_le by auto
    qed
    ultimately show ?thesis by auto
  qed
  finally have "rank_of X + rank_of Y \<ge> card (B_Un \<inter> (X \<union> Y)) + card (B_Un \<inter> (X \<inter> Y))" .
  moreover have "B_Un \<inter> (X \<union> Y) = B_Un" using assms basis_in_subset_carrier[OF _ B_Un(1)] by auto
  moreover have "B_Un \<inter> (X \<inter> Y) = B_Int"
  proof -
    have "card (B_Un \<inter> (X \<inter> Y)) \<le> card B_Int"
    proof -
      have "indep_in (X \<inter> Y) (B_Un \<inter> (X \<inter> Y))"
        using assms basis_in_indep_in[OF _ B_Un(1)] indep_in_subI by auto
      then show ?thesis using assms basis_in_indep_in_card[of "X \<inter> Y" _ B_Int] B_Int by auto
    qed
    moreover have "finite (B_Un \<inter> (X \<inter> Y))"
      using assms carrier_finite finite_subset[of "B_Un \<inter> (X \<inter> Y)"] by auto
    moreover have "B_Int \<subseteq> B_Un \<inter> (X \<inter> Y)"
      using assms B_Un B_Int basis_in_subset_carrier[of "X \<inter> Y" B_Int] by auto
    ultimately show ?thesis using card_seteq by blast
  qed
  ultimately have "rank_of X + rank_of Y \<ge> card B_Un + card B_Int" by auto
  moreover have "card B_Un = rank_of (X \<union> Y)"
    using assms rank_of_eq_card_basis_in[OF _ B_Un(1)] by auto
  moreover have "card B_Int = rank_of (X \<inter> Y)"
    using assms rank_of_eq_card_basis_in[OF _ B_Int] by fastforce
  ultimately show "rank_of X + rank_of Y \<ge> rank_of (X \<union> Y) + rank_of (X \<inter> Y)" by auto
qed

lemma rank_of_Un_absorbI:
  assumes "X \<subseteq> carrier" "Y \<subseteq> carrier"
  assumes "\<And>y. y \<in> Y - X \<Longrightarrow> rank_of (insert y X) = rank_of X"
  shows "rank_of (X \<union> Y) = rank_of X"
proof -
  have "finite (Y - X)" using finite_subset[OF \<open>Y \<subseteq> carrier\<close>] carrier_finite by auto
  then show ?thesis using assms
  proof (induction "Y - X" arbitrary: Y rule: finite_induct )
    case empty
    then have "X \<union> Y = X" by auto
    then show ?case by auto
  next
    case (insert y F)
    have "rank_of (X \<union> Y) + rank_of X \<le> rank_of X + rank_of X"
    proof -
      have "rank_of (X \<union> Y) + rank_of X = rank_of ((X \<union> (Y - {y})) \<union> (insert y X)) + rank_of ((X \<union> (Y - {y})) \<inter> (insert y X))"
      proof -
        have "X \<union> Y = (X \<union> (Y - {y})) \<union> (insert y X)" "X = (X \<union> (Y - {y})) \<inter> (insert y X)" using insert by auto
        then show ?thesis by auto
      qed
      also have "\<dots> \<le> rank_of (X \<union> (Y - {y})) +  rank_of (insert y X)"
      proof (rule rank_of_Un_Int_le)
        show "X \<union> (Y - {y}) \<subseteq> carrier" using insert by auto
      next
        show "insert y X \<subseteq> carrier" using insert by auto
      qed
      also have "\<dots> = rank_of (X \<union> (Y - {y})) + rank_of X"
      proof -
        have "y \<in> Y - X" using insert by auto
        then show ?thesis using insert by auto
      qed
      also have "\<dots> = rank_of X + rank_of X"
      proof -
        have "F = (Y - {y}) - X" "Y - {y} \<subseteq> carrier" using insert by auto
        then show ?thesis using insert insert(3)[of "Y - {y}"] by auto
      qed
      finally show ?thesis .
    qed
    moreover have "rank_of (X \<union> Y) + rank_of X \<ge> rank_of X + rank_of X"
      using insert rank_of_mono by auto
    ultimately show ?case by auto
  qed
qed

lemma indep_iff_rank_of:
  assumes "X \<subseteq> carrier"
  shows "indep X \<longleftrightarrow> rank_of X = card X"
proof (standard, goal_cases LTR RTL)
  case LTR
  then have "indep_in X X" by (auto intro: indep_inI)
  then have "basis_in X X" by (auto intro: basis_inI[OF assms])
  then show ?case using rank_of_eq_card_basis_in[OF assms] by auto
next
  case RTL
  obtain B where B: "basis_in X B" using basis_in_ex[OF assms] by auto
  then have "card B = card X" using RTL rank_of_eq_card_basis_in[OF assms] by auto
  then have "B = X"
    using basis_in_subset_carrier[OF assms B] card_seteq[OF finite_subset[OF assms carrier_finite]]
    by auto
  then show ?case using basis_in_indep_in[OF assms B] indep_in_indep by auto
qed

lemma basis_iff_rank_of:
  assumes "X \<subseteq> carrier"
  shows "basis X \<longleftrightarrow> rank_of X = card X \<and> rank_of X = rank_of carrier"
proof (standard, goal_cases LTR RTL)
  case LTR
  then have "rank_of X = card X" using assms indep_iff_rank_of basis_indep by auto
  moreover have "\<dots> = rank_of carrier"
    using LTR rank_of_eq_card_basis_in[of carrier X] basis_iff_basis_in by auto
  ultimately show ?case by auto
next
  case RTL
  show ?case
  proof (rule basisI)
    show "indep X" using assms RTL indep_iff_rank_of by blast
  next
    fix x
    assume x: "x \<in> carrier - X"
    show "\<not> indep (insert x X)"
    proof (rule ccontr, goal_cases False)
      case False
      then have "card (insert x X) \<le> rank_of carrier"
        using assms x indep_inI rank_of_indep_in_le by auto
      also have "\<dots> = card X" using RTL by auto
      finally show ?case using finite_subset[OF assms carrier_finite] x by auto
    qed
  qed
qed

lemma circuit_iff_rank_of:
  assumes "X \<subseteq> carrier"
  shows "circuit X \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>x \<in> X. rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = rank_of X)"
proof (standard, goal_cases LTR RTL)
  case LTR
  then have "X \<noteq> {}" using circuit_nonempty by auto
  moreover have indep_remove: "\<And>x. x \<in> X \<Longrightarrow> rank_of (X - {x}) = card (X - {x})"
  proof -
    fix x
    assume "x \<in> X"
    then have "indep (X - {x})" using circuit_min_dep[OF LTR] by auto
    moreover have "X - {x} \<subseteq> carrier" using assms by auto
    ultimately show "rank_of (X - {x}) = card (X - {x})" using indep_iff_rank_of by auto
  qed
  moreover have "\<And>x. x \<in> X \<Longrightarrow> rank_of (X - {x}) = rank_of X"
  proof -
    fix x
    assume *: "x \<in> X"
    have "rank_of X \<le> card X" using assms rank_of_le by auto
    moreover have "rank_of X \<noteq> card X" using assms LTR circuitD indep_iff_rank_of[of X] by auto
    ultimately have "rank_of X < card X" by auto
    then have "rank_of X \<le> card (X - {x})" using * finite_subset[OF assms] carrier_finite by auto
    also have "\<dots> = rank_of (X - {x})" using indep_remove \<open>x \<in> X\<close> by auto
    finally show "rank_of (X - {x}) = rank_of X" using assms rank_of_mono[of "X - {x}" X] by auto
  qed
  ultimately show ?case by auto
next
  case RTL
  then have "X \<noteq> {}"
    and indep_remove: "\<And>x. x \<in> X \<Longrightarrow> rank_of (X - {x}) = card (X - {x})"
    and dep: "\<And>x. x \<in> X \<Longrightarrow> rank_of (X - {x}) = rank_of X"
    by auto
  show ?case using assms
  proof (rule circuitI)
    obtain x where x: "x \<in> X" using \<open>X \<noteq> {}\<close> by auto
    then have "rank_of X = card (X - {x})" using dep indep_remove by auto
    also have "\<dots> < card X" using card_Diff1_less[OF finite_subset[OF assms carrier_finite] x] .
    finally show "\<not> indep X" using indep_iff_rank_of[OF assms] by auto
  next
    fix x
    assume "x \<in> X"
    then show "indep (X - {x})" using assms indep_remove[of x] indep_iff_rank_of[of "X - {x}"]
      by auto
  qed
qed

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using * by auto

lemma basis_in_iff_rank_of:
  assumes "X \<subseteq> \<E>"
  shows "basis_in \<E> X \<longleftrightarrow> rank_of X = card X \<and> rank_of X = rank_of \<E>"
  using \<E>.basis_iff_rank_of[OF assms] rank_of_sub_cong[OF *] assms
  unfolding basis_in_def by auto

lemma circuit_in_iff_rank_of:
  assumes "X \<subseteq> \<E>"
  shows "circuit_in \<E> X \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>x \<in> X. rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = rank_of X)"
proof -
  have "circuit_in \<E> X \<longleftrightarrow> \<E>.circuit X" unfolding circuit_in_def ..
  also have "\<dots> \<longleftrightarrow>  X \<noteq> {} \<and> (\<forall>x \<in> X. \<E>.rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = \<E>.rank_of X)"
    using \<E>.circuit_iff_rank_of[OF assms] .
  also have "\<dots> \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>x \<in> X. rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = rank_of X)"
  proof -
    {
      fix x
      have "\<E>.rank_of (X - {x}) = rank_of (X - {x})" "\<E>.rank_of X = rank_of X"
        using assms rank_of_sub_cong[OF *, of "X - {x}"] rank_of_sub_cong[OF *, of X] by auto
      then have "\<E>.rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = \<E>.rank_of X \<longleftrightarrow> rank_of (X - {x}) = card (X - {x}) \<and> card (X - {x}) = rank_of X"
        by auto
    }
    then show ?thesis by auto
  qed
  finally show ?thesis .
qed

end

subsection \<open>Closure\<close>

definition cl :: "'a set \<Rightarrow> 'a set" where
  "cl X \<equiv> {x \<in> carrier. rank_of (insert x X) = rank_of X}"

lemma clI:
  assumes "x \<in> carrier"
  assumes "rank_of (insert x X) = rank_of X"
  shows "x \<in> cl X"
  unfolding cl_def using assms by auto

lemma cl_altdef:
  assumes "X \<subseteq> carrier"
  shows "cl X = \<Union>{Y \<in> Pow carrier. X \<subseteq> Y \<and> rank_of Y = rank_of X}"
proof -
  {
    fix x
    assume *: "x \<in> cl X"
    have "x \<in> \<Union>{Y \<in> Pow carrier. X \<subseteq> Y \<and> rank_of Y = rank_of X}"
    proof
      show "insert x X \<in> {Y \<in> Pow carrier. X \<subseteq> Y \<and> rank_of Y = rank_of X}"
        using assms * unfolding cl_def by auto
    qed auto
  }
  moreover {
    fix x
    assume *: "x \<in> \<Union>{Y \<in> Pow carrier. X \<subseteq> Y \<and> rank_of Y = rank_of X}"
    then obtain Y where Y: "x \<in> Y" "Y \<subseteq> carrier" "X \<subseteq> Y" "rank_of Y = rank_of X" by auto
    have "rank_of (insert x X) = rank_of X"
    proof -
      have "rank_of (insert x X) \<le> rank_of X"
      proof -
        have "insert x X \<subseteq> Y" using Y by auto
        then show ?thesis using rank_of_mono[of "insert x X" Y] Y by auto
      qed
      moreover have "rank_of X \<le> rank_of (insert x X)" using Y by (auto intro: rank_of_mono)
      ultimately show ?thesis by auto
    qed
    then have "x \<in> cl X" using * unfolding cl_def by auto
  }
  ultimately show ?thesis by blast
qed

lemma cl_rank_of: "x \<in> cl X \<Longrightarrow> rank_of (insert x X) = rank_of X"
  unfolding cl_def by auto

lemma cl_subset_carrier: "cl X \<subseteq> carrier"
  unfolding cl_def by auto

lemmas clD = cl_rank_of cl_subset_carrier

lemma cl_subset:
  assumes "X \<subseteq> carrier"
  shows "X \<subseteq> cl X"
  using assms using insert_absorb[of _ X] by (auto intro!: clI)

lemma cl_mono:
  assumes "X \<subseteq> Y"
  assumes "Y \<subseteq> carrier"
  shows "cl X \<subseteq> cl Y"
proof
  fix x
  assume "x \<in> cl X"
  then have "x \<in> carrier" using cl_subset_carrier by auto

  have "insert x X \<subseteq> carrier"
    using assms \<open>x \<in> cl X\<close> cl_subset_carrier[of X] by auto
  then interpret X_insert: matroid "insert x X" "indep_in (insert x X)" by auto

  have "insert x Y \<subseteq> carrier"
    using assms \<open>x \<in> cl X\<close> cl_subset_carrier[of X] by auto
  then interpret Y_insert: matroid "insert x Y" "indep_in (insert x Y)" by auto

  show "x \<in> cl Y" using \<open>x \<in> carrier\<close>
  proof (rule clI, cases "x \<in> X")
    case True
    then show "rank_of (insert x Y) = rank_of Y" using assms insert_absorb[of x Y] by auto
  next
    case False
    obtain B\<^sub>X where B\<^sub>X: "basis_in X B\<^sub>X" using assms basis_in_ex[of X] by auto

    have "basis_in (insert x X) B\<^sub>X"
    proof -
      have "rank_of B\<^sub>X = card B\<^sub>X \<and> rank_of B\<^sub>X = rank_of (insert x X)"
      proof -
        have "rank_of B\<^sub>X = card B\<^sub>X \<and> rank_of B\<^sub>X = rank_of X"
          using assms B\<^sub>X
            basis_in_subset_carrier[where \<E> = X and X = B\<^sub>X]
            basis_in_iff_rank_of[where \<E> = X and X = B\<^sub>X]
          by blast
        then show ?thesis using cl_rank_of[OF \<open>x \<in> cl X\<close>] by auto
      qed
      then show ?thesis
        using assms basis_in_subset_carrier[OF _ B\<^sub>X] \<open>x \<in> carrier\<close> basis_in_iff_rank_of[of "insert x X" B\<^sub>X]
        by auto
    qed

    have "indep_in (insert x Y) B\<^sub>X"
      using assms basis_in_indep_in[OF _ B\<^sub>X] indep_in_subI_subset[of X "insert x Y"] by auto
    then obtain B\<^sub>Y where B\<^sub>Y: "basis_in (insert x Y) B\<^sub>Y" "B\<^sub>X \<subseteq> B\<^sub>Y"
      using assms \<open>x \<in> carrier\<close> indep_in_iff_subset_basis_in[of "insert x Y" B\<^sub>X] by auto

    have "basis_in Y B\<^sub>Y"
    proof -
      have "x \<notin> B\<^sub>Y"
      proof (rule ccontr, goal_cases False)
        case False
        then have "insert x B\<^sub>X \<subseteq> B\<^sub>Y" using \<open>B\<^sub>X \<subseteq> B\<^sub>Y\<close> by auto
        then have "indep_in (insert x Y) (insert x B\<^sub>X)"
          using assms \<open>x \<in> carrier\<close>
            B\<^sub>Y basis_in_indep_in[where \<E> = "insert x Y" and X = B\<^sub>Y]
            indep_in_subset[where \<E> = "insert x Y" and X = B\<^sub>Y and Y = "insert x B\<^sub>X"]
          by auto
        then have "indep_in (insert x X) (insert x B\<^sub>X)"
          using assms B\<^sub>X
            basis_in_subset_carrier[where \<E> = X and X = B\<^sub>X]
            indep_in_supI[where \<E> = "insert x Y" and \<E>' = "insert x X" and X = "insert x B\<^sub>X"]
          by auto
        moreover have "x \<in> insert x X - B\<^sub>X"
          using assms \<open>x \<notin> X\<close> B\<^sub>X basis_in_subset_carrier[where \<E> = X and X = B\<^sub>X] by auto
        ultimately show ?case
          using assms \<open>x \<in> carrier\<close> \<open>basis_in (insert x X) B\<^sub>X\<close>
            basis_in_max_indep_in[where \<E> = "insert x X" and X = B\<^sub>X and x = x]
          by auto
      qed
      then show ?thesis
      using assms \<open>x \<in> carrier\<close> B\<^sub>Y basis_in_subset_carrier[of "insert x Y" B\<^sub>Y]
        basis_in_supI[where \<E> = "insert x Y" and \<E>' = Y and B = B\<^sub>Y] by auto
    qed

    show "rank_of (insert x Y) = rank_of Y"
    proof -
      have "rank_of (insert x Y) = card B\<^sub>Y"
        using assms \<open>x \<in> carrier\<close> \<open>basis_in (insert x Y) B\<^sub>Y\<close> basis_in_subset_carrier
        using basis_in_iff_rank_of[where \<E> = "insert x Y" and X = B\<^sub>Y]
        by auto
      also have "\<dots> = rank_of Y"
        using assms \<open>x \<in> carrier\<close> \<open>basis_in Y B\<^sub>Y\<close> basis_in_subset_carrier
        using basis_in_iff_rank_of[where \<E> = Y and X = B\<^sub>Y]
        by auto
      finally show ?thesis .
    qed
  qed
qed

lemma cl_insert_absorb:
  assumes "X \<subseteq> carrier"
  assumes "x \<in> cl X"
  shows "cl (insert x X) = cl X"
proof
  show "cl (insert x X) \<subseteq> cl X"
  proof (standard, goal_cases elem)
    case (elem y)
    then have *: "x \<in> carrier" "y \<in> carrier" using assms cl_subset_carrier by auto

    have "rank_of (insert y X) = rank_of (insert y (insert x X))"
    proof -
      have "rank_of (insert y X) \<le> rank_of (insert y (insert x X))"
        using assms * by (auto intro: rank_of_mono)
      moreover have "rank_of (insert y (insert x X)) = rank_of (insert y X)"
      proof -
        have "insert y (insert x X) = insert x (insert y X)" by auto
        then have "rank_of (insert y (insert x X)) = rank_of (insert x (insert y X))" by auto
        also have "\<dots> = rank_of (insert y X)"
        proof -
          have "cl X \<subseteq> cl (insert y X)" by (rule cl_mono) (auto simp add: assms \<open>y \<in> carrier\<close>)
          then have "x \<in> cl (insert y X)" using assms by auto
          then show ?thesis unfolding cl_def by auto
        qed
        finally show ?thesis .
      qed
      ultimately show ?thesis by auto
    qed
    also have "\<dots> = rank_of (insert x X)" using elem using cl_rank_of by auto
    also have "\<dots> = rank_of X" using assms cl_rank_of by auto
    finally show "y \<in> cl X" using * by (auto intro: clI)
  qed
next
  have "insert x X \<subseteq> carrier" using assms cl_subset_carrier by auto
  moreover have "X \<subseteq> insert x X" using assms by auto
  ultimately show "cl X \<subseteq> cl (insert x X)" using assms cl_subset_carrier cl_mono by auto
qed

lemma cl_cl_absorb:
  assumes "X \<subseteq> carrier"
  shows "cl (cl X) = cl X"
proof
  show "cl (cl X) \<subseteq> cl X"
  proof (standard, goal_cases elem)
    case (elem x)
    then have "x \<in> carrier" using cl_subset_carrier by auto
    then show ?case
    proof (rule clI)
      have "rank_of (insert x X) \<ge> rank_of X"
        using assms \<open>x \<in> carrier\<close> rank_of_mono[of X "insert x X"] by auto
      moreover have "rank_of (insert x X) \<le> rank_of X"
      proof -
        have "rank_of (insert x X) \<le> rank_of (insert x (cl X))"
          using assms \<open>x \<in> carrier\<close> cl_subset_carrier cl_subset[of X]
                rank_of_mono[of "insert x X" "insert x (cl X)"] by auto
        also have "\<dots> = rank_of (cl X)" using elem cl_rank_of by auto
        also have "\<dots> = rank_of (X \<union> (cl X - X))"
          using Diff_partition[OF cl_subset[OF assms]] by auto
        also have "\<dots> = rank_of X" using \<open>X \<subseteq> carrier\<close>
        proof (rule rank_of_Un_absorbI)
          show "cl X - X \<subseteq> carrier" using assms cl_subset_carrier by auto
        next
          fix y
          assume "y \<in> cl X - X - X"
          then show "rank_of (insert y X) = rank_of X" unfolding cl_def by auto
        qed
        finally show ?thesis .
      qed
      ultimately show "rank_of (insert x X) = rank_of X" by auto
    qed
  qed
next
  show "cl X \<subseteq> cl (cl X)" using cl_subset[OF cl_subset_carrier] by auto
qed

lemma cl_augment:
  assumes "X \<subseteq> carrier"
  assumes "x \<in> carrier"
  assumes "y \<in> cl (insert x X) - cl X"
  shows "x \<in> cl (insert y X)"
  using \<open>x \<in> carrier\<close>
proof (rule clI)
  have "rank_of (insert y X) \<le> rank_of (insert x (insert y X))"
    using assms cl_subset_carrier by (auto intro: rank_of_mono)
  moreover have "rank_of (insert x (insert y X)) \<le> rank_of (insert y X)"
  proof -
    have "rank_of (insert x (insert y X)) = rank_of (insert y (insert x X))"
    proof -
      have "insert x (insert y X) = insert y (insert x X)" by auto
      then show ?thesis by auto
    qed
    also have "rank_of (insert y (insert x X)) = rank_of (insert x X)"
      using assms cl_def by auto
    also have "\<dots> \<le> Suc (rank_of X)"
      using assms cl_subset_carrier by (auto intro: rank_of_insert_le)
    also have "\<dots> = rank_of (insert y X)"
    proof -
      have "rank_of (insert y X) \<le> Suc (rank_of X)"
        using assms cl_subset_carrier by (auto intro: rank_of_insert_le)
      moreover have "rank_of (insert y X) \<noteq> rank_of X"
        using assms cl_def by auto
      moreover have "rank_of X \<le> rank_of (insert y X)"
        using assms cl_subset_carrier by (auto intro: rank_of_mono)
      ultimately show ?thesis by auto
    qed
    finally show ?thesis .
  qed
  ultimately show "rank_of (insert x (insert y X)) = rank_of (insert y X)" by auto
qed

lemma clI_insert:
  assumes "x \<in> carrier"
  assumes "indep X"
  assumes "\<not> indep (insert x X)"
  shows "x \<in> cl X"
  using \<open>x \<in> carrier\<close>
proof (rule clI)
  have *: "X \<subseteq> carrier" using assms indep_subset_carrier by auto
  then have **: "insert x X \<subseteq> carrier" using assms by auto

  have "indep_in (insert x X) X" using assms by (auto intro: indep_inI)
  then obtain B where B: "basis_in (insert x X) B" "X \<subseteq> B"
    using assms indep_in_iff_subset_basis_in[OF **] by auto
  have "x \<notin> B"
  proof (rule ccontr, goal_cases False)
    case False
    then have "indep_in (insert x X) (insert x X)"
      using B indep_in_subset[OF ** basis_in_indep_in[OF **]] by auto
    then show ?case using assms indep_in_indep by auto
  qed

  have "basis_in X B" using *
  proof (rule basis_inI, goal_cases indep max_indep)
    case indep
    show ?case
    proof (rule indep_in_supI[where \<E> = "insert x X"])
      show "B \<subseteq> X" using B basis_in_subset_carrier[OF **] \<open>x \<notin> B\<close> by auto
    next
      show "indep_in (insert x X) B" using basis_in_indep_in[OF ** B(1)] .
    qed auto
  next
    case (max_indep y)
    then have "\<not> indep_in (insert x X) (insert y B)"
      using B basis_in_max_indep_in[OF **] by auto
    then show ?case by (auto intro: indep_in_subI_subset)
  qed
  then show "rank_of (insert x X) = rank_of X"
    using B rank_of_eq_card_basis_in[OF *] rank_of_eq_card_basis_in[OF **] by auto
qed

lemma indep_in_carrier [simp]: "indep_in carrier = indep"
  using indep_subset_carrier by (auto simp: indep_in_def fun_eq_iff)

context
  fixes I
  defines "I \<equiv> (\<lambda>X. X \<subseteq> carrier \<and> (\<forall>x\<in>X. x \<notin> cl (X - {x})))"
begin

lemma I_mono: "I Y" if "Y \<subseteq> X" "I X" for X Y :: "'a set"
proof -
  have "\<forall>x\<in>Y. x \<notin> cl (Y - {x})"
  proof (intro ballI)
    fix x assume x: "x \<in> Y"
    with that have "cl (Y - {x}) \<subseteq> cl (X - {x})"
      by (intro cl_mono) (auto simp: I_def)
    with that and x show "x \<notin> cl (Y - {x})" by (auto simp: I_def)
  qed
  with that show ?thesis by (auto simp: I_def)
qed

lemma clI':
  assumes "I X" "x \<in> carrier" "\<not>I (insert x X)"
  shows   "x \<in> cl X"
proof -
  from assms have x: "x \<notin> X" by (auto simp: insert_absorb)
  from assms obtain y where y: "y \<in> insert x X" "y \<in> cl (insert x X - {y})"
    by (force simp: I_def)
  show "x \<in> cl X"
  proof (cases "x = y")
    case True
    thus ?thesis using assms x y by (auto simp: I_def)
  next
    case False
    have "y \<in> cl (insert x X - {y})" by fact
    also from False have "insert x X - {y} = insert x (X - {y})" by auto
    finally have "y \<in> cl (insert x (X - {y})) - cl (X - {y})"
      using assms False y unfolding I_def by blast
    hence "x \<in> cl (insert y (X - {y}))"
      using cl_augment[of "X - {y}" x y] assms False y by (auto simp: I_def)
    also from y and False have "insert y (X - {y}) = X" by auto
    finally show ?thesis .
  qed
qed

    have False
    proof (cases "X \<subseteq> cl (Y - {y})")
      case True
      from y XY have [simp]: "y \<in> carrier" by (auto simp: I_def)
      assume "X \<subseteq> cl (Y - {y})"
      hence "cl X \<subseteq> cl (cl (Y - {y}))"
        by (intro cl_mono cl_subset_carrier)
      also have "\<dots> = cl (Y - {y})"
        using XY by (intro cl_cl_absorb) (auto simp: I_def)
      finally have "cl X \<subseteq> cl (Y - {y})" .
      moreover have "y \<notin> cl (Y - {y})"
        using y I_def XY(1) by blast
      ultimately have "y \<notin> cl X" by blast
      thus False unfolding I_def
        using XY y clI' \<open>y \<in> carrier\<close> by blast
    next
      case False
      with y XY have [simp]: "y \<in> carrier" by (auto simp: I_def)
      assume "\<not>(X \<subseteq> cl (Y - {y}))"
      then obtain t where t: "t \<in> X" "t \<notin> cl (Y - {y})"
        by auto
      with XY have [simp]: "t \<in> carrier" by (auto simp: I_def)

      have "t \<in> X - Y"
        using t y clI[of t "Y - {y}"] by (cases "t = y") (auto simp: insert_absorb)
      moreover have "I  (Y - {y})" using XY(1) I_mono[of "Y - {y}" Y] by blast
      ultimately have *: "I (insert t (Y - {y}))"
        using clI'[of "Y - {y}" t] t by auto

      from XY have "finite Y"
        by (intro finite_subset[OF _ carrier_finite]) (auto simp: I_def)
      moreover from y have "Y \<noteq> {}" by auto
      ultimately have [simp]: "card (insert t (Y - {y})) = card Y" using \<open>t \<in> X - Y\<close> y
        by (simp add: Suc_diff_Suc card_gt_0_iff)

      have "\<exists>x\<in>Y - X. I (insert x X)"
      proof (rule ccontr)
        assume "\<not>?thesis"
        hence "?P X (insert t (Y - {y}))" using XY * \<open>t \<in> X - Y\<close>
          by auto
        hence "card (X \<inter> insert t (Y - {y})) \<le> n"
          unfolding n_def using finite by (intro Max_ge) auto
        also have "X \<inter> insert t (Y - {y}) = insert t ((X \<inter> Y) - {y})"
          using y \<open>t \<in> X - Y\<close> by blast
        also have "card \<dots> = Suc (card (X \<inter> Y))"
          using y \<open>t \<in> X - Y\<close> \<open>finite Y\<close> by (simp add: card_insert)
        finally show False using XY by simp
      qed
      with XY show False by blast
    qed
    thus False .
  qed
  with 5 show ?case by auto
qed (auto simp: I_def)

end

definition cl_in where "cl_in \<E> X = matroid.cl \<E> (indep_in \<E>) X"

lemma cl_eq_cl_in:
  assumes "X \<subseteq> carrier"
  shows "cl X = cl_in carrier X"
proof -
  interpret \<E>: matroid carrier "indep_in carrier"
    by (intro matroid_subset) auto
  have "cl X = {x \<in> carrier. rank_of (insert x X) = rank_of X}"
    unfolding cl_def by auto
  also have "\<dots> = {x \<in> carrier. \<E>.rank_of (insert x X) = \<E>.rank_of X}"
    using rank_of_sub_cong[of carrier] assms by auto
  also have "\<dots> = cl_in carrier X"
    unfolding cl_in_def \<E>.cl_def by auto
  finally show ?thesis .
qed

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using * by auto

lemma cl_inI_aux: "x \<in> \<E>.cl X \<Longrightarrow> x \<in> cl_in \<E> X"
  unfolding cl_in_def by auto

lemma cl_inD_aux: "x \<in> cl_in \<E> X \<Longrightarrow> x \<in> \<E>.cl X"
  unfolding cl_in_def by auto

lemma cl_inI:
  assumes "X \<subseteq> \<E>"
  assumes "x \<in> \<E>"
  assumes "rank_of (insert x X) = rank_of X"
  shows "x \<in> cl_in \<E> X"
proof -
  have "\<E>.rank_of (insert x X) = rank_of (insert x X)" "\<E>.rank_of X = rank_of X"
    using assms rank_of_sub_cong[OF *] by auto
  then show ?thesis unfolding cl_in_def using assms by (auto intro: \<E>.clI)
qed

lemma cl_in_altdef:
  assumes "X \<subseteq> \<E>"
  shows "cl_in \<E> X = \<Union>{Y \<in> Pow \<E>. X \<subseteq> Y \<and> rank_of Y = rank_of X}"
  unfolding cl_in_def
proof (safe, goal_cases LTR RTL)
  case (LTR x)
  then have "x \<in> \<Union>{Y \<in> Pow \<E>. X \<subseteq> Y \<and> \<E>.rank_of Y = \<E>.rank_of X}"
    using \<E>.cl_altdef[OF assms] by auto
  then obtain Y where Y: "x \<in> Y" "Y \<in> Pow \<E>" "X \<subseteq> Y" "\<E>.rank_of Y = \<E>.rank_of X" by auto
  then show ?case using rank_of_sub_cong[OF *] by auto
next
  case (RTL x Y)
  then have "x \<in> \<Union>{Y \<in> Pow \<E>. X \<subseteq> Y \<and> \<E>.rank_of Y = \<E>.rank_of X}"
     using rank_of_sub_cong[OF *, of X] rank_of_sub_cong[OF *, of Y] by auto
  then show ?case using \<E>.cl_altdef[OF assms] by auto
qed

lemma cl_in_subset_carrier: "cl_in \<E> X \<subseteq> \<E>"
  using \<E>.cl_subset_carrier unfolding cl_in_def .

lemma cl_in_rank_of:
  assumes "X \<subseteq> \<E>"
  assumes "x \<in> cl_in \<E> X"
  shows "rank_of (insert x X) = rank_of X"
proof -
  have "\<E>.rank_of (insert x X) = \<E>.rank_of X"
    using assms \<E>.cl_rank_of unfolding cl_in_def by auto
  moreover have "\<E>.rank_of (insert x X) = rank_of (insert x X)"
    using assms rank_of_sub_cong[OF *, of "insert x X"] cl_in_subset_carrier by auto
  moreover have "\<E>.rank_of X = rank_of X"
    using assms rank_of_sub_cong[OF *] by auto
  ultimately show ?thesis by auto
qed

lemmas cl_inD = cl_in_rank_of cl_in_subset_carrier

lemma cl_in_subset:
  assumes "X \<subseteq> \<E>"
  shows "X \<subseteq> cl_in \<E> X"
  using \<E>.cl_subset[OF assms] unfolding cl_in_def .

lemma cl_in_mono:
  assumes "X \<subseteq> Y"
  assumes "Y \<subseteq> \<E>"
  shows "cl_in \<E> X \<subseteq> cl_in \<E> Y"
  using \<E>.cl_mono[OF assms] unfolding cl_in_def .

lemma cl_in_insert_absorb:
  assumes "X \<subseteq> \<E>"
  assumes "x \<in> cl_in \<E> X"
  shows "cl_in \<E> (insert x X) = cl_in \<E> X"
  using assms \<E>.cl_insert_absorb unfolding cl_in_def by auto

lemma cl_in_augment:
  assumes "X \<subseteq> \<E>"
  assumes "x \<in> \<E>"
  assumes "y \<in> cl_in \<E> (insert x X) - cl_in \<E> X"
  shows "x \<in> cl_in \<E> (insert y X)"
  using assms \<E>.cl_augment unfolding cl_in_def by auto

lemmas cl_inI_insert = cl_inI_aux[OF \<E>.clI_insert]

end

lemma cl_in_subI:
  assumes "X \<subseteq> \<E>'" "\<E>' \<subseteq> \<E>" "\<E> \<subseteq> carrier"
  shows "cl_in \<E>' X \<subseteq> cl_in \<E> X"
proof (safe, goal_cases elem)
  case (elem x)
  then have "x \<in> \<E>'" "rank_of (insert x X) = rank_of X"
    using assms cl_inD[where \<E> = \<E>' and X = X] by auto
  then show "x \<in> cl_in \<E> X" using assms by (auto intro: cl_inI)
qed

context
  fixes \<E>
  assumes *: "\<E> \<subseteq> carrier"
begin

interpretation \<E>: matroid \<E> "indep_in \<E>"
  using * by auto

lemma cl_in_sub_cong:
  assumes "X \<subseteq> \<E>'" "\<E>' \<subseteq> \<E>"
  shows "\<E>.cl_in \<E>' X = cl_in \<E>' X"
proof (safe, goal_cases LTR RTL)
  case (LTR x)
  then have "x \<in> \<E>'" "\<E>.rank_of (insert x X) = \<E>.rank_of X"
    using assms
      \<E>.cl_in_rank_of[where \<E> = \<E>' and X = X and x = x]
      \<E>.cl_in_subset_carrier[where \<E> = \<E>']
    by auto
  moreover have "\<E>.rank_of X = rank_of X"
    using assms rank_of_sub_cong[OF *] by auto
  moreover have "\<E>.rank_of (insert x X) = rank_of (insert x X)"
    using assms rank_of_sub_cong[OF *, of "insert x X"] \<open>x \<in> \<E>'\<close> by auto
  ultimately show ?case using assms * by (auto intro: cl_inI)
next
  case (RTL x)
  then have "x \<in> \<E>'" "rank_of (insert x X) = rank_of X"
    using * assms cl_inD[where \<E> = \<E>' and X = X] by auto
  moreover have "\<E>.rank_of X = rank_of X"
    using assms rank_of_sub_cong[OF *] by auto
  moreover have "\<E>.rank_of (insert x X) = rank_of (insert x X)"
    using assms rank_of_sub_cong[OF *, of "insert x X"] \<open>x \<in> \<E>'\<close> by auto
  ultimately show ?case using assms by (auto intro: \<E>.cl_inI)
qed

end
end
end


section\<open>Modular and Distributive Lattices\<close>

(*
    Author: Viorel Preoteasa
*)

theory Modular_Distrib_Lattice
imports Lattice_Prop
begin

text \<open>
The main result of this theory is the fact that a lattice is distributive
if and only if it satisfies the following property:
\<close>

term "(\<forall> x y z . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y)"

text\<open>
This result was proved by Bergmann in \cite{bergmann:1929}. The formalization
presented here is based on \cite{birkhoff:1967,burris:sankappanavar:1981}.
\<close>

class modular_lattice = lattice +
  assumes modular: "x \<le> y \<Longrightarrow>  x \<squnion> (y \<sqinter> z) = y \<sqinter> (x \<squnion> z)"

context distrib_lattice begin
subclass modular_lattice
  apply unfold_locales
  by (simp add: inf_sup_distrib inf_absorb2)
end

context lattice begin
definition
  "d_aux a b c = (a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a)"

lemma d_b_c_a: "d_aux b c a = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

lemma d_c_a_b: "d_aux c a b = d_aux a b c"
  by (metis d_aux_def sup.assoc sup_commute)

definition
  "e_aux a b c = (a \<squnion> b) \<sqinter> (b \<squnion> c) \<sqinter> (c \<squnion> a)"

lemma e_b_c_a: "e_aux b c a = e_aux a b c"
  by (simp add: e_aux_def ac_simps)

lemma e_c_a_b: "e_aux c a b = e_aux a b c"
  by (simp add: e_aux_def ac_simps)

definition
  "a_aux a b c = (a \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "b_aux a b c = (b \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

definition
  "c_aux a b c = (c \<sqinter> (e_aux a b c)) \<squnion> (d_aux a b c)"

lemma b_a: "b_aux a b c = a_aux b c a"
  by (simp add: a_aux_def b_aux_def e_b_c_a d_b_c_a)

lemma c_a: "c_aux a b c = a_aux c a b"
  by (simp add: a_aux_def c_aux_def e_c_a_b d_c_a_b)

lemma [simp]: "b_aux a b c \<le> e_aux a b c"
  apply (unfold b_a)
  apply (subst e_b_c_a [THEN sym])
  by simp

lemma [simp]: "c_aux a b c \<le> e_aux a b c"
  apply (unfold c_a)
  apply (subst e_c_a_b [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> a_aux a b c"
  by (simp add: a_aux_def e_aux_def d_aux_def)

lemma [simp]: "d_aux a b c \<le> b_aux a b c"
  apply (unfold b_a)
  apply (subst d_b_c_a [THEN sym])
  by simp

lemma [simp]: "d_aux a b c \<le> c_aux a b c"
  apply (unfold c_a)
  apply (subst d_c_a_b [THEN sym])
  by simp

lemma a_meet_e: "a \<sqinter> (e_aux a b c) = a \<sqinter> (b \<squnion> c)"
  by (rule order.antisym) (simp_all add: e_aux_def le_infI2)

lemma b_meet_e: "b \<sqinter> (e_aux a b c) = b \<sqinter> (c \<squnion> a)"
  by (simp add: a_meet_e [THEN sym] e_b_c_a)

lemma c_meet_e: "c \<sqinter> (e_aux a b c) = c \<sqinter> (a \<squnion> b)"
  by (simp add: a_meet_e [THEN sym] e_c_a_b)

lemma a_join_d: "a \<squnion> d_aux a b c = a \<squnion> (b \<sqinter> c)"
  by (rule order.antisym) (simp_all add: d_aux_def le_supI2)

lemma b_join_d: "b \<squnion> d_aux a b c = b \<squnion> (c \<sqinter> a)"
  by (simp add: a_join_d [THEN sym] d_b_c_a)

end

context lattice begin
definition
  "no_distrib a b c = (a \<sqinter> b \<squnion> c \<sqinter> a < a \<sqinter> (b \<squnion> c))"

definition
  "incomp x y = (\<not> x \<le> y \<and> \<not> y \<le> x)"

definition
  "N5_lattice a b c = (a \<sqinter> c = b \<sqinter> c \<and> a < b \<and> a \<squnion> c = b \<squnion> c)"

definition
  "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"

lemma M5_lattice_incomp: "M5_lattice a b c \<Longrightarrow> incomp a b"
  apply (simp add: M5_lattice_def incomp_def)
  apply safe
  apply (simp_all add: inf_absorb1 inf_absorb2 )
  apply (simp_all add: sup_absorb1 sup_absorb2 )
  apply (subgoal_tac "c \<sqinter> (b \<squnion> c) = c")
  apply simp
  apply (subst sup_commute)
  by simp
end

context modular_lattice begin

lemma a_meet_d: "a \<sqinter> (d_aux a b c) = (a \<sqinter> b) \<squnion> (c \<sqinter> a)"
  proof -
    have "a \<sqinter> (d_aux a b c) = a \<sqinter> ((a \<sqinter> b) \<squnion> (b \<sqinter> c) \<squnion> (c \<sqinter> a))" by (simp add: d_aux_def)
    also have "... = a \<sqinter> (a \<sqinter> b \<squnion> c \<sqinter> a \<squnion> b \<sqinter> c)" by (simp add: sup_assoc, simp add: sup_commute)
    also have "... = (a \<sqinter> b \<squnion> c \<sqinter> a) \<squnion> (a \<sqinter> (b \<sqinter> c))" by (simp add: modular)
    also have "... = (a \<sqinter> b) \<squnion> (c \<sqinter> a)" by (rule order.antisym, simp_all, rule_tac y = "a \<sqinter> b" in order_trans, simp_all)
    finally show ?thesis by simp
  qed

lemma b_meet_d: "b \<sqinter> (d_aux a b c) = (b \<sqinter> c) \<squnion> (a \<sqinter> b)"
  by (simp add: a_meet_d [THEN sym] d_b_c_a)

lemma c_meet_d: "c \<sqinter> (d_aux a b c) = (c \<sqinter> a) \<squnion> (b \<sqinter> c)"
  by (simp add: a_meet_d [THEN sym] d_c_a_b)

lemma d_less_e: "no_distrib a b c \<Longrightarrow> d_aux a b c < e_aux a b c"
  apply (subst less_le)
  apply(case_tac "d_aux a b c = e_aux a b c")
  apply simp_all
  apply (simp add: no_distrib_def a_meet_e [THEN sym] a_meet_d [THEN sym])
  apply (rule_tac y = "a_aux a b c" in order_trans)
  by simp_all

lemma a_meet_b_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<sqinter> b_aux a b c = d_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "(a \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (b \<sqinter> e_aux a b c \<squnion> d_aux a b c) = (b \<sqinter> e_aux a b c \<squnion>  d_aux a b c) \<sqinter> (d_aux a b c \<squnion> a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((b \<sqinter> e_aux a b c \<squnion> d_aux a b c) \<sqinter> (a \<sqinter> e_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (d_aux a b c \<squnion> e_aux a b c \<sqinter> b) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<sqinter> (a \<sqinter> e_aux a b c)"
      by (cut_tac d_less_e, simp add: modular [THEN sym] less_le)
    also have "\<dots> =  d_aux a b c \<squnion> ((a \<sqinter> e_aux a b c) \<sqinter> (e_aux a b c \<sqinter> (b \<squnion> d_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> d_aux a b c))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> e_aux a b c \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: b_join_d)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: a_meet_e)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((b \<squnion> c) \<sqinter> (b \<squnion> (c \<sqinter> a))))" by (simp add: inf_assoc)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> ((b \<squnion> c) \<sqinter> (c \<sqinter> a))))" by (simp add: modular)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> (b \<squnion> (c \<sqinter> a)))" by (simp add: inf_absorb2)
    also have "\<dots> = d_aux a b c \<squnion> (a \<sqinter> ((c \<sqinter> a) \<squnion> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = d_aux a b c \<squnion> ((c \<sqinter> a) \<squnion> (a \<sqinter> b))" by (simp add: modular)
    also have "\<dots> = d_aux a b c"
      by (rule order.antisym, simp_all add: d_aux_def)
    finally show ?thesis by (simp add: a_aux_def b_aux_def)
  qed

lemma b_meet_c_eq_d: " d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c \<sqinter> c_aux a b c = d_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_meet_a_eq_d: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c \<sqinter> a_aux a b c = d_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_meet_b_eq_d)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma a_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c = (a \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (simp add: a_aux_def)
  apply (subst inf_commute)
  apply (subst sup_commute)
  apply (simp add: modular)
  by (simp add: inf_commute sup_commute)

lemma b_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> b_aux a b c = (b \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = b and b = c and c = a in a_def_equiv)
  by (simp_all add: d_b_c_a e_b_c_a b_a)

lemma c_def_equiv: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> c_aux a b c = (c \<squnion> d_aux a b c) \<sqinter> e_aux a b c"
  apply (cut_tac a = c and b = a and c = b in a_def_equiv)
  by (simp_all add: d_c_a_b e_c_a_b c_a)

lemma a_join_b_eq_e: "d_aux a b c \<le> e_aux a b c \<Longrightarrow> a_aux a b c \<squnion> b_aux a b c = e_aux a b c"
  proof -
    assume d_less_e: " d_aux a b c \<le> e_aux a b c"
    have "((a \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) = ((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (e_aux a b c \<sqinter> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (((b \<squnion> d_aux a b c) \<sqinter> e_aux a b c) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((e_aux a b c \<sqinter> (d_aux a b c \<squnion> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((d_aux a b c \<squnion> (e_aux a b c \<sqinter> b)) \<squnion> (a \<squnion> d_aux a b c))"
      by (cut_tac d_less_e, simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> ((a \<squnion> d_aux a b c) \<squnion> (d_aux a b c \<squnion> (b \<sqinter> e_aux a b c)))"
      by (simp add: inf_commute sup_commute)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> e_aux a b c))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> d_aux a b c \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: b_meet_e)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: a_join_d)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((b \<sqinter> c) \<squnion> (b \<sqinter> (c \<squnion> a))))" by (simp add: sup_assoc)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> ((b \<sqinter> c) \<squnion> (c \<squnion> a))))" by (simp add: modular)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> (b \<sqinter> (c \<squnion> a)))" by (simp add: sup_absorb2)
    also have "\<dots> = e_aux a b c \<sqinter> (a \<squnion> ((c \<squnion> a) \<sqinter> b))" by (simp add: sup_commute inf_commute)
    also have "\<dots> = e_aux a b c \<sqinter> ((c \<squnion> a) \<sqinter> (a \<squnion> b))" by (simp add: modular)
    also have "\<dots> = e_aux a b c"
      by (rule order.antisym, simp_all, simp_all add: e_aux_def)
    finally show ?thesis by (cut_tac d_less_e, simp add: a_def_equiv b_def_equiv)
  qed

lemma b_join_c_eq_e: " d_aux a b c <= e_aux a b c \<Longrightarrow> b_aux a b c \<squnion> c_aux a b c = e_aux a b c"
  apply (subst b_a)
  apply (subgoal_tac "c_aux a b c = b_aux b c a")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: c_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma c_join_a_eq_e: "d_aux a b c <= e_aux a b c \<Longrightarrow> c_aux a b c \<squnion> a_aux a b c = e_aux a b c"
  apply (subst c_a)
  apply (subgoal_tac "a_aux a b c = b_aux c a b")
  apply simp
  apply (subst a_join_b_eq_e)
  by (simp_all add: a_aux_def b_aux_def d_b_c_a e_b_c_a)

lemma "no_distrib a b c \<Longrightarrow> incomp a b"
  apply (simp add: no_distrib_def incomp_def ac_simps)
  using order.strict_iff_not inf.absorb_iff2 inf.commute modular
  apply fastforce
  done

lemma M5_modular: "no_distrib a b c \<Longrightarrow> M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
  apply (frule d_less_e)
  by (simp add: M5_lattice_def a_meet_b_eq_d b_meet_c_eq_d c_meet_a_eq_d a_join_b_eq_e b_join_c_eq_e c_join_a_eq_e)

lemma M5_modular_def: "M5_lattice a b c = (a \<sqinter> b = b \<sqinter> c \<and> c \<sqinter> a = b \<sqinter> c \<and> a \<squnion> b = b \<squnion> c \<and> c \<squnion> a = b \<squnion> c \<and> a \<sqinter> b < a \<squnion> b)"
  by (simp add: M5_lattice_def)

end

context lattice begin

lemma not_modular_N5: "(\<not> class.modular_lattice inf ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) sup) =
   (\<exists> a b c::'a . N5_lattice a b c)"
  apply (subgoal_tac "class.lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) sup")
  apply (unfold N5_lattice_def class.modular_lattice_def class.modular_lattice_axioms_def)
  apply simp_all
  apply safe
  apply (subgoal_tac "x \<squnion> y \<sqinter> z < y \<sqinter> (x \<squnion> z)")
  apply (rule_tac x = "x \<squnion> y \<sqinter> z" in exI)
  apply (rule_tac x = "y \<sqinter> (x \<squnion> z)" in exI)
  apply (rule_tac x = z in exI)
  apply safe
  apply (rule order.antisym)
  apply simp
  apply (rule_tac y = "x \<squnion> y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> z" in order_trans)
  apply simp_all
  apply (rule order.antisym)
  apply simp_all
  apply (rule_tac y = "y \<sqinter> (x \<squnion> z)" in order_trans)
  apply simp_all
  apply (rule_tac y = "x \<squnion> z" in order_trans)
  apply simp_all
  apply (rule neq_le_trans)
  apply simp
  apply simp
  apply (rule_tac x = a in exI)
  apply (rule_tac x = b in exI)
  apply safe
  apply (simp add: less_le)
  apply (rule_tac x = c in exI)
  apply simp
  apply (simp add: less_le)
  apply safe
  apply (subgoal_tac "a \<squnion> a \<sqinter> c = b")
  apply (unfold sup_inf_absorb) [1]
  apply simp
  apply simp
  proof qed

lemma not_distrib_N5_M5: "(\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
   ((\<exists> a b c::'a . N5_lattice a b c) \<or> (\<exists> a b c::'a . M5_lattice a b c))"
  apply (unfold not_modular_N5 [THEN sym])
  proof
    assume A: "\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
    have B: "\<exists> a b c:: 'a . (a \<sqinter> b) \<squnion> (a \<sqinter> c) < a \<sqinter> (b \<squnion> c)"
      apply (cut_tac A)
      apply (unfold  class.distrib_lattice_def)
      apply safe
      apply simp_all
      proof
        fix x y z::'a
        assume A: "\<forall>(a::'a) (b::'a) c::'a. \<not> a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
          apply (cut_tac A)
          apply (rule distrib_imp1)
          by (simp add: less_le)
      qed
    from B show "\<not> class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>) \<or> (\<exists>a b c::'a. M5_lattice a b c)"
      proof (unfold disj_not1, safe)
        fix a b c::'a
        assume A: "a \<sqinter> b \<squnion> a \<sqinter> c < a \<sqinter> (b \<squnion> c)"
        assume B: "class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
        interpret modular: modular_lattice "(\<sqinter>)" "((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool)" "(<)" "(\<squnion>)"
          by (fact B)

        have H: "M5_lattice (a_aux a b c) (b_aux a b c) (c_aux a b c)"
          apply (cut_tac a = a and b = b and c = c in  modular.M5_modular)
          apply (unfold no_distrib_def)
          by (simp_all add: A inf_commute)
        from H show "\<exists>a b c::'a. M5_lattice a b c" by blast
     qed
   next
     assume A: "\<not> class.modular_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>) \<or> (\<exists>(a::'a) (b::'a) c::'a. M5_lattice a b c)"
     show "\<not> class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
       apply (cut_tac A)
       apply safe
       apply (erule notE)
       apply unfold_locales
       apply (unfold class.distrib_lattice_def)
       apply (unfold class.distrib_lattice_axioms_def)
       apply safe
       apply (simp add: sup_absorb2)
       apply (frule M5_lattice_incomp)
       apply (unfold M5_lattice_def)
       apply (drule_tac x = a in spec)
       apply (drule_tac x = b in spec)
       apply (drule_tac x = c in spec)
       apply safe
       proof -
         fix a b c:: 'a
         assume A:"a \<squnion> b \<sqinter> c = (a \<squnion> b) \<sqinter> (a \<squnion> c)"
         assume B: "a \<sqinter> b = b \<sqinter> c"
         assume D: "a \<squnion> b = b \<squnion> c"
         assume E: "c \<squnion> a = b \<squnion> c"
         assume G: "incomp a b"
         have H: "a \<squnion> b \<sqinter> c = a" by (simp add: B [THEN sym] sup_absorb1)
         have I: "(a \<squnion> b) \<sqinter> (a \<squnion> c) = a \<squnion> b" by (cut_tac E, simp add: sup_commute D)
         have J: "a = a \<squnion> b" by (cut_tac A, simp add: H I)
         show False
           apply (cut_tac G J)
           apply (subgoal_tac "b \<le> a")
           apply (simp add: incomp_def)
           apply (rule_tac y = "a \<squnion> b" in order_trans)
           apply (rule sup_ge2)
           by simp
       qed
     qed

lemma distrib_not_N5_M5: "(class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
   ((\<forall> a b c::'a . \<not> N5_lattice a b c) \<and> (\<forall> a b c::'a . \<not> M5_lattice a b c))"
  apply (cut_tac not_distrib_N5_M5)
  by auto

lemma distrib_inf_sup_eq:
  "(class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)) =
    (\<forall> x y z::'a . x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
  apply safe
  proof -
    fix x y z:: 'a
    assume A: "class.distrib_lattice (\<sqinter>) ((\<le>) ::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
    interpret distrib: distrib_lattice "(\<sqinter>)" "(\<le>) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" "(<)" "(\<squnion>)"
      by (fact A)
    assume B: "x \<sqinter> z = y \<sqinter> z"
    assume C: "x \<squnion> z = y \<squnion> z"
    have "x = x \<sqinter> (x \<squnion> z)" by simp
    also have "\<dots> = x \<sqinter> (y \<squnion> z)" by (simp add: C)
    also have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = (y \<sqinter> x) \<squnion> (y \<sqinter> z)" by (simp add: B inf_commute)
    also have "\<dots> = y \<sqinter> (x \<squnion> z)" by (simp add: distrib.inf_sup_distrib)
    also have "\<dots> = y" by (simp add: C)
    finally show "x = y" .
  next
    assume A: "(\<forall>x y z:: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<longrightarrow> x = y)"
    have B: "!! x y z :: 'a. x \<sqinter> z = y \<sqinter> z \<and> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
      by (cut_tac A, blast)
    show "class.distrib_lattice (\<sqinter>) ((\<le>)::'a \<Rightarrow> 'a \<Rightarrow> bool) (<) (\<squnion>)"
      apply (unfold distrib_not_N5_M5)
      apply safe
      apply (unfold N5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      apply (simp_all)
      apply (unfold M5_lattice_def)
      apply (cut_tac x = a and y = b and z = c in B)
      by (simp_all add: inf_commute sup_commute)
 qed
end

class inf_sup_eq_lattice = lattice +
  assumes inf_sup_eq: "x \<sqinter> z = y \<sqinter> z \<Longrightarrow> x \<squnion> z = y \<squnion> z \<Longrightarrow> x = y"
begin
subclass distrib_lattice
  by (metis distrib_inf_sup_eq inf_sup_eq)
end

end


theory Eplus_assoc
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

theorem eplus_assoc: "eplus a (eplus b c) = eplus (eplus a b) c"
  by hipster_coinduct_sledgehammer

end