theory Desargues_2D
  imports Main Higher_Projective_Space_Rank_Axioms Matroid_Rank_Properties
begin

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

text \<open>
Contents:
\<^item> We prove Desargues's theorem: if two triangles ABC and A'B'C' are perspective from a point P (ie.
the lines AA', BB' and CC' are concurrent in P), then they are perspective from a line (ie. the points
\<alpha> = BC \<inter> B'C', \<beta> = AC \<inter> A'C' and \<gamma> = AB \<inter> A'B' are collinear).
In this file we restrict ourself to the case where the two triangles ABC and A'B'C' are coplanar.
\<close>

section \<open>Desargues's Theorem: The Coplanar Case\<close>

definition desargues_config_2D ::
  "[Points, Points, Points, Points, Points, Points, Points, Points, Points, Points] \<Rightarrow> bool"
  where "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma> \<equiv> rk {A, B, C} = 3 \<and> rk {A', B', C'} = 3 \<and>
rk {A, A', P} = 2 \<and> rk {B, B', P} = 2 \<and> rk {C, C', P} = 2 \<and> rk {A, B, \<gamma>} = 2 \<and> rk {A', B', \<gamma>} = 2 \<and>
rk {A, C, \<beta>} = 2 \<and> rk {A', C', \<beta>} = 2 \<and> rk {B, C, \<alpha>} = 2 \<and> rk {B', C', \<alpha>} = 2 \<and>
rk {A, B, C, A', B', C'} = 3 \<and>
(* We add the following non-degeneracy conditions *)
rk {A, B, P} = 3 \<and> rk {A, C, P} = 3 \<and> rk {B, C, P} = 3 \<and>
rk {A, A'} = 2 \<and> rk {B, B'} = 2 \<and> rk {C, C'} = 2"

lemma coplanar_ABCA'B'C'P :
  assumes "rk {A, A'} = 2" and "rk {A, B, C, A', B', C'} = 3" and "rk {A, A', P} = 2"
  shows "rk {A, B, C, A', B', C', P} = 3"
proof-
  have "rk {A, B, C, A', B', C', P} + rk {A, A'} \<le> rk {A, B, C, A', B', C'} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, B, C, A', B', C'}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, C, A', B', C', P} \<le> 3"
    using assms(1) assms(2) assms(3)
    by linarith
  then show "rk {A, B, C, A', B', C', P} = 3"
    using assms(2) matroid_ax_2
    by (metis Un_insert_right Un_upper2 le_antisym sup_bot.right_neutral)
qed

lemma non_colinear_A'B'P :
  assumes "rk {A, B, P} = 3" and "rk {A, A', P} = 2" and "rk {B, B', P} = 2" and "rk {A', P} = 2"
and "rk {B', P} = 2"
  shows "rk {A', B', P} = 3"
proof-
  have f1:"rk {A', B', P} \<le> 3"
    using rk_triple_le by auto
  have "rk {A, B, A', B', P} \<ge> 3"
    using assms(1) matroid_ax_2
    by (metis insert_mono insert_subset subset_insertI)
  then have f2:"rk {A, B, A', B', P} = 3"
    using matroid_ax_3_alt[of "{P}" "{A, A', P}" "{B, B', P}"] assms(2) assms(3)
    by (simp add: insert_commute rk_singleton)
  have "rk {A, B, A', B', P} + rk {B', P} \<le> rk {A, A', B', P} + rk {B, B', P}"
    using matroid_ax_3_alt[of "{B', P}" "{A, A', B', P}" "{B, B', P}"]
    by (simp add: insert_commute)
  then have "rk {A, A', B', P} \<ge> 3"
    using f2 assms(3) assms(5) by linarith
  then have f3:"rk {A, A', B', P} = 3"
    using f2 matroid_ax_2
    by (metis eq_iff insert_commute subset_insertI)
  have "rk {A, A', B', P} + rk {A', P} \<le> rk {A', B', P} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A', P}" "{A', B', P}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A', B', P} \<ge> 3"
    using f3 assms(2) assms(4) by linarith
  thus "rk {A', B', P} = 3"
    using f1 by auto
qed

lemma desargues_config_2D_non_collinear_P :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 2" and "rk {B', P} = 2"
and "rk {C', P} = 2"
  shows "rk {A', B', P} = 3" and "rk {A', C', P} = 3" and "rk {B', C', P} = 3"
proof-
  show "rk {A', B', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2)
      assms(3)
    by blast
  show "rk {A', C', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2)
      assms(4)
    by blast
  show "rk {B', C', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(3)
      assms(4)
    by blast
qed

lemma rk_A'B'PQ :
  assumes "rk {A, A'} = 2" and "rk {A, B, C, A', B', C'} = 3" and "rk {A, A', P} = 2" and
"rk {A, B, P} = 3" and "rk {B, B', P} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and
"rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {A', B', P, Q} = 4"
proof-
  have "card {A', B', P, Q} \<le> 4"
    by (smt One_nat_def Suc_numeral card.insert card_empty finite.emptyI finite_insert insert_absorb
        insert_not_empty linear nat_add_left_cancel_le numeral_3_eq_3 numeral_Bit0 numeral_code(3)
        numeral_le_one_iff numerals(1) one_plus_numeral semiring_norm(4) semiring_norm(69)
        semiring_norm(70) semiring_norm(8))
  then have f1:"rk {A', B', P, Q} \<le> 4"
    using matroid_ax_1b dual_order.trans by blast
  have "rk {A, B, C, A', B', C', P, Q} + rk {A', B', P} \<le> rk {A', B', P, Q} + rk {A, B, C, A', B', C', P}"
    using matroid_ax_3_alt[of "{A', B', P}" "{A', B', P, Q}" "{A, B, C, A', B', C', P}"]
    by (simp add: insert_commute)
  then have "rk {A', B', P, Q} \<ge> rk {A, B, C, A', B', C', P, Q} + rk {A', B', P} - rk {A, B, C, A', B', C', P}"
    using le_diff_conv
    by blast
  then have f2:"rk {A', B', P, Q} \<ge> 4"
    using assms non_colinear_A'B'P coplanar_ABCA'B'C'P
    by (smt diff_add_inverse2 le_trans)
  from f1 and f2 show "rk {A', B', P, Q} = 4"
    by (simp add: f1 eq_iff)
qed

lemma desargues_config_2D_rkA'B'PQ_rkA'C'PQ_rkB'C'PQ :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 2" and "rk {B', P} = 2"
and "rk {C', P} = 2" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {A', B', P, Q} = 4" and "rk {A', C', P, Q} = 4" and "rk {B', C', P, Q} = 4"
proof-
  show "rk {A', B', P, Q} = 4"
    using rk_A'B'PQ[of "A" "A'" "B" "C" "B'" "C'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(5)
    by blast
  show "rk {A', C', P, Q} = 4"
    using rk_A'B'PQ[of "A" "A'" "C" "B" "C'" "B'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(4) assms(5)
    by (metis insert_commute)
  show "rk {B', C', P, Q} = 4"
    using rk_A'B'PQ[of "B" "B'" "C" "A" "C'" "A'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(3) assms(4) assms(5)
    by (metis insert_commute)
qed

lemma rk_A'B'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4"
shows "rk {A', B', P, R} = 4"
proof-
  have "card {A', B', P, R} \<le> 4"
    by (smt Suc_numeral assms(2) card_empty card_insert_disjoint dual_order.trans finite.emptyI
        finite_insert insert_absorb linear nat_add_left_cancel_le numeral_2_eq_2 numeral_3_eq_3
        numeral_Bit0 numeral_code(3) numeral_le_one_iff rk_singleton rk_triple_le semiring_norm(2)
        semiring_norm(69) semiring_norm(8))
  then have f1:"rk {A', B', P, R} \<le> 4"
    using dual_order.trans matroid_ax_1b
    by auto
  have f2:"rk {A', B', P, Q, R} + rk {P, R} \<le> rk {A', B', P, R} + rk {P, Q, R}"
    using matroid_ax_3_alt[of "{P, R}" "{A', B', P, R}" "{P, Q, R}"]
    by (simp add: insert_commute)
  have f3:"rk {A', B', P, Q, R} \<ge> 4"
    using matroid_ax_2 assms(3)
    by (metis insert_mono subset_insertI)
  from f2 and f3 have f4:"rk {A', B', P, R} \<ge> 4"
    using assms(1) assms(2)
    by linarith
  thus "rk {A', B', P, R} = 4"
    using f1 f4
    by (simp add: f1 le_antisym)
qed

lemma rk_A'C'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', C', P, Q} = 4"
  shows "rk {A', C', P, R} = 4"
  using assms(1) assms(2) assms(3) rk_A'B'PR
  by blast

lemma rk_B'C'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {B', C', P, Q} = 4"
  shows "rk {B', C', P, R} = 4"
  using assms(1) assms(2) assms(3) rk_A'C'PR
  by blast

lemma rk_ABA' :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, B, A'} = 3"
proof-
  have "rk {A, B, A', P} + rk {A, A'} \<le> rk {A, B, A'} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, B, A'}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, A'} \<ge> 3"
    using assms matroid_ax_2
    by (smt eq_iff insert_absorb2 insert_commute non_colinear_A'B'P rk_couple)
  thus "rk {A, B, A'} = 3"
    by (simp add: le_antisym rk_triple_le)
qed

lemma desargues_config_2D_non_collinear :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, A'} = 3" and "rk {A, B, B'} = 3" and "rk {A, C, C'} = 3"
proof-
  show "rk {A, B, A'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by auto
  show "rk {A, B, B'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by (smt insert_commute)
  show "rk {A, C, C'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by (smt insert_commute)
qed

lemma rk_Aa :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2" and "rk {Q, A', a} = 2"
and "rk {A, B, C, A', B', C', P, Q} \<ge> 4" and "rk {A, B, C, A', B', C'} \<le> 3"
  shows "rk {A, a} = 2"
proof-
  have "rk {Q, A', A, a} + rk {a} \<le> rk {Q, A', a} + rk {A, a}"
    using matroid_ax_3_alt[of "{a}" "{Q, A', a}" "{A, a}"]
    by (simp add: insert_commute)
  then have "rk {Q, A', A, a} \<le> rk {Q, A', a} + rk {A, a} - rk {a}"
    using add_le_imp_le_diff
    by blast
  then have "rk {Q, A', A, a} \<le> 2" if "rk {A, a} = 1"
    using assms(4)
    by (simp add: rk_singleton that)
  then have "rk {Q, A', A} \<le> 2" if "rk {A, a} = 1"
    using matroid_ax_2
    by (metis One_nat_def assms(4) le_numeral_extra(4) nat_add_left_cancel_le numeral_2_eq_2
        numeral_3_eq_3 one_add_one rk_couple rk_triple_le that)
  then have "rk {Q, A', A} = 2" if "rk {A, a} = 1"
    using assms(2) matroid_ax_2
    by (metis assms(4) numeral_eq_one_iff rk_couple semiring_norm(85) that)
  then have "rk {A, A', P, Q} = 2" if "rk {A, a} = 1"
    using assms(3) matroid_ax_3_alt'[of "{A, A'}" "P" "Q"]
    by (simp add: assms(2) insert_commute that)
  then have f1:"rk {A, A', B, P, Q} \<le> 3" if "rk {A, a} = 1"
    by (metis One_nat_def Un_insert_right add.right_neutral add_Suc_right insert_commute matroid_ax_2_alt
        numeral_2_eq_2 numeral_3_eq_3 sup_bot.right_neutral that)
  have "rk {A, B, C, A', B', C', P, Q} + rk {A, B, A'} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'}"
    using matroid_ax_3_alt[of "{A, B, A'}" "{A, A', B, P, Q}" "{A, B, C, A', B', C'}"]
    by (simp add: insert_commute)
  then have "rk {A, B, C, A', B', C', P, Q} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'} - rk {A, B, A'}"
    by linarith
  then have "rk {A, B, C, A', B', C', P, Q} \<le> 3" if "rk {A, a} = 1"
    using assms(1) assms(2) assms(3) assms(6) f1 rk_ABA'
    by (smt \<open>rk {A, B, C, A', B', C', P, Q} + rk {A, B, A'} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'}\<close>
        add_diff_cancel_right' add_leD2 le_less_trans not_le
        ordered_cancel_comm_monoid_diff_class.add_diff_inverse
        ordered_cancel_comm_monoid_diff_class.le_add_diff that)
  then have "\<not> (rk {A, a} = 1)"
    using assms(5)
    by linarith
  thus "rk {A, a} = 2"
    using rk_couple rk_singleton_bis
    by blast
qed

lemma desargues_config_2D_rkAa_rkBb_rkCc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2"
  shows "rk {A, a} = 2" and "rk {B, b} = 2" and "rk {C, c} = 2"
proof-
  show "rk {A, a} = 2"
    using rk_Aa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(3)
    by (metis rk_triple_le)
  show "rk {B, b} = 2"
    using rk_Aa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(4)
    by (smt insert_commute rk_triple_le)
  show "rk {C, c} = 2"
    using rk_Aa[of "C" "A" "P" "C'" "Q" "c" "B" "B'" "A'"] assms(1)
      desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5)
    by (metis insert_commute rk_triple_le)
qed

lemma rk_ABPRa :
  assumes "rk {A, B, P} = 3" and "rk {A, B, C, A', B', C', P} = 3" and "rk {P, Q, R} = 2"
and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4"
  shows "rk {A, B, P, R, a} \<ge> 4"
proof-
  have "rk {A', B', P, R, a, A, B} \<ge> rk {A', B', P, R}"
    using matroid_ax_2
    by auto
  then have f1:"rk {A', B', P, R, a, A, B} \<ge> 4"
    using rk_A'B'PR assms(3) assms(4) assms(5)
    by auto
  have f2:"rk {A', B', A, B, P} \<le> 3"
    using matroid_ax_2 assms(2)
    by (smt insertI1 insert_subset subset_insertI)
  have "rk {A', B', P, R, a, A, B} + rk {A, B, P} \<le> rk {A, B, P, R, a} + rk {A', B', A, B, P}"
    using matroid_ax_3_alt[of "{A, B, P}" "{A, B, P, R, a}" "{A', B', A, B, P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, P, R, a} \<ge> rk {A', B', P, R, a, A, B} + rk {A, B, P} - rk {A', B', A, B, P}"
    by linarith
  thus "rk {A, B, P, R, a} \<ge> 4"
    using f1 assms(1) f2
    by linarith
qed

lemma rk_ABPa :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2" and "rk {Q, A', a} = 2"
and "rk {A, B, C, A', B', C', P, Q} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3" and "rk {P, Q, R} = 2"
and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4" and "rk {R, A, a} = 2"
  shows "rk {A, B, P, a} \<ge> 4"
proof-
  have "rk {A, B, C, A', B', C'} \<le> 3"
    using matroid_ax_2 assms(6)
    by (smt insert_iff subsetI)
  then have f1:"rk {A, a} = 2"
    using assms(1) assms(2) assms(3) assms(4) assms(5) rk_Aa
    by blast
  have f2:"rk {A, B, P, R, a} \<ge> 4"
    using assms(1) assms(6) assms(7) assms(8) assms(9) rk_ABPRa
    by blast
  have "rk {A, B, P, R, a} + rk {A, a} \<le> rk {A, B, P, a} + rk {R, A, a}"
    using matroid_ax_3_alt[of "{A, a}" "{A, B, P, a}" "{R, A, a}"]
    by (simp add: insert_commute)
  thus "rk {A, B, P, a} \<ge> 4"
    using f1 f2 assms(10)
    by (smt add_le_imp_le_diff diff_add_inverse2 order_trans)
qed

lemma desargues_config_2D_rkABPa_rkABPb_rkABPc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and
"rk {Q, A', a} = 2" and "rk {R, A, a} = 2" and "rk {Q, B', b} = 2" and "rk {R, B, b} = 2" and
"rk {Q, C', c} = 2" and "rk {R, C, c} = 2"
  shows "rk {A, B, P, a} \<ge> 4" and "rk {A, B, P, b} \<ge> 4" and "rk {A, B, P, c} \<ge> 4"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  have f2:"rk {A', B', P, Q} = 4"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5) assms(6)
      rk_A'B'PQ[of "A" "A'" "B" "C" "B'" "C'" "P" "Q"]
    by auto
  show "rk {A, B, P, a} \<ge> 4"
    using f1 f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(7) assms(2) assms(3)
      assms(4) assms(8) rk_ABPa
    by auto
  show "rk {A, B, P, b} \<ge> 4"
    using f1 f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(9) assms(2) assms(3)
      assms(4) assms(10) rk_ABPa[of "B" "A" "P" "B'" "Q" "b" "C" "A'" "C'" "R"]
    by (metis insert_commute)
  show "rk {A, B, P, c} \<ge> 4"
  proof-
    have f3:"rk {A, B, P, R, c} \<ge> 4"
      using rk_ABPRa[of A B P C A' B' C' Q R c] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
        f1 assms(3) assms(4) f2
      by auto
    have "{A, B, P, R, c} \<subseteq> {A, B, C, P, R, c}"
      by auto
    then have f4:"rk {A, B, C, P, R, c} \<ge> 4"
      using matroid_ax_2 f3
      by (meson dual_order.trans)
    have "rk {A, B, C, P, R, c} + rk {C, c} \<le> rk {A, B, C, P, c} + rk {R, C, c}"
      using matroid_ax_3_alt[of "{C,c}" "{A, B, C, P, c}" "{R, C, c}"]
      by (simp add: insert_commute)
    then have f5:"rk {A, B, C, P, c} \<ge> 4"
      using f4 assms(12) desargues_config_2D_rkAa_rkBb_rkCc assms(1) assms(9) assms(11) assms(2) assms(7)
      by auto
    have f6:"rk {A, B, C, P} \<le> 3"
      using matroid_ax_2 f1
      by (smt insert_iff subsetI)
    have "rk {A, B, C, P, c} + rk {A, B, P} \<le> rk {A, B, P, c} + rk {A, B, C, P}"
      using matroid_ax_3_alt[of "{A, B, P}" "{A, B, P, c}" "{A, B, C, P}"]
      by (simp add: insert_commute)
    then have "rk {A, B, P, c} \<ge> rk {A, B, C, P, c}"
      using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f6
      by linarith
    thus "rk {A, B, P, c} \<ge> 4"
      using f5
      by linarith
  qed
qed

lemma rk_AA'C :
  assumes "rk {A, C, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, A', C} \<ge> 3"
proof-
  have f1:"rk {A, C, A', P} \<ge> 3"
    using assms(1) matroid_ax_2
    by (metis insert_commute subset_insertI)
  have "rk {A, C, A', P} + rk {A, A'} \<le> rk {A, A', C} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, A', C}" "{A, A', P}"]
    by (simp add: insert_commute)
  thus "rk {A, A', C} \<ge> 3"
    using f1 assms(2) assms(3)
    by linarith
qed

lemma rk_AA'C' :
  assumes "rk {A', C', P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, A', C'} \<ge> 3"
  by (smt assms(1) assms(2) assms(3) insert_commute rk_AA'C)

lemma rk_AA'Ca :
  assumes "rk {A, A', C} \<ge> 3" and "rk {A, B, P, a} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3"
  shows "rk {A, A', C, a} \<ge> 4"
proof-
  have f1:"rk {A, A', C, a, B, P} \<ge> 4"
    using assms(2) matroid_ax_2
    by (smt dual_order.trans insert_commute insert_mono insert_subset subset_insertI)
  have f2:"rk {A, B, C, P, A'} \<le> 3"
    using assms(3) matroid_ax_2
    by (smt empty_subsetI insert_commute insert_mono semiring_norm(3))
  have "rk {A, A', C, a, B, P} + rk {A, A', C} \<le> rk {A, A', C, a} + rk {A, B, C, P, A'}"
    using matroid_ax_3_alt[of "{A, A', C}" "{A, A', C, a}" "{A, B, C, P, A'}"]
    by (simp add: insert_commute)
  then have "rk {A, A', C, a} \<ge> rk {A, A', C, a, B, P} + rk {A, A', C} - rk {A, B, C, P, A'}"
    using le_diff_conv
    by blast
  thus "rk {A, A', C, a} \<ge> 4"
    using f1 assms(1) f2
    by linarith
qed

lemma rk_AA'C'a :
  assumes "rk {A, A', C'} \<ge> 3" and "rk {A, B, P, a} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3"
  shows "rk {A, A', C', a} \<ge> 4"
  by (smt assms(1) assms(2) assms(3) insert_commute rk_AA'Ca)

lemma rk_Ra :
  assumes "rk {Q, A', a} = 2" and "rk {P, Q, R} = 2" and "rk {R, Q} = 2" and "rk {A, A', P} = 2"
and "rk {A', P} = 2" and "rk {A, B, C, A', B', C', P} = 3" and "rk {A, B, A'} = 3" and
"rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {R, a} = 2"
proof-
  have "R = a" if "rk {R, a} = 1"
    using rk_couple_to_singleton
    by (simp add: that)
  then have "rk {R, Q, A'} = 2" if "rk {R, a} = 1"
    using assms(1)
    by (simp add: insert_commute that)
  then have f1:"rk {P, Q, R, A'} = 2" if "rk {R, a} = 1"
    using assms(2) assms(3) matroid_ax_3_alt'
    by (metis Un_empty_right Un_insert_right insert_commute that)
  have "rk {P, Q, R, A', A} + rk {A', P} \<le> rk {A, A', P} + rk {P, Q, R, A'}"
    using matroid_ax_3_alt[of "{A', P}" "{A, A', P}" "{P, Q, R, A'}"]
    by (simp add: insert_commute)
  then have "rk {P, Q, R, A', A} = 2" if "rk {R, a} = 1"
    using assms(4) f1 assms(5)
    by (metis Un_insert_right add_le_cancel_right insert_is_Un le_antisym matroid_ax_2 subset_insertI that)
  then have f2:"rk {P, Q, R, A', A, B} \<le> 3" if "rk {R, a} = 1"
    using matroid_ax_2_alt[of "{P, Q, R, A', A}" "B"]
    by (simp add: insert_commute that)
  have f3:"rk {A, B, A', P} \<ge> 3"
    using assms(7) matroid_ax_2
    by (metis insert_commute subset_insertI)
  have "rk {P, Q, R, A', A, B, C, B', C'} + rk {A, B, A', P} \<le> rk {P, Q, R, A', A, B} + rk {A, B, C, A', B', C', P}"
    using matroid_ax_3_alt[of "{A, B, A', P}" "{P, Q, R, A', A, B}" "{A, B, C, A', B', C', P}"]
    by (simp add: insert_commute)
  then have f4:"rk {P, Q, R, A', A, B, C, B', C'} \<le> 3" if "rk {R, a} = 1"
    using f2 f3 assms(6) that
    by linarith
  have f5:"rk {P, Q, R, A', A, B, C, B', C'} \<ge> rk {A, B, C, A', B', C', P, Q}"
    using matroid_ax_2
    by auto
  thus "rk {R, a} = 2" using f4 f5 assms(8)
    by (smt Suc_1 Suc_le_eq add_Suc add_Suc_right nat_1_add_1 not_le numeral_2_eq_2 numeral_3_eq_3
        numeral_Bit0 order.trans rk_couple rk_singleton_bis)
qed

lemma desargues_config_2D_rkRa_rkRb_rkRc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {P, Q, R} = 2" and "rk {Q, R} = 2" and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and
"rk {Q, C', c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {R, a} = 2" and "rk {R, b} = 2" and "rk {R, c} = 2"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by blast
  have f2:"rk {A, B, A'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  have f3:"rk {A, B, B'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  have f4:"rk {A, C, C'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  show "rk {R, a} = 2"
    using f1 f2 rk_Ra[of Q A' a P R A B C B' C'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(5) assms(8)
    by (metis insert_commute)
  show "rk {R, b} = 2"
    using f1 f3 rk_Ra[of Q B' b P R B A C A' C'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(6) assms(9)
    by (metis insert_commute)
  show "rk {R, c} = 2"
    using f1 f4 rk_Ra[of Q C' c P R C A B A' B'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(7) assms(10)
    by (metis insert_commute)
qed

lemma rk_acAC\<beta> :
  assumes "rk {R, A, a} = 2" and "rk {R, C, c} = 2" and "rk {A, C} = 2" and "rk {A, C, \<beta>} = 2"
and "rk {Q, A', a} = 2" and "rk {A, A', C, a} \<ge> 4"
  shows "rk {a, c, A, C, \<beta>} = 3"
proof-
  have "rk {a, c, A, C, R} + rk {R} \<le> rk {R, A, a} + rk {R, C, c}"
    using matroid_ax_3_alt[of "{R}" "{R, A, a}" "{R, C, c}"]
    by (simp add: insert_commute)
  then have f1:"rk {a, c, A, C, R} \<le> 3"
    using assms(1) assms(2)
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono add_Suc_right numeral_3_eq_3 numeral_nat(1) numerals(1)
        rk_singleton)
  have "rk {a, c, A, C, R, \<beta>} + rk {A, C} \<le> rk {a, c, A, C, R} + rk {A, C, \<beta>}"
    using matroid_ax_3_alt[of "{A, C}" "{a, c, A, C, R}" "{A, C, \<beta>}"]
    by (simp add: insert_commute)
  then have f2:"rk {a, c, A, C, R, \<beta>} \<le> 3"
    using f1 assms(3) assms(4)
    by linarith
  have "{a, c, A, C, \<beta>} \<subseteq> {a, c, A, C, R, \<beta>}"
    by auto
  then have f3:"rk {a, c, A, C, \<beta>} \<le> 3"
    using matroid_ax_2 f2
    by (meson order_trans)
  have f4:"rk {A, A', C, a, c, Q} \<ge> 4"
    using matroid_ax_2 assms(6)
    by (smt dual_order.trans insert_commute insert_mono insert_subset subset_insertI)
  have "rk {A, A', C, a, c, Q} + rk {a} \<le> rk {a, c, A, C} + rk {Q, A', a}"
    using matroid_ax_3_alt[of "{a}" "{a, c, A, C}" "{Q, A', a}"]
    by (simp add: insert_commute)
  then have "rk {a, c, A, C} \<ge> rk {A, A', C, a, c, Q} + rk {a} - rk {Q, A', a}"
    using le_diff_conv
    by blast
  then have "rk {a, c, A, C} \<ge> 3"
    using f4 assms(5)
    by (smt One_nat_def \<open>rk {A, A', C, a, c, Q} + rk {a} \<le> rk {a, c, A, C} + rk {Q, A', a}\<close>
        ab_semigroup_add_class.add_ac(1) add_2_eq_Suc' add_diff_cancel_right' add_le_imp_le_diff
        card.empty card.insert dual_order.antisym finite.intros(1) insert_absorb insert_not_empty
        matroid_ax_1b nat_1_add_1 numeral_3_eq_3 numeral_Bit0 order.trans rk_ax_singleton)
  then have "rk {a, c, A, C, \<beta>} \<ge> 3"
    using matroid_ax_2
    by (metis Un_insert_right Un_upper2 dual_order.trans sup_bot.comm_neutral)
  thus "rk {a, c, A, C, \<beta>} = 3"
    using f3 le_antisym
    by blast
qed

lemma rk_acA'C'\<beta> :
  assumes "rk {Q, A', a} = 2" and "rk {Q, C', c} = 2" and "rk {A', C'} = 2" and "rk {A', C', \<beta>} = 2"
and "rk {R, A, a} = 2" and "rk {A', A, C', a} \<ge> 4"
  shows "rk {a, c, A', C', \<beta>} = 3"
  using assms rk_acAC\<beta>
  by blast

lemma plane_representation_change :
  assumes "rk {A, B, C, P} = 3" and "rk {B, C, P} = 3" and "rk {A, B, C, Q} = 4"
  shows "rk {P, B, C, Q} = 4"
proof-
  have "rk {P, B, C, Q} \<le> 4" using assms(2) matroid_ax_2_alt[of "{B, C, P}" "Q"]
    by (simp add: insert_commute)
  have "rk {A, B, C, Q, P} + rk {B, C, P} \<le> rk {P, B, C, Q} + rk {A, B, C, P}"
    using matroid_ax_3_alt[of "{B, C, P}" "{P, B, C, Q}" "{A, B, C, P}"]
    by (simp add: insert_commute)
  then have "rk {P, B, C, Q} \<ge> 4"
    using assms
    by (smt add.commute dual_order.trans insert_commute matroid_ax_2 nat_add_left_cancel_le
        subset_insertI)
  thus "rk {P, B, C, Q} = 4"
    by (simp add: \<open>rk {P, B, C, Q} \<le> 4\<close> antisym)
qed

lemma desargues_config_2D_rkABCP :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, P} = 3"
proof-
  have "rk {A, B, C} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  then have f1:"rk {A, B, C, P} \<ge> 3"
    using matroid_ax_2
    by (metis empty_subsetI insert_mono)
  have f2:"rk {A, B, C, A', B', C', P} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P] coplanar_ABCA'B'C'P
    by auto
  have "{A, B, C, P} \<subseteq> {A, B, C, A', B', C', P}"
    by auto
  then have "rk {A, B, C, P} \<le> 3"
    using matroid_ax_2 f2
    by metis
  thus "rk {A, B, C, P} = 3"
    using f1 antisym
    by blast
qed

lemma desargues_config_2D_rkABCabc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {R, A, a} = 2" and
"rk {A', P} = 2" and "rk {B', P} = 2"
  shows "rk {A, B, C, a, b, c} \<ge> 4"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  have f2:"rk {A', B', P, Q} = 4"
    using rk_A'B'PQ[of A A' B C B' C' P Q] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(7) assms(8)
    by auto
  from f1 and f2 have f3:"rk {A, B, P, a} \<ge> 4"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(3) assms(4)
      assms(5) assms(6) rk_ABPa
    by auto
  have "{A, B, P, a} \<subseteq> {A, B, C, a, b, c, P}"
    by auto
  then have f4:"rk {A, B, C, a, b, c, P} \<ge> 4"
    using matroid_ax_2 f3
    by (meson dual_order.trans)
  have f5:"rk {A, B, C, P} = 3"
    using assms(1) desargues_config_2D_rkABCP
    by auto
  have "rk {A, B, C, a, b, c, P} + rk {A, B, C} \<le> rk {A, B, C, a, b, c} + rk {A, B, C, P}"
    using matroid_ax_3_alt[of "{A, B, C}" "{A, B, C, a, b, c}" "{A, B, C, P}"]
    by (simp add: insert_commute)
  thus "rk {A, B, C, a, b, c} \<ge> 4"
    using f4 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f5
    by linarith
qed

lemma rk_abc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, c} = 3"
proof-
  have "rk {a, b, c} \<le> 3"
    by (simp add: rk_triple_le)
  have "rk {A, B, C, a, b, c} \<ge> 4"
    using desargues_config_2D_rkABCabc assms(1) assms(13) assms(2) assms(3) assms(6) assms(7) assms(9)
      assms(12)
    by auto
  then have f1:"rk {A, B, C, R, a, b, c} \<ge> 4"
    using matroid_ax_2
    by (smt dual_order.trans insert_commute subset_insertI)
  have f2:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  have f3:"rk {A, C, C'} = 3"
    using assms(1) desargues_config_2D_non_collinear(3)
    by auto
  from f2 and f3 have f4:"rk {R, c} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5) assms(6)
      assms(8) assms(14) rk_Ra[of Q C' c P R C A B A' B']
    by (metis insert_commute)
  have "rk {A, B, C, R, a, b, c} + rk {R, c} \<le> rk {a, b, c, R, A, B} + rk {R, C, c}"
    using matroid_ax_3_alt[of "{R, c}" "{a, b, c, R, A, B}" "{R, C, c}"]
    by (simp add: insert_commute)
  then have f5:"rk {a, b, c, R, A, B} \<ge> 4"
    using f1 f4 assms(11)
    by linarith
  have "rk {A, B, B'} = 3"
    using assms(1) desargues_config_2D_non_collinear(2)
    by auto
  then have f6:"rk {R, b} = 2"
    using f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      rk_Ra[of Q B' b P R B A C A' C'] assms(2) assms(4) assms(6) assms(8) assms(13)
    by (metis insert_commute)
  have "rk {a, b, c, R, A, B} + rk {R, b} \<le> rk {a, b, c, R, A} + rk {R, B, b}"
    using matroid_ax_3_alt[of "{R, b}" "{a, b, c, R, A}" "{R, B, b}"]
    by (simp add: insert_commute)
  then have f7:"rk {a, b, c, R, A} \<ge> 4"
    using f5 f6 assms(10)
    by linarith
  have "rk {a, b, c, R, A} + rk {a} \<le> rk {a, b, c} + rk {R, A, a}"
    using matroid_ax_3_alt[of "{a}" "{a, b, c}" "{R, A, a}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c} \<ge> 3"
    using f7 assms(9)
    by (smt One_nat_def Suc_eq_plus1 Suc_le_mono Suc_numeral add.assoc card.empty card.insert
        dual_order.trans finite.intros(1) insert_absorb insert_not_empty le_antisym matroid_ax_1b
        one_add_one rk_ax_singleton semiring_norm(2) semiring_norm(8))
  thus "rk {a, b, c} = 3"
    by (simp add: \<open>rk {a, b, c} \<le> 3\<close> le_antisym)
qed

lemma rk_ac\<beta> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, c, \<beta>} = 2"
proof-
  have "rk {a, b, c} = 3"
    using rk_abc assms
    by auto
  then have "rk {a, c} = 2"
    by (metis insert_commute rk_triple_to_rk_couple)
  then have "rk {a, c, \<beta>} \<ge> 2"
    using matroid_ax_2
    by (metis empty_subsetI insert_mono)
  have f1:"rk {a, c, A, C, A', C', \<beta>} + rk {a, c, \<beta>} \<le> rk {a, c, A, C, \<beta>} + rk {a, c, A', C', \<beta>}"
    using matroid_ax_3_alt[of "{a, c, \<beta>}" "{a, c, A, C, \<beta>}" "{a, c, A', C', \<beta>}"]
    by (simp add: insert_commute)
  have f2:"rk {A, A', C} \<ge> 3"
    using rk_AA'C assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  have f3:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  then have f4:"rk {A, B, P, a} \<ge> 4"
    using rk_ABPa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (meson assms(12) assms(13) assms(14) assms(2) assms(3) assms(6) assms(7) assms(9)
        desargues_config_2D_rkA'B'PQ_rkA'C'PQ_rkB'C'PQ(1))
  have "rk {A, A', C, a} \<ge> 4"
    using f2 f3 f4 rk_AA'Ca[of A A' C B P a B' C']
    by auto
  then have f5:"rk {a, c, A, C, \<beta>} = 3"
    using rk_acAC\<beta>[of R A a C c \<beta> Q A'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(9) assms(11) assms(3) rk_triple_to_rk_couple
    by blast
  have "rk {A', A, C', a} \<ge> 4"
    using rk_AA'C'a[of A A' C' B P a C B'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (smt assms(12) assms(13) assms(14) desargues_config_2D_non_collinear_P(2) f3 f4 insert_commute
        rk_AA'C)
  then have f6:"rk {a, c, A', C', \<beta>} = 3"
    using rk_acA'C'\<beta>[of Q A' a C' c \<beta> R A] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(3) assms(5) assms(9)
    by (metis (full_types) insert_commute rk_triple_to_rk_couple)
  have "{A, A', C, a} \<subseteq> {a, c, A, C, A', C', \<beta>}"
    by auto
  then have f7:"rk {a, c, A, C, A', C', \<beta>} \<ge> 4"
    using matroid_ax_2
    by (meson \<open>4 \<le> rk {A, A', C, a}\<close> dual_order.trans)
  then have "rk {a, c, \<beta>} \<le> 2"
    using f1 f5 f6
    by linarith
  thus "rk {a, c, \<beta>} = 2"
    using \<open>2 \<le> rk {a, c, \<beta>}\<close> le_antisym
    by blast
qed

lemma rk_ab\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, \<gamma>} = 2"
proof-
  have "desargues_config_2D A C B A' C' B' P \<alpha> \<gamma> \<beta>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of A C B A' C' B' P \<alpha> \<gamma> \<beta>]
    by (metis insert_commute)
  thus "rk {a, b, \<gamma>} = 2"
    using rk_ac\<beta>[of A C B A' C' B' P \<alpha> \<gamma> \<beta> Q a c b R]
    by (metis assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5)
        assms(6) assms(7) assms(8) assms(9) insert_commute)
qed

lemma rk_bc\<alpha> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {b, c, \<alpha>} = 2"
proof-
  have "desargues_config_2D B A C B' A' C' P \<beta> \<alpha> \<gamma>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of B A C B' A' C' P \<beta> \<alpha> \<gamma>]
    by (metis insert_commute)
  thus "rk {b, c, \<alpha>} = 2"
    using rk_ac\<beta>[of B A C B' A' C' P \<beta> \<alpha> \<gamma> Q b a c R]
    by (metis assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5)
        assms(6) assms(7) assms(8) assms(9) insert_commute)
qed

lemma rk_abc\<alpha>\<beta>\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  have f1:"rk {a, b, \<gamma>} = 2"
    using rk_ab\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have f2:"rk {a, c, \<beta>} = 2"
    using rk_ac\<beta>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have f3:"rk {b, c, \<alpha>} = 2"
    using rk_bc\<alpha>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have "rk {a, b, c, \<beta>, \<gamma>} + rk {a} \<le> rk {a, b, \<gamma>} + rk {a, c, \<beta>}"
    using matroid_ax_3_alt[of "{a}" "{a, b, \<gamma>}" "{a, c, \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c, \<beta>, \<gamma>} \<le> 3"
    using f1 f2
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono add_Suc_right numeral_3_eq_3 numeral_nat(1) numerals(1)
        rk_singleton)
  then have f4:"rk {a, b, c, \<beta>, \<gamma>} = 3"
    using matroid_ax_2 rk_abc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R]
    by (metis Un_upper2 assms(1) assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3)
        assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) insert_mono le_antisym sup_bot.comm_neutral)
  have "rk {a, b, c} = 3"
    using rk_abc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms(1) assms(10) assms(11) assms(12) assms(13)
      assms(14) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9)
    by blast
  then have f5:"rk {b, c} = 2"
    using rk_triple_to_rk_couple rk_couple
    by force
  have "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} + rk {b, c} \<le> rk {a, b, c, \<beta>, \<gamma>} + rk {b, c, \<alpha>}"
    using matroid_ax_3_alt[of "{b, c}" "{a, b, c, \<beta>, \<gamma>}" "{b, c, \<alpha>}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} \<le> 3"
    using f3 f4 f5
    by linarith
  thus "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} = 3"
    using matroid_ax_2
    by (metis \<open>rk {a, b, c} = 3\<close> empty_subsetI insert_mono le_antisym)
qed

lemma rk_\<alpha>\<beta>\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "rk {A, B, C, a, b, c} \<ge> 4"
    using desargues_config_2D_rkABCabc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a R b c] assms
    by auto
  have "{A, B, C, a, b, c} \<subseteq> {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>}"
    by auto
  then have f1:"rk {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>} \<ge> 4"
    using matroid_ax_2
    by (meson \<open>4 \<le> rk {A, B, C, a, b, c}\<close> dual_order.trans)
  have "rk {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>} + rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {a, b, c, \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_3_alt[of "{\<alpha>, \<beta>, \<gamma>}" "{A, B, C, \<alpha>, \<beta>, \<gamma>}" "{a, b, c, \<alpha>, \<beta>, \<gamma>}"]
    by (simp add: insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using f1 rk_ABC\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] rk_abc\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R]
    by (smt One_nat_def Suc_1 Suc_le_eq add_Suc_right add_le_imp_le_diff assms(1) assms(10) assms(11)
        assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8)
        assms(9) diff_add_inverse2 le_antisym nat_1_add_1 not_less numeral_3_eq_3 one_plus_numeral
        rk_triple_le semiring_norm(2) semiring_norm(4))
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_1 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "A' = P"
    by (simp add: assms(2) rk_couple_to_singleton)
  then have "rk {A', C', C, \<beta>} + rk {C', A'} \<le> rk {C, C', P} + rk {A', C', \<beta>}"
    using matroid_ax_3_alt[of "{C', A'}" "{C, C', P}" "{A', C', \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {A', C', C, \<beta>} \<le> rk {A', C', \<beta>}"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis (full_types) add_le_cancel_right insert_commute rk_triple_to_rk_couple)
  then have f5:"rk {A', C', C, \<beta>} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute le_antisym matroid_ax_2 subset_insertI)
  have "rk {A, A', C, a, C', \<beta>} + rk {A, C, \<beta>} \<le> rk {A, A', C', C, \<beta>} + rk {a, A, C, \<beta>}" for a
    using matroid_ax_3_alt[of "{A, C, \<beta>}" "{A, A', C', C, \<beta>}" "{a, A, C, \<beta>}"]
    by (simp add: insert_commute)
  then have f6:"rk {A, A', C', C, \<beta>} \<ge> 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_AA'Ca rk_acAC\<beta>
    by (metis Un_insert_right Un_upper2 \<open>A' = P\<close> insert_commute matroid_ax_2 sup_bot.right_neutral)
  have "rk {A, A', C', C, \<beta>} + rk {\<beta>, C} \<le> rk {A, C, \<beta>} + rk {A', C', C, \<beta>}"
    using matroid_ax_3_alt[of "{\<beta>, C}" "{A, C, \<beta>}" "{A', C', C, \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {\<beta>, C} \<le> 1"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f5 f6
    by linarith
  then have "\<beta> = C"
    using rk_couple
    by force
  have "rk {A', B', B, \<gamma>} + rk {B', A'} \<le> rk {B, B', P} + rk {A', B', \<gamma>}"
    using matroid_ax_3_alt[of "{B', A'}" "{B, B', P}" "{A', B', \<gamma>}"]
    by (simp add: \<open>A' = P\<close> insert_commute)
  then have "rk {A', B', B, \<gamma>} \<le> rk {A', B', \<gamma>}"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis (full_types) add_le_cancel_right insert_commute rk_triple_to_rk_couple)
  then have f7:"rk {A', B', B, \<gamma>} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute le_antisym matroid_ax_2 subset_insertI)
  have "rk {A, A', B, a, B', \<gamma>} + rk {A, B, \<gamma>} \<le> rk {A, A', B', B, \<gamma>} + rk {a, A, B, \<gamma>}" for a
    using matroid_ax_3_alt[of "{A, B, \<gamma>}" "{A, A', B', B, \<gamma>}" "{a, A, B, \<gamma>}"]
    by (simp add: insert_commute)
  then have f8:"rk {A, A', B', B, \<gamma>} \<ge> 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_AA'Ca rk_acAC\<beta>
    by (metis Un_insert_right Un_upper2 \<open>A' = P\<close> insert_commute matroid_ax_2 sup_bot.right_neutral)
  have "rk {A, A', B', B, \<gamma>} + rk {\<gamma>, B} \<le> rk {A, B, \<gamma>} + rk {A', B', B, \<gamma>}"
    using matroid_ax_3_alt[of "{\<gamma>, B}" "{A, B, \<gamma>}" "{A', B', B, \<gamma>}"]
    by (simp add: insert_commute)
  then have "rk {\<gamma>, B} \<le> 1"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f7 f8
    by linarith
  then have "\<gamma> = B"
    using rk_couple
    by force
  then have "rk {\<alpha>, \<beta>, \<gamma>} = rk {\<alpha>, C, B}"
    using \<open>\<beta> = C \<close>
    by auto
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute order_refl)
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_2 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {B', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "desargues_config_2D B A C B' A' C' P \<beta> \<alpha> \<gamma>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of B A C B' A' C' P \<beta> \<alpha> \<gamma>]
    by (metis insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1[of B A C B' A' C' P \<beta> \<alpha> \<gamma>] assms(2)
    by (simp add: insert_commute)
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_3 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {C', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "desargues_config_2D  C B A C' B' A' P \<gamma> \<beta> \<alpha>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of C B A C' B' A' P \<gamma> \<beta> \<alpha>]
    by (metis insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1[of C B A C' B' A' P \<gamma> \<beta> \<alpha>] assms(2)
    by (simp add: insert_commute)
qed

theorem desargues_2D :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  obtain Q where "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
    using f1 rk_ext[of "{A, B, C, A', B', C', P}"]
    by (metis Un_insert_left add.commute one_plus_numeral order_refl semiring_norm(2) semiring_norm(4)
        sup_bot.left_neutral)
  obtain R where "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {Q, R} = 2"
    using rk_ax_3_pts
    by auto
  have "rk {Q, A', R, A, P} + rk {P} \<le> rk {P, Q, R} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, A', R, A, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f2:"rk {Q, A', R, A} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, hide_lams) dual_order.trans insert_commute subset_insertI)
  obtain a where "rk {Q, A', a} = 2" and "rk {R, A, a} = 2"
    using f2 rk_ax_pasch
    by blast
  have "rk {Q, B', R, B, P} + rk {P} \<le> rk {P, Q, R} + rk {B, B', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{B, B', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, B', R, B, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f3:"rk {Q, B', R, B} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, hide_lams) dual_order.trans insert_commute subset_insertI)
  obtain b where "rk {Q, B', b} = 2" and "rk {R, B, b} = 2"
    using f3 rk_ax_pasch
    by blast
  have "rk {Q, C', R, C, P} + rk {P} \<le> rk {P, Q, R} + rk {C, C', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{C, C', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, C', R, C, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f4:"rk {Q, C', R, C} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, hide_lams) dual_order.trans insert_commute subset_insertI)
  obtain c where "rk {Q, C', c} = 2" and "rk {R, C, c} = 2"
    using f4 rk_ax_pasch
    by blast
  then have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
    using rk_\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] \<open>4 \<le> rk {A, B, C, A', B', C', P, Q}\<close>
      \<open>rk {P, Q, R} = 2\<close> \<open>rk {P, R} = 2\<close> \<open>rk {Q, A', a} = 2\<close> \<open>rk {Q, B', b} = 2\<close> \<open>rk {Q, R} = 2\<close>
      \<open>rk {R, A, a} = 2\<close> \<open>rk {R, B, b} = 2\<close> assms that(1) that(2) that(3)
    by blast
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {A', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1 assms that
    by auto
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {B', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_2 assms that
    by auto
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {C', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_3 assms that
    by auto
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using \<open>\<lbrakk>rk {A', P} = 2; rk {B', P} = 2; rk {C', P} = 2\<rbrakk> \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close>
      \<open>rk {A', P} = 1 \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close> \<open>rk {B', P} = 1 \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close>
      rk_couple rk_singleton_bis
    by blast
qed

end


(* Author: Bohua Zhan, with modifications by Tobias Nipkow *)

section \<open>Interval Trees\<close>

theory Interval_Tree
imports
  "HOL-Data_Structures.Cmp"
  "HOL-Data_Structures.List_Ins_Del"
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Set_Specs"
begin

subsection \<open>Intervals\<close>

text \<open>The following definition of intervals uses the \<^bold>\<open>typedef\<close> command
to define the type of non-empty intervals as a subset of the type of pairs \<open>p\<close>
where @{prop "fst p \<le> snd p"}:\<close>

typedef (overloaded) 'a::linorder ivl =
  "{p :: 'a \<times> 'a. fst p \<le> snd p}" by auto

text \<open>More precisely, @{typ "'a ivl"} is isomorphic with that subset via the function
@{const Rep_ivl}. Hence the basic interval properties are not immediate but
need simple proofs:\<close>

definition low :: "'a::linorder ivl \<Rightarrow> 'a" where
"low p = fst (Rep_ivl p)"

definition high :: "'a::linorder ivl \<Rightarrow> 'a" where
"high p = snd (Rep_ivl p)"

lemma ivl_is_interval: "low p \<le> high p"
by (metis Rep_ivl high_def low_def mem_Collect_eq)

lemma ivl_inj: "low p = low q \<Longrightarrow> high p = high q \<Longrightarrow> p = q"
by (metis Rep_ivl_inverse high_def low_def prod_eqI)

text \<open>Now we can forget how exactly intervals were defined.\<close>

instantiation ivl :: (linorder) linorder begin

definition ivl_less: "(x < y) = (low x < low y | (low x = low y \<and> high x < high y))"
definition ivl_less_eq: "(x \<le> y) = (low x < low y | (low x = low y \<and> high x \<le> high y))"

instance proof
  fix x y z :: "'a ivl"
  show a: "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    using ivl_less ivl_less_eq by force
  show b: "x \<le> x"
    by (simp add: ivl_less_eq)
  show c: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    using ivl_less_eq by fastforce
  show d: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    using ivl_less_eq a ivl_inj ivl_less by fastforce
  show e: "x \<le> y \<or> y \<le> x"
    by (meson ivl_less_eq leI not_less_iff_gr_or_eq)
qed end

definition overlap :: "('a::linorder) ivl \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"overlap x y \<longleftrightarrow> (high x \<ge> low y \<and> high y \<ge> low x)"

definition has_overlap :: "('a::linorder) ivl set \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"has_overlap S y \<longleftrightarrow> (\<exists>x\<in>S. overlap x y)"

subsection \<open>Interval Trees\<close>

type_synonym 'a ivl_tree = "('a ivl * 'a) tree"

fun max_hi :: "('a::order_bot) ivl_tree \<Rightarrow> 'a" where
"max_hi Leaf = bot" |
"max_hi (Node _ (_,m) _) = m"

definition max3 :: "('a::linorder) ivl \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"max3 a m n = max (high a) (max m n)"

fun inv_max_hi :: "('a::{linorder,order_bot}) ivl_tree \<Rightarrow> bool" where
"inv_max_hi Leaf \<longleftrightarrow> True" |
"inv_max_hi (Node l (a, m) r) \<longleftrightarrow> (m = max3 a (max_hi l) (max_hi r) \<and> inv_max_hi l \<and> inv_max_hi r)"

lemma max_hi_is_max:
  "inv_max_hi t \<Longrightarrow> a \<in> set_tree t \<Longrightarrow> high a \<le> max_hi t"
by (induct t, auto simp add: max3_def max_def)

lemma max_hi_exists:
  "inv_max_hi t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> \<exists>a\<in>set_tree t. high a = max_hi t"
proof (induction t rule: tree2_induct)
  case Leaf
  then show ?case by auto
next
  case N: (Node l v m r)
  then show ?case
  proof (cases l rule: tree2_cases)
    case Leaf
    then show ?thesis
      using N.prems(1) N.IH(2) by (cases r, auto simp add: max3_def max_def le_bot)
  next
    case Nl: Node
    then show ?thesis
    proof (cases r rule: tree2_cases)
      case Leaf
      then show ?thesis
        using N.prems(1) N.IH(1) Nl by (auto simp add: max3_def max_def le_bot)
    next
      case Nr: Node
      obtain p1 where p1: "p1 \<in> set_tree l" "high p1 = max_hi l"
        using N.IH(1) N.prems(1) Nl by auto
      obtain p2 where p2: "p2 \<in> set_tree r" "high p2 = max_hi r"
        using N.IH(2) N.prems(1) Nr by auto
      then show ?thesis
        using p1 p2 N.prems(1) by (auto simp add: max3_def max_def)
    qed
  qed
qed

subsection \<open>Insertion and Deletion\<close>

definition node where
[simp]: "node l a r = Node l (a, max3 a (max_hi l) (max_hi r)) r"

fun insert :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
"insert x Leaf = Node Leaf (x, high x) Leaf" |
"insert x (Node l (a, m) r) =
  (case cmp x a of
     EQ \<Rightarrow> Node l (a, m) r |
     LT \<Rightarrow> node (insert x l) a r |
     GT \<Rightarrow> node l a (insert x r))"

lemma inorder_insert:
  "sorted (inorder t) \<Longrightarrow> inorder (insert x t) = ins_list x (inorder t)"
by (induct t rule: tree2_induct) (auto simp: ins_list_simps)

lemma inv_max_hi_insert:
  "inv_max_hi t \<Longrightarrow> inv_max_hi (insert x t)"
by (induct t rule: tree2_induct) (auto simp add: max3_def)

fun split_min :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<times> 'a ivl_tree" where
"split_min (Node l (a, m) r) =
  (if l = Leaf then (a, r)
   else let (x,l') = split_min l in (x, node l' a r))"

fun delete :: "'a::{linorder,order_bot} ivl \<Rightarrow> 'a ivl_tree \<Rightarrow> 'a ivl_tree" where
"delete x Leaf = Leaf" |
"delete x (Node l (a, m) r) =
  (case cmp x a of
     LT \<Rightarrow> node (delete x l) a r |
     GT \<Rightarrow> node l a (delete x r) |
     EQ \<Rightarrow> if r = Leaf then l else
           let (a', r') = split_min r in node l a' r')"

lemma split_minD:
  "split_min t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x # inorder t' = inorder t"
by (induct t arbitrary: t' rule: split_min.induct)
   (auto simp: sorted_lems split: prod.splits if_splits)

lemma inorder_delete:
  "sorted (inorder t) \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
by (induct t)
   (auto simp: del_list_simps split_minD Let_def split: prod.splits)

lemma inv_max_hi_split_min:
  "\<lbrakk> t \<noteq> Leaf;  inv_max_hi t \<rbrakk> \<Longrightarrow> inv_max_hi (snd (split_min t))"
by (induct t) (auto split: prod.splits)

lemma inv_max_hi_delete:
  "inv_max_hi t \<Longrightarrow> inv_max_hi (delete x t)"
apply (induct t)
 apply simp
using inv_max_hi_split_min by (fastforce simp add: Let_def split: prod.splits)

subsection \<open>Search\<close>

text \<open>Does interval \<open>x\<close> overlap with any interval in the tree?\<close>

fun search :: "'a::{linorder,order_bot} ivl_tree \<Rightarrow> 'a ivl \<Rightarrow> bool" where
"search Leaf x = False" |
"search (Node l (a, m) r) x =
  (if overlap x a then True
   else if l \<noteq> Leaf \<and> max_hi l \<ge> low x then search l x
   else search r x)"

lemma search_correct:
  "inv_max_hi t \<Longrightarrow> sorted (inorder t) \<Longrightarrow> search t x = has_overlap (set_tree t) x"
proof (induction t rule: tree2_induct)
  case Leaf
  then show ?case by (auto simp add: has_overlap_def)
next
  case (Node l a m r)
  have search_l: "search l x = has_overlap (set_tree l) x"
    using Node.IH(1) Node.prems by (auto simp: sorted_wrt_append)
  have search_r: "search r x = has_overlap (set_tree r) x"
    using Node.IH(2) Node.prems by (auto simp: sorted_wrt_append)
  show ?case
  proof (cases "overlap a x")
    case True
    thus ?thesis by (auto simp: overlap_def has_overlap_def)
  next
    case a_disjoint: False
    then show ?thesis
    proof cases
      assume [simp]: "l = Leaf"
      have search_eval: "search (Node l (a, m) r) x = search r x"
        using a_disjoint overlap_def by auto
      show ?thesis
        unfolding search_eval search_r
        by (auto simp add: has_overlap_def a_disjoint)
    next
      assume "l \<noteq> Leaf"
      then show ?thesis
      proof (cases "max_hi l \<ge> low x")
        case max_hi_l_ge: True
        have "inv_max_hi l"
          using Node.prems(1) by auto
        then obtain p where p: "p \<in> set_tree l" "high p = max_hi l"
          using \<open>l \<noteq> Leaf\<close> max_hi_exists by auto
        have search_eval: "search (Node l (a, m) r) x = search l x"
          using a_disjoint \<open>l \<noteq> Leaf\<close> max_hi_l_ge by (auto simp: overlap_def)
        show ?thesis
        proof (cases "low p \<le> high x")
          case True
          have "overlap p x"
            unfolding overlap_def using True p(2) max_hi_l_ge by auto
          then show ?thesis
            unfolding search_eval search_l
            using p(1) by(auto simp: has_overlap_def overlap_def)
        next
          case False
          have "\<not>overlap x rp" if asm: "rp \<in> set_tree r" for rp
          proof -
            have "low p \<le> low rp"
              using asm p(1) Node(4) by(fastforce simp: sorted_wrt_append ivl_less)
            then show ?thesis
              using False by (auto simp: overlap_def)
          qed
          then show ?thesis
            unfolding search_eval search_l
            using a_disjoint by (auto simp: has_overlap_def overlap_def)
        qed
      next
        case False
        have search_eval: "search (Node l (a, m) r) x = search r x"
          using a_disjoint False by (auto simp: overlap_def)
        have "\<not>overlap x lp" if asm: "lp \<in> set_tree l" for lp
          using asm False Node.prems(1) max_hi_is_max
          by (fastforce simp: overlap_def)
        then show ?thesis
          unfolding search_eval search_r
          using a_disjoint by (auto simp: has_overlap_def overlap_def)
      qed
    qed
  qed
qed

definition empty :: "'a ivl_tree" where
"empty = Leaf"

subsection \<open>Specification\<close>

locale Interval_Set = Set +
  fixes has_overlap :: "'t \<Rightarrow> 'a::linorder ivl \<Rightarrow> bool"
  assumes set_overlap: "invar s \<Longrightarrow> has_overlap s x = Interval_Tree.has_overlap (set s) x"

fun invar :: "('a::{linorder,order_bot}) ivl_tree \<Rightarrow> bool" where
"invar t = (inv_max_hi t \<and> sorted(inorder t))"

interpretation S: Interval_Set
  where empty = Leaf and insert = insert and delete = delete
  and has_overlap = search and isin = isin and set = set_tree
  and invar = invar
proof (standard, goal_cases)
  case 1
  then show ?case by auto
next
  case 2
  then show ?case by (simp add: isin_set_inorder)
next
  case 3
  then show ?case by(simp add: inorder_insert set_ins_list flip: set_inorder)
next
  case 4
  then show ?case by(simp add: inorder_delete set_del_list flip: set_inorder)
next
  case 5
  then show ?case by auto
next
  case 6
  then show ?case by (simp add: inorder_insert inv_max_hi_insert sorted_ins_list)
next
  case 7
  then show ?case by (simp add: inorder_delete inv_max_hi_delete sorted_del_list)
next
  case 8
  then show ?case by (simp add: search_correct)
qed

end


theory fixed_points imports "HOL-Cardinals.Cardinal_Order_Relation"
begin

locale Fix_Lim_Ord =
  fixes r :: \<open>'a rel\<close>
  fixes b :: \<open>'b :: complete_lattice\<close>
  assumes WELL: \<open>Well_order r\<close>
    and isLimOrd_r: \<open>isLimOrd r\<close>
    and ab_card: \<open>\<not>(\<exists> f. \<forall> n \<in> Field r. \<exists> x :: 'b. f x = n)\<close> (*there is no surjective function from the lattice to the set of ordinals*)
begin

lemma wo_rel_r: \<open>wo_rel r\<close>
  by (simp add: WELL wo_rel.intro Kleene_iter_lpfp)

definition iterS where \<open>iterS f \<delta> x \<equiv> f x\<close>

definition iterL where \<open>iterL rec n \<equiv> Sup (rec ` underS r n)\<close>

definition iter where
  \<open>iter f s \<delta> = worecZSL r s (iterS f) iterL \<delta>\<close>

lemma adm_woL_iterL: \<open>adm_woL r iterL\<close>
  unfolding iterL_def wo_rel.adm_woL_def[OF wo_rel_r] by auto

lemma succ_Field: \<open>n \<in> Field r \<Longrightarrow> succ r n \<in> Field r\<close>
  by (simp add: isLimOrd_r wo_rel.isLimOrd_succ wo_rel_r)

lemma above_Field: \<open>aboveS r n \<noteq> {} \<Longrightarrow> n \<in> Field r\<close>
  by (meson FieldI1 wo_rel.succ_in_diff wo_rel_r)

lemma iter_zero[simp]: \<open>iter f s (zero r) = s\<close>
  using iter_def wo_rel.worecZSL_zero wo_rel_r adm_woL_iterL by metis

lemma iter_succ[simp]: \<open>n \<in> Field r \<Longrightarrow> iter f s (succ r n) = f (iter f s n)\<close>
  using iter_def iterS_def wo_rel.worecZSL_succ wo_rel_r adm_woL_iterL wo_rel.isLimOrd_aboveS isLimOrd_r by metis

lemma iter_lim[simp]: \<open>isLim r n \<Longrightarrow> n \<noteq> zero r \<Longrightarrow> iter f s n = Sup (iter f s ` underS r n)\<close>
proof-
  assume \<open>isLim r n\<close> \<open>n \<noteq> zero r\<close>
  have \<open>worecZSL r s (iterS f) iterL n = iterL (worecZSL r s (iterS f) iterL) n\<close>
    using wo_rel.worecZSL_isLim wo_rel_r adm_woL_iterL \<open>isLim r n\<close> \<open>n \<noteq> zero r\<close> by metis
  moreover have \<open>... = Sup (worecZSL r s (iterS f) iterL ` underS r n)\<close>
    using iterL_def by auto
  ultimately show ?thesis
    by (simp add: iter_def)
qed

lemma prefixes_iter:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>n \<in> Field r \<Longrightarrow> s \<le> p \<Longrightarrow> f p \<le> p \<Longrightarrow> iter f s n \<le> p\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case by simp
next
  case (2 i)
  then have \<open>i \<in> Field r\<close>
    by (meson WELL well_order_on_domain wo_rel.succ_in_diff wo_rel_r)
  with 2 show ?case
    using fmono by (metis dual_order.trans iter_succ monoE)
next
  case (3 i)
  then show ?case
    using iter_lim by (simp add: BNF_Least_Fixpoint.underS_Field SUP_least)
qed

lemma mono_chain_iter_succ:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>n \<in> Field r \<Longrightarrow> s \<le> f s \<Longrightarrow> iter f s n \<le> iter f s (succ r n)\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by simp
next
  case (2 i)
  then have \<open>iter f s i \<le> iter f s (succ r i)\<close>
    by (simp add: above_Field)
  then have \<open>f (iter f s i) \<le> f (iter f s (succ r i))\<close>
    using 2(4) fmono monotoneD by metis
  then show ?case
    by (simp add: "2.hyps"(1) "2.prems"(1) above_Field)
next
  case (3 i)
  then have *: \<open>iter f s i = Sup (iter f s ` underS r i)\<close>
    by simp
  then have **: \<open>\<forall> j \<in> underS r i. iter f s j \<le> iter f s i\<close>
    by (simp add: SUP_upper)
  have \<open>\<forall> j \<in> underS r i. iter f s j \<le> f (iter f s i)\<close>
  proof safe
    fix j
    assume \<open>j \<in> underS r i\<close>
    then have \<open>j \<in> Field r\<close>
      using 3 by (meson BNF_Least_Fixpoint.underS_Field)
    then have \<open>iter f s j \<le> f (iter f s j)\<close>
      using 3 by (simp add: \<open>j \<in> underS r i\<close>)
    have \<open>iter f s j \<le> iter f s i\<close>
      using ** \<open>j \<in> underS r i\<close> by simp
    then have \<open>f (iter f s j) \<le> f (iter f s i)\<close>
      using 3(5) fmono monotoneD by metis
    with \<open>iter f s j \<le> f (iter f s j)\<close> show \<open>iter f s j \<le> f (iter f s i)\<close>
      by simp
  qed
  then have \<open>Sup (iter f s ` underS r i) \<le> f (iter f s i)\<close>
    by (simp add: Sup_le_iff)
  with * show ?case
    by (simp add: "3.prems"(1))
qed

lemma mono_chain_iter_under:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>m \<in> under r n \<Longrightarrow> s \<le> f s \<Longrightarrow> iter f s m \<le> iter f s n\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by (metis empty_iff order_refl singletonD under_empty wo_rel.under_zero wo_rel_r)
next
  case (2 i)
  then have \<open>m \<in> under r i \<or> m = succ r i\<close>
    by (metis insertE wo_rel.under_succ wo_rel_r)
  moreover have \<open>iter f s i \<le> iter f s (succ r i)\<close>
    using 2 above_Field mono_chain_iter_succ fmono by simp
  ultimately show ?case
    using "2.hyps"(2) "2.prems"(2) by fastforce
next
  case (3 i)
  then show ?case
    by (metis SUP_upper iter_lim mem_Collect_eq order_class.order_eq_iff underS_I under_def)
qed

lemma reach_fixpoint_succ:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>s \<le> f s \<Longrightarrow> \<exists> n \<in> Field r. iter f s n = iter f s (succ r n)\<close>
proof (rule ccontr)
  assume assms: \<open>s \<le> f s\<close>
  assume \<open>\<not>(\<exists> n \<in> Field r. iter f s n = iter f s (succ r n))\<close>
  then have \<open>\<forall> n \<in> Field r. iter f s n < iter f s (succ r n)\<close>
    using fmono assms mono_chain_iter_succ nless_le by meson
  have \<open>m \<noteq> n \<Longrightarrow> m \<in> underS r n \<Longrightarrow> iter f s m < iter f s n\<close> for m n
  proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
    case 1
    then show ?case
      by (simp add: wo_rel.underS_zero wo_rel_r)
  next
    case (2 i)
    then show ?case
      using \<open>\<forall> n \<in> Field r. iter f s n < iter f s (succ r n)\<close>
      by (metis (no_types, lifting) dual_order.strict_trans local.above_Field underS_E underS_I wo_rel.less_succ wo_rel_r)
  next
    case (3 i)
    then have \<open>succ r m \<in> under r i\<close>
      using underS_subset_under under_def wo_rel.succ_smallest wo_rel_r by fastforce
    then have \<open>iter f s (succ r m) \<le> iter f s i\<close>
      by (simp add: assms fmono mono_chain_iter_under)
    moreover have \<open>iter f s m \<le> iter f s (succ r m)\<close>
      by (meson fmono BNF_Least_Fixpoint.underS_Field 3(5) assms mono_chain_iter_succ)
    moreover have \<open>m \<in> Field r\<close>
      by (meson "3.prems"(2) BNF_Least_Fixpoint.underS_Field)
    ultimately show ?case
      using \<open>\<forall>n\<in>Field r. iter f s n < iter f s (succ r n)\<close> by auto
  qed
  then have \<open>\<forall> n \<in> Field r. \<forall> m \<in> Field r. n \<noteq> m \<longrightarrow> iter f s n \<noteq> iter f s m\<close>
    by (metis dual_order.irrefl underS_I wo_rel.in_notinI wo_rel_r)
  have \<open>\<forall> n \<in> Field r. \<exists> x :: 'b. (\<lambda> i. THE n. n \<in> Field r \<and> iter f s n = i) x = n\<close>
  proof
    fix n
    assume \<open>n \<in> Field r\<close>
    then have \<open>(\<lambda> i. THE n. n \<in> Field r \<and> iter f s n = i) (iter f s n) = n\<close>
      using \<open>\<forall>n\<in>Field r. \<forall>m\<in>Field r. n \<noteq> m \<longrightarrow> iter f s n \<noteq> iter f s m\<close> by auto
    then show \<open>\<exists> x :: 'b. (\<lambda> i. THE n. n \<in> Field r \<and> iter f s n = i) x = n\<close>
      by auto
  qed
  then show False
    using ab_card by meson
qed

lemma reach_fixpoint_above:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>s \<le> f s \<Longrightarrow> iter f s n = iter f s (succ r n) \<Longrightarrow> n \<in> under r m \<Longrightarrow> iter f s n = iter f s m\<close>
proof (induct m rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by (metis emptyE insertE under_empty wo_rel.under_zero wo_rel_r)
next
  case (2 i)
  then show ?case
    by (metis in_mono insert_iff iter_succ local.above_Field under_Field wo_rel.under_succ wo_rel_r)
next
  case (3 i)
  show ?case
  proof (cases \<open>n = i\<close>)
    case True
    then show ?thesis
      by simp
  next
    case False
    have \<open>\<forall> j \<in> under r n. iter f s j \<le> iter f s n\<close>
      using 3 fmono mono_chain_iter_under by blast
    moreover have \<open>\<forall> j. n \<in> under r j \<and> j \<in> underS r i \<longrightarrow> iter f s n = iter f s j\<close>
      using 3 by fast
    moreover have \<open>\<forall> j \<in> underS r i. j \<in> underS r n \<or> n \<in> under r j\<close>
      by (metis (no_types, lifting) "3.prems"(3) isLimOrd_r subsetD underS_I underS_subset_under
          under_Field wo_rel.TOTALS wo_rel.isLimOrd_aboveS wo_rel.succ_diff wo_rel.succ_in wo_rel.underS_succ wo_rel_r)
    ultimately have \<open>\<forall> x \<in> {iter f s j | j. j \<in> underS r i}. x \<le> iter f s n\<close>
      using in_mono mem_Collect_eq order_refl underS_subset_under by fastforce
    moreover have \<open>iter f s n \<in> {iter f s j | j. j \<in> underS r i}\<close>
      using False by (metis (mono_tags, lifting) "3.prems"(3) mem_Collect_eq underS_I under_def)
    moreover have \<open>iter f s i = Sup {iter f s j | j. j \<in> underS r i}\<close>
      by (simp add: "3.hyps"(1) "3.hyps"(2) Setcompr_eq_image)
    ultimately show ?thesis
      by (metis (mono_tags, lifting) Sup_least Sup_upper order_antisym_conv)
  qed
qed

definition Fix\<delta> where \<open>Fix\<delta> f s = (SOME n. n \<in> Field r \<and> iter f s n = iter f s (succ r n))\<close>

definition Fix where \<open>Fix f s \<equiv> iter f s (Fix\<delta> f s)\<close>

lemma Fix_in_Field_and_fixed:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>s \<le> f s \<Longrightarrow> Fix\<delta> f s \<in> Field r \<and> iter f s (Fix\<delta> f s) = iter f s (succ r (Fix\<delta> f s))\<close>
proof-
  let ?n = \<open>SOME n. n \<in> Field r \<and> iter f s n = iter f s (succ r n)\<close>
  assume \<open>s \<le> f s\<close>
  then have \<open>\<exists> n. n \<in> Field r \<and> iter f s n = iter f s (succ r n)\<close>
    using reach_fixpoint_succ fmono by blast
  then have \<open>?n \<in> Field r \<and> iter f s ?n = iter f s (succ r ?n)\<close>
    by (metis (mono_tags, lifting) some_eq_imp)
  then show ?thesis
    unfolding Fix\<delta>_def by meson
qed

lemma Fix_is_fixed:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>s \<le> f s \<Longrightarrow> Fix f s = f (Fix f s)\<close>
  unfolding Fix_def using fmono Fix_in_Field_and_fixed iter_succ by metis

lemma Fix_is_least:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>s \<le> f s \<Longrightarrow> s \<le> x \<Longrightarrow> x = f x \<Longrightarrow> Fix f s \<le> x\<close>
proof-
  assume \<open>s \<le> f s\<close> \<open>s \<le> x\<close> \<open>x = f x\<close>
  then have \<open>iter f s (Fix\<delta> f s) \<le> x\<close>
    using fmono Fix_in_Field_and_fixed by (metis order_refl prefixes_iter)
  then show ?thesis
    unfolding Fix_def by simp
qed

lemma Fix_meet:
  assumes \<open>mono (f :: 'b \<Rightarrow> 'b)\<close> \<open>s \<le> f s\<close> \<open>mono g\<close> \<open>s \<le> g s\<close> \<open>mono h\<close> \<open>s \<le> h s\<close>
    and \<open>\<forall> n. inf (iter f s n) (iter g s n) \<le> iter h s n\<close>
  shows \<open>inf (Fix f s) (Fix g s) \<le> Fix h s\<close>
proof-
  let ?m2 = \<open>max2 r (Fix\<delta> g s) (Fix\<delta> h s)\<close>
  let ?m = \<open>max2 r (Fix\<delta> f s) ?m2\<close>
  have xField: \<open>Fix\<delta> f s \<in> Field r\<close>
    using \<open>mono f\<close> \<open>s \<le> f s\<close> by (simp add: Fix_in_Field_and_fixed)
  moreover have yField: \<open>Fix\<delta> g s \<in> Field r\<close>
    using \<open>mono g\<close> \<open>s \<le> g s\<close> by (simp add: Fix_in_Field_and_fixed)
  moreover have zField: \<open>Fix\<delta> h s \<in> Field r\<close>
    using \<open>mono h\<close> \<open>s \<le> h s\<close> by (simp add: Fix_in_Field_and_fixed)
  ultimately have mField: \<open>?m \<in> Field r\<close>
    by (simp add: wo_rel.max2_def wo_rel_r)
  have m2Field: \<open>?m2 \<in> Field r\<close>
    using yField zField by (simp add: wo_rel.max2_def wo_rel_r)

  have xmax: \<open>Fix\<delta> f s \<in> under r ?m\<close>
    by (metis (full_types) Diff_insert_absorb Refl_under_in m2Field subset_Diff_insert under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r xField)

  have ymax: \<open>Fix\<delta> g s \<in> under r ?m\<close>
  proof-
    have \<open>Fix\<delta> g s \<in> under r ?m2\<close>
      by (meson Refl_under_in in_mono under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater wo_rel_r yField zField)
    moreover have \<open>?m2 \<in> under r ?m\<close>
      by (meson Refl_under_in in_mono m2Field under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r xField)
    ultimately show ?thesis
      by (meson WELL in_mono m2Field under_mono wo_rel.max2_greater_among wo_rel_r xField)
  qed

  have zmax: \<open>Fix\<delta> h s \<in> under r ?m\<close>
  proof-
    have \<open>Fix\<delta> h s \<in> under r ?m2\<close>
      by (meson Refl_under_in in_mono under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater wo_rel_r yField zField)
    moreover have \<open>?m2 \<in> under r ?m\<close>
      by (meson Refl_under_in in_mono m2Field under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r xField)
    ultimately show ?thesis
      by (meson WELL in_mono m2Field under_mono wo_rel.max2_greater_among wo_rel_r xField)
  qed

  from assms have \<open>inf (iter f s ?m) (iter g s ?m) \<le> iter h s ?m\<close>
    by simp
  moreover have \<open>Fix f s = iter f s ?m\<close>
    unfolding Fix_def using xmax reach_fixpoint_above Fix_in_Field_and_fixed assms  by blast
  moreover have \<open>Fix g s = iter g s ?m\<close>
    unfolding Fix_def using ymax reach_fixpoint_above Fix_in_Field_and_fixed assms  by blast
  moreover have \<open>Fix h s = iter h s ?m\<close>
    unfolding Fix_def using zmax reach_fixpoint_above Fix_in_Field_and_fixed assms  by blast
  ultimately show ?thesis
    by simp
qed

lemma Fix_is_lfp:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>Fix f bot = lfp f\<close>
proof-
  have \<open>bot \<le> f bot\<close>
    by simp
  moreover have \<open>bot \<le> lfp f\<close>
    by simp
  moreover have \<open>lfp f = f (lfp f)\<close>
    by (simp add: def_lfp_unfold fmono)
  ultimately have \<open>Fix f bot = f (Fix f bot) \<and> Fix f bot \<le> lfp f\<close>
    using fmono Fix_is_fixed Fix_is_least by simp
  then show ?thesis
    by (simp add: dual_order.eq_iff lfp_lowerbound)
qed

lemma iter_induct_lfp: \<open>mono (f :: 'b \<Rightarrow> 'b) \<Longrightarrow> (\<And> n. P (iter f bot n)) \<Longrightarrow> P (lfp f)\<close>
  by (metis Fix_def Fix_is_lfp)

text \<open>corresponding theory for gfp\<close>

definition IterL where \<open>IterL rec n \<equiv> Inf (rec ` underS r n)\<close>

definition Iter where
  \<open>Iter f s \<delta> = worecZSL r s (iterS f) IterL \<delta>\<close>

lemma adm_woL_IterL: \<open>adm_woL r IterL\<close>
  unfolding IterL_def wo_rel.adm_woL_def[OF wo_rel_r] by auto

lemma Iter_zero[simp]: \<open>Iter f s (zero r) = s\<close>
  using Iter_def wo_rel.worecZSL_zero wo_rel_r adm_woL_IterL by metis

lemma Iter_succ[simp]: \<open>n \<in> Field r \<Longrightarrow> Iter f s (succ r n) = f (Iter f s n)\<close>
  using Iter_def iterS_def wo_rel.worecZSL_succ wo_rel_r adm_woL_IterL wo_rel.isLimOrd_aboveS isLimOrd_r by metis

lemma Iter_lim[simp]: \<open>isLim r n \<Longrightarrow> n \<noteq> zero r \<Longrightarrow> Iter f s n = Inf (Iter f s ` underS r n)\<close>
proof-
  assume \<open>isLim r n\<close> \<open>n \<noteq> zero r\<close>
  have \<open>worecZSL r s (iterS f) IterL n = IterL (worecZSL r s (iterS f) IterL) n\<close>
    using wo_rel.worecZSL_isLim wo_rel_r adm_woL_IterL \<open>isLim r n\<close> \<open>n \<noteq> zero r\<close> by metis
  moreover have \<open>... = Inf (worecZSL r s (iterS f) IterL ` underS r n)\<close>
    using IterL_def by auto
  ultimately show ?thesis
    by (simp add: Iter_def)
qed

lemma postfixes_iter:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>n \<in> Field r \<Longrightarrow> p \<le> s \<Longrightarrow> p \<le> f p \<Longrightarrow> p \<le> Iter f s n\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case by simp
next
  case (2 i)
  then have \<open>i \<in> Field r\<close>
    by (meson WELL well_order_on_domain wo_rel.succ_in_diff wo_rel_r)
  with 2 show ?case
    using fmono by (metis dual_order.trans Iter_succ monoE)
next
  case (3 i)
  then show ?case
    by (simp add: BNF_Least_Fixpoint.underS_Field INF_greatest)
qed

lemma mono_chain_Iter_succ:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>n \<in> Field r \<Longrightarrow> s \<ge> f s \<Longrightarrow> Iter f s n \<ge> Iter f s (succ r n)\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by simp
next
  case (2 i)
  then have \<open>Iter f s i \<ge> Iter f s (succ r i)\<close>
    by (simp add: above_Field)
  then have \<open>f (Iter f s i) \<ge> f (Iter f s (succ r i))\<close>
    using 2(4) fmono monotoneD by metis
  then show ?case
    by (simp add: "2.hyps"(1) "2.prems"(1) above_Field)
next
  case (3 i)
  then have *: \<open>Iter f s i = Inf (Iter f s ` underS r i)\<close>
    by simp
  then have **: \<open>\<forall> j \<in> underS r i. Iter f s i \<le> Iter f s j\<close>
    by (simp add: INF_lower)
  have \<open>\<forall> j \<in> underS r i. Iter f s j \<ge> f (Iter f s i)\<close>
  proof safe
    fix j
    assume \<open>j \<in> underS r i\<close>
    then have \<open>j \<in> Field r\<close>
      using 3 by (meson BNF_Least_Fixpoint.underS_Field)
    then have \<open>Iter f s j \<ge> f (Iter f s j)\<close>
      using 3 by (simp add: \<open>j \<in> underS r i\<close>)
    have \<open>Iter f s j \<ge> Iter f s i\<close>
      using ** \<open>j \<in> underS r i\<close> by simp
    then have \<open>f (Iter f s j) \<ge> f (Iter f s i)\<close>
      using 3(5) fmono monotoneD by metis
    with \<open>Iter f s j \<ge> f (Iter f s j)\<close> show \<open>Iter f s j \<ge> f (Iter f s i)\<close>
      by simp
  qed
  then have \<open>Inf (Iter f s ` underS r i) \<ge> f (Iter f s i)\<close>
    by (simp add: INF_greatest)
  with * show ?case
    by (simp add: "3.prems"(1))
qed

lemma mono_chain_Iter_under:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>m \<in> under r n \<Longrightarrow> f s \<le> s \<Longrightarrow> Iter f s m \<ge> Iter f s n\<close>
proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by (metis empty_iff order_refl singletonD under_empty wo_rel.under_zero wo_rel_r)
next
  case (2 i)
  then have \<open>m \<in> under r i \<or> m = succ r i\<close>
    by (metis insertE wo_rel.under_succ wo_rel_r)
  moreover have \<open>Iter f s i \<ge> Iter f s (succ r i)\<close>
    using 2 above_Field mono_chain_Iter_succ fmono by simp
  ultimately show ?case
    using "2.hyps"(2) "2.prems"(2) by fastforce
next
  case (3 i)
  then show ?case
    by (metis INF_lower Iter_lim mem_Collect_eq order_class.order_eq_iff underS_I under_def)
qed

lemma reach_fixpoint_succ':
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>f s \<le> s \<Longrightarrow> \<exists> n \<in> Field r. Iter f s n = Iter f s (succ r n)\<close>
proof (rule ccontr)
  assume assms: \<open>f s \<le> s\<close>
  assume \<open>\<not>(\<exists> n \<in> Field r. Iter f s n = Iter f s (succ r n))\<close>
  then have \<open>\<forall> n \<in> Field r. Iter f s n > Iter f s (succ r n)\<close>
    using fmono assms mono_chain_Iter_succ by (metis nless_le)
  have \<open>m \<noteq> n \<Longrightarrow> m \<in> underS r n \<Longrightarrow> Iter f s m > Iter f s n\<close> for m n
  proof (induct n rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
    case 1
    then show ?case
      by (simp add: wo_rel.underS_zero wo_rel_r)
  next
    case (2 i)
    then show ?case
      using \<open>\<forall> n \<in> Field r. Iter f s n > Iter f s (succ r n)\<close>
      by (metis (no_types, lifting) dual_order.strict_trans local.above_Field underS_E underS_I wo_rel.less_succ wo_rel_r)
  next
    case (3 i)
    then have \<open>succ r m \<in> under r i\<close>
      using underS_subset_under under_def wo_rel.succ_smallest wo_rel_r by fastforce
    then have \<open>Iter f s (succ r m) \<ge> Iter f s i\<close>
      by (simp add: assms fmono mono_chain_Iter_under)
    moreover have \<open>Iter f s m \<ge> Iter f s (succ r m)\<close>
      by (meson fmono BNF_Least_Fixpoint.underS_Field 3(5) assms mono_chain_Iter_succ)
    moreover have \<open>m \<in> Field r\<close>
      by (meson "3.prems"(2) BNF_Least_Fixpoint.underS_Field)
    ultimately show ?case
      using \<open>\<forall>n\<in>Field r. Iter f s n > Iter f s (succ r n)\<close> by auto
  qed
  then have \<open>\<forall> n \<in> Field r. \<forall> m \<in> Field r. n \<noteq> m \<longrightarrow> Iter f s n \<noteq> Iter f s m\<close>
    by (metis dual_order.irrefl underS_I wo_rel.in_notinI wo_rel_r)
  have \<open>\<forall> n \<in> Field r. \<exists> x :: 'b. (\<lambda> i. THE n. n \<in> Field r \<and> Iter f s n = i) x = n\<close>
  proof
    fix n
    assume \<open>n \<in> Field r\<close>
    then have \<open>(\<lambda> i. THE n. n \<in> Field r \<and> Iter f s n = i) (Iter f s n) = n\<close>
      using \<open>\<forall>n\<in>Field r. \<forall>m\<in>Field r. n \<noteq> m \<longrightarrow> Iter f s n \<noteq> Iter f s m\<close> by auto
    then show \<open>\<exists> x :: 'b. (\<lambda> i. THE n. n \<in> Field r \<and> Iter f s n = i) x = n\<close>
      by auto
  qed
  then show False
    using ab_card by meson
qed

lemma reach_fixpoint_above':
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>f s \<le> s \<Longrightarrow> Iter f s n = Iter f s (succ r n) \<Longrightarrow> n \<in> under r m \<Longrightarrow> Iter f s n = Iter f s m\<close>
proof (induct m rule: wo_rel.well_order_inductZSL[OF wo_rel_r])
  case 1
  then show ?case
    by (metis emptyE insertE under_empty wo_rel.under_zero wo_rel_r)
next
  case (2 i)
  then show ?case
    by (metis in_mono insert_iff Iter_succ local.above_Field under_Field wo_rel.under_succ wo_rel_r)
next
  case (3 i)
  show ?case
  proof (cases \<open>n = i\<close>)
    case True
    then show ?thesis
      by simp
  next
    case False
    have \<open>\<forall> j \<in> under r n. Iter f s j \<ge> Iter f s n\<close>
      using 3 fmono mono_chain_Iter_under by blast
    moreover have \<open>\<forall> j. n \<in> under r j \<and> j \<in> underS r i \<longrightarrow> Iter f s n = Iter f s j\<close>
      using 3 by fast
    moreover have \<open>\<forall> j \<in> underS r i. j \<in> underS r n \<or> n \<in> under r j\<close>
      by (metis (no_types, lifting) "3.prems"(3) isLimOrd_r subsetD underS_I underS_subset_under
          under_Field wo_rel.TOTALS wo_rel.isLimOrd_aboveS wo_rel.succ_diff wo_rel.succ_in wo_rel.underS_succ wo_rel_r)
    ultimately have \<open>\<forall> x \<in> {Iter f s j | j. j \<in> underS r i}. x \<ge> Iter f s n\<close>
      using in_mono mem_Collect_eq order_refl underS_subset_under by fastforce
    moreover have \<open>Iter f s n \<in> {Iter f s j | j. j \<in> underS r i}\<close>
      using False by (metis (mono_tags, lifting) "3.prems"(3) mem_Collect_eq underS_I under_def)
    moreover have \<open>Iter f s i = Inf {Iter f s j | j. j \<in> underS r i}\<close>
      by (simp add: "3.hyps"(1) "3.hyps"(2) Setcompr_eq_image)
    ultimately show ?thesis
      by (metis (mono_tags, lifting) Inf_greatest Inf_lower order_antisym_conv)
  qed
qed

definition FIX\<delta> where \<open>FIX\<delta> f s = (SOME n. n \<in> Field r \<and> Iter f s n = Iter f s (succ r n))\<close>

definition FIX where \<open>FIX f s \<equiv> Iter f s (FIX\<delta> f s)\<close>

lemma FIX_in_Field_and_fixed:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>f s \<le> s \<Longrightarrow> FIX\<delta> f s \<in> Field r \<and> Iter f s (FIX\<delta> f s) = Iter f s (succ r (FIX\<delta> f s))\<close>
proof-
  let ?n = \<open>SOME n. n \<in> Field r \<and> Iter f s n = Iter f s (succ r n)\<close>
  assume \<open>f s \<le> s\<close>
  then have \<open>\<exists> n. n \<in> Field r \<and> Iter f s n = Iter f s (succ r n)\<close>
    using reach_fixpoint_succ' fmono by blast
  then have \<open>?n \<in> Field r \<and> Iter f s ?n = Iter f s (succ r ?n)\<close>
    by (metis (mono_tags, lifting) some_eq_imp)
  then show ?thesis
    unfolding FIX\<delta>_def by meson
qed

lemma FIX_is_fixed:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>f s \<le> s \<Longrightarrow> FIX f s = f (FIX f s)\<close>
  unfolding FIX_def using fmono FIX_in_Field_and_fixed Iter_succ by metis

lemma FIX_is_greatest:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows\<open>f s \<le> s \<Longrightarrow> x \<le> s \<Longrightarrow> x = f x \<Longrightarrow> x \<le> FIX f s\<close>
proof-
  assume \<open>f s \<le> s\<close> \<open>x \<le> s\<close> \<open>x = f x\<close>
  then have \<open>Iter f s (FIX\<delta> f s) \<ge> x\<close>
    using fmono FIX_in_Field_and_fixed by (metis order_refl postfixes_iter)
  then show ?thesis
    unfolding FIX_def by simp
qed

lemma FIX_is_gfp:
  assumes fmono: \<open>mono (f :: 'b \<Rightarrow> 'b)\<close>
  shows \<open>FIX f top = gfp f\<close>
proof-
  have \<open>f top \<le> top\<close>
    by simp
  moreover have \<open>top \<ge> gfp f\<close>
    by simp
  moreover have \<open>gfp f = f (gfp f)\<close>
    by (simp add: def_gfp_unfold fmono)
  ultimately have \<open>FIX f top = f (FIX f top) \<and> FIX f top \<ge> gfp f\<close>
    using fmono FIX_is_fixed FIX_is_greatest by simp
  then show ?thesis
    by (simp add: dual_order.eq_iff gfp_upperbound)
qed

lemma Iter_induct_gfp: \<open>mono (f :: 'b \<Rightarrow> 'b) \<Longrightarrow> (\<And> n. P (Iter f top n)) \<Longrightarrow> P (gfp f)\<close>
  by (metis FIX_def FIX_is_gfp)

lemma Iter_induct_gfp2: \<open>mono (f :: 'b \<Rightarrow> 'b) \<Longrightarrow> mono (g :: 'b \<Rightarrow> 'b) \<Longrightarrow> (\<And> n. P (Iter f top n) (Iter g top n)) \<Longrightarrow> P (gfp f) (gfp g)\<close>
proof-
  assume a: \<open>mono f\<close> \<open>mono g\<close> \<open>\<And> n. P (Iter f top n) (Iter g top n)\<close>
  let ?m = \<open>max2 r (FIX\<delta> f top) (FIX\<delta> g top)\<close>
  have *: \<open>FIX\<delta> f top \<in> Field r\<close> \<open>FIX\<delta> g top \<in> Field r\<close>
    by (simp_all add: FIX_in_Field_and_fixed a)
  then have \<open>FIX\<delta> f top \<in> under r ?m\<close>
    by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater wo_rel_r)
  then have **: \<open>Iter f top ?m = gfp f\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(1) reach_fixpoint_above' top_greatest)
  have \<open>FIX\<delta> g top \<in> under r ?m\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r)
  then have \<open>Iter g top ?m = gfp g\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(2) reach_fixpoint_above' top_greatest)
  with ** show ?thesis
    using a by metis
qed

lemma Iter_induct_gfp3: \<open>mono (f :: 'b \<Rightarrow> 'b) \<Longrightarrow> mono (g :: 'b \<Rightarrow> 'b) \<Longrightarrow> mono (h :: 'b \<Rightarrow> 'b) \<Longrightarrow>
  (\<And> n. P (Iter f top n) (Iter g top n) (Iter h top n)) \<Longrightarrow> P (gfp f) (gfp g) (gfp h)\<close>
proof-
  assume a: \<open>mono f\<close> \<open>mono g\<close> \<open>mono h\<close> \<open>\<And> n. P (Iter f top n) (Iter g top n) (Iter h top n)\<close>
  let ?m' = \<open>max2 r (FIX\<delta> g top) (FIX\<delta> h top)\<close>
  let ?m = \<open>max2 r (FIX\<delta> f top) ?m'\<close>
  have *: \<open>FIX\<delta> f top \<in> Field r\<close> \<open>FIX\<delta> g top \<in> Field r\<close> \<open>FIX\<delta> h top \<in> Field r\<close>
    by (simp_all add: FIX_in_Field_and_fixed a)
  then have \<open>?m' \<in> Field r\<close>
    by (simp add: wo_rel.max2_def wo_rel_r)
  then have \<open>FIX\<delta> f top \<in> under r ?m\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater wo_rel_r)
  then have 1: \<open>Iter f top ?m = gfp f\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(1) reach_fixpoint_above' top_greatest)
  have \<open>FIX\<delta> g top \<in> under r ?m'\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r)
  then have \<open>FIX\<delta> g top \<in> under r ?m\<close>
    by (meson "*"(1) WELL \<open>max2 r (FIX\<delta> g top) (FIX\<delta> h top) \<in> Field r\<close> in_mono under_mono wo_rel.max2_greater_among wo_rel_r)
  then have 2: \<open>Iter g top ?m = gfp g\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(2) reach_fixpoint_above' top_greatest)
  have \<open>FIX\<delta> h top \<in> under r ?m'\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r)
  then have \<open>FIX\<delta> h top \<in> under r ?m\<close>
    by (meson "*"(1) WELL \<open>max2 r (FIX\<delta> g top) (FIX\<delta> h top) \<in> Field r\<close> in_mono under_mono wo_rel.max2_greater_among wo_rel_r)
  then have \<open>Iter h top ?m = gfp h\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(3) reach_fixpoint_above' top_greatest)
  with 1 2 show ?thesis
    using a by metis
qed

lemma Iter_iter_induct_gfp3: \<open>mono (f :: 'b \<Rightarrow> 'b) \<Longrightarrow> mono (g :: 'b \<Rightarrow> 'b) \<Longrightarrow> mono (h :: 'b \<Rightarrow> 'b) \<Longrightarrow>
  (\<And> n. P (iter f bot n) (Iter g top n) (iter h bot n)) \<Longrightarrow> P (lfp f) (gfp g) (lfp h)\<close>
proof-
  assume a: \<open>mono f\<close> \<open>mono g\<close> \<open>mono h\<close> \<open>\<And> n. P (iter f bot n) (Iter g top n) (iter h bot n)\<close>
  let ?m' = \<open>max2 r (FIX\<delta> g top) (Fix\<delta> h bot)\<close>
  let ?m = \<open>max2 r (Fix\<delta> f bot) ?m'\<close>
  have *: \<open>Fix\<delta> f bot \<in> Field r\<close> \<open>FIX\<delta> g top \<in> Field r\<close> \<open>Fix\<delta> h bot \<in> Field r\<close>
    by (simp_all add: FIX_in_Field_and_fixed Fix_in_Field_and_fixed a)
  then have \<open>?m' \<in> Field r\<close>
    by (simp add: wo_rel.max2_def wo_rel_r)
  then have \<open>Fix\<delta> f bot \<in> under r ?m\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater wo_rel_r)
  then have 1: \<open>iter f bot ?m = lfp f\<close>
    by (metis Fix_def Fix_in_Field_and_fixed Fix_is_lfp a(1) reach_fixpoint_above bot_least)
  have \<open>FIX\<delta> g top \<in> under r ?m'\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r)
  then have \<open>FIX\<delta> g top \<in> under r ?m\<close>
    by (meson "*"(1) WELL \<open>?m' \<in> Field r\<close>  in_mono under_mono wo_rel.max2_greater_among wo_rel_r)
  then have 2: \<open>Iter g top ?m = gfp g\<close>
    by (metis FIX_def FIX_in_Field_and_fixed FIX_is_gfp a(2) reach_fixpoint_above' top_greatest)
  have \<open>Fix\<delta> h bot \<in> under r ?m'\<close>
    using * by (meson Refl_under_in subset_iff under_incl_iff wo_rel.REFL wo_rel.TRANS wo_rel.max2_greater_among wo_rel_r)
  then have \<open>Fix\<delta> h bot \<in> under r ?m\<close>
    by (meson "*"(1) WELL \<open>?m' \<in> Field r\<close> in_mono under_mono wo_rel.max2_greater_among wo_rel_r)
  then have \<open>iter h bot ?m = lfp h\<close>
    by (metis Fix_def Fix_in_Field_and_fixed Fix_is_lfp a(3) reach_fixpoint_above bot_least)
  with 1 2 show ?thesis
    using a by metis
qed

end

locale power_set_Fix_Lim_Ord =
  fixes undefined :: \<open>'a :: complete_lattice\<close>
  assumes infinite_univ: \<open>infinite (UNIV :: 'a set)\<close>
sublocale power_set_Fix_Lim_Ord \<subseteq> Fix_Lim_Ord \<open>|UNIV :: ('a set) set |\<close> \<open>bot :: 'a\<close>
proof
  show \<open>Well_order |UNIV|\<close>
    by (rule card_of_Well_order)
  have \<open>infinite (UNIV :: ('a set) set )\<close>
    using infinite_univ by (simp add: Finite_Set.finite_set)
  then have \<open>infinite ( Field |UNIV :: ('a set) set| )\<close>
    by simp
  then show \<open>isLimOrd |UNIV :: ('a set) set |\<close>
    using card_order_infinite_isLimOrd card_of_Card_order by metis
  have \<open>Field |UNIV| = UNIV\<close>
    by simp
  moreover have \<open>\<nexists>f. \<forall>n :: 'a set. \<exists>x :: 'a. f x = n\<close>
    by force
  ultimately show \<open>\<nexists>f. \<forall>n\<in>Field |UNIV :: ('a set) set |. \<exists>x :: 'a. f x = n\<close>
    by simp
qed

end