(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Real Roots\<close>

text \<open>This theory contains an algorithm to determine the set of real roots of a
  rational polynomial. It further contains an algorithm which tries to determine the
  real roots of real-valued polynomial, which incorporates Yun-factorization and
  closed formulas for polynomials of degree 2.\<close>

theory Real_Roots
imports
  Real_Algebraic_Numbers
begin

hide_const (open) UnivPoly.coeff
hide_const (open) Module.smult

text \<open>Division of integers, rounding to the upper value.\<close>
definition div_ceiling :: "int \<Rightarrow> int \<Rightarrow> int" where
  "div_ceiling x y = (let q = x div y in if q * y = x then q else q + 1)"

definition root_bound :: "int poly \<Rightarrow> rat" where
  "root_bound p \<equiv> let
     n = degree p;
     m = 1 + div_ceiling (max_list_non_empty (map (\<lambda>i. abs (coeff p i)) [0..<n]))
          (abs (lead_coeff p))
     \<comment> \<open>round to the next higher number \<open>2^n\<close>, so that bisection will\<close>
     \<comment> \<open>stay on integers for as long as possible\<close>
   in of_int (2 ^ (log_ceiling 2 m))"

partial_function (tailrec) roots_of_2_main ::
  "int poly \<Rightarrow> root_info \<Rightarrow> (rat \<Rightarrow> rat \<Rightarrow> nat) \<Rightarrow> (rat \<times> rat)list \<Rightarrow> real_alg_2 list \<Rightarrow> real_alg_2 list" where
  [code]: "roots_of_2_main p ri cr lrs rais = (case lrs of Nil \<Rightarrow> rais
  | (l,r) # lrs \<Rightarrow> let c = cr l r in
    if c = 0 then roots_of_2_main p ri cr lrs rais
    else if c = 1 then roots_of_2_main p ri cr lrs (real_alg_2'' ri p l r # rais)
    else let m = (l + r) / 2 in roots_of_2_main p ri cr ((m,r) # (l,m) # lrs) rais)"

definition roots_of_2_irr :: "int poly \<Rightarrow> real_alg_2 list" where
  "roots_of_2_irr p = (if degree p = 1
    then [Rational (Rat.Fract (- coeff p 0) (coeff p 1)) ] else
    let ri = root_info p;
        cr = root_info.l_r ri;
        B = root_bound p
      in (roots_of_2_main p ri cr [(-B,B)] []))"

lemma root_imp_deg_nonzero: assumes "p \<noteq> 0" "poly p x = 0"
  shows "degree p \<noteq> 0"
proof
  assume "degree p = 0"
  from degree0_coeffs[OF this] assms show False by auto
qed

lemma cauchy_root_bound: fixes x :: "'a :: real_normed_field"
  assumes x: "poly p x = 0" and p: "p \<noteq> 0"
  shows "norm x \<le> 1 + max_list_non_empty (map (\<lambda> i. norm (coeff p i)) [0 ..< degree p])
    / norm (lead_coeff p)" (is "_ \<le> _ + ?max / ?nlc")
proof -
  let ?n = "degree p"
  let ?p = "coeff p"
  let ?lc = "lead_coeff p"
  define ml where "ml = ?max / ?nlc"
  from p have lc: "?lc \<noteq> 0" by auto
  hence nlc: "norm ?lc > 0" by auto
  from root_imp_deg_nonzero[OF p x] have *: "0 \<in> set [0 ..< degree p]" by auto
  have "0 \<le> norm (?p 0)" by simp
  also have "\<dots> \<le> ?max"
    by (rule max_list_non_empty, insert *, auto)
  finally have max0: "?max \<ge> 0" .
  with nlc have ml0: "ml \<ge> 0" unfolding ml_def by auto
  hence easy: "norm x \<le> 1 \<Longrightarrow> ?thesis" unfolding ml_def[symmetric] by auto
  show ?thesis
  proof (cases "norm x \<le> 1")
    case True
    thus ?thesis using easy by auto
  next
    case False
    hence nx: "norm x > 1" by simp
    hence x0: "x \<noteq> 0" by auto
    hence xn0: "0 < norm x ^ ?n" by auto
    from x[unfolded poly_altdef] have "x ^ ?n * ?lc = x ^ ?n * ?lc - (\<Sum>i\<le>?n. x ^ i * ?p i)"
      unfolding poly_altdef by (simp add: ac_simps)
    also have "(\<Sum>i\<le>?n. x ^ i * ?p i) = x ^ ?n * ?lc + (\<Sum>i < ?n. x ^ i * ?p i)"
      by (subst sum.remove[of _ ?n], auto intro: sum.cong)
    finally have "x ^ ?n * ?lc = - (\<Sum>i < ?n. x ^ i * ?p i)" by simp
    with lc have "x ^ ?n = - (\<Sum>i < ?n. x ^ i * ?p i) / ?lc" by (simp add: field_simps)
    from arg_cong[OF this, of norm]
    have "norm x ^ ?n = norm ((\<Sum>i < ?n. x ^ i * ?p i) / ?lc)" unfolding norm_power by simp
    also have "(\<Sum>i < ?n. x ^ i * ?p i) / ?lc = (\<Sum>i < ?n. x ^ i * ?p i / ?lc)"
      by (rule sum_divide_distrib)
    also have "norm \<dots> \<le> (\<Sum>i < ?n. norm (x ^ i * (?p i / ?lc)))"
      by (simp add: field_simps, rule norm_sum)
    also have "\<dots> = (\<Sum>i < ?n. norm x ^ i * norm (?p i / ?lc))"
      unfolding norm_mult norm_power ..
    also have "\<dots> \<le> (\<Sum>i < ?n. norm x ^ i * ml)"
    proof (rule sum_mono)
      fix i
      assume "i \<in> {..<?n}"
      hence i: "i < ?n" by simp
      show "norm x ^ i * norm (?p i / ?lc) \<le> norm x ^ i * ml"
      proof (rule mult_left_mono)
        show "0 \<le> norm x ^ i" using nx by auto
        show "norm (?p i / ?lc) \<le> ml" unfolding norm_divide ml_def
          by (rule divide_right_mono[OF max_list_non_empty], insert nlc i, auto)
      qed
    qed
    also have "\<dots> = ml * (\<Sum>i < ?n. norm x ^ i)"
      unfolding sum_distrib_right[symmetric] by simp
    also have "(\<Sum>i < ?n. norm x ^ i) = (norm x ^ ?n - 1) / (norm x - 1)"
      by (rule geometric_sum, insert nx, auto)
    finally have "norm x ^ ?n \<le> ml * (norm x ^ ?n - 1) / (norm x - 1)" by simp
    from mult_left_mono[OF this, of "norm x - 1"]
    have "(norm x - 1) * (norm x ^ ?n) \<le> ml * (norm x ^ ?n - 1)" using nx by auto
    also have "\<dots> = (ml * (1 - 1 / (norm x ^ ?n))) * norm x ^ ?n"
      using nx False x0 by (simp add: field_simps)
    finally have "(norm x - 1) * (norm x ^ ?n) \<le> (ml * (1 - 1 / (norm x ^ ?n))) * norm x ^ ?n" .
    from mult_right_le_imp_le[OF this xn0]
    have "norm x - 1 \<le> ml * (1 - 1 / (norm x ^ ?n))" by simp
    hence "norm x \<le> 1 + ml - ml / (norm x ^ ?n)" by (simp add: field_simps)
    also have "\<dots> \<le> 1 + ml" using ml0 xn0 by auto
    finally show ?thesis unfolding ml_def .
  qed
qed

lemma div_le_div_ceiling: "x div y \<le> div_ceiling x y"
  unfolding div_ceiling_def Let_def by auto

lemma div_ceiling: assumes q: "q \<noteq> 0"
  shows "(of_int x :: 'a :: floor_ceiling) / of_int q \<le> of_int (div_ceiling x q)"
proof (cases "q dvd x")
  case True
  then obtain k where xqk: "x = q * k" unfolding dvd_def by auto
  hence id: "div_ceiling x q = k" unfolding div_ceiling_def Let_def using q by auto
  show ?thesis unfolding id unfolding xqk using q by simp
next
  case False
  {
    assume "x div q * q = x"
    hence "x = q * (x div q)" by (simp add: ac_simps)
    hence "q dvd x" unfolding dvd_def by auto
    with False have False by simp
  }
  hence id: "div_ceiling x q = x div q + 1"
    unfolding div_ceiling_def Let_def using q by auto
  show ?thesis unfolding id
    by (metis floor_divide_of_int_eq le_less add1_zle_eq floor_less_iff)
qed

lemma max_list_non_empty_map: assumes hom: "\<And> x y. max (f x) (f y) = f (max x y)"
  shows "xs \<noteq> [] \<Longrightarrow> max_list_non_empty (map f xs) = f (max_list_non_empty xs)"
  by (induct xs rule: max_list_non_empty.induct, auto simp: hom)

lemma root_bound: assumes "root_bound p = B" and deg: "degree p > 0"
  shows "ipoly p (x :: real) = 0 \<Longrightarrow> norm x \<le> of_rat B" "B \<ge> 0"
proof -
  let ?r = real_of_rat
  let ?i = real_of_int
  let ?p = "real_of_int_poly p"
  define n where "n = degree p"
  let ?lc = "coeff p n"
  let ?list = "map (\<lambda>i. abs (coeff p i)) [0..<n]"
  let ?list' = "(map (\<lambda>i. ?i (abs ((coeff p i)))) [0..<n])"
  define m where "m = max_list_non_empty ?list"
  define m_up where "m_up = 1 + div_ceiling m (abs ?lc)"
  define C where "C = rat_of_int (2^(log_ceiling 2 m_up))"
  from deg have p0: "p \<noteq> 0" by auto
  from p0 have alc0: "abs ?lc \<noteq> 0" unfolding n_def by auto
  from deg have mem: "abs (coeff p 0) \<in> set ?list" unfolding n_def by auto
  from max_list_non_empty[OF this, folded m_def]
  have m0: "m \<ge> 0" by auto
  have "div_ceiling m (abs ?lc) \<ge> 0"
    by (rule order_trans[OF _ div_le_div_ceiling[of m "abs ?lc"]], subst
    pos_imp_zdiv_nonneg_iff, insert p0 m0, auto simp: n_def)
  hence mup: "m_up \<ge> 1" unfolding m_up_def by auto
  have "m_up \<le> 2 ^ (log_ceiling 2 m_up)" using  mup log_ceiling_sound(1) by auto
  hence Cmup: "C \<ge> of_int m_up" unfolding C_def by linarith
  with mup have C: "C \<ge> 1" by auto
  from assms(1)[unfolded root_bound_def Let_def]
  have B: "C = of_rat B" unfolding C_def m_up_def n_def m_def by auto
  note dc = div_le_div_ceiling[of m "abs ?lc"]
  with C show "B \<ge> 0" unfolding B by auto
  assume "ipoly p x = 0"
  hence rt: "poly ?p x = 0" by simp
  from root_imp_deg_nonzero[OF _ this] p0 have n0: "n \<noteq> 0" unfolding n_def by auto
  from cauchy_root_bound[OF rt] p0
  have "norm x \<le> 1 + max_list_non_empty ?list' / ?i (abs ?lc)"
    by (simp add: n_def)
  also have "?list' = map ?i ?list" by simp
  also have "max_list_non_empty \<dots> = ?i m" unfolding m_def
    by (rule max_list_non_empty_map, insert mem, auto)
  also have "1 + m / ?i (abs ?lc) \<le> ?i m_up"
    unfolding m_up_def using div_ceiling[OF alc0, of m] by auto
  also have "\<dots> \<le> ?r C" using Cmup using of_rat_less_eq by force
  finally have "norm x \<le> ?r C" .
  thus "norm x \<le> ?r B" unfolding B by simp
qed

fun pairwise_disjoint :: "'a set list \<Rightarrow> bool" where
  "pairwise_disjoint [] = True"
| "pairwise_disjoint (x # xs) = ((x \<inter> (\<Union> y \<in> set xs. y) = {}) \<and> pairwise_disjoint xs)"

lemma roots_of_2_irr: assumes pc: "poly_cond p" and deg: "degree p > 0"
  shows "real_of_2 ` set (roots_of_2_irr p) = {x. ipoly p x = 0}" (is ?one)
    "Ball (set (roots_of_2_irr p)) invariant_2" (is ?two)
    "distinct (map real_of_2 (roots_of_2_irr p))" (is ?three)
proof -
  note d = roots_of_2_irr_def
  from poly_condD[OF pc] have mon: "lead_coeff p > 0" and irr: "irreducible p" by auto
  let ?norm = "real_alg_2'"
  have "?one \<and> ?two \<and> ?three"
  proof (cases "degree p = 1")
    case True
    define c where "c = coeff p 0"
    define d where "d = coeff p 1"
    from True have rr: "roots_of_2_irr p = [Rational (Rat.Fract (- c) (d))]" unfolding d d_def c_def by auto
    from degree1_coeffs[OF True] have p: "p = [:c,d:]" and d: "d \<noteq> 0" unfolding c_def d_def by auto
    have *: "real_of_int c + x * real_of_int d = 0 \<Longrightarrow> x = - (real_of_int c / real_of_int d)" for x
      using d by (simp add: field_simps)
    show ?thesis unfolding rr using d * unfolding p using of_rat_1[of "Rat.Fract (- c) (d)"]
      by (auto simp: Fract_of_int_quotient hom_distribs)
  next
    case False
    let ?r = real_of_rat
    let ?rp = "map_poly ?r"
    let ?rr = "set (roots_of_2_irr p)"
    define ri where "ri = root_info p"
    define cr where "cr = root_info.l_r ri"
    define bnds where "bnds = [(-root_bound p, root_bound p)]"
    define empty where "empty = (Nil :: real_alg_2 list)"
    have empty: "Ball (set empty) invariant_2 \<and> distinct (map real_of_2 empty)" unfolding empty_def by auto
    from mon have p: "p \<noteq> 0" by auto
    from root_info[OF irr deg] have ri: "root_info_cond ri p" unfolding ri_def .
    from False
    have rr: "roots_of_2_irr p = roots_of_2_main p ri cr bnds empty"
      unfolding d ri_def cr_def Let_def bnds_def empty_def by auto
    note root_bound = root_bound[OF refl deg]
    from root_bound(2)
    have bnds: "\<And> l r. (l,r) \<in> set bnds \<Longrightarrow> l \<le> r" unfolding bnds_def by auto
    have "ipoly p x = 0 \<Longrightarrow> ?r (- root_bound p) \<le> x \<and> x \<le> ?r (root_bound p)" for x
      using root_bound(1)[of x] by (auto simp: hom_distribs)
    hence rts: "{x. ipoly p x = 0}
      = real_of_2 ` set empty \<union> {x. \<exists> l r. root_cond (p,l,r) x \<and> (l,r) \<in> set bnds}"
      unfolding empty_def bnds_def by (force simp: root_cond_def)
    define rts where "rts lr = Collect (root_cond (p,lr))" for lr
    have disj: "pairwise_disjoint (real_of_2 ` set empty # map rts bnds)"
      unfolding empty_def bnds_def by auto
    from deg False have deg1: "degree p > 1" by auto
    define delta where "delta = ipoly_root_delta p"
    note delta = ipoly_root_delta[OF p, folded delta_def]
    define rel' where "rel' = ({(x, y). 0 \<le> y \<and> delta_gt delta x y})^-1"
    define mm where "mm = (\<lambda>bnds. mset (map (\<lambda> (l,r). ?r r - ?r l) bnds))"
    define rel where "rel = inv_image (mult1 rel') mm"
    have wf: "wf rel" unfolding rel_def rel'_def
      by (rule wf_inv_image[OF wf_mult1[OF SN_imp_wf[OF delta_gt_SN[OF delta(1)]]]])
    let ?main = "roots_of_2_main p ri cr"
    have "real_of_2 ` set (?main bnds empty) =
      real_of_2 ` set empty \<union>
      {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set bnds} \<and>
      Ball (set (?main bnds empty)) invariant_2 \<and> distinct (map real_of_2 (?main bnds empty))" (is "?one' \<and> ?two' \<and> ?three'")
      using empty bnds disj
    proof (induct bnds arbitrary: empty rule: wf_induct[OF wf])
      case (1 lrss rais)
      note rais = 1(2)[rule_format]
      note lrs = 1(3)
      note disj = 1(4)
      note IH = 1(1)[rule_format]
      note simp = roots_of_2_main.simps[of p ri cr lrss rais]
      show ?case
      proof (cases lrss)
        case Nil
        with rais show ?thesis unfolding simp by auto
      next
        case (Cons lr lrs)
        obtain l r where lr': "lr = (l,r)" by force
        {
          fix lr'
          assume lt: "\<And> l' r'. (l',r') \<in> set lr' \<Longrightarrow>
            l' \<le> r' \<and> delta_gt delta (?r r - ?r l) (?r r' - ?r l')"
          have l: "mm (lr' @ lrs) = mm lrs + mm lr'" unfolding mm_def by (auto simp: ac_simps)
          have r: "mm lrss = mm lrs + {# ?r r - ?r l #}" unfolding Cons lr' rel_def mm_def
            by auto
          have "(mm (lr' @ lrs), mm lrss) \<in> mult1 rel'" unfolding l r mult1_def
          proof (rule, unfold split, intro exI conjI, unfold add_mset_add_single[symmetric], rule refl, rule refl, intro allI impI)
            fix d
            assume "d \<in># mm lr'"
            then obtain l' r' where d: "d = ?r r' - ?r l'" and lr': "(l',r') \<in> set lr'"
              unfolding mm_def in_multiset_in_set by auto
            from lt[OF lr']
            show "(d, ?r r - ?r l) \<in> rel'"  unfolding d rel'_def
              by (auto simp: of_rat_less_eq)
          qed
          hence "(lr' @ lrs, lrss) \<in> rel" unfolding rel_def by auto
        } note rel = this
        from rel[of Nil] have easy_rel: "(lrs,lrss) \<in> rel" by auto
        define c where "c = cr l r"
        from simp Cons lr' have simp: "?main lrss rais =
          (if c = 0 then ?main lrs rais else if c = 1 then
             ?main lrs (real_alg_2' ri p l r # rais)
               else let m = (l + r) / 2 in ?main ((m, r) # (l, m) # lrs) rais)"
          unfolding c_def simp Cons lr' using real_alg_2''[OF False] by auto
        note lrs = lrs[unfolded Cons lr']
        from lrs have lr: "l \<le> r" by auto
        from root_info_condD(1)[OF ri lr, folded cr_def]
        have c: "c = card {x. root_cond (p,l,r) x}" unfolding c_def by auto
        let ?rt = "\<lambda> lrs. {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set lrs}"
        have rts: "?rt lrss = ?rt lrs \<union> {x. root_cond (p,l,r) x}" (is "?rt1 = ?rt2 \<union> ?rt3")
          unfolding Cons lr' by auto
        show ?thesis
        proof (cases "c = 0")
          case True
          with simp have simp: "?main lrss rais = ?main lrs rais" by simp
          from disj have disj: "pairwise_disjoint (real_of_2 ` set rais # map rts lrs)"
            unfolding Cons by auto
          from finite_ipoly_roots[OF p] True[unfolded c] have empty: "?rt3 = {}"
            unfolding root_cond_def[abs_def] split by simp
          with rts have rts: "?rt1 = ?rt2" by auto
          show ?thesis unfolding simp rts
            by (rule IH[OF easy_rel rais lrs disj], auto)
        next
          case False
          show ?thesis
          proof (cases "c = 1")
            case True
            let ?rai = "real_alg_2' ri p l r"
            from True simp have simp: "?main lrss rais = ?main lrs (?rai # rais)" by auto
            from card_1_Collect_ex1[OF c[symmetric, unfolded True]]
            have ur: "unique_root (p,l,r)"  .
            from real_alg_2'[OF ur pc ri]
            have rai: "invariant_2 ?rai" "real_of_2 ?rai = the_unique_root (p, l, r)" by auto
            with rais have rais: "\<And> x. x \<in> set (?rai # rais) \<Longrightarrow> invariant_2 x"
              and dist: "distinct (map real_of_2 rais)" by auto
            have rt3: "?rt3 = {real_of_2 ?rai}"
              using ur rai by (auto intro: the_unique_root_eqI theI')
            have "real_of_2 ` set (roots_of_2_main p ri cr lrs (?rai # rais)) =
              real_of_2 ` set (?rai # rais) \<union> ?rt2 \<and>
              Ball (set (roots_of_2_main p ri cr lrs (?rai # rais))) invariant_2 \<and>
              distinct (map real_of_2 (roots_of_2_main p ri cr lrs (?rai # rais)))"
              (is "?one \<and> ?two \<and> ?three")
            proof (rule IH[OF easy_rel, of "?rai # rais", OF conjI lrs])
              show "Ball (set (real_alg_2' ri p l r # rais)) invariant_2" using rais by auto
              have "real_of_2 (real_alg_2' ri p l r) \<notin> set (map real_of_2 rais)"
                using disj rt3 unfolding Cons lr' rts_def by auto
              thus "distinct (map real_of_2 (real_alg_2' ri p l r # rais))" using dist by auto
              show "pairwise_disjoint (real_of_2 ` set (real_alg_2' ri p l r # rais) # map rts lrs)"
                using disj rt3 unfolding Cons lr' rts_def by auto
            qed auto
            hence ?one ?two ?three by blast+
            show ?thesis unfolding simp rts rt3
              by (rule conjI[OF _ conjI[OF \<open>?two\<close> \<open>?three\<close>]], unfold \<open>?one\<close>, auto)
          next
            case False
            let ?m = "(l+r)/2"
            let ?lrs = "[(?m,r),(l,?m)] @ lrs"
            from False \<open>c \<noteq> 0\<close> have simp: "?main lrss rais = ?main ?lrs rais"
              unfolding simp by (auto simp: Let_def)
            from False \<open>c \<noteq> 0\<close> have "c \<ge> 2" by auto
            from delta(2)[OF this[unfolded c]] have delta: "delta \<le> ?r (r - l) / 4" by auto
            have lrs: "\<And> l r. (l,r) \<in> set ?lrs \<Longrightarrow> l \<le> r"
              using lr lrs by (fastforce simp: field_simps)
            have "?r ?m \<in> \<rat>" unfolding Rats_def by blast
            with poly_cond_degree_gt_1[OF pc deg1, of "?r ?m"]
            have disj1: "?r ?m \<notin> rts lr" for lr unfolding rts_def root_cond_def by auto
            have disj2: "rts (?m, r) \<inter> rts (l, ?m) = {}" using disj1[of "(l,?m)"] disj1[of "(?m,r)"]
              unfolding rts_def root_cond_def by auto
            have disj3: "(rts (l,?m) \<union> rts (?m,r)) = rts (l,r)"
              unfolding rts_def root_cond_def by (auto simp: hom_distribs)
            have disj4: "real_of_2 ` set rais \<inter> rts (l,r) = {}" using disj unfolding Cons lr' by auto
            have disj: "pairwise_disjoint (real_of_2 ` set rais # map rts ([(?m, r), (l, ?m)] @ lrs))"
              using disj disj2 disj3 disj4 by (auto simp: Cons lr')
            have "(?lrs,lrss) \<in> rel"
            proof (rule rel, intro conjI)
              fix l' r'
              assume mem: "(l', r') \<in> set [(?m,r),(l,?m)]"
              from mem lr show "l' \<le> r'" by auto
              from mem have diff: "?r r' - ?r l' = (?r r - ?r l) / 2" by auto
               (metis eq_diff_eq minus_diff_eq mult_2_right of_rat_add of_rat_diff,
                metis of_rat_add of_rat_mult of_rat_numeral_eq)
              show "delta_gt delta (?r r - ?r l) (?r r' - ?r l')" unfolding diff
                delta_gt_def by (rule order.trans[OF delta], insert lr,
                auto simp: field_simps of_rat_diff of_rat_less_eq)
            qed
            note IH = IH[OF this, of rais, OF rais lrs disj]
            have "real_of_2 ` set (?main ?lrs rais) =
              real_of_2 ` set rais \<union> ?rt ?lrs \<and>
              Ball (set (?main ?lrs rais)) invariant_2 \<and> distinct (map real_of_2 (?main ?lrs rais))"
              (is "?one \<and> ?two")
              by (rule IH)
            hence ?one ?two by blast+
            have cong: "\<And> a b c. b = c \<Longrightarrow> a \<union> b = a \<union> c" by auto
            have id: "?rt ?lrs = ?rt lrs \<union> ?rt [(?m,r),(l,?m)]" by auto
            show ?thesis unfolding rts simp \<open>?one\<close> id
            proof (rule conjI[OF cong[OF cong] conjI])
              have "\<And> x. root_cond (p,l,r) x = (root_cond (p,l,?m) x \<or> root_cond (p,?m,r) x)"
                unfolding root_cond_def by (auto simp:hom_distribs)
              hence id: "Collect (root_cond (p,l,r)) = {x. (root_cond (p,l,?m) x \<or> root_cond (p,?m,r) x)}"
                by auto
              show "?rt [(?m,r),(l,?m)] = Collect (root_cond (p,l,r))" unfolding id list.simps by blast
              show "\<forall> a \<in> set (?main ?lrs rais). invariant_2 a" using \<open>?two\<close> by auto
              show "distinct (map real_of_2 (?main ?lrs rais))" using \<open>?two\<close> by auto
            qed
          qed
        qed
      qed
    qed
    hence idd: "?one'" and cond: ?two' ?three' by blast+
    define res where "res = roots_of_2_main p ri cr bnds empty"
    have e: "set empty = {}" unfolding empty_def by auto
    from idd[folded res_def] e have idd: "real_of_2 ` set res = {} \<union> {x. \<exists>l r. root_cond (p, l, r) x \<and> (l, r) \<in> set bnds}"
      by auto
    show ?thesis
      unfolding rr unfolding rts id e norm_def using cond
      unfolding res_def[symmetric] image_empty e idd[symmetric] by auto
  qed
  thus ?one ?two ?three by blast+
qed

definition roots_of_2 :: "int poly \<Rightarrow> real_alg_2 list" where
  "roots_of_2 p = concat (map roots_of_2_irr
     (factors_of_int_poly p))"

lemma roots_of_2:
  shows "p \<noteq> 0 \<Longrightarrow> real_of_2 ` set (roots_of_2 p) = {x. ipoly p x = 0}"
    "Ball (set (roots_of_2 p)) invariant_2"
    "distinct (map real_of_2 (roots_of_2 p))"
proof -
  let ?rr = "roots_of_2 p"
  note d = roots_of_2_def
  note frp1 = factors_of_int_poly
  {
    fix q r
    assume "q \<in> set ?rr"
    then obtain s where
      s: "s \<in> set (factors_of_int_poly p)" and
      q: "q \<in> set (roots_of_2_irr s)"
      unfolding d by auto
    from frp1(1)[OF refl s] have "poly_cond s" "degree s > 0" by (auto simp: poly_cond_def)
    from roots_of_2_irr[OF this] q
    have "invariant_2 q" by auto
  }
  thus "Ball (set ?rr) invariant_2" by auto
  {
    assume p: "p \<noteq> 0"
    have "real_of_2 ` set ?rr = (\<Union> ((\<lambda> p. real_of_2 ` set (roots_of_2_irr p)) `
      (set (factors_of_int_poly p))))"
      (is "_ = ?rrr")
      unfolding d set_concat set_map by auto
    also have "\<dots> = {x. ipoly p x = 0}"
    proof -
      {
        fix x
        assume "x \<in> ?rrr"
        then obtain q s where
          s: "s \<in> set (factors_of_int_poly p)" and
          q: "q \<in> set (roots_of_2_irr s)" and
          x: "x = real_of_2 q" by auto
        from frp1(1)[OF refl s] have s0: "s \<noteq> 0" and pt: "poly_cond s" "degree s > 0"
          by (auto simp: poly_cond_def)
        from roots_of_2_irr[OF pt] q have rt: "ipoly s x = 0" unfolding x by auto
        from frp1(2)[OF refl p, of x] rt s have rt: "ipoly p x = 0" by auto
      }
      moreover
      {
        fix x :: real
        assume rt: "ipoly p x = 0"
        from rt frp1(2)[OF refl p, of x] obtain s where s: "s \<in> set (factors_of_int_poly p)"
          and rt: "ipoly s x = 0" by auto
        from frp1(1)[OF refl s] have s0: "s \<noteq> 0" and ty: "poly_cond s" "degree s > 0"
          by (auto simp: poly_cond_def)
        from roots_of_2_irr(1)[OF ty] rt obtain q where
          q: "q \<in> set (roots_of_2_irr s)" and
          x: "x = real_of_2 q" by blast
        have "x \<in> ?rrr" unfolding x using q s by auto
      }
      ultimately show ?thesis by auto
    qed
    finally show "real_of_2 ` set ?rr = {x. ipoly p x = 0}" by auto
  }
  show "distinct (map real_of_2 (roots_of_2 p))"
  proof (cases "p = 0")
    case True
    from factors_of_int_poly_const[of 0] True show ?thesis unfolding roots_of_2_def by auto
  next
    case p: False
    note frp1 = frp1[OF refl]
    let ?fp = "factors_of_int_poly p"
    let ?cc = "concat (map roots_of_2_irr ?fp)"
    show ?thesis unfolding roots_of_2_def distinct_conv_nth length_map
    proof (intro allI impI notI)
      fix i j
      assume ij: "i < length ?cc" "j < length ?cc" "i \<noteq> j" and id: "map real_of_2 ?cc ! i = map real_of_2 ?cc ! j"
      from ij id have id: "real_of_2 (?cc ! i) = real_of_2 (?cc ! j)" by auto
      from nth_concat_diff[OF ij, unfolded length_map] obtain j1 k1 j2 k2 where
        *: "(j1,k1) \<noteq> (j2,k2)"
        "j1 < length ?fp" "j2 < length ?fp" and
        "k1 < length (map roots_of_2_irr ?fp ! j1)"
        "k2 < length (map roots_of_2_irr ?fp ! j2)"
        "?cc ! i = map roots_of_2_irr ?fp ! j1 ! k1"
        "?cc ! j = map roots_of_2_irr ?fp ! j2 ! k2" by blast
      hence **: "k1 < length (roots_of_2_irr (?fp ! j1))"
        "k2 < length (roots_of_2_irr (?fp ! j2))"
        "?cc ! i = roots_of_2_irr (?fp ! j1) ! k1"
        "?cc ! j = roots_of_2_irr (?fp ! j2) ! k2"
        by auto
      from * have mem: "?fp ! j1 \<in> set ?fp" "?fp ! j2 \<in> set ?fp" by auto
      from frp1(1)[OF mem(1)] frp1(1)[OF mem(2)]
      have pc1: "poly_cond (?fp ! j1)" "degree (?fp ! j1) > 0" and pc10: "?fp ! j1 \<noteq> 0"
        and pc2: "poly_cond (?fp ! j2)" "degree (?fp ! j2) > 0"
        by (auto simp: poly_cond_def)
      show False
      proof (cases "j1 = j2")
        case True
        with * have neq: "k1 \<noteq> k2" by auto
        from **[unfolded True] id *
        have "map real_of_2 (roots_of_2_irr (?fp ! j2)) ! k1 = real_of_2 (?cc ! j)"
          "map real_of_2 (roots_of_2_irr (?fp ! j2)) ! k1 = real_of_2 (?cc ! j)"
          by auto
        hence "\<not> distinct (map real_of_2 (roots_of_2_irr (?fp ! j2)))"
          unfolding distinct_conv_nth using * ** True by auto
        with roots_of_2_irr(3)[OF pc2] show False by auto
      next
        case neq: False
        with frp1(4)[of p] * have neq: "?fp ! j1 \<noteq> ?fp ! j2" unfolding distinct_conv_nth by auto
        let ?x = "real_of_2 (?cc ! i)"
        define x where "x = ?x"
        from ** have "x \<in> real_of_2 ` set (roots_of_2_irr (?fp ! j1))" unfolding x_def by auto
        with roots_of_2_irr(1)[OF pc1] have x1: "ipoly (?fp ! j1) x = 0" by auto
        from ** id have "x \<in> real_of_2 ` set (roots_of_2_irr (?fp ! j2))" unfolding x_def
          by (metis image_eqI nth_mem)
        with roots_of_2_irr(1)[OF pc2] have x2: "ipoly (?fp ! j2) x = 0" by auto
        have "ipoly p x = 0" using x1 mem unfolding roots_of_2_def by (metis frp1(2) p)
        from frp1(3)[OF p this] x1 x2 neq mem show False by blast
      qed
    qed
  qed
qed

lift_definition roots_of_3 :: "int poly \<Rightarrow> real_alg_3 list" is roots_of_2
  by (insert roots_of_2, auto simp: list_all_iff)

lemma roots_of_3:
  shows "p \<noteq> 0 \<Longrightarrow> real_of_3 ` set (roots_of_3 p) = {x. ipoly p x = 0}"
    "distinct (map real_of_3 (roots_of_3 p))"
proof -
  show "p \<noteq> 0 \<Longrightarrow> real_of_3 ` set (roots_of_3 p) = {x. ipoly p x = 0}"
    by (transfer; intro roots_of_2, auto)
  show "distinct (map real_of_3 (roots_of_3 p))"
    by (transfer; insert roots_of_2, auto)
qed

lift_definition roots_of_real_alg :: "int poly \<Rightarrow> real_alg list" is roots_of_3 .

lemma roots_of_real_alg:
  "p \<noteq> 0 \<Longrightarrow> real_of ` set (roots_of_real_alg p) = {x. ipoly p x = 0}"
  "distinct (map real_of (roots_of_real_alg p))"
proof -
  show "p \<noteq> 0 \<Longrightarrow> real_of ` set (roots_of_real_alg p) = {x. ipoly p x = 0}"
    by (transfer', insert roots_of_3, auto)
  show "distinct (map real_of (roots_of_real_alg p))"
    by (transfer, insert roots_of_3(2), auto)
qed

text \<open>It follows an implementation for @{const roots_of_3},
  since the current definition does not provide a code equation.\<close>
context
begin
private typedef real_alg_2_list = "{xs. Ball (set xs) invariant_2}" by (intro exI[of _ Nil], auto)

setup_lifting type_definition_real_alg_2_list

private lift_definition roots_of_2_list :: "int poly \<Rightarrow> real_alg_2_list" is roots_of_2
  by (insert roots_of_2, auto)
private lift_definition real_alg_2_list_nil :: "real_alg_2_list \<Rightarrow> bool" is "\<lambda> xs. case xs of Nil \<Rightarrow> True | _ \<Rightarrow> False" .

private fun real_alg_2_list_hd_intern :: "real_alg_2 list \<Rightarrow> real_alg_2" where
  "real_alg_2_list_hd_intern (Cons x xs) = x"
| "real_alg_2_list_hd_intern Nil = of_rat_2 0"

private lift_definition real_alg_2_list_hd :: "real_alg_2_list \<Rightarrow> real_alg_3" is real_alg_2_list_hd_intern
proof (goal_cases)
  case (1 xs)
  thus ?case using of_rat_2[of 0] by (cases xs, auto)
qed

private lift_definition real_alg_2_list_tl :: "real_alg_2_list \<Rightarrow> real_alg_2_list" is tl
proof (goal_cases)
  case (1 xs)
  thus ?case by (cases xs, auto)
qed

private lift_definition real_alg_2_list_length :: "real_alg_2_list \<Rightarrow> nat" is length .

private lemma real_alg_2_list_length[simp]: "\<not> real_alg_2_list_nil xs \<Longrightarrow> real_alg_2_list_length (real_alg_2_list_tl xs) < real_alg_2_list_length xs"
  by (transfer, auto split: list.splits)

private function real_alg_2_list_convert :: "real_alg_2_list \<Rightarrow> real_alg_3 list" where
  "real_alg_2_list_convert xs = (if real_alg_2_list_nil xs then [] else real_alg_2_list_hd xs
    # real_alg_2_list_convert (real_alg_2_list_tl xs))" by pat_completeness auto

termination by (relation "measure real_alg_2_list_length", auto)

private definition roots_of_3_impl :: "int poly \<Rightarrow> real_alg_3 list" where
  "roots_of_3_impl p = real_alg_2_list_convert (roots_of_2_list p)"

private lift_definition real_alg_2_list_convert_id :: "real_alg_2_list \<Rightarrow> real_alg_3 list" is id
  by (auto simp: list_all_iff)

lemma real_alg_2_list_convert: "real_alg_2_list_convert xs = real_alg_2_list_convert_id xs"
proof (induct xs rule: wf_induct[OF wf_measure[of real_alg_2_list_length], rule_format])
  case (1 xs)
  show ?case
  proof (cases "real_alg_2_list_nil xs")
    case True
    hence "real_alg_2_list_convert xs = []" by auto
    also have "[] = real_alg_2_list_convert_id xs" using True
      by (transfer', auto split: list.splits)
    finally show ?thesis .
  next
    case False
    hence "real_alg_2_list_convert xs = real_alg_2_list_hd xs # real_alg_2_list_convert (real_alg_2_list_tl xs)" by simp
    also have "real_alg_2_list_convert (real_alg_2_list_tl xs) = real_alg_2_list_convert_id (real_alg_2_list_tl xs)"
      by (rule 1, insert False, simp)
    also have "real_alg_2_list_hd xs # \<dots> = real_alg_2_list_convert_id xs" using False
      by (transfer', auto split: list.splits)
    finally show ?thesis .
  qed
qed

lemma roots_of_3_code[code]: "roots_of_3 p = roots_of_3_impl p"
  unfolding roots_of_3_impl_def real_alg_2_list_convert
  by (transfer, simp)
end

definition real_roots_of_int_poly :: "int poly \<Rightarrow> real list" where
  "real_roots_of_int_poly p = map real_of (roots_of_real_alg p)"

definition real_roots_of_rat_poly :: "rat poly \<Rightarrow> real list" where
  "real_roots_of_rat_poly p = map real_of (roots_of_real_alg (snd (rat_to_int_poly p)))"

abbreviation rpoly :: "rat poly \<Rightarrow> 'a :: field_char_0 \<Rightarrow> 'a"
where "rpoly f \<equiv> poly (map_poly of_rat f)"

lemma real_roots_of_int_poly: "p \<noteq> 0 \<Longrightarrow> set (real_roots_of_int_poly p) = {x. ipoly p x = 0}"
  "distinct (real_roots_of_int_poly p)"
  unfolding real_roots_of_int_poly_def using roots_of_real_alg[of p] by auto

lemma real_roots_of_rat_poly: "p \<noteq> 0 \<Longrightarrow> set (real_roots_of_rat_poly p) = {x. rpoly p x = 0}"
  "distinct (real_roots_of_rat_poly p)"
proof -
  obtain c q where cq: "rat_to_int_poly p = (c,q)" by force
  from rat_to_int_poly[OF this]
  have pq: "p = smult (inverse (of_int c)) (of_int_poly q)"
    and c: "c \<noteq> 0" by auto
  have id: "{x. rpoly p x = (0 :: real)} = {x. ipoly q x = 0}"
    unfolding pq by (simp add: c of_rat_of_int_poly hom_distribs)
  show "distinct (real_roots_of_rat_poly p)" unfolding real_roots_of_rat_poly_def cq snd_conv
    using roots_of_real_alg(2)[of q] .
  assume "p \<noteq> 0"
  with pq c have q: "q \<noteq> 0" by auto
  show "set (real_roots_of_rat_poly p) = {x. rpoly p x = 0}" unfolding id
    unfolding real_roots_of_rat_poly_def cq snd_conv using roots_of_real_alg(1)[OF q]
    by auto
qed

text \<open>The upcoming functions no longer demand an integer or rational polynomial as input.\<close>

definition roots_of_real_main :: "real poly \<Rightarrow> real list" where
  "roots_of_real_main p \<equiv> let n = degree p in
    if n = 0 then [] else if n = 1 then [roots1 p] else if n = 2 then rroots2 p
    else (real_roots_of_rat_poly (map_poly to_rat p))"

definition roots_of_real_poly :: "real poly \<Rightarrow> real list option" where
  "roots_of_real_poly p \<equiv> let (c,pis) = yun_factorization gcd p in
    if (c \<noteq> 0 \<and> (\<forall> (p,i) \<in> set pis. degree p \<le> 2 \<or> (\<forall> x \<in> set (coeffs p). x \<in> \<rat>))) then
    Some (concat (map (roots_of_real_main o fst) pis)) else None"

lemma roots_of_real_main: assumes p: "p \<noteq> 0" and deg: "degree p \<le> 2 \<or> set (coeffs p) \<subseteq> \<rat>"
  shows "set (roots_of_real_main p) = {x. poly p x = 0}" (is "?l = ?r")
proof -
  note d = roots_of_real_main_def Let_def
  show ?thesis
  proof (cases "degree p = 0")
    case True
    hence "?l = {}" unfolding d by auto
    with roots0[OF p True] show ?thesis by auto
  next
    case False note 0 = this
    show ?thesis
    proof (cases "degree p = 1")
      case True
      hence "?l = {roots1 p}" unfolding d by auto
      with roots1[OF True] show ?thesis by auto
    next
      case False note 1 = this
      show ?thesis
      proof (cases "degree p = 2")
        case True
        hence "?l = set (rroots2 p)" unfolding d by auto
        with rroots2[OF True] show ?thesis by auto
      next
        case False note 2 = this
        let ?q = "map_poly to_rat p"
        from 0 1 2 have l: "?l = set (real_roots_of_rat_poly ?q)" unfolding d by auto
        from deg 0 1 2 have rat: "set (coeffs p) \<subseteq> \<rat>" by auto
        have "p = map_poly (of_rat o to_rat) p"
          by (rule sym, rule map_poly_idI, insert rat, auto)
        also have "\<dots> = real_of_rat_poly ?q"
          by (subst map_poly_map_poly, auto simp: to_rat)
        finally have id: "{x. poly p x = 0} = {x. poly (real_of_rat_poly ?q) x = 0}" and q: "?q \<noteq> 0"
          using p by auto
        from real_roots_of_rat_poly(1)[OF q, folded id l] show ?thesis by simp
      qed
    qed
  qed
qed

lemma roots_of_real_poly: assumes rt: "roots_of_real_poly p = Some xs"
  shows "set xs = {x. poly p x = 0}"
proof -
  obtain c pis where yun: "yun_factorization gcd p = (c,pis)" by force
  from rt[unfolded roots_of_real_poly_def yun split Let_def]
  have c: "c \<noteq> 0" and pis: "\<And> p i. (p, i)\<in>set pis \<Longrightarrow> degree p \<le> 2 \<or> (\<forall>x\<in>set (coeffs p). x \<in> \<rat>)"
    and xs: "xs = concat (map (roots_of_real_main \<circ> fst) pis)"
    by (auto split: if_splits)
  note yun = square_free_factorizationD(1,2,4)[OF yun_factorization(1)[OF yun]]
  from yun(1) have p: "p = smult c (\<Prod>(a, i)\<in>set pis. a ^ Suc i)" .
  have "{x. poly p x = 0} = {x. poly (\<Prod>(a, i)\<in>set pis. a ^ Suc i) x = 0}"
    unfolding p using c by auto
  also have "\<dots> = \<Union> ((\<lambda> p. {x. poly p x = 0}) ` fst ` set pis)" (is "_ = ?r")
    by (subst poly_prod_0, force+)
  finally have r: "{x. poly p x = 0} = ?r" .
  {
    fix p i
    assume p: "(p,i) \<in> set pis"
    have "set (roots_of_real_main p) = {x. poly p x = 0}"
      by (rule roots_of_real_main, insert yun(2)[OF p] pis[OF p], auto)
  } note main = this
  have "set xs = \<Union> ((\<lambda> (p, i). set (roots_of_real_main p)) ` set pis)" unfolding xs o_def
    by auto
  also have "\<dots> = ?r" using main by auto
  finally show ?thesis unfolding r by simp
qed

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Operations on indexed families of sets\<close>
theory CZH_Sets_IF
  imports CZH_Sets_BRelations
begin

subsection\<open>Background\<close>

text\<open>
This section presents results about the fundamental operations on the indexed
families of sets, such as unions and intersections of the indexed families
of sets, disjoint unions and infinite Cartesian products.

Certain elements of the content of this section were inspired by
elements of the content of \<^cite>\<open>"paulson_hereditarily_2013"\<close>.
However, as previously, many other results were ported (with amendments) from
the main library of Isabelle/HOL.
\<close>

abbreviation (input) imVLambda :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
  where "imVLambda A f \<equiv> (\<lambda>a\<in>\<^sub>\<circ>A. f a) `\<^sub>\<circ> A"

subsection\<open>Intersection of an indexed family of sets\<close>

syntax "_VIFINTER" :: "pttrn \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V"  (\<open>(3\<Inter>\<^sub>\<circ>_\<in>\<^sub>\<circ>_./ _)\<close> [0, 0, 10] 10)

translations "\<Inter>\<^sub>\<circ>x\<in>\<^sub>\<circ>A. f" \<rightleftharpoons> "CONST VInter (CONST imVLambda A (\<lambda>x. f))"

text\<open>Rules.\<close>

lemma vifintersectionI[intro]:
  assumes "I \<noteq> 0" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> a \<in>\<^sub>\<circ> f i"
  shows "a \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by (auto intro!: vsubset_antisym)

lemma vifintersectionD[dest]:
  assumes "a \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)" and "i \<in>\<^sub>\<circ> I"
  shows "a \<in>\<^sub>\<circ> f i"
  using assms by blast

lemma vifintersectionE1[elim]:
  assumes "a \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)" and "a \<in>\<^sub>\<circ> f i \<Longrightarrow> P" and "i \<notin>\<^sub>\<circ> I \<Longrightarrow> P"
  shows P
  using assms by blast

lemma vifintersectionE3[elim]:
  assumes "a \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  obtains "\<And>i. i\<in>\<^sub>\<circ>I \<Longrightarrow> a \<in>\<^sub>\<circ> f i"
  using assms by blast

lemma vifintersectionE2[elim]:
  assumes "a \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  obtains i where "i \<in>\<^sub>\<circ> I" and "a \<in>\<^sub>\<circ> f i"
  using assms by (elim vifintersectionE3) (meson assms VInterE2 app_vimageE)

text\<open>Set operations.\<close>

lemma vifintersection_vempty_is[simp]: "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>0. f i) = 0" by auto

lemma vifintersection_vsingleton_is[simp]: "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{i}. f i) = f i"
  using elts_0 by blast

lemma vifintersection_vdoubleton_is[simp]: "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {i, j}. f i) = f i \<inter>\<^sub>\<circ> f j"
  by
    (
      intro vsubset_antisym vsubsetI;
      (elim vifintersectionE3 | intro vifintersectionI)
    )
    auto

lemma vifintersection_antimono1:
  assumes "I \<noteq> 0" and "I \<subseteq>\<^sub>\<circ> J"
  shows "(\<Inter>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. f j) \<subseteq>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by blast

lemma vifintersection_antimono2:
  assumes "I \<noteq> 0" and " I \<subseteq>\<^sub>\<circ> J" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i \<subseteq>\<^sub>\<circ> g i"
  shows "(\<Inter>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. f j) \<subseteq>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. g i)"
  using assms by blast

lemma vifintersection_vintersection:
  assumes "I \<noteq> 0" and "J \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>J. f i) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I \<union>\<^sub>\<circ> J. f i)"
  using assms by (auto intro!: vsubset_antisym)

lemma vifintersection_vintersection_family:
  assumes "I \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<inter>\<^sub>\<circ> B i)"
  using assms
  by (intro vsubset_antisym vsubsetI, intro vifintersectionI | tactic\<open>all_tac\<close>)
    blast+

lemma vifintersection_vunion:
  assumes "I \<noteq> 0" and "J \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<union>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. g j) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<Inter>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. f i \<union>\<^sub>\<circ> g j)"
  using assms by (blast intro!: vsubset_antisym)

lemma vifintersection_vinsert_is[intro, simp]:
  assumes "I \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>i \<in>\<^sub>\<circ> vinsert j I. f i) = f j \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  apply(insert assms, intro vsubset_antisym vsubsetI)
  subgoal for b by (subgoal_tac \<open>b \<in>\<^sub>\<circ> f j\<close> \<open>b \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)\<close>) blast+
  subgoal for b
    by (subgoal_tac \<open>b \<in>\<^sub>\<circ> f j\<close> \<open>b \<in>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)\<close>)
      (blast intro!: vsubset_antisym)+
  done

lemma vifintersection_VPow:
  assumes "I \<noteq> 0"
  shows "VPow (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. VPow (f i))"
  using assms by (auto intro!: vsubset_antisym)

text\<open>Elementary properties.\<close>

lemma vifintersection_constant[intro, simp]:
  assumes "I \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>y\<in>\<^sub>\<circ>I. c) = c"
  using assms by auto

lemma vifintersection_vsubset_iff:
  assumes "I \<noteq> 0"
  shows "A \<subseteq>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<longleftrightarrow> (\<forall>i\<in>\<^sub>\<circ>I. A \<subseteq>\<^sub>\<circ> f i)"
  using assms by blast

lemma vifintersection_vsubset_lower:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<subseteq>\<^sub>\<circ> f i"
  using assms by blast

lemma vifintersection_vsubset_greatest:
  assumes "I \<noteq> 0" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> A \<subseteq>\<^sub>\<circ> f i"
  shows "A \<subseteq>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by (intro vsubsetI vifintersectionI) auto

lemma vifintersection_vintersection_value:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "f i \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by blast

lemma vifintersection_vintersection_single:
  assumes "I \<noteq> 0"
  shows "B \<union>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) = (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B \<union>\<^sub>\<circ> A i)"
  by (insert assms, intro vsubset_antisym vsubsetI vifintersectionI)
    blast+

text\<open>Connections.\<close>

lemma vifintersection_vrange_VLambda: "(\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = \<Inter>\<^sub>\<circ> (\<R>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>I. f a))"
  by (simp add: vimage_VLambda_vrange_rep)

subsection\<open>Union of an indexed family of sets\<close>

syntax "_VIFUNION" :: "pttrn \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (\<open>(3\<Union>\<^sub>\<circ>_\<in>\<^sub>\<circ>_./ _)\<close> [0, 0, 10] 10)

translations "\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A. f" \<rightleftharpoons> "CONST VUnion (CONST imVLambda A (\<lambda>x. f))"

text\<open>Rules.\<close>

lemma vifunion_iff: "b \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<longleftrightarrow> (\<exists>i\<in>\<^sub>\<circ>I. b \<in>\<^sub>\<circ> f i)" by force

lemma vifunionI[intro]:
  assumes "i \<in>\<^sub>\<circ> I" and "a \<in>\<^sub>\<circ> f i"
  shows "a \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by force

lemma vifunionD[dest]:
  assumes "a \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  shows "\<exists>i\<in>\<^sub>\<circ>I. a \<in>\<^sub>\<circ> f i"
  using assms by auto

lemma vifunionE[elim!]:
  assumes "a \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)" and "\<And>i. \<lbrakk> i \<in>\<^sub>\<circ> I; a \<in>\<^sub>\<circ> f i \<rbrakk> \<Longrightarrow> R"
  shows R
  using assms by auto

text\<open>Set operations.\<close>

lemma vifunion_vempty_family[simp]: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. 0) = 0" by auto

lemma vifunion_vsingleton_is[simp]: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {i}. f i) = f i" by force

lemma vifunion_vsingleton_family[simp]: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. set {i}) = I" by force

lemma vifunion_vdoubleton: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {i, j}. f i) = f i \<union>\<^sub>\<circ> f j"
  using VLambda_vinsert vimage_vunion_left
  by (force simp: VLambda_vsingleton simp: vinsert_set_insert_eq)

lemma vifunion_mono:
  assumes "I \<subseteq>\<^sub>\<circ> J" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i \<subseteq>\<^sub>\<circ> g i"
  shows "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. g j)"
  using assms by force

lemma vifunion_vunion_is: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. f j) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I \<union>\<^sub>\<circ> J. f i)"
  by force

lemma vifunion_vunion_family:
  "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. g i) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i \<union>\<^sub>\<circ> g i)"
  by (intro vsubset_antisym vsubsetI; elim vunionE vifunionE) force+

lemma vifunion_vintersection:
  "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<inter>\<^sub>\<circ> (\<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. g j) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>J. f i \<inter>\<^sub>\<circ> g j)"
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vinsert_is:
  "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>vinsert j I. f i) = f j \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_VPow: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. VPow (f i)) \<subseteq>\<^sub>\<circ> VPow (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)" by force

text\<open>Elementary properties.\<close>

lemma vifunion_vempty_conv:
  "0 = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<longleftrightarrow> (\<forall>i\<in>\<^sub>\<circ>I. f i = 0)"
  "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = 0 \<longleftrightarrow> (\<forall>i\<in>\<^sub>\<circ>I. f i = 0)"
  by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_constant[simp]: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. c) = (if I = 0 then 0 else c)"
proof(intro vsubset_antisym)
  show "(if I = 0 then 0 else c) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. c)"
    by (cases \<open>vdisjnt I I\<close>) (auto simp: VLambda_vconst_on)
qed auto

lemma vifunion_upper:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "f i \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by force

lemma vifunion_least:
  assumes "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i \<subseteq>\<^sub>\<circ> C"
  shows "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<subseteq>\<^sub>\<circ> C"
  using assms by auto

lemma vifunion_absorb:
  assumes "j \<in>\<^sub>\<circ> I"
  shows "f j \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
  using assms by force

lemma vifunion_vifunion_flatten:
  "(\<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i). g j) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<Union>\<^sub>\<circ>j\<in>\<^sub>\<circ>f i. g j)"
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vsubset_iff: "((\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<subseteq>\<^sub>\<circ> B) = (\<forall>i\<in>\<^sub>\<circ>I. f i \<subseteq>\<^sub>\<circ> B)" by force

lemma vifunion_vsingleton_eq_vrange: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. set {f i}) = \<R>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>I. f a)"
  by force

lemma vball_vifunion[simp]: "(\<forall>z\<in>\<^sub>\<circ>(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i). P z) \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>I. \<forall>z\<in>\<^sub>\<circ>f x. P z)"
  by force

lemma vbex_vifunion[simp]: "(\<exists>z\<in>\<^sub>\<circ>(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i). P z) \<longleftrightarrow> (\<exists>x\<in>\<^sub>\<circ>I. \<exists>z\<in>\<^sub>\<circ>f x. P z)"
  by force

lemma vifunion_vintersection_index_right[simp]: "(\<Union>\<^sub>\<circ>C\<in>\<^sub>\<circ>B. A \<inter>\<^sub>\<circ> C) = A \<inter>\<^sub>\<circ> \<Union>\<^sub>\<circ>B"
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_vintersection_index_left[simp]: "(\<Union>\<^sub>\<circ>C\<in>\<^sub>\<circ>B. C \<inter>\<^sub>\<circ> A) = \<Union>\<^sub>\<circ>B \<inter>\<^sub>\<circ> A"
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_vunion_index[intro, simp]:
  assumes "B \<noteq> 0"
  shows "(\<Inter>\<^sub>\<circ>C\<in>\<^sub>\<circ>B. A \<union>\<^sub>\<circ> C) = A \<union>\<^sub>\<circ> \<Inter>\<^sub>\<circ>B"
  using assms
  by
    (
      (intro vsubset_antisym vsubsetI);
      (intro vifintersectionI | tactic\<open>all_tac\<close>)
    )
    blast+

lemma vifunion_vintersection_single: "B \<inter>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B \<inter>\<^sub>\<circ> f i)"
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vifunion_flip:
  "(\<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. \<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. f b a) = (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. f b a)"
proof-
  have "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. f b a)" if "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. \<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. f b a)"
    for x f A B
  proof-
    from that obtain b where b: "b \<in>\<^sub>\<circ> B" and x_b: "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. f b a)"
      by fastforce
    then obtain a where a: "a \<in>\<^sub>\<circ> A" and x_fba: "x \<in>\<^sub>\<circ> f b a" by fastforce
    show "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>a\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>b\<in>\<^sub>\<circ>B. f b a)"
      unfolding vifunion_iff by (auto intro: a b x_fba)
  qed
  then show ?thesis by (intro vsubset_antisym vsubsetI) auto
qed

text\<open>Connections.\<close>

lemma vifunion_disjoint: "(\<Union>\<^sub>\<circ>C \<inter>\<^sub>\<circ> A = 0) \<longleftrightarrow> (\<forall>B\<in>\<^sub>\<circ>C. vdisjnt B A)"
  by (intro iffI)
    (auto intro!: vsubset_antisym simp: Sup_upper vdisjnt_vsubset_left)

lemma vdisjnt_vifunion_iff:
  "vdisjnt A (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<longleftrightarrow> (\<forall>i\<in>\<^sub>\<circ>I. vdisjnt A (f i))"
  by (force intro!: vsubset_antisym simp: vdisjnt_iff)+

lemma vifunion_VLambda: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>A. set {\<langle>i, f i\<rangle>}) = (\<lambda>a\<in>\<^sub>\<circ>A. f a)"
  using vifunionI by (intro vsubset_antisym vsubsetI) auto

lemma vifunion_vrange_VLambda: "(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = \<Union>\<^sub>\<circ>(\<R>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>I. f a))"
  using vimage_VLambda_vrange_rep by auto

lemma (in vsv) vsv_vrange_vsubset_vifunion_app:
  assumes "\<D>\<^sub>\<circ> r = I" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> r\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
  shows "\<R>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
proof(intro vsubsetI)
  fix x assume "x \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> r"
  with assms(1) obtain i where x_def: "x = r\<lparr>i\<rparr>" and i: "i \<in>\<^sub>\<circ> I"
    by (metis vrange_atE)
  from i assms(2)[rule_format, OF i] show "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
    unfolding x_def by (intro vifunionI) auto
qed

lemma v11_vlrestriction_vifintersection:
  assumes "I \<noteq> 0" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> v11 (f \<restriction>\<^sup>l\<^sub>\<circ> (A i))"
  shows "v11 (f \<restriction>\<^sup>l\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i))"
proof(intro v11I)
  show "vsv (f \<restriction>\<^sup>l\<^sub>\<circ> \<Inter>\<^sub>\<circ> ((\<lambda>a\<in>\<^sub>\<circ>I. A a) `\<^sub>\<circ> I))"
    (*slow*)
    apply(subgoal_tac \<open>\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> vsv (f \<restriction>\<^sup>l\<^sub>\<circ> (A i))\<close>)
    subgoal by (insert assms(1), intro vsvI) (blast intro!: vsubset_antisym)+
    subgoal using assms by blast
    done
  show "vsv ((f \<restriction>\<^sup>l\<^sub>\<circ> \<Inter>\<^sub>\<circ> ((\<lambda>a\<in>\<^sub>\<circ>I. A a) `\<^sub>\<circ> I))\<inverse>\<^sub>\<circ>)"
  proof(intro vsvI)
    fix a b c
    assume ab: "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> (f \<restriction>\<^sup>l\<^sub>\<circ> \<Inter>\<^sub>\<circ> ((\<lambda>a\<in>\<^sub>\<circ>I. A a) `\<^sub>\<circ> I))\<inverse>\<^sub>\<circ>"
      and ac: "\<langle>a, c\<rangle> \<in>\<^sub>\<circ> (f \<restriction>\<^sup>l\<^sub>\<circ> \<Inter>\<^sub>\<circ> ((\<lambda>a\<in>\<^sub>\<circ>I. A a) `\<^sub>\<circ> I))\<inverse>\<^sub>\<circ>"
    from assms(2) have hyp: "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> vsv ((f \<restriction>\<^sup>l\<^sub>\<circ> (A i))\<inverse>\<^sub>\<circ>)" by blast
    from assms(1) obtain i where "i \<in>\<^sub>\<circ> I" and "\<Inter>\<^sub>\<circ> ((\<lambda>a\<in>\<^sub>\<circ>I. A a) `\<^sub>\<circ> I) \<subseteq>\<^sub>\<circ> A i"
      by (auto intro!: vsubset_antisym)
    with ab ac hyp \<open>i \<in>\<^sub>\<circ> I\<close> show "b = c" by auto
  qed auto
qed

subsection\<open>Additional simplification rules for indexed families of sets.\<close>

text\<open>Union.\<close>

lemma vifunion_simps[simp]:
  "\<And>a B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. vinsert a (B i)) =
    (if I=0 then 0 else vinsert a (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i))"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<union>\<^sub>\<circ> B) = ((if I=0 then 0 else (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<union>\<^sub>\<circ> B))"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<union>\<^sub>\<circ> B i) = ((if I=0 then 0 else A \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i)))"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<inter>\<^sub>\<circ> B) = ((\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<inter>\<^sub>\<circ> B)"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<inter>\<^sub>\<circ> B i) = (A \<inter>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i))"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i -\<^sub>\<circ> B) = ((\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) -\<^sub>\<circ> B)"
  "\<And>A B. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>\<Union>\<^sub>\<circ>A. B i) = (\<Union>\<^sub>\<circ>y\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>y. B i)"
  by
    (
      force
        simp: vrange_VLambda vimage_VLambda_vrange_rep
        intro!: vsubset_antisym
    )+

lemma vifunion_simps_ext:
  "\<And>a B I. vinsert a (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) =
    (if I=0 then set {a} else (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. vinsert a (B i)))"
  "\<And>A B I. (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<union>\<^sub>\<circ> B = (if I=0 then B else (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<union>\<^sub>\<circ> B))"
  "\<And>A B I. A \<union>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) = (if I=0 then A else (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<union>\<^sub>\<circ> B i))"
  "\<And>A B I. ((\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<inter>\<^sub>\<circ> B) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<inter>\<^sub>\<circ> B)"
  "\<And>A B I. ((\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) -\<^sub>\<circ> B) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i -\<^sub>\<circ> B)"
  "\<And>A B. (\<Union>\<^sub>\<circ>y\<in>\<^sub>\<circ>A. \<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>y. B i) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>\<Union>\<^sub>\<circ>A. B i)"
  by (auto simp: vrange_VLambda)

lemma vifunion_vball_vbex_simps[simp]:
  "\<And>A P. (\<forall>a\<in>\<^sub>\<circ>\<Union>\<^sub>\<circ>A. P a) \<longleftrightarrow> (\<forall>y\<in>\<^sub>\<circ>A. \<forall>a\<in>\<^sub>\<circ>y. P a)"
  "\<And>A P. (\<exists>a\<in>\<^sub>\<circ>\<Union>\<^sub>\<circ>A. P a) \<longleftrightarrow> (\<exists>y\<in>\<^sub>\<circ>A. \<exists>a\<in>\<^sub>\<circ>y. P a)"
  using vball_vifunion vbex_vifunion by auto

text\<open>Intersection.\<close>

lemma vifintersection_simps[simp]:
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<inter>\<^sub>\<circ> B) = (if I = 0 then 0 else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<inter>\<^sub>\<circ> B)"
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<inter>\<^sub>\<circ> B i) = (if I = 0 then 0 else A \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i))"
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i -\<^sub>\<circ> B) = (if I = 0 then 0 else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) -\<^sub>\<circ> B)"
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A -\<^sub>\<circ> B i) = (if I = 0 then 0 else A -\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i))"
  "\<And>I a B.
    (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. vinsert a (B i)) = (if I = 0 then 0 else vinsert a (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i))"
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<union>\<^sub>\<circ> B) = (if I = 0 then 0 else ((\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<union>\<^sub>\<circ> B))"
  "\<And>I A B. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<union>\<^sub>\<circ> B i) = (if I = 0 then 0 else (A \<union>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i)))"
  by force+

lemma vifintersection_simps_ext:
  "\<And>A B I. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<inter>\<^sub>\<circ> B = (if I = 0 then 0 else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<inter>\<^sub>\<circ> B))"
  "\<And>A B I. A \<inter>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) = (if I = 0 then 0 else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<inter>\<^sub>\<circ> B i))"
  "\<And>A B I. (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) -\<^sub>\<circ> B = (if I = 0 then 0 else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i -\<^sub>\<circ> B))"
  "\<And>A B I. A -\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) = (if I = 0 then A else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A -\<^sub>\<circ> B i))"
  "\<And>a B I. vinsert a (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) =
    (if I = 0 then set {a} else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. vinsert a (B i)))"
  "\<And>A B I. ((\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<union>\<^sub>\<circ> B) = (if I = 0 then B else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i \<union>\<^sub>\<circ> B))"
  "\<And>A B I. A \<union>\<^sub>\<circ> (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. B i) = (if I = 0 then A else (\<Inter>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A \<union>\<^sub>\<circ> B i))"
  using vifintersection_simps by auto

subsection\<open>Knowledge transfer: union and intersection of indexed families\<close>

lemma SUP_vifunion: "(SUP \<xi>\<in>elts \<alpha>. A \<xi>) = (\<Union>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. A \<xi>)"
  by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)

lemma INF_vifintersection: "(INF \<xi>\<in>elts \<alpha>. A \<xi>) = (\<Inter>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. A \<xi>)"
  by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)

lemmas Ord_induct3'[consumes 1, case_names 0 succ Limit, induct type: V] =
  Ord_induct3[unfolded SUP_vifunion]

lemma Limit_vifunion_def[simp]:
  assumes "Limit \<alpha>"
  shows "(\<Union>\<^sub>\<circ>\<xi>\<in>\<^sub>\<circ>\<alpha>. \<xi>) = \<alpha>"
  using assms unfolding SUP_vifunion[symmetric] by simp

lemmas_with[unfolded SUP_vifunion INF_vifintersection]:
  TC = ZFC_Cardinals.TC
  and rank_Sup = ZFC_Cardinals.rank_Sup
  and TC_def = ZFC_Cardinals.TC_def
  and Ord_equality = ZFC_in_HOL.Ord_equality
  and Aleph_Limit = ZFC_Cardinals.Aleph_Limit
  and rank = ZFC_Cardinals.rank
  and Vset = ZFC_in_HOL.Vset
  and mult = Kirby.mult
  and Aleph_def = ZFC_Cardinals.Aleph_def
  and times_V_def = Kirby.times_V_def
  and mult_Limit = Kirby.mult_Limit
  and Vfrom = ZFC_in_HOL.Vfrom
  and Vfrom_def = ZFC_in_HOL.Vfrom_def
  and rank_def = ZFC_Cardinals.rank_def
  and add_Limit = Kirby.add_Limit
  and Limit_Vfrom_eq = ZFC_in_HOL.Limit_Vfrom_eq
  and VSigma_def = ZFC_Cardinals.VSigma_def
  and add_Sup_distrib_id = Kirby.add_Sup_distrib_id
  and Limit_add_Sup_distrib = Kirby.Limit_add_Sup_distrib
  and TC_mult = Kirby.TC_mult
  and add_Sup_distrib = Kirby.add_Sup_distrib

subsection\<open>Disjoint union\<close>

text\<open>
See the main library of \<open>ZFC in HOL\<close> for further information
and elementary properties.
\<close>

syntax "_VSIGMA" :: "pttrn \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (\<open>(3\<Coprod>\<^sub>\<circ>_\<in>\<^sub>\<circ>_./ _)\<close> [0, 0, 10] 10)

translations "\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A" \<rightleftharpoons> "CONST VSigma I (\<lambda>i. A)"

text\<open>Further rules.\<close>

lemma vdunion_def: "(\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) = (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. \<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>})"
  by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vdunionI:
  assumes "ix = \<langle>i, x\<rangle>" and "i \<in>\<^sub>\<circ> I" and "x \<in>\<^sub>\<circ> A i"
  shows "ix \<in>\<^sub>\<circ> (\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  using assms(2,3) unfolding assms(1) vdunion_def by (intro vifunionI) auto

lemmas vdunionD = VSigmaD1 VSigmaD2
  and vdunionE = VSigmaE

text\<open>Set operations.\<close>

lemma vdunion_vsingleton: "(\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{c}. A i) = set {c} \<times>\<^sub>\<circ> A c" by auto

lemma vdunion_vdoubleton:
  "(\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{a, b}. A i) = set {a} \<times>\<^sub>\<circ> A a \<union>\<^sub>\<circ> set {b} \<times>\<^sub>\<circ> A b"
  by auto

text\<open>Connections.\<close>

lemma vdunion_vsum: "(\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{0, 1}. if i=0 then A else B) = A \<Uplus> B"
  unfolding vdunion_vdoubleton vsum_def by simp

subsection\<open>Canonical injection\<close>

definition vcinjection :: "(V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V"
  where "vcinjection A i = (\<lambda>x\<in>\<^sub>\<circ>A i. \<langle>i, x\<rangle>)"

text\<open>Rules.\<close>

mk_VLambda vcinjection_def
  |vsv vcinjection_vsv[intro]|
  |vdomain vcinjection_vdomain[simp]|
  |app vcinjection_app[simp, intro]|

text\<open>Elementary results.\<close>

lemma vcinjection_vrange_vsubset:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "\<R>\<^sub>\<circ> (vcinjection A i) \<subseteq>\<^sub>\<circ> (\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  unfolding vcinjection_def
proof(intro vrange_VLambda_vsubset)
  fix x assume prems: "x \<in>\<^sub>\<circ> A i"
  show "\<langle>i, x\<rangle> \<in>\<^sub>\<circ> (\<Coprod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
    by (intro vdunionI[where A=A, OF _ assms prems]) simp
qed

lemma vcinjection_vrange:
  assumes "i \<in>\<^sub>\<circ> I" and "\<And>j. j \<in>\<^sub>\<circ> I \<Longrightarrow> A j \<noteq> 0"
  shows "\<R>\<^sub>\<circ> (vcinjection A i) = (\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>})"
proof(intro vsubset_antisym)
  interpret vsv \<open>vcinjection A i\<close> by (rule vcinjection_vsv)
  show "\<R>\<^sub>\<circ> (vcinjection A i) \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>})"
    unfolding vcinjection_def
  proof(intro vrange_VLambda_vsubset)
    fix x assume prems: "x \<in>\<^sub>\<circ> A i"
    show "\<langle>i, x\<rangle> \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>})"
      by (intro vifunionI, rule prems) simp
  qed
  show "(\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>}) \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (vcinjection A i)"
  proof(rule vsubsetI)
    fix ix assume "ix \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>x\<in>\<^sub>\<circ>A i. set {\<langle>i, x\<rangle>})"
    then obtain x where x: "x \<in>\<^sub>\<circ> A i" and ix_def: "ix = \<langle>i, x\<rangle>"
      by (elim vifunionE) auto
    with x show "ix \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (vcinjection A i)"
      unfolding ix_def by (intro vsv_vimageI2') auto
  qed
qed

subsection\<open>Infinite Cartesian product\<close>

definition vproduct :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V"
  where "vproduct I A = set {f. vsv f \<and> \<D>\<^sub>\<circ> f = I \<and> (\<forall>i\<in>\<^sub>\<circ>I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i)}"

syntax "_VPRODUCT" :: "pttrn \<Rightarrow> V \<Rightarrow> V \<Rightarrow> V" (\<open>(3\<Prod>\<^sub>\<circ>_\<in>\<^sub>\<circ>_./ _)\<close> [0, 0, 10] 10)

translations "\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A" \<rightleftharpoons> "CONST vproduct I (\<lambda>i. A)"

lemma small_vproduct[simp]:
  "small {f. vsv f \<and> \<D>\<^sub>\<circ> f = I \<and> (\<forall>i\<in>\<^sub>\<circ>I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i)}"
  (is \<open>small ?A\<close>)
proof-
  from small_vsv[of I \<open>(\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)\<close>] have
    "small {f. vsv f \<and> \<D>\<^sub>\<circ> f = I \<and> \<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)}"
    by simp
  moreover have "?A \<subseteq> {f. vsv f \<and> \<D>\<^sub>\<circ> f = I \<and> \<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)}"
  proof(intro subsetI, unfold mem_Collect_eq, elim conjE, intro conjI)
    fix f assume prems: "vsv f" "\<D>\<^sub>\<circ> f = I" "\<forall>i\<in>elts I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
    interpret vsv f by (rule prems(1))
    show "\<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
    proof(intro vsubsetI)
      fix y assume "y \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> f"
      with prems(2) obtain i where y_def: "y = f\<lparr>i\<rparr>" and i: "i \<in>\<^sub>\<circ> I"
        by (blast dest: vrange_atD)
      from i prems(3) vifunionI show "y \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
        unfolding y_def by auto
    qed
  qed
  ultimately show ?thesis by (metis (lifting) smaller_than_small)
qed

text\<open>Rules.\<close>

lemma vproductI[intro!]:
  assumes "vsv f" and "\<D>\<^sub>\<circ> f = I" and "\<forall>i\<in>\<^sub>\<circ>I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
  shows "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  using assms small_vproduct unfolding vproduct_def by auto

lemma vproductD[dest]:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  shows "vsv f"
    and "\<D>\<^sub>\<circ> f = I"
    and "\<forall>i\<in>\<^sub>\<circ>I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
  using assms unfolding vproduct_def by auto

lemma vproductE[elim!]:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  obtains "vsv f" and "\<D>\<^sub>\<circ> f = I" and "\<forall>i\<in>\<^sub>\<circ>I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
  using assms unfolding vproduct_def by auto

text\<open>Set operations.\<close>

lemma vproduct_index_vempty[simp]: "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>0. A i) = set {0}"
proof-
  have "{f. vsv f \<and> \<D>\<^sub>\<circ> f = 0 \<and> (\<forall>i\<in>\<^sub>\<circ>0. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i)} = {0}"
    using vbrelation.vlrestriction_vdomain vsv_eqI by fastforce
  then show ?thesis unfolding vproduct_def by simp
qed

lemma vproduct_vsingletonI:
  assumes "f\<lparr>c\<rparr> \<in>\<^sub>\<circ> A c" and "f = set {\<langle>c, f\<lparr>c\<rparr>\<rangle>}"
  shows "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{c}. A i)"
  using assms
  apply(intro vproductI)
  subgoal by (metis rel_vsingleton.vsv_axioms)
  subgoal by (force intro!: vsubset_antisym)
  subgoal by auto
  done

lemma vproduct_vsingletonD:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{c}. A i)"
  shows "vsv f" and "f\<lparr>c\<rparr> \<in>\<^sub>\<circ> A c" and "f = set {\<langle>c, f\<lparr>c\<rparr>\<rangle>}"
proof-
  from assms show "f = set {\<langle>c, f\<lparr>c\<rparr>\<rangle>}"
    by (elim vproductE) (metis VLambda_vsingleton  vsv.vsv_is_VLambda)
qed (use assms in auto)

lemma vproduct_vsingletonE:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{c}. A i)"
  obtains "vsv f" and "f\<lparr>c\<rparr> \<in>\<^sub>\<circ> A c" and "f = set {\<langle>c, f\<lparr>c\<rparr>\<rangle>}"
  using assms vproduct_vsingletonD that by auto

lemma vproduct_vsingleton_iff:
  "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{c}. A i) \<longleftrightarrow> f\<lparr>c\<rparr> \<in>\<^sub>\<circ> A c \<and> f = set {\<langle>c, f\<lparr>c\<rparr>\<rangle>}"
  by (rule iffI) (auto simp: vproduct_vsingletonD intro!: vproduct_vsingletonI)

lemma vproduct_vdoubletonI[intro]:
  assumes "vsv f"
    and "f\<lparr>a\<rparr> \<in>\<^sub>\<circ> A a"
    and "f\<lparr>b\<rparr> \<in>\<^sub>\<circ> A b"
    and "\<D>\<^sub>\<circ> f = set {a, b}"
    and "\<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> A a \<union>\<^sub>\<circ> A b"
  shows "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {a, b}. A i)"
  using assms vifunion_vdoubleton by (intro vproductI) auto

lemma vproduct_vdoubletonD[dest]:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{a, b}. A i)"
  shows "vsv f"
    and "f\<lparr>a\<rparr> \<in>\<^sub>\<circ> A a"
    and "f\<lparr>b\<rparr> \<in>\<^sub>\<circ> A b"
    and "\<D>\<^sub>\<circ> f = set {a, b}"
    and "f = set {\<langle>a, f\<lparr>a\<rparr>\<rangle>, \<langle>b, f\<lparr>b\<rparr>\<rangle>}"
  subgoal using assms by auto
  subgoal using assms by auto
  subgoal using assms by auto
  subgoal using assms vifunion_vdoubleton by fastforce
  subgoal by (metis assms VLambda_vdoubleton vproductE vsv.vsv_is_VLambda)
  done

lemma vproduct_vdoubletonE:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set{a, b}. A i)"
  obtains "vsv f"
    and "f\<lparr>a\<rparr> \<in>\<^sub>\<circ> A a"
    and "f\<lparr>b\<rparr> \<in>\<^sub>\<circ> A b"
    and "\<D>\<^sub>\<circ> f = set {a, b}"
    and "f = set {\<langle>a, f\<lparr>a\<rparr>\<rangle>, \<langle>b, f\<lparr>b\<rparr>\<rangle>}"
  using assms vproduct_vdoubletonD that by simp

lemma vproduct_vdoubleton_iff:
  "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {a, b}. A i) \<longleftrightarrow>
    vsv f \<and>
    f\<lparr>a\<rparr> \<in>\<^sub>\<circ> A a \<and>
    f\<lparr>b\<rparr> \<in>\<^sub>\<circ> A b \<and>
    \<D>\<^sub>\<circ> f = set {a, b} \<and>
    f = set {\<langle>a, f\<lparr>a\<rparr>\<rangle>, \<langle>b, f\<lparr>b\<rparr>\<rangle>}"
  by (force elim!: vproduct_vdoubletonE)+

text\<open>Elementary properties.\<close>

lemma vproduct_eq_vemptyI:
  assumes "i \<in>\<^sub>\<circ> I" and "A i = 0"
  shows "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) = 0"
proof(intro vsubset_antisym vsubsetI)
  fix x assume prems: "x \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  from assms vproductD(3)[OF prems] show "x \<in>\<^sub>\<circ> 0" by auto
qed auto

lemma vproduct_eq_vemptyD:
  assumes "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<noteq> 0"
  shows "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> A i \<noteq> 0"
proof(rule ccontr, unfold not_not)
  fix i assume prems: "i \<in>\<^sub>\<circ> I" "A i = 0"
  with vproduct_eq_vemptyI[where A=A, OF prems] assms show False by simp
qed

lemma vproduct_vrange:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  shows "\<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
proof(intro vsubsetI)
  fix x assume prems: "x \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> f"
  have vsv_f: "vsv f"
    and dom_f: "\<D>\<^sub>\<circ> f = I"
    and fi: "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
    by (simp_all add: vproductD[OF assms, rule_format])
  interpret f: vsv f by (rule vsv_f)
  from prems dom_f obtain i where x_def: "x = f\<lparr>i\<rparr>" and i: "i \<in>\<^sub>\<circ> I"
    by (auto elim: f.vrange_atE)
  from i fi show "x \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)" unfolding x_def by (intro vifunionI) auto
qed

lemma vproduct_vsubset_VPow: "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i) \<subseteq>\<^sub>\<circ> VPow (I \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i))"
proof(intro vsubsetI)
  fix f assume "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  then have vsv: "vsv f"
    and domain: "\<D>\<^sub>\<circ> f = I"
    and range: "\<forall>i\<in>elts I. f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i"
    by auto
  interpret f: vsv f by (rule vsv)
  have "f \<subseteq>\<^sub>\<circ> I \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  proof(intro vsubsetI)
    fix x assume prems: "x \<in>\<^sub>\<circ> f"
    then obtain a b where x_def: "x = \<langle>a, b\<rangle>" by (elim f.vbrelation_vinE)
    with prems have "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> f" and "b \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> f" by auto
    with range domain prems show "x \<in>\<^sub>\<circ> I \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
      by (fastforce simp: x_def)
  qed
  then show "f \<in>\<^sub>\<circ> VPow (I \<times>\<^sub>\<circ> (\<Union>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i))" by simp
qed

lemma VLambda_in_vproduct:
  assumes "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i \<in>\<^sub>\<circ> A i"
  shows "(\<lambda>i\<in>\<^sub>\<circ>I. f i) \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  using assms by (simp add: vproductI vsv.vsv_vrange_vsubset_vifunion_app)

lemma vproduct_cong:
  assumes "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i = g i"
  shows "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) = (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. g i)"
proof-
  have "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i) \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. g i)" if "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> f i = g i" for f g
  proof(intro vsubsetI)
    fix x assume "x \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. f i)"
    note xD = vproductD[OF this]
    interpret vsv x by (rule xD(1))
    show "x \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. g i)"
      by (metis xD(2,3) that VLambda_in_vproduct vsv_is_VLambda)
  qed
  with assms show ?thesis by (intro vsubset_antisym) auto
qed

lemma vproduct_ex_in_vproduct:
  assumes "x \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>J. A i)" and "J \<subseteq>\<^sub>\<circ> I" and "\<And>i. i \<in>\<^sub>\<circ> I \<Longrightarrow> A i \<noteq> 0"
  obtains X where "X \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)" and "x = X \<restriction>\<^sup>l\<^sub>\<circ> J"
proof-
  define X where "X = (\<lambda>i\<in>\<^sub>\<circ>I. if i \<in>\<^sub>\<circ> J then x\<lparr>i\<rparr> else (SOME x. x \<in>\<^sub>\<circ> A i))"
  have X: "X \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
    by (intro vproductI) (use assms in \<open>auto simp: X_def\<close>)
  moreover have "x = X \<restriction>\<^sup>l\<^sub>\<circ> J"
  proof(rule vsv_eqI)
    from assms(1) have [simp]: "\<D>\<^sub>\<circ> x = J" by clarsimp
    moreover from assms(2) have "\<D>\<^sub>\<circ> (X \<restriction>\<^sup>l\<^sub>\<circ> J) = J" unfolding X_def by fastforce
    ultimately show "\<D>\<^sub>\<circ> x = \<D>\<^sub>\<circ> (X \<restriction>\<^sup>l\<^sub>\<circ> J)" by simp
    show "x\<lparr>i\<rparr> = (X \<restriction>\<^sup>l\<^sub>\<circ> J)\<lparr>i\<rparr>" if "i \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> x" for i
      using that assms(2) unfolding X_def by auto
  qed (use assms X in auto)
  ultimately show ?thesis using that by simp
qed

lemma vproduct_vsingleton_def: "(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {j}. A i) = (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>set {j}. A j)"
  by auto

lemma vprojection_in_VUnionI:
  assumes "A \<subseteq>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. F i)" and "f \<in>\<^sub>\<circ> A" and "i \<in>\<^sub>\<circ> I"
  shows "f\<lparr>i\<rparr> \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>(\<Union>\<^sub>\<circ>A))"
proof(intro VUnionI)
  show "f \<in>\<^sub>\<circ> A" by (rule assms(2))
  from assms(1,2) have "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. F i)" by auto
  note f = vproductD[OF this, rule_format]
  interpret vsv f rewrites "\<D>\<^sub>\<circ> f = I" by (auto intro: f(1) simp: f(2))
  show "\<langle>i, f\<lparr>i\<rparr>\<rangle> \<in>\<^sub>\<circ> f" by (meson assms(3) vsv_appE)
  show "set {i, f\<lparr>i\<rparr>} \<in>\<^sub>\<circ> \<langle>i, f\<lparr>i\<rparr>\<rangle>" unfolding vpair_def by simp
qed simp

subsection\<open>Projection\<close>

definition vprojection :: "V \<Rightarrow> (V \<Rightarrow> V) \<Rightarrow> V \<Rightarrow> V"
  where "vprojection I A i = (\<lambda>f\<in>\<^sub>\<circ>(\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i). f\<lparr>i\<rparr>)"

text\<open>Rules.\<close>

mk_VLambda vprojection_def
  |vsv vprojection_vsv[intro]|
  |vdomain vprojection_vdomain[simp]|
  |app vprojection_app[simp, intro]|

text\<open>Elementary results.\<close>

lemma vprojection_vrange_vsubset:
  assumes "i \<in>\<^sub>\<circ> I"
  shows "\<R>\<^sub>\<circ> (vprojection I A i) \<subseteq>\<^sub>\<circ> A i"
  unfolding vprojection_def
proof(intro vrange_VLambda_vsubset)
  fix f assume prems: "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>I. A i)"
  show "f\<lparr>i\<rparr> \<in>\<^sub>\<circ> A i" by (intro vproductD(3)[OF prems, rule_format] assms)
qed

lemma vprojection_vrange:
  assumes "i \<in>\<^sub>\<circ> I" and "\<And>j. j \<in>\<^sub>\<circ> I \<Longrightarrow> A j \<noteq> 0"
  shows "\<R>\<^sub>\<circ> (vprojection I A i) = A i"
proof
  (
    intro
      vsubset_antisym vprojection_vrange_vsubset vrange_VLambda_vsubset assms(1)
  )
  show "A i \<subseteq>\<^sub>\<circ> \<R>\<^sub>\<circ> (vprojection I A i)"
  proof(intro vsubsetI)
    fix x assume prems: "x \<in>\<^sub>\<circ> A i"
    obtain f
      where f: "\<And>x. x \<in>\<^sub>\<circ> set {A i | i. i \<in>\<^sub>\<circ> I} \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> f\<lparr>x\<rparr> \<in>\<^sub>\<circ> x"
        and "vsv f"
      using that by (rule Axiom_of_Choice)
    define f' where "f' = (\<lambda>j\<in>\<^sub>\<circ>I. if j = i then x else f\<lparr>A j\<rparr>)"
    show "x \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (vprojection I A i)"
      unfolding vprojection_def
    proof(rule rel_VLambda.vsv_vimageI2')
      show "f' \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<lambda>f\<in>\<^sub>\<circ>vproduct I A. f\<lparr>i\<rparr>)"
        unfolding vdomain_VLambda
      proof(intro vproductI, unfold Ball_def; (intro allI conjI impI)?)
        fix j assume "j \<in>\<^sub>\<circ> I"
        with prems assms(2) show "f'\<lparr>j\<rparr> \<in>\<^sub>\<circ> A j"
          unfolding f'_def by (cases \<open>j = i\<close>) (auto intro!: f)
      qed (simp_all add: f'_def)
      with assms(1) show "x = (\<lambda>f\<in>\<^sub>\<circ>vproduct I A. f\<lparr>i\<rparr>)\<lparr>f'\<rparr>"
        unfolding f'_def by simp
    qed
  qed
qed

subsection\<open>Cartesian power of a set\<close>

definition vcpower :: "V \<Rightarrow> V \<Rightarrow> V" (infixr \<open>^\<^sub>\<times>\<close> 80)
  where "A ^\<^sub>\<times> n = (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>n. A)"

text\<open>Rules.\<close>

lemma vcpowerI[intro]:
  assumes "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>n. A)"
  shows "f \<in>\<^sub>\<circ> (A ^\<^sub>\<times> n)"
  using assms unfolding vcpower_def by auto

lemma vcpowerD[dest]:
  assumes "f \<in>\<^sub>\<circ> (A ^\<^sub>\<times> n)"
  shows "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>n. A)"
  using assms unfolding vcpower_def by auto

lemma vcpowerE[elim]:
  assumes "f \<in>\<^sub>\<circ> (A ^\<^sub>\<times> n)" and "f \<in>\<^sub>\<circ> (\<Prod>\<^sub>\<circ>i\<in>\<^sub>\<circ>n. A) \<Longrightarrow> P"
  shows P
  using assms unfolding vcpower_def by auto

text\<open>Set operations.\<close>

lemma vcpower_index_vempty[simp]: "A ^\<^sub>\<times> 0 = set {0}"
  unfolding vcpower_def by (rule vproduct_index_vempty)

lemma vcpower_of_vempty:
  assumes "n \<noteq> 0"
  shows "0 ^\<^sub>\<times> n = 0"
  using assms unfolding vcpower_def vproduct_def by simp

lemma vcpower_vsubset_mono:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "A ^\<^sub>\<times> n \<subseteq>\<^sub>\<circ> B ^\<^sub>\<times> n"
  using assms
  by (intro vsubsetI vcpowerI vproductI)
    (auto intro: vproductD[OF vcpowerD, rule_format])

text\<open>Connections.\<close>

lemma vcpower_vdomain:
  assumes "f \<in>\<^sub>\<circ> (A ^\<^sub>\<times> n)"
  shows "\<D>\<^sub>\<circ> f = n"
  using assms by auto

lemma vcpower_vrange:
  assumes "f \<in>\<^sub>\<circ> (A ^\<^sub>\<times> n)"
  shows "\<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> A"
  using assms by (intro vsubsetI; elim vcpowerE vproductE) auto

text\<open>\newpage\<close>

end


theory Desargues_Property
  imports Main Projective_Plane_Axioms Pappus_Property Pascal_Property
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We formalize Desargues's property, @{term "desargues_prop"}, that states that if two triangles are perspective
from a point, then they are perspective from a line.
Note that some planes satisfy that property and some others don't, hence Desargues's property is
not a theorem though it is a theorem in projective space geometry.
\<close>

section \<open>Desargues's Property\<close>

context projective_plane
begin

lemma distinct3_def:
  "distinct [A, B, C] = (A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C)"
  by auto

definition triangle :: "['point, 'point, 'point] \<Rightarrow> bool" where
"triangle A B C \<equiv> distinct [A,B,C] \<and> (line A B \<noteq> line A C)"

definition meet_in :: "'line \<Rightarrow> 'line => 'point => bool " where
"meet_in l m P \<equiv> incid P l \<and> incid P m"

lemma meet_col_1:
  assumes "meet_in (line A B) (line C D) P"
  shows "col A B P"
  using assms col_def incidA_lAB incidB_lAB meet_in_def
  by blast

lemma meet_col_2:
  assumes "meet_in (line A B) (line C D) P"
  shows "col C D P"
  using assms meet_col_1 meet_in_def
  by auto

definition meet_3_in :: "['line, 'line, 'line, 'point] \<Rightarrow> bool" where
"meet_3_in l m n P \<equiv> meet_in l m P \<and> meet_in l n P"

lemma meet_all_3:
  assumes "meet_3_in l m n P"
  shows "meet_in m n P"
  using assms meet_3_in_def meet_in_def
  by auto

lemma meet_3_col_1:
  assumes "meet_3_in (line A B) m n P"
  shows "col A B P"
  using assms meet_3_in_def meet_col_2 meet_in_def
  by auto

lemma meet_3_col_2:
  assumes "meet_3_in l (line A B) n P"
  shows "col A B P"
  using assms col_def incidA_lAB incidB_lAB meet_3_in_def meet_in_def
  by blast

lemma meet_3_col_3:
  assumes "meet_3_in l m (line A B) P"
  shows "col A B P"
  using assms meet_3_col_2 meet_3_in_def
  by auto

lemma distinct7_def: "distinct [A,B,C,D,E,F,G] = ((A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D) \<and> (A \<noteq> E) \<and> (A \<noteq> F) \<and> (A \<noteq> G) \<and>
(B \<noteq> C) \<and> (B \<noteq> D) \<and> (B \<noteq> E) \<and> (B \<noteq> F) \<and> (B \<noteq> G) \<and>
(C \<noteq> D) \<and> (C \<noteq> E) \<and> (C \<noteq> F) \<and> (C \<noteq> G) \<and>
(D \<noteq> E) \<and> (D \<noteq> F) \<and> (D \<noteq> G) \<and>
(E \<noteq> F) \<and> (E \<noteq> G) \<and>
(F \<noteq> G))"
  by auto

(* From now on we give less general statements on purpose to avoid a lot of uninteresting
degenerate cases, since we can hardly think of any interesting application where one would need
to instantiate a statement on such degenerate case, hence our statements and proofs will be more
textbook-like. For the working mathematician the only thing that probably matters is the main
theorem without considering all the degenerate cases for which the statement might still hold. *)

definition desargues_config ::
  "['point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point] => bool" where
"desargues_config A B C A' B' C' M N P R \<equiv> distinct [A,B,C,A',B',C',R] \<and> \<not> col A B C
\<and> \<not> col A' B' C' \<and> distinct [(line A A'),(line B B'),(line C C')] \<and>
meet_3_in (line A A') (line B B') (line C C') R \<and> (line A B) \<noteq> (line A' B') \<and>
(line B C) \<noteq> (line B' C') \<and> (line A C) \<noteq> (line A' C') \<and> meet_in (line B C) (line B' C') M \<and>
meet_in (line A C) (line A' C') N \<and> meet_in (line A B) (line A' B') P"

lemma distinct7_rot_CW:
  assumes "distinct [A,B,C,D,E,F,G]"
  shows "distinct [C,A,B,F,D,E,G]"
  using assms distinct7_def
  by auto

(* Desargues configurations are stable under any rotation (i,j,k) of {1,2,3} *)

lemma desargues_config_rot_CCW:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "desargues_config B C A B' C' A' N P M R"
  by (simp add: assms desargues_config_rot_CW)

(* With the two following definitions we repackage the definition of a Desargues configuration in a
"high-level", i.e. textbook-like, way. *)

definition are_perspective_from_point ::
  "['point, 'point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"are_perspective_from_point A B C A' B' C' R \<equiv> distinct [A,B,C,A',B',C',R] \<and> triangle A B C \<and>
triangle A' B' C' \<and> distinct [(line A A'),(line B B'),(line C C')] \<and>
meet_3_in (line A A') (line B B') (line C C') R"

definition are_perspective_from_line ::
  "['point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"are_perspective_from_line A B C A' B' C' \<equiv> distinct [A,B,C,A',B',C'] \<longrightarrow> triangle A B C \<longrightarrow>
triangle A' B' C' \<longrightarrow> line A B \<noteq> line A' B' \<longrightarrow> line A C \<noteq> line A' C' \<longrightarrow> line B C \<noteq> line B' C' \<longrightarrow>
col (inter (line A B) (line A' B')) (inter (line A C) (line A' C')) (inter (line B C) (line B' C'))"

lemma meet_in_inter:
  assumes "l \<noteq> m"
  shows "meet_in l m (inter l m)"
  by (simp add: incid_inter_left incid_inter_right meet_in_def)

lemma perspective_from_point_desargues_config:
  assumes "are_perspective_from_point A B C A' B' C' R" and "line A B \<noteq> line A' B'" and
    "line A C \<noteq> line A' C'" and "line B C \<noteq> line B' C'"
  shows "desargues_config A B C A' B' C' (inter (line B C) (line B' C')) (inter (line A C) (line A' C'))
    (inter (line A B) (line A' B')) R"
  unfolding desargues_config_def distinct7_def distinct3_def

  using assms are_perspective_from_point_def  apply auto
      apply (smt (z3) ax_uniqueness col_2cycle col_line_ext_1 incidB_lAB line_ext_def mem_Collect_eq triangle_def)
  apply (smt (z3) ax_uniqueness col_def incidA_lAB line_comm triangle_def)
  using meet_in_inter apply presburger+
  done

(* Now, we state Desargues's property in a textbook-like form *)
definition desargues_prop :: "bool" where
"desargues_prop \<equiv>
\<forall>A B C A' B' C' P.
  are_perspective_from_point A B C A' B' C' P \<longrightarrow> are_perspective_from_line A B C A' B' C'"

end

end


(*  Title:      HOL/Proofs/ex/Hilbert_Classical.thy
    Author:     Stefan Berghofer
    Author:     Makarius Wenzel
*)

section \<open>Hilbert's choice and classical logic\<close>

theory Hilbert_Classical
  imports MainRLT
begin

text \<open>
  Derivation of the classical law of tertium-non-datur by means of
  Hilbert's choice operator (due to M. J. Beeson and J. Harrison).
\<close>

subsection \<open>Proof text\<close>

theorem tertium_non_datur: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (A \<and> x) \<or> \<not> x"
  let ?Q = "\<lambda>x. (A \<and> \<not> x) \<or> x"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    have "\<not> False" ..
    then show "?P False" ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    have True ..
    then show "?Q True" ..
  qed

  from a show ?thesis
  proof
    assume "A \<and> Eps ?P"
    then have A ..
    then show ?thesis ..
  next
    assume "\<not> Eps ?P"
    from b show ?thesis
    proof
      assume "A \<and> \<not> Eps ?Q"
      then have A ..
      then show ?thesis ..
    next
      assume "Eps ?Q"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note \<open>Eps ?Q\<close>
        finally have "Eps ?P" .
        with \<open>\<not> Eps ?P\<close> show False by contradiction
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "\<not> x"
              with \<open>A\<close> have "A \<and> \<not> x" ..
              then show ?thesis ..
            next
              assume "A \<and> x"
              then have x ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "A \<and> \<not> x"
              then have "\<not> x" ..
              then show ?thesis ..
            next
              assume x
              with \<open>A\<close> have "A \<and> x" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by contradiction
      qed
      then show ?thesis ..
    qed
  qed
qed

subsection \<open>Old proof text\<close>

theorem tertium_non_datur1: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>x. (x \<longleftrightarrow> False) \<or> (x \<longleftrightarrow> True) \<and> A"
  let ?Q = "\<lambda>x. (x \<longleftrightarrow> False) \<and> A \<or> (x \<longleftrightarrow> True)"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    show "?P False" using refl ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    show "?Q True" using refl ..
  qed

  from a show ?thesis
  proof
    assume "(Eps ?P \<longleftrightarrow> True) \<and> A"
    then have A ..
    then show ?thesis ..
  next
    assume P: "Eps ?P \<longleftrightarrow> False"
    from b show ?thesis
    proof
      assume "(Eps ?Q \<longleftrightarrow> False) \<and> A"
      then have A ..
      then show ?thesis ..
    next
      assume Q: "Eps ?Q \<longleftrightarrow> True"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        then have "Eps ?P \<longleftrightarrow> Eps ?Q" by (rule arg_cong)
        also note P
        also note Q
        finally show False by (rule False_neq_True)
      qed
      have "\<not> A"
      proof
        assume A
        have "?P = ?Q"
        proof (rule ext)
          show "?P x \<longleftrightarrow> ?Q x" for x
          proof
            assume "?P x"
            then show "?Q x"
            proof
              assume "x \<longleftrightarrow> False"
              from this and \<open>A\<close> have "(x \<longleftrightarrow> False) \<and> A" ..
              then show ?thesis ..
            next
              assume "(x \<longleftrightarrow> True) \<and> A"
              then have "x \<longleftrightarrow> True" ..
              then show ?thesis ..
            qed
          next
            assume "?Q x"
            then show "?P x"
            proof
              assume "(x \<longleftrightarrow> False) \<and> A"
              then have "x \<longleftrightarrow> False" ..
              then show ?thesis ..
            next
              assume "x \<longleftrightarrow> True"
              from this and \<open>A\<close> have "(x \<longleftrightarrow> True) \<and> A" ..
              then show ?thesis ..
            qed
          qed
        qed
        with neq show False by contradiction
      qed
      then show ?thesis ..
    qed
  qed
qed

subsection \<open>Old proof script\<close>

theorem tertium_non_datur2: "A \<or> \<not> A"
  apply (subgoal_tac
      "(((SOME x. x = False \<or> x = True \<and> A) = False) \<or>
      ((SOME x. x = False \<or> x = True \<and> A) = True) \<and> A) \<and>
      (((SOME x. x = False \<and> A \<or> x = True) = False) \<and> A \<or>
      ((SOME x. x = False \<and> A \<or> x = True) = True))")
   prefer 2
   apply (rule conjI)
    apply (rule someI)
    apply (rule disjI1)
    apply (rule refl)
   apply (rule someI)
   apply (rule disjI2)
   apply (rule refl)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule disjE)
    apply (erule conjE)
    apply (erule disjI1)
   prefer 2
   apply (erule conjE)
   apply (erule disjI1)
  apply (subgoal_tac
      "(\<lambda>x. (x = False) \<or> (x = True) \<and> A) \<noteq>
      (\<lambda>x. (x = False) \<and> A \<or> (x = True))")
   prefer 2
   apply (rule notI)
   apply (drule_tac f = "\<lambda>y. SOME x. y x" in arg_cong)
   apply (drule trans, assumption)
   apply (drule sym)
   apply (drule trans, assumption)
   apply (erule False_neq_True)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule ext)
  apply (rule iffI)
   apply (erule disjE)
    apply (rule disjI1)
    apply (erule conjI)
    apply assumption
   apply (erule conjE)
   apply (erule disjI2)
  apply (erule disjE)
   apply (erule conjE)
   apply (erule disjI1)
  apply (rule disjI2)
  apply (erule conjI)
  apply assumption
  done

subsection \<open>Proof terms\<close>

prf tertium_non_datur
prf tertium_non_datur1
prf tertium_non_datur2

end