(* Author: Fabian Hellauer, 2018 *)
section \<open>Old Development\<close>
theory Old_Field_Extension
  imports "HOL-Algebra.Subrings"
begin

subsection \<open>Generated Groups\<close>

lemma (in abelian_group) contains_trivial:
  "a1\<in>carrier G \<Longrightarrow> a2\<in>carrier G \<Longrightarrow> \<ominus>a1 \<oplus> a2 \<in> carrier G"
    by simp

lemma carrier_K: "carrier (L\<lparr>carrier:=K\<rparr>) = K"
  by simp

lemma (in abelian_monoid) intersect_nonzeros:
  "\<M> \<noteq> {} \<Longrightarrow> \<Inter>\<M> - {\<zero>} = \<Inter>{M - {\<zero>}| M . M \<in> \<M>}"
  by auto

lemma add_monoid_update[simp]: "add_monoid (R\<lparr>carrier := S\<rparr>) = add_monoid R \<lparr>carrier := S\<rparr>"
  by simp

lemma (in field) mult_of_update[intro]: "\<zero> \<notin> S \<Longrightarrow> mult_of (R\<lparr>carrier := S\<rparr>) = mult_of R\<lparr>carrier := S\<rparr>"
  by simp

context subgroup
begin

lemma "\<Inter>_is_supergroup":
  "group G \<Longrightarrow> \<M> \<noteq> {} \<Longrightarrow> \<forall>M\<in>\<M>. H \<subseteq> M \<and> subgroup M G \<Longrightarrow> subgroup H (G\<lparr>carrier:=\<Inter>\<M>\<rparr>)"
\<comment> \<open>Cannot use @{thm group.subgroupI} because @{locale subgroup} does not extend @{locale group}\<close>
  apply unfold_locales apply auto using group.subgroups_Inter
  by (metis (mono_tags) Collect_mem_eq Inf_greatest empty_Collect_eq group.subgroup_incl
      subgroup.m_inv_closed subgroup_axioms)

lemma generated_group:
  "S \<subseteq> carrier G \<Longrightarrow> group G \<Longrightarrow> subgroup H (G\<lparr>carrier:=(\<lambda>M. subgroup M G \<and> H \<subseteq> M) hull S\<rparr>)"
  unfolding hull_def apply (intro "\<Inter>_is_supergroup") apply auto
  by (meson group.subgroup_self rcosets_carrier subgroup_in_rcosets)

end

subsection \<open>Subrings\<close>

context ring begin

lemma nonzero_ring_one (*rm*): "card (carrier R) \<noteq> 1 \<Longrightarrow> one R \<noteq> zero R"
  using is_singleton_altdef is_singleton_def one_zeroD by blast

definition old_sr where
  "old_sr S \<longleftrightarrow>
    carrier S \<subseteq> carrier R \<and>
    ring S \<and>
    one R \<in> carrier S \<and>
    (\<forall>r1\<in>carrier S. \<forall>r2\<in>carrier S. add S r1 r2 = add R r1 r2 \<and> monoid.mult S r1 r2 = monoid.mult R r1 r2)"

lemma "old_sr S \<Longrightarrow> Units S \<subseteq> Units R"
  unfolding Units_def apply auto
  using old_sr_def apply blast
  unfolding old_sr_def apply auto
  by (metis (no_types, hide_lams) contra_subsetD r_one ring.ring_simprules(12) ring.ring_simprules(6))

lemma old_sr_refl: "old_sr R"
  unfolding old_sr_def using ring_axioms by blast

lemma old_sr_fullI: "\<lbrakk>A \<subseteq> carrier R; \<one>\<in>A; \<forall>r1\<in>A.\<forall>r2\<in>A. r1\<otimes>r2\<in>A \<and> \<ominus>r1\<oplus>r2\<in>A\<rbrakk>
  \<Longrightarrow> old_sr (R\<lparr>carrier:=A\<rparr>)"
  unfolding old_sr_def apply auto
  apply (rule ringI)
     apply (rule abelian_groupI)
          apply auto
         apply (metis add.inv_closed minus_minus r_zero ring_simprules(9) subsetCE)
  using l_neg apply fastforce
       apply (meson add.m_assoc subsetCE)
  apply (meson add.m_comm subsetCE)
     apply (metis add.inv_closed r_zero ring_simprules(9) subset_eq)
    apply (rule monoidI)
  apply auto
    apply (meson m_assoc subsetCE)
    apply (meson l_distr subsetCE)
    by (meson ring_axioms ring.ring_simprules(23) subsetCE)

lemma old_sr_zero: "old_sr S \<Longrightarrow> zero S = \<zero>"
  by (metis (full_types) l_zero add.right_cancel ring.ring_simprules(15)
      ring.ring_simprules(2) old_sr_def subsetCE zero_closed)

lemma normalize_old_sr: "old_sr S \<Longrightarrow> old_sr (R\<lparr>carrier:=carrier S\<rparr>)"
  apply (rule old_sr_fullI)
  using old_sr_def apply blast
  using old_sr_def apply blast
  unfolding old_sr_def ring_def
    apply auto
   apply (metis monoid.m_closed)
  using abelian_group.contains_trivial[of S]
proof -
  fix r1 :: 'a and r2 :: 'a
  assume a1: "r1 \<in> carrier S"
  assume a2: "r2 \<in> carrier S"
  assume a3: "carrier S \<subseteq> carrier R"
  assume a4: "abelian_group S"
  assume a5: "\<forall>r1\<in>carrier S. \<forall>r2\<in>carrier S. r1 \<oplus>\<^bsub>S\<^esub> r2 = r1 \<oplus> r2 \<and> r1 \<otimes>\<^bsub>S\<^esub> r2 = r1 \<otimes> r2"
  assume a6: "\<And>a1 a2. \<lbrakk>abelian_group S; a1 \<in> carrier S; a2 \<in> carrier S\<rbrakk> \<Longrightarrow> \<ominus>\<^bsub>S\<^esub> a1 \<oplus>\<^bsub>S\<^esub> a2 \<in> carrier S"
  have "\<ominus>\<^bsub>S\<^esub> r1 \<in> carrier S"
    using a4 a1 by (simp add: abelian_group.a_inv_closed)
  then show "\<ominus> r1 \<oplus> r2 \<in> carrier S"
    using a6 a5 a4 a3 a2 a1 by (metis (full_types) abelian_group.r_neg2 add.inv_closed add.m_lcomm r_neg2 subsetCE)
qed

lemma old_sr_nontrivial: "card (carrier R) \<noteq> 1 \<Longrightarrow> old_sr S \<Longrightarrow> card (carrier S) \<noteq> 1"
  by (metis add.r_cancel_one' card_1_singletonE nonzero_ring_one one_closed ring.ring_simprules(15)
      ring.ring_simprules(2) singleton_iff old_sr_def)

lemma old_sr_trivial_iff: "old_sr S \<Longrightarrow> card (carrier R) = 1 \<longleftrightarrow> card (carrier S) = 1"
  by (metis card_1_singletonE contra_subsetD monoid.one_closed ring.nonzero_ring_one ring_def
      singleton_iff old_sr_def old_sr_nontrivial old_sr_zero zero_closed)

lemma subgroup_to_old_sr:
  "\<lbrakk>additive_subgroup A R; \<one>\<in>A; \<forall>a\<in>A. \<forall>b\<in>A. a\<otimes>b\<in>A\<rbrakk>
    \<Longrightarrow> old_sr (R\<lparr>carrier:=A\<rparr>)" using old_sr_fullI
  by (simp add: additive_subgroup.a_closed additive_subgroup.a_inv_closed additive_subgroup.a_subset)

lemma subyada_to_old_sr:
  "\<lbrakk>additive_subgroup A R; submonoid A R\<rbrakk> \<Longrightarrow> old_sr (R\<lparr>carrier:=A\<rparr>)"
  apply (rule subgroup_to_old_sr) apply auto
  apply (simp add: submonoid.one_closed)
  by (simp add: submonoid.m_closed)

lemma old_sr_imp_subgroup:
  "old_sr S \<Longrightarrow> additive_subgroup (carrier S) R"
  apply (rule additive_subgroup.intro, rule subgroup.intro)
     apply (auto simp: old_sr_def)
  apply (metis ring.ring_simprules(1))
  apply (metis (no_types, hide_lams) add.r_cancel_one' ring.ring_simprules(15)
      ring.ring_simprules(2) ring.ring_simprules(5) submonoid.intro submonoid.mem_carrier)
proof -
fix x :: 'a
  assume a1: "carrier S \<subseteq> carrier R"
  assume a2: "\<forall>r1\<in>carrier S. \<forall>r2\<in>carrier S. r1 \<oplus>\<^bsub>S\<^esub> r2 = r1 \<oplus> r2 \<and> r1 \<otimes>\<^bsub>S\<^esub> r2 = r1 \<otimes> r2"
  assume a3: "ring S"
assume a4: "x \<in> carrier S"
  have "\<forall>a. a \<in> carrier R \<or> a \<notin> carrier S"
using a1 by (meson subsetCE)
  then show "inv\<^bsub>add_monoid R\<^esub> x \<in> carrier S"
using a4 a3 a2 by (metis (no_types) a_inv_def abelian_group.a_inv_closed add.r_cancel_one'
    minus_equality ring.ring_simprules(15) ring.ring_simprules(2) ring.ring_simprules(9) ring_def)
qed

lemma old_sr_imp_submonoid:
  "old_sr S \<Longrightarrow> submonoid (carrier S) R"
  unfolding old_sr_def apply auto
  by (metis ring.ring_simprules(5) submonoid.intro)

lemma intermediate_ring_1:
  "old_sr S \<Longrightarrow> carrier S \<subseteq> M \<Longrightarrow> M \<subseteq> carrier R \<Longrightarrow> ring (R\<lparr>carrier:=M\<rparr>) \<Longrightarrow> old_sr (R\<lparr>carrier:=M\<rparr>)"
  unfolding old_sr_def by auto
lemma intermediate_ring_2:
  "old_sr S \<Longrightarrow> carrier S \<subseteq> M \<Longrightarrow> ring (R\<lparr>carrier:=M\<rparr>)
    \<Longrightarrow> ring.old_sr (R\<lparr>carrier:=M\<rparr>) S"
  unfolding old_sr_def ring.old_sr_def by auto

lemma old_sr_ring_hom_ring: "old_sr S \<Longrightarrow> ring_hom_ring S R id"
  unfolding ring_hom_ring_def ring_hom_ring_axioms_def apply auto
  using old_sr_def apply blast
  apply (rule ring_axioms)
  apply (auto intro!: ring_hom_memI simp: old_sr_def)
  by (metis (no_types, lifting) r_one ring.ring_simprules(12) ring.ring_simprules(6) subsetCE)

end

lemma (in cring) old_sr_cring: "old_sr S \<Longrightarrow> cring S" unfolding old_sr_def cring_def ring_def
  by (simp add: comm_monoid.m_ac(2) comm_monoid_axioms monoid.monoid_comm_monoidI subset_eq)

lemma (in cring) old_sr_ring_hom_cring: "old_sr S \<Longrightarrow> ring_hom_cring S R id"
  by (simp add: RingHom.ring_hom_cringI is_cring old_sr_cring old_sr_ring_hom_ring)

context field begin

lemma has_inverse: "a \<in> carrier R \<Longrightarrow> a \<noteq> \<zero> \<Longrightarrow> \<exists>b\<in>carrier R. a\<otimes>b = \<one>"
  by (simp add: Units_r_inv_ex field_Units)

definition old_sf where
  "old_sf K \<longleftrightarrow> old_sr K \<and> field K"

lemma old_sf_refl: "old_sf R"
  by (simp add: field_axioms old_sf_def old_sr_refl)

lemma old_sf_zero: "old_sf S \<Longrightarrow> zero S = \<zero>"
  unfolding old_sf_def using old_sr_zero by blast

lemma old_sf_one: "old_sf S \<Longrightarrow> one S = \<one>"
proof -
  assume a1: "old_sf S"
  then have "carrier S \<subseteq> carrier R \<and> ring S \<and> \<one> \<in> carrier S \<and> (\<forall>a. a \<notin> carrier S \<or> (\<forall>aa. aa \<notin>
    carrier S \<or> a \<oplus>\<^bsub>S\<^esub> aa = a \<oplus> aa \<and> a \<otimes>\<^bsub>S\<^esub> aa = a \<otimes> aa))"
    by (simp add: field.old_sf_def field_axioms old_sr_def)
  then show ?thesis
    using a1 by (metis (no_types, hide_lams) contra_subsetD ring_axioms monoid.r_one
        ring.ring_simprules(6,12) ring_def)
qed

lemma normalize_old_sf: "old_sf S \<Longrightarrow> old_sf (R\<lparr>carrier:=carrier S\<rparr>)"
  unfolding old_sf_def apply auto
   apply (simp add: normalize_old_sr)
  apply (rule cring.cring_fieldI2)
    apply auto
  using normalize_old_sr old_sr_cring apply auto[1]
  unfolding old_sr_def apply auto
  by (metis (no_types, lifting) field.has_inverse[simplified] old_sf_def old_sf_one old_sr_def old_sr_zero)

lemma old_sfI:
  assumes "additive_subgroup A R"
  and "subgroup (A-{\<zero>}) (mult_of R)"
shows "old_sf (R\<lparr>carrier:=A\<rparr>)"
  unfolding old_sf_def apply auto apply (rule subgroup_to_old_sr)
     apply (simp add: assms(1)) apply auto
  using assms(2) subgroup.one_closed apply fastforce
subgoal for a b
proof -
  assume a1: "b \<in> A"
  assume a2: "a \<in> A"
  have f3: "insert \<zero> (A - {\<zero>}) = A"
    by (metis additive_subgroup.a_subgroup assms(1) insert_Diff monoid.simps(2) subgroup_def)
  have "(a \<otimes> b = \<zero>) = (a = \<zero> \<or> b = \<zero>)"
    using a2 a1 by (meson additive_subgroup.a_subset assms(1) integral_iff set_rev_mp)
  then show ?thesis
    using f3 a2 a1 by (metis (no_types) assms(2) insertCI insertE mult_mult_of subgroup_def)
qed
  apply (rule cring.cring_fieldI2[of "R\<lparr>carrier:=A\<rparr>"])
    apply auto
  apply (rule old_sr_cring) apply (rule subyada_to_old_sr)
  apply (simp add: assms(1))
  apply (metis (mono_tags, lifting) Diff_subset \<open>\<And>b a. \<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a\<otimes>b \<in> A\<close>
    additive_subgroup.a_subset assms ring_axioms monoid_incl_imp_submonoid one_mult_of
    ring.is_monoid ring.subgroup_to_old_sr ring.old_sr_def subgroup.one_closed subsetCE)
proof -
  fix a :: 'a
  assume a1: "a \<in> A"
  assume a2: "a \<noteq> \<zero>"
  have "\<forall>a. (a \<in> {\<zero>} \<or> a \<in> Units R) \<or> a \<notin> A"
    by (metis (no_types) Diff_iff assms(2) carrier_mult_of contra_subsetD field_Units subgroup_def)
  then show "\<exists>aa\<in>A. a \<otimes> aa = \<one>"
    using a2 a1 by (metis (no_types) Diff_iff Units_r_inv assms(2) empty_iff mult_of_is_Units insert_iff subgroup_def units_of_inv)
qed

lemma subgroup_add: \<open>old_sf S \<Longrightarrow> abelian_subgroup (carrier S) R\<close>
  by (simp add: abelian_subgroupI3 is_abelian_group old_sf_def old_sr_imp_subgroup)

lemma old_sf_imp_subgroup:
  "old_sf S \<Longrightarrow> subgroup (carrier S-{\<zero>}) (mult_of R)"
  apply (drule normalize_old_sf)
  apply (rule group.subgroupI)
  apply (simp add: field_mult_group) unfolding old_sf_def old_sr_def apply auto[]
  apply simp
    apply auto[1] apply simp
  using field.has_inverse[of "R\<lparr>carrier := carrier S\<rparr>", simplified] monoid.inv_unique[of
      "R\<lparr>carrier := carrier S\<rparr>", simplified] apply auto
  using set_rev_mp  Units_one_closed comm_inv_char mult_of_is_Units units_of_inv
  apply (metis (no_types, lifting) insert_Diff insert_iff field_Units zero_closed)
subgoal
proof -
  fix a :: 'a
  assume a1: "a \<in> carrier S"
  assume a2: "carrier S \<subseteq> carrier R"
assume a3: "a \<noteq> \<zero>"
  assume a4: "inv\<^bsub>mult_of R\<^esub> a = \<zero>"
  have "a \<in> carrier R"
  using a2 a1 by auto
  then show False
    using a4 a3 by (metis (no_types) carrier_mult_of insert_Diff insert_iff field_Units m_inv_mult_of monoid.Units_r_inv monoid_axioms r_null zero_closed zero_not_one)
qed
  apply (metis monoid_incl_imp_submonoid ring.is_monoid submonoid_def)
  by (metis (full_types) integral monoid.monoid_incl_imp_submonoid monoid_axioms ring.is_monoid
      submonoid.mem_carrier)

lemma old_sf_altdef: \<open>old_sf (R\<lparr>carrier := S\<rparr>) \<longleftrightarrow>
  additive_subgroup S R \<and> subgroup (S-{\<zero>}) (mult_of R)\<close>
  apply auto using subgroup_add abelian_subgroup_def apply force
  using old_sf_imp_subgroup apply force
  using old_sfI by blast

end

locale old_fe = field L for L (structure) +
  fixes K :: "'a set" \<comment> \<open>I see no reason why not to inherit @{term \<zero>}, @{term \<one>} and the
 operations. @{locale subgroup} does the same.\<close>
  assumes L_extends_K: "old_sf (L\<lparr>carrier:=K\<rparr>)"
begin \<comment> \<open>"Let @{term L}/@{term K} be a field extension."\<close>

(* replace by interpretation K: field "L\<lparr>carrier:K\<rparr>" ? *)
lemma K_field: "field (L\<lparr>carrier:=K\<rparr>)"
  using L_extends_K by (simp add: old_sf_def)

lemma K_old_sr: "old_sr (L\<lparr>carrier:=K\<rparr>)"
  using L_extends_K old_sf_def by blast

lemmas K_subgroup =
  L_extends_K[unfolded old_sf_altdef, THEN conjunct1]
  L_extends_K[unfolded old_sf_altdef, THEN conjunct2]

lemma K_inv: "a \<in> K \<Longrightarrow> a \<noteq> \<zero> \<Longrightarrow> inv a \<in> K"
proof -
  assume a1: "a \<noteq> \<zero>"
  assume a2: "a \<in> K"
  have f3: "carrier (L\<lparr>carrier := K\<rparr>) \<subseteq> carrier L \<and> ring (L\<lparr>carrier := K\<rparr>) \<and> \<one> \<in> carrier (L\<lparr>carrier
    := K\<rparr>) \<and> (\<forall>a. a \<notin> carrier (L\<lparr>carrier := K\<rparr>) \<or> (\<forall>aa. aa \<notin> carrier (L\<lparr>carrier := K\<rparr>) \<or> a
    \<oplus>\<^bsub>L\<lparr>carrier := K\<rparr>\<^esub> aa = a \<oplus> aa \<and> a \<otimes>\<^bsub>L\<lparr>carrier := K\<rparr>\<^esub> aa = a \<otimes> aa))"
    by (metis (no_types) K_old_sr old_sr_def)
  then have "\<forall>a. a \<notin> K \<or> a \<in> carrier L"
    by (simp add: subset_eq)
  then show ?thesis
    using f3 a2 a1
    by (metis K_field L_extends_K carrier_K comm_inv_char f3 field.has_inverse old_sf_one old_sf_zero)
qed

end

lemma (in field) old_fe_refl: "old_fe R (carrier R)"
  unfolding old_fe_def old_fe_axioms_def apply auto
  using field_axioms apply blast
  using normalize_old_sf old_sf_refl by auto

lemma (in field) old_fe_iff_old_sf: "old_fe R K \<longleftrightarrow> old_sf (R\<lparr>carrier:=K\<rparr>)"
  using old_fe.L_extends_K old_fe.intro old_fe_axioms_def
    field_axioms by blast

subsection \<open>Intersections of Intermediate Fields\<close>

context old_fe
begin

lemma intermediate_field_1: "field (L\<lparr>carrier:=M\<rparr>) \<Longrightarrow> K \<subseteq> M \<Longrightarrow> M \<subseteq> carrier L \<Longrightarrow> old_fe L M"
  apply unfold_locales unfolding old_sf_def apply auto unfolding field_def
  using intermediate_ring_1 K_old_sr cring_def domain_def by (metis carrier_K)
lemma intermediate_field_2:
  "K \<subseteq> M \<Longrightarrow> field (L\<lparr>carrier:=M\<rparr>) \<Longrightarrow> old_fe (L\<lparr>carrier:=M\<rparr>) K"
  by (metis K_field K_old_sr carrier_K cring_def domain_def field.old_fe_iff_old_sf
      field.normalize_old_sf field.old_sf_def field_def intermediate_ring_2)

lemma "\<Inter>_is_old_sf": "\<M>\<noteq>{} \<Longrightarrow> \<forall>M\<in>\<M>. old_fe L M \<and> M \<supseteq> K \<Longrightarrow> old_fe L (\<Inter>\<M>)"
  apply (unfold_locales) apply (auto simp add: old_sf_altdef)
  apply (metis add.subgroups_Inter additive_subgroup.a_subgroup additive_subgroupI equals0D
      old_fe.K_subgroup(1))
proof goal_cases
  case (1 M)
  then show ?case using group.subgroups_Inter[OF field_mult_group]
    by (smt equals0D field.old_fe_iff_old_sf field_axioms mem_Collect_eq old_sf_altdef
        intersect_nonzeros)
qed

corollary "16_3_aux": "\<M>\<noteq>{} \<Longrightarrow> \<forall>M\<in>\<M>. old_fe L M \<and> M \<supseteq> K \<Longrightarrow> field (L\<lparr>carrier := \<Inter>\<M>\<rparr>)"
  by (simp add: "\<Inter>_is_old_sf" old_fe.K_field)

text \<open>Proposition 16.3 of Prof. Gregor Kemper's lecture notes @{cite Algebra1}.\<close>

proposition intersection_of_intermediate_fields_is_old_fe[intro]:
  "\<M>\<noteq>{} \<Longrightarrow> \<forall>M\<in>\<M>. old_fe L M \<and> M \<supseteq> K \<Longrightarrow> old_fe (L\<lparr>carrier:=\<Inter>\<M>\<rparr>) K"
proof goal_cases
  case 1
  note to_old_sf =
    field.old_fe_iff_old_sf[OF "16_3_aux"[OF 1]]
    field.old_sf_altdef[OF "16_3_aux"[OF 1]]
  from 1 show ?case
    unfolding to_old_sf additive_subgroup_def apply safe
    apply (unfold add_monoid_update)
     apply (rule "subgroup.\<Inter>_is_supergroup") apply auto
    apply (simp add: additive_subgroup.a_subgroup old_fe.K_subgroup(1) old_fe_axioms)
    using additive_subgroup.a_subgroup old_fe.K_subgroup(1) apply blast
  proof goal_cases
    case 1
    have "mult_of (L\<lparr>carrier := \<Inter>\<M>\<rparr>) = mult_of (L\<lparr>carrier := \<Inter>\<M> - {\<zero>}\<rparr>)"
      by simp
    with \<open>\<M> \<noteq> {}\<close> have minus_swap: "mult_of (L\<lparr>carrier := \<Inter>\<M>\<rparr>) = mult_of (L\<lparr>carrier := \<Inter>{M-{\<zero>}|M. M \<in> \<M>}\<rparr>)"
      by (simp add: intersect_nonzeros)
    have "mult_of (L\<lparr>carrier := \<Inter>{M-{\<zero>} |M. M \<in> \<M>}\<rparr>) = mult_of L\<lparr>carrier := \<Inter>{M-{\<zero>} |M. M \<in> \<M>}\<rparr>"
      using "1"(2) Diff_iff by blast
    then show ?case unfolding minus_swap apply simp
      apply (rule "subgroup.\<Inter>_is_supergroup")
      using 1 apply auto using K_subgroup apply simp
      using field_mult_group apply simp
      using old_fe.K_subgroup(2) by blast
  qed
qed

definition genfield where
  "genfield S = (\<lambda>M. old_fe L M \<and> M \<supseteq> K) hull S"

lemma old_fe_genfield: "S \<subseteq> carrier L \<Longrightarrow> old_fe (L\<lparr>carrier := genfield S\<rparr>) K"
  unfolding genfield_def hull_def
  by (auto simp add: K_subgroup(1) additive_subgroup.a_subset old_fe_refl)

corollary field_genfield: "S \<subseteq> carrier L \<Longrightarrow> field (L\<lparr>carrier := genfield S\<rparr>)"
  using old_fe_genfield old_fe_def by auto

interpretation emb: ring_hom_cring "(L\<lparr>carrier:=K\<rparr>)" L id
  by (simp add: K_old_sr old_sr_ring_hom_cring)

interpretation old_fe_up: UP_pre_univ_prop "L\<lparr>carrier := K\<rparr>" L id "UP (L\<lparr>carrier := K\<rparr>)"
   by intro_locales

end

definition standard_ring
  where "standard_ring A = \<lparr>carrier = A, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr>"

definition univ_ring
  where "univ_ring = \<lparr>carrier = UNIV, monoid.mult = (*) , one = 1, zero = 0, add = (+)\<rparr>"

lemma ring_univ_ring: "Ring.ring (univ_ring::_::Rings.ring_1 ring)"
  unfolding univ_ring_def
  apply (intro ringI abelian_groupI monoidI)
  apply (auto simp: ring_distribs mult.assoc)
  using ab_group_add_class.ab_left_minus apply blast
  done

lemma ring_standard_ring:
  "ring (standard_ring (range rat_of_int))"
  "ring (standard_ring (range real_of_rat))"
  "ring (standard_ring (range complex_of_real))"
  unfolding standard_ring_def
  apply standard
               apply auto
      apply (metis of_int_add range_eqI)
  unfolding Units_def apply auto
     apply (metis add.left_neutral add_diff_cancel_right' add_uminus_conv_diff of_int_add)
  using Ints_def apply auto[1]
        apply (simp add: mult.commute ring_class.ring_distribs(1))
  apply (simp add: ring_class.ring_distribs(1))
  using Rats_def apply auto[]
     apply (smt of_rat_minus)
  using Rats_def apply auto[1]
  using ring_class.ring_distribs(2) apply blast
  apply (simp add: ring_class.ring_distribs(1))
  using Reals_def apply auto[1]
  apply (simp add: add_eq_0_iff)
  using Reals_def apply auto[1]
  by (simp_all add: ring_class.ring_distribs)

lemma old_sr_example: "ring.old_sr univ_ring (standard_ring (range rat_of_int))"
  unfolding ring.old_sr_def[OF ring_univ_ring]
  apply (auto simp add: univ_ring_def) unfolding standard_ring_def
     apply (metis ring_standard_ring(1) standard_ring_def)
  by auto

lemma field_univ_ring: "Ring.field (univ_ring::_::Fields.field ring)"
  apply unfold_locales apply (auto intro: right_inverse simp: univ_ring_def Units_def field_simps)
  by (metis ab_group_add_class.ab_left_minus add.commute)

lemma f_r_o_r: \<open>field (standard_ring (range real_of_rat))\<close>
  apply standard
                   apply (auto simp: standard_ring_def)
  using Rats_add Rats_def apply blast
  unfolding Units_def apply auto
      apply (smt of_rat_minus)
  using Rats_def apply auto[1]
  apply (simp_all add: ring_class.ring_distribs)
  by (metis mult.commute nonzero_mult_div_cancel_left of_rat_eq_1_iff of_rat_mult
      times_divide_eq_right)

lemma old_fe_real_over_rat: "old_fe univ_ring (range real_of_rat)"
  apply (simp add: old_fe_def old_fe_axioms_def field_univ_ring)
proof -
  have f1: "ring \<lparr>carrier = range real_of_rat, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr>"
    by (metis (no_types) ring_standard_ring(2) standard_ring_def)
  have f2: "univ_ring = \<lparr>carrier = UNIV, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr>"
    using univ_ring_def by auto
  have "ring \<lparr>carrier = UNIV, monoid.mult = (*), one = 1::real, zero = 0, add = (+)\<rparr>"
    by (metis ring_univ_ring univ_ring_def)
  then have "ring.old_sr \<lparr>carrier = UNIV, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr> \<lparr>carrier = range real_of_rat, monoid.mult = (*), one = 1, zero = 0, add = (+)\<rparr>"
    using f1 by (simp add: ring.old_sr_def)
  then show "field.old_sf univ_ring (univ_ring\<lparr>carrier := range real_of_rat\<rparr>)"
    using f2 by (metis (mono_tags, lifting) f_r_o_r field.old_sf_def field_univ_ring partial_object.update_convs(1) standard_ring_def)
qed

end


theory Faces
  imports
    Linear_Inequalities.Decomposition_Theorem
    Linear_Inequalities.Missing_Matrix
    LP_Duality.LP_Duality
    Jordan_Normal_Form.Matrix
    Jordan_Normal_Form.DL_Rank_Submatrix
    Subsystems
begin
(*

definition undef_vec :: "nat \<Rightarrow> 'a" where
  "undef_vec i \<equiv> [] ! i"

definition mk_vec :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" where
  "mk_vec n f \<equiv> \<lambda> i. if i < n then f i else undef_vec (i - n)"

typedef 'a vec = "{(n, mk_vec n f) | n f :: nat \<Rightarrow> 'a. True}"
  by auto

definition mk_mat :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a)" where
  "mk_mat nr nc f \<equiv> \<lambda> (i,j). if i < nr \<and> j < nc then f (i,j) else undef_mat nr nc f (i,j)"

lemma cong_mk_mat: assumes "\<And> i j. i < nr \<Longrightarrow> j < nc \<Longrightarrow> f (i,j) = f' (i,j)"
  shows "mk_mat nr nc f = mk_mat nr nc f'"
  using undef_cong_mat[of nr nc f f', OF assms]
  using assms unfolding mk_mat_def
  by auto

typedef 'a mat = "{(nr, nc, mk_mat nr nc f) | nr nc f :: nat \<times> nat \<Rightarrow> 'a. True}"
  by auto
*)
definition
  one_vec :: "nat \<Rightarrow> 'a :: one vec" ("1\<^sub>v")
  where "1\<^sub>v n \<equiv> vec n (\<lambda> i. 1)"

lemma one_carrier_vec[simp]: "1\<^sub>v n \<in> carrier_vec n"
  unfolding one_vec_def carrier_vec_def by auto

lemma index_one_vec[simp]: "i < n \<Longrightarrow> 1\<^sub>v n $ i = 1" "dim_vec (1\<^sub>v n) = n"
  unfolding one_vec_def by auto

lemma vec_of_dim_1[simp]: "dim_vec v = 0 \<longleftrightarrow> v = 1\<^sub>v 0" by auto

lemma scalar_prod_left_one[simp]:
  "(v :: 'a :: semiring_1 vec) \<in> carrier_vec n \<Longrightarrow> 1\<^sub>v n \<bullet> v = sum (\<lambda> i. v $ i) {0..<n}"
  unfolding scalar_prod_def
  by auto

lemma scalar_prod_right_one[simp]:
  "(v :: 'a :: semiring_1 vec) \<in> carrier_vec n \<Longrightarrow> v \<bullet> 1\<^sub>v n = sum (\<lambda> i. v $ i) {0..<n}"
  unfolding scalar_prod_def
  by auto

context gram_schmidt
begin

definition support_hyp where
  "support_hyp P \<alpha> \<beta> \<equiv> (\<beta> = Maximum { \<alpha> \<bullet> x | x. x \<in> P})
                        \<and> has_Maximum { \<alpha> \<bullet> x | x. x \<in> P}
                        \<and> \<alpha> \<in> carrier_vec n"

definition valid_ineq where
  "valid_ineq P \<alpha> \<beta> \<equiv> (\<forall>x \<in> P. \<alpha> \<bullet> x \<le> \<beta>) \<and> \<alpha> \<in> carrier_vec n"

lemma suport_hypE:
  "support_hyp P \<alpha> \<beta> \<Longrightarrow>
   (\<lbrakk>\<beta> = Maximum { \<alpha> \<bullet> x | x. x \<in> P};
   has_Maximum { \<alpha> \<bullet> x | x. x \<in> P};
   \<alpha> \<in> carrier_vec n\<rbrakk> \<Longrightarrow> R)
   \<Longrightarrow> R"
  by(auto simp: support_hyp_def)

lemma support_hypI[intro]:
  assumes "has_Maximum { \<alpha> \<bullet> x | x. x \<in> P}"
  assumes "\<beta> = Maximum { \<alpha> \<bullet> x | x. x \<in> P}"
  assumes "\<alpha> \<in> carrier_vec n"
  shows "support_hyp P \<alpha> \<beta>"
  unfolding support_hyp_def
  using assms
  by auto

lemma valid_ineqE[elim]:
"valid_ineq P \<alpha> \<beta> \<Longrightarrow>
   (\<lbrakk>\<forall>x \<in> P. \<alpha> \<bullet> x \<le> \<beta>;
   \<alpha> \<in> carrier_vec n\<rbrakk> \<Longrightarrow> R)
   \<Longrightarrow> R"
  unfolding valid_ineq_def
  by auto

lemma valid_ineq_intro[intro]:
  assumes "\<forall>x \<in> P. \<alpha> \<bullet> x \<le> \<beta>"
  assumes "\<alpha> \<in> carrier_vec n"
  shows "valid_ineq P \<alpha> \<beta>"
  unfolding valid_ineq_def
  using assms
  by auto

lemma exists_greater_if_not_Maximum:
  assumes "a \<in> A"
  assumes "a \<noteq> Maximum A"
  shows "\<exists> m \<in> A. m > a"
  using assms
  by (metis assms(2) eqMaximumI leI)

lemma valid_ineq_non_empty_is_support:
  assumes "valid_ineq P \<alpha> \<beta>"
  assumes "{x. \<alpha> \<bullet> x = \<beta>} \<inter> P \<noteq> {}"
  shows "support_hyp P \<alpha> \<beta>"
proof
  obtain x where "x \<in> P \<and> \<alpha> \<bullet> x = \<beta>" using assms(2)
    by blast
  then have " \<beta> \<in> {\<alpha> \<bullet> x |x. x \<in> P}"
    by auto
 show "\<beta> = Maximum {\<alpha> \<bullet> x |x. x \<in> P}"
 using assms(1)
  apply(elim valid_ineqE)
  using eqMaximumI[of \<beta> "{\<alpha> \<bullet> x |x. x \<in> P}"] mem_Collect_eq `\<beta> \<in> {\<alpha> \<bullet> x |x. x \<in> P}`
  by blast
  show "has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}"
    using assms(1)
    apply(elim valid_ineqE)
    using \<open>\<beta> \<in> {\<alpha> \<bullet> x |x. x \<in> P}\<close> has_Maximum_def by auto
  show "\<alpha> \<in> carrier_vec n"
    using assms(1) valid_ineqE by blast
qed

lemma support_hyp_is_valid:
  assumes "support_hyp P \<alpha> \<beta>"
  shows  "valid_ineq P \<alpha> \<beta>" (is ?g1)
     and "{x. \<alpha> \<bullet> x = \<beta>} \<inter> P \<noteq> {}" (is ?g2)
proof-
  have \<beta>_max: "\<beta> = Maximum {\<alpha> \<bullet> x |x. x \<in> P}" "has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}"
    using assms suport_hypE by blast+
  then show ?g1
    using \<open>support_hyp P \<alpha> \<beta>\<close>
    by (auto elim: suport_hypE dest: has_MaximumD(2))
  have "\<beta> \<in> {\<alpha> \<bullet> x |x. x \<in> P}"
    using \<beta>_max has_MaximumD(1) by blast
  then show "{x. \<alpha> \<bullet> x = \<beta>} \<inter> P \<noteq> {}"
    by blast
qed

definition face :: "'a vec set \<Rightarrow> 'a vec set \<Rightarrow> bool" where
  "face P F \<equiv> P \<noteq> {} \<and> (\<exists> \<alpha> \<beta>. F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> support_hyp P \<alpha> \<beta> )"

lemma faceE[elim]:
"face P F \<Longrightarrow>
   (\<lbrakk>P \<noteq> {};
   (\<exists> \<alpha> \<beta>. F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> support_hyp P \<alpha> \<beta> )\<rbrakk> \<Longrightarrow> R)
   \<Longrightarrow> R"
 unfolding face_def by auto

lemma faceI[intro]:
  assumes "P \<noteq> {}"
  assumes "F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>}"
  assumes "support_hyp P \<alpha> \<beta>"
  shows "face P F"
  unfolding face_def
  using assms
  by auto

lemma faceE':
"face P F \<Longrightarrow>
   (\<lbrakk>(\<exists> \<alpha> \<beta>. F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> valid_ineq P \<alpha> \<beta> \<and> F \<noteq> {})\<rbrakk> \<Longrightarrow> R)
   \<Longrightarrow> R"
  apply (elim faceE)
  using support_hyp_is_valid
  by (metis  inf.commute)

lemma face_intro'[intro]:
  assumes "valid_ineq P \<alpha> \<beta>"
  assumes "F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>}"
  assumes "F \<noteq> {}"
  shows "face P F"
  unfolding face_def
  using valid_ineq_non_empty_is_support[of P \<alpha> \<beta>] assms
  by blast

lemma face_non_empty:
  assumes "face P F"
  shows "F \<noteq> {}"
  using faceE'
  using assms by blast

lemma face_subset_polyhedron:
  assumes "face P F"
  shows "F \<subseteq> P"
  using assms unfolding face_def
  by auto

lemma face_is_Max':
  assumes "{x. \<alpha> \<bullet> x = \<beta>  \<and> x \<in> P} \<noteq> {}"
  assumes "valid_ineq P \<alpha> \<beta>"
  shows "\<beta> =  Maximum {\<alpha> \<bullet> x | x. x \<in> P}" (is "\<beta> = Maximum ?Ineq")
  and "has_Maximum {\<alpha> \<bullet> x | x. x \<in> P}"  (is "has_Maximum ?Ineq")
proof -
  have "\<beta> \<in> {\<alpha> \<bullet> x | x. x \<in> P}" using assms(1)  by auto
  then show "\<beta> = Maximum ?Ineq"
    by (smt (verit, best) assms(2) eqMaximumI valid_ineq_def mem_Collect_eq)
  show "has_Maximum ?Ineq"
    unfolding has_Maximum_def
    using assms(2) \<open>\<beta> \<in> {\<alpha> \<bullet> x |x. x \<in> P}\<close>
    by(auto simp: valid_ineqE)
qed

lemma face_primal_bounded:
  fixes A b
  defines "P \<equiv> polyhedron A b"
  assumes "valid_ineq P \<alpha> \<beta>"
  shows "\<forall> x \<in> carrier_vec n. A *\<^sub>v x \<le> b \<longrightarrow> \<alpha> \<bullet> x \<le> \<beta>"
  using assms
  unfolding polyhedron_def valid_ineq_def
  by simp

lemma valid_ineq_dual:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "valid_ineq P \<alpha> \<beta>"
  assumes "P \<noteq> {}"
  shows "Maximum {\<alpha> \<bullet> x | x. x \<in> P} = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
    and "has_Maximum {\<alpha> \<bullet> x | x. x \<in> P}"
    and "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
proof -
  have "\<alpha> \<in> carrier_vec n"
    using assms(4) valid_ineqE by blast
  have sat: "\<exists> x \<in> carrier_vec n. A *\<^sub>v x \<le> b"
    using assms(3) assms(5) unfolding polyhedron_def by auto
  have bounded: "\<forall> x \<in> carrier_vec n. A *\<^sub>v x \<le> b \<longrightarrow> \<alpha> \<bullet> x \<le> \<beta>"
    using P_def assms(4) face_primal_bounded by blast
  show "Maximum {\<alpha> \<bullet> x | x. x \<in> P} = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
    "has_Maximum {\<alpha> \<bullet> x | x. x \<in> P}" "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
    using strong_duality_theorem_primal_sat_bounded_min_max[of A nr n b \<alpha> \<beta>]
    using A \<open>\<alpha> \<in> carrier_vec n\<close> b bounded sat
    by (auto simp: P_def polyhedron_def)
qed

lemma valid_ineq_dual_min:
 fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "valid_ineq P \<alpha> \<beta>"
  assumes "{x. \<alpha> \<bullet> x = \<beta> \<and> x \<in> P} \<noteq> {}"
  shows "\<beta> = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
    and "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
proof -
  have "P \<noteq> {}" using assms(5) by blast
  show "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
  using valid_ineq_dual(3)[of A nr b \<alpha> \<beta>] `P \<noteq> {}`
    using A P_def assms(4) b by fastforce
  show "\<beta> = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha>}"
     using valid_ineq_dual(1)[of A nr b \<alpha> \<beta>] face_is_Max'(1)[of \<alpha> \<beta> P]
     using A P_def \<open>P \<noteq> {}\<close>  assms(4) assms(5) b by fastforce
 qed

lemma if_sum_0_then_all_0:
  fixes f :: "nat \<Rightarrow> 'a :: trivial_conjugatable_linordered_field"
  assumes "(\<Sum>i = 0..<nr. f i) = 0"
  assumes "\<forall> i < nr. f i \<ge> 0"
  shows "(\<Sum>i = 0..<nr. f i) = 0 \<longleftrightarrow> (\<forall> i < nr. f i = 0)"
  using assms
  apply (induct rule: nat_induct)
   apply blast
  by (metis add_nonneg_eq_0_iff atLeastLessThan_iff less_Suc_eq
      sum.atLeast0_lessThan_Suc sum_nonneg)

lemma eq_vec_zero_diff_in_mult:
  fixes a :: "'a :: trivial_conjugatable_linordered_field vec"
  assumes "a \<in> carrier_vec nr"
  assumes "b \<in> carrier_vec nr"
  assumes "y \<in> carrier_vec nr"
  assumes "a \<le> b"
  assumes "y \<ge> 0\<^sub>v nr"
  shows "y \<bullet> a = y \<bullet> b \<longleftrightarrow> (\<forall> i < nr. y $ i * (b - a) $ i = 0)"
proof -
  have ge0:"\<forall> i < nr. y $ i * (b - a) $ i \<ge> 0"
    by (metis assms(1-5) carrier_vecD diff_ge_0_iff_ge index_minus_vec(1) index_zero_vec(1)
        lesseq_vecD zero_le_mult_iff)
  have "y \<bullet> a = y \<bullet> b \<longleftrightarrow> y \<bullet> b - y \<bullet> a  = 0" using assms(5)  by auto
  also have "\<dots> \<longleftrightarrow> y \<bullet> (b - a) = 0"
    by (metis assms(1-3) scalar_prod_minus_distrib)
  also have "\<dots> \<longleftrightarrow> (\<Sum>i = 0..<nr. y $ i * (b - a) $ i) = 0"
    unfolding scalar_prod_def
    using assms(1)  by auto
  also have "\<dots> \<longleftrightarrow> (\<forall> i < nr. y $ i * (b - a) $ i = 0)"
    by (meson ge0 atLeastLessThan_iff finsum_zero' if_sum_0_then_all_0)
  finally show ?thesis by auto
qed

lemma complementary_slackness:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  assumes "y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha> \<and> b \<bullet> y = \<beta>"
  assumes "x \<in> polyhedron A b"
  shows "\<alpha> \<bullet> x = \<beta> \<longleftrightarrow> (\<forall> i < nr. y $ i = 0 \<or> (row A i) \<bullet> x = b $ i)"
proof -
  have "dim_row A = nr" using A by auto
  have "y \<in> carrier_vec nr"
    by (metis assms(3) carrier_dim_vec index_zero_vec(2) less_eq_vec_def)
  then  have "(A\<^sup>T *\<^sub>v y) \<bullet> x = y \<bullet> (A *\<^sub>v x)"
    using transpose_vec_mult_scalar[of A nr n x y] assms(1) assms(3)
    using assms(4) gram_schmidt.polyhedron_def by blast
  then have " \<alpha> \<bullet> x = \<beta>  \<longleftrightarrow> y \<bullet> (A *\<^sub>v x) = y \<bullet> b"
    by (metis \<open>y \<in> carrier_vec nr\<close> assms(3) b comm_scalar_prod)
  also have "\<dots> \<longleftrightarrow> (\<forall> i < nr. y $ i * (b - A *\<^sub>v x) $ i = 0)"
    using eq_vec_zero_diff_in_mult[of "A *\<^sub>v x" nr b y]
    using A \<open>y \<in> carrier_vec nr\<close> assms(3) assms(4) b mult_mat_vec_carrier
    by (simp add: gram_schmidt.polyhedron_def)
  also have "\<dots> \<longleftrightarrow>  (\<forall> i < nr. y $ i = 0 \<or> (row A i) \<bullet> x = b $ i)"
    unfolding mult_mat_vec_def
    using \<open>dim_row A = nr\<close> by auto
  finally show ?thesis
    by blast
qed

lemma complementary_slackness_subsystem:
 fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  assumes "y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = \<alpha> \<and> b \<bullet> y = \<beta>"
  assumes "x \<in> polyhedron A b"
  shows "\<alpha> \<bullet> x = \<beta> \<longleftrightarrow>
  fst (sub_system A b {i. y $ i > 0 \<and> i < nr}) *\<^sub>v x = snd (sub_system A b {i. y $ i > 0 \<and> i < nr})"
   (is "\<alpha> \<bullet> x = \<beta> \<longleftrightarrow> ?A' *\<^sub>v x = ?b'")
proof -
   have "\<alpha> \<bullet> x = \<beta> \<longleftrightarrow> (\<forall> i < nr. y $ i = 0 \<or> (row A i) \<bullet> x = b $ i)"
    using assms complementary_slackness by blast
  also have "\<dots> \<longleftrightarrow>
    (\<forall>i \<in> {i. y $ i > 0 \<and> i < nr} \<inter> {0..<dim_row A}. (row A i) \<bullet> x = b $ i)"
    by (smt (verit) A Int_iff assms(3) atLeastLessThan_iff carrier_matD(1) index_zero_vec(1)
        index_zero_vec(2) le0 less_eq_vec_def less_numeral_extra(3) mem_Collect_eq
        order_le_imp_less_or_eq)
  also have "\<dots> \<longleftrightarrow> (\<forall> i < dim_row ?A'. (row ?A' i) \<bullet> x = ?b' $ i)"
    using subsystem_fulfills_P'[of A b ?A' ?b' _ "(\<lambda> a c. a \<bullet> x = c)"]
 using subsystem_fulfills_P[of A b ?A' ?b' _ "(\<lambda> a c. a \<bullet> x = c)"]
    by (metis (no_types, lifting) A b carrier_matD(1) carrier_vecD prod.collapse)
  also have "(\<forall> i < dim_row ?A'. (row ?A' i) \<bullet> x = ?b' $ i) \<longleftrightarrow> ?A' *\<^sub>v x = ?b'"
    unfolding mult_mat_vec_def
    by (smt (verit, ccfv_SIG) A b carrier_matD(1) carrier_vecD dim_vec dims_subsyst_same
        eq_vecI index_vec)
  finally show ?thesis
    by blast
qed

lemma char_face1:
 fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "face P F"
 obtains A' b' I where "((A', b') = sub_system A b I)" "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
proof -
  obtain \<alpha> \<beta> where face:" F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> valid_ineq P \<alpha> \<beta> \<and> F \<noteq> {}"
    using assms(4)
    apply (elim faceE')
  by presburger
  then have "{x. \<alpha> \<bullet> x = \<beta> \<and> x \<in> polyhedron A b} \<noteq> {}"
    using P_def face by fastforce
  then obtain y' where y': "y' \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y' = \<alpha> \<and> b \<bullet> y' = \<beta>"
    using valid_ineq_dual_min[of A nr b \<alpha> \<beta>]
    by (smt (verit, best) A P_def b face has_MinimumD(1) mem_Collect_eq)
  let ?A' = "fst (sub_system A b {i. y' $ i > 0 \<and> i < nr})"
  let ?b' = "snd (sub_system A b {i. y' $ i > 0 \<and> i < nr})"
  have "{x. \<alpha> \<bullet> x = \<beta> \<and> x \<in> P} = {x. ?A' *\<^sub>v x = ?b' \<and> x \<in> P}"
    unfolding P_def using complementary_slackness_subsystem A y' b by blast
  moreover have "((?A', ?b') = sub_system A b {i. 0 < y' $ i \<and> i < nr})"
    by simp
  ultimately show ?thesis
    using face that by blast
qed

lemma subsyst_valid:
 assumes "x \<in> polyhedron A b"
 shows "fst (sub_system A b I) *\<^sub>v x \<le> snd (sub_system A b I)"
  using assms
  unfolding polyhedron_def
  by (smt (verit, best) dim_mult_mat_vec dims_subsyst_same exist_index_in_A
       index_mult_mat_vec less_eq_vec_def mem_Collect_eq)

lemma eq_iff_sum_eq_for_el_in_P:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "((A', b') = sub_system A b I)"
  assumes "x \<in> polyhedron A b"
  shows "A' *\<^sub>v x = b' \<longleftrightarrow> 1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) = 1\<^sub>v (dim_vec b') \<bullet> b'"
  apply rule+
   apply blast
proof -
  assume  " 1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) = 1\<^sub>v (dim_vec b') \<bullet> b'"
  then have "A' *\<^sub>v x \<le> b'"
    by (metis (no_types, lifting) assms polyhedron_def subsyst_valid  prod.sel(1) prod.sel(2))
  then have "\<forall>i<dim_vec b'. (A' *\<^sub>v x) $ i \<le> b' $ i"
    using less_eq_vec_def by blast
  show "A' *\<^sub>v x = b'"
  proof(rule ccontr)
    assume "A' *\<^sub>v x \<noteq> b'"
    then obtain i where "i < dim_vec b'\<and> (A' *\<^sub>v x) $ i < b' $ i"
      by (metis \<open>A' *\<^sub>v x \<le> b'\<close> antisym less_eq_vec_def linorder_le_less_linear)
    then have "sum (\<lambda> i. (A' *\<^sub>v x) $ i) {0..<dim_vec b'}  < sum (\<lambda> i. b' $ i) {0..<dim_vec b'}"
      by (metis \<open>A' *\<^sub>v x \<le> b'\<close> atLeastLessThan_iff bot_nat_0.extremum carrier_vec_dim_vec
          finite_atLeastLessThan lesseq_vecD sum_strict_mono_ex1)
    then have "1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) < 1\<^sub>v (dim_vec b') \<bullet> b'"
      by (metis \<open>A' *\<^sub>v x \<le> b'\<close> carrier_vec_dim_vec less_eq_vec_def scalar_prod_left_one)
    then show False
      using \<open>1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) = 1\<^sub>v (dim_vec b') \<bullet> b'\<close> by linarith
  qed
qed

lemma char_face2:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "((A', b') = sub_system A b I)"
  assumes "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
  assumes "F \<noteq> {}"
  shows  "face P F"
proof -
  let ?\<alpha> = "A'\<^sup>T *\<^sub>v 1\<^sub>v (dim_vec b')"
  let ?\<beta> = " 1\<^sub>v (dim_vec b') \<bullet> b'"
  have "?\<beta> = sum (\<lambda> i. b' $ i) {0..<dim_vec b'}"
    by auto
  have "A' \<in> carrier_mat (dim_vec b') n" using carrier_mat_subsyst
    by (metis A assms(4) b carrier_matD(1) carrier_matD(2) carrier_vecD dims_subsyst_same' fst_conv)
  have 1: "\<forall> x\<in> carrier_vec n. (A'\<^sup>T *\<^sub>v 1\<^sub>v (dim_vec b')) \<bullet> x =  1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x)"
    using transpose_vec_mult_scalar[of A' "dim_vec b'" n  _ "1\<^sub>v (dim_vec b')"]
    using `A' \<in> carrier_mat (dim_vec b') n`  by simp
  have "\<forall>x \<in> P. A' *\<^sub>v x = b' \<longleftrightarrow> 1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) = 1\<^sub>v (dim_vec b') \<bullet> b'"
    using eq_iff_sum_eq_for_el_in_P
    using P_def assms(4) by blast
  then have "\<forall>x \<in> P. A' *\<^sub>v x = b' \<longleftrightarrow> (A'\<^sup>T *\<^sub>v 1\<^sub>v (dim_vec b')) \<bullet> x = 1\<^sub>v (dim_vec b') \<bullet> b'"
    by (simp add: P_def 1 gram_schmidt.polyhedron_def)
  then have "{x. A' *\<^sub>v x = b' \<and> x \<in> P} = {x. ?\<alpha> \<bullet> x = ?\<beta> \<and> x \<in> P}"
    by blast
  have "\<forall> x \<in> P. A' *\<^sub>v x \<le> b'"
    by (metis (no_types, lifting) assms(3-4) polyhedron_def subsyst_valid  prod.sel(1) prod.sel(2))
  then have "\<forall> x \<in> P.  1\<^sub>v (dim_vec b') \<bullet> (A' *\<^sub>v x) \<le> 1\<^sub>v (dim_vec b') \<bullet> b'"
    by (metis (no_types, lifting) atLeastLessThan_iff carrier_vec_dim_vec
         less_eq_vec_def scalar_prod_left_one sum_mono)
  then have "valid_ineq P ?\<alpha> ?\<beta>"
    unfolding valid_ineq_def P_def polyhedron_def
    using "1" \<open>A' \<in> carrier_mat (dim_vec b') n\<close> by force
  then show "face P F" using face_intro'[of P ?\<alpha> ?\<beta> F] assms(5-6)
      `{x. A' *\<^sub>v x = b' \<and> x \<in> P} = {x. ?\<alpha> \<bullet> x = ?\<beta> \<and> x \<in> P}` by auto
qed

lemma set_of_sub_dims_finite:
  shows "finite {dim_vec d| C d I. (C, d) = sub_system A b I}" (is "finite ?M")
proof -
  have "\<forall> nd \<in> ?M. nd\<le> dim_vec b"
    by (smt (verit, ccfv_SIG) dim_subsyst_vec_less_b mem_Collect_eq snd_eqD)
   then have "?M \<subseteq> {0..<dim_vec b+1}" by fastforce
  then show "finite ?M"
    using subset_eq_atLeast0_lessThan_finite by blast
qed

lemma subset_set_of_sub_dims_finite:
  assumes "M \<subseteq> {dim_vec d| C d I. (C, d) = sub_system A b I}"
  shows "finite M"
  using set_of_sub_dims_finite[of A b] finite_subset
  using assms by blast

lemma exist_max_subsystem:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "face P F"
 obtains A' b' I  where "((A', b') = sub_system A b I)"
                      "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
                      "dim_vec b' = Max {dim_vec d| C d I. (C, d) = sub_system A b I \<and>
                                                                    F = {x. C *\<^sub>v x = d \<and> x \<in> P}}"
proof-
  have "dim_vec b = nr" using b by auto
  let ?M = "{dim_vec d| C d I.  (C, d) = sub_system A b I \<and> F = {x. C *\<^sub>v x = d \<and> x \<in> P}}"
  have "?M \<noteq> {}"  using char_face1[of A nr b F] assms
    by (smt (verit, best) Collect_cong Collect_empty_eq)
  then have "finite ?M"
    using subset_set_of_sub_dims_finite[of ?M A b] by blast
  then have "Max ?M \<in> ?M \<and> (\<forall>a \<in> ?M. a \<le> (Max ?M))"
    using eq_Max_iff[of ?M] `?M \<noteq> {}`
    by auto
  then show ?thesis
    using that by force
qed

lemma exist_min_ineq_subsystem:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "((A', b') = sub_system A b I')"
 assumes "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
 obtains A'' b'' I''
 where  "((A'', b'') = sub_system A b I'')"
       "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A'' *\<^sub>v x \<le> b'' }"
       "dim_vec b'' = Min {dim_vec d| C d I.  (C, d) = sub_system A b I
                                  \<and> F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}}"
proof -
  let ?M = "{dim_vec d| C d I.  (C, d) = sub_system A b I \<and>
           F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}}"
   have "(A, b) = sub_system A b UNIV" using itself_is_subsyst by auto
   have "F = {x. x \<in> carrier_vec n \<and>  A' *\<^sub>v x = b' \<and> A *\<^sub>v x \<le> b}"
    using assms(5) P_def  unfolding polyhedron_def
    by blast
  then  have "?M \<noteq> {}" using `(A, b) = sub_system A b UNIV` by auto
  then have "finite ?M"
using subset_set_of_sub_dims_finite[of ?M A b] by blast
  then have "Min ?M \<in> ?M \<and> (\<forall>a \<in> ?M. a \<ge> (Min ?M))"
    using eq_Min_iff[of ?M] `?M \<noteq> {}`
    by auto
  then show ?thesis using that by force
qed

lemma exist_min_ineq_subsystem':
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  assumes "((A', b') = sub_system A b I')"
  assumes "((A'', b'') = sub_system A b I'')"
  assumes "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A'' *\<^sub>v x \<le> b'' }"
  assumes "dim_vec b'' = Min {dim_vec d| C d I.  (C, d) = sub_system A b I
                                  \<and> F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}}"
  shows "I' \<inter> I'' \<inter> {0..<nr} = {}"
proof(rule ccontr)
  let ?N =  "{dim_vec d| C d I.  (C, d) = sub_system A b I
                                  \<and> F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}}"
  have 2:"finite ?N"
    using subset_set_of_sub_dims_finite[of ?N A b] by blast
  have "dim_vec b = nr" using b by auto
  assume "I' \<inter> I'' \<inter> {0..<nr}\<noteq> {}"
  then obtain i where i:"i \<in> I' \<and> i \<in> I'' \<and> i < nr" by fastforce
  then obtain C d where "(C, d) = sub_system A b (I'' - {i})"
    by (metis surj_pair)
  then have "{x. A'' *\<^sub>v x \<le> b''} = {x. C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i}"
    using remove_index_sub_system assms(4) i  A \<open>dim_vec b = nr\<close> by blast
  then have "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i}"
    using assms(5) by blast
  have "\<forall> x \<in> carrier_vec n. b' = A' *\<^sub>v x \<longrightarrow> row A i \<bullet> x = b $ i"
    using remove_index_sub_system_eq[of A b i I' A' b']
    by (metis (mono_tags, lifting) A \<open>dim_vec b = nr\<close> assms(3) carrier_vecD dim_mult_mat_vec i
        mem_Collect_eq mult_mat_vec_carrier surj_pair)
  then have "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}"
    using \<open>F = {x \<in> carrier_vec n. A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i}\<close> by fastforce
  then have "dim_vec d \<in> ?N"
    using `(C, d) = sub_system A b (I'' - {i})` by blast
  then have "dim_vec d \<ge> dim_vec b''"
    using 2 assms(6) `(C, d) = sub_system A b (I'' - {i})`
    by auto
  have "dim_vec d + 1 = dim_vec b''"
    using \<open>(A'', b'') = sub_system A b I''\<close> \<open>(C, d) = sub_system A b (I'' - {i})\<close>
      i remove_index_sub_system_dims
    by (metis \<open>dim_vec b = nr\<close>)
  then have "dim_vec d < dim_vec b''" by auto
  then show False
    using \<open>dim_vec b'' \<le> dim_vec d\<close> linorder_not_le by blast
qed

text \<open>Minimal Faces\<close>

text \<open>Minimal faces are faces that doesn't contain any other face. They are affine spaces\<close>

definition min_face where
  "min_face P F \<equiv> face P F \<and> (\<nexists> F'. F' \<subset> F \<and> face P F')"

lemma min_face_elim[elim]:
  assumes "min_face P F"
  shows "face P F"
       "(\<nexists> F'. F' \<subset> F \<and> face P F')"
  using assms unfolding min_face_def by auto

lemma min_face_intro[intro]:
  assumes "face P F"
  assumes "(\<nexists> F'. F' \<subset> F \<and> face P F')"
  shows "min_face P F"
  unfolding min_face_def using assms by auto

lemma smult_minus_distrib_vec:
  assumes "v \<in> carrier_vec n" "w \<in> carrier_vec n"
  shows "(a::'b::ring) \<cdot>\<^sub>v (v - w) = a \<cdot>\<^sub>v v - a \<cdot>\<^sub>v w"
  apply (rule eq_vecI)
  unfolding smult_vec_def minus_vec_def
  using assms(1) assms(2) right_diff_distrib
   apply force
  by force

lemma char_min_face1:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "min_face P F"
 obtains A' b' I where  " F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}" "(A', b') = sub_system A b I"
proof -
  have "face P F" using assms(4) min_face_elim by auto
  have "dim_vec b = nr" using b by auto
  let ?M = "{dim_vec d| C d I.  (C, d) = sub_system A b I \<and> F = {x. C *\<^sub>v x = d \<and> x \<in> P}}"
  have 7:"finite ?M"
    using subset_set_of_sub_dims_finite[of ?M A b] by blast

  then obtain A' b' I  where sub_A:"((A', b') = sub_system A b I)"
                      "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
                      "dim_vec b' = Max ?M"
    using exist_max_subsystem[of A nr b F] assms min_face_elim
    by auto

  let ?N =  "{dim_vec d| C d I.  (C, d) = sub_system A b I
                                  \<and> F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}}"
 have 2:"finite ?N"
    using subset_set_of_sub_dims_finite[of ?N A b] by blast
  obtain A'' b'' I''
    where  sub_A'':"((A'', b'') = sub_system A b I'')"
       "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A'' *\<^sub>v x \<le> b'' }"
       "dim_vec b'' = Min ?N"
    using  exist_min_ineq_subsystem[of A nr b A' b' I F] sub_A assms(1-3) by auto
  have "dim_vec b = nr"
    using b by auto
  have "I \<inter> I'' \<inter> {0..<nr}= {}"
    using exist_min_ineq_subsystem'[of A nr b A' b' I A'' b'' I'']
      assms  sub_A sub_A''
    by presburger
  have "dim_vec b'' = 0"
  proof(rule ccontr)
    assume "dim_vec b'' \<noteq> 0"
    then have "dim_vec b'' > 0" by auto
    then obtain j where "j < dim_vec b''" by auto
    then obtain i where i:"i < nr \<and> i \<in> I'' \<and> row A'' j = row A i \<and> b'' $ j = b $ i"
      using exist_index_in_A[of A  b j I'']
      by (metis A sub_A''(1) \<open>dim_vec b = nr\<close> carrier_matD(1) fst_conv snd_conv)
    obtain C d where sub_C: "((C, d) = sub_system A b (I'' - {i}))"
      by (metis surj_pair)
    have "{x. A'' *\<^sub>v x \<le> b''} = {x. C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i}"
      using remove_index_sub_system
      using sub_A''(1) sub_C(1)  i
      using A \<open>dim_vec b = nr\<close> by blast
    then have F_by_Cd: "F = {x. x \<in> carrier_vec n \<and>
                                A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d \<and>
                                row A i \<bullet> x \<le> b $ i}"
      using sub_A''(2) by fastforce

    show False
    proof(cases "{x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d} \<inter>
                 {x. row A i \<bullet> x > b $ i} = {}")
      case True
      then have "F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d}"
        using True F_by_Cd by fastforce
      then have "dim_vec d \<in> ?N"
        using  `((C, d) = sub_system A b (I'' - {i}))`
        by auto
      then have "dim_vec d \<ge> dim_vec b''"
        using `dim_vec b'' = Min ?N` 2 by simp
      have "dim_vec d + 1 = dim_vec b''"
        using remove_index_sub_system_dims[of i I'' b A'' b'' A]
        using \<open>dim_vec b = nr\<close> i sub_A''(1) sub_C by presburger
      then show ?thesis using `dim_vec d \<ge> dim_vec b''` by simp
    next
      case False
      have 1:"row A i \<in> carrier_vec n"
        using A i row_carrier_vec by blast
      then obtain y where
        "y \<in> {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d} \<inter> {x. row A i \<bullet> x > b $ i}"
        using False  by auto
      then have y: "y \<in> carrier_vec n \<and> A' *\<^sub>v y = b' \<and> C *\<^sub>v y \<le> d \<and> row A i \<bullet> y > b $ i"
        by fastforce
      then have y_n:"y \<in> carrier_vec n" by auto
      obtain x  where "x\<in> F"
        by (metis \<open>face P F\<close> equals0I gram_schmidt.face_non_empty)
      then have x: "x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i"
        using F_by_Cd by fastforce
      then have x_n:"x \<in> carrier_vec n" by auto
      have 2: "row A i \<bullet> x - row A i \<bullet> y \<noteq> 0"
        using x y by linarith
      let ?z = "y + ((b $ i - row A i \<bullet> y)/(row A i \<bullet> x - row A i \<bullet> y)) \<cdot>\<^sub>v (x - y)"
      have "row A i \<bullet> ?z =
            row A i \<bullet> y + row A i \<bullet> (((b $ i - row A i \<bullet> y)/(row A i \<bullet> x - row A i \<bullet> y)) \<cdot>\<^sub>v (x - y))"
        by (meson 1 x_n y_n minus_carrier_vec scalar_prod_add_distrib smult_closed)
      then have "row A i \<bullet> ?z = row A i \<bullet> y + ((b $ i - row A i \<bullet> y)/(row A i \<bullet> x - row A i \<bullet> y)) *
                                               (row A i \<bullet> (x - y))"
        by (metis 1 x_n y_n minus_carrier_vec scalar_prod_smult_distrib)
      then have "row A i \<bullet> ?z = row A i \<bullet> y + (b $ i - row A i \<bullet> y)"
        by (metis 2 1 x_n y_n nonzero_eq_divide_eq scalar_prod_minus_distrib)
      then have 4:"row A i \<bullet> ?z = b $ i"
        by simp
      let ?l = "(b $ i - row A i \<bullet> y)/(row A i \<bullet> x - row A i \<bullet> y)"
      have "?z = y + ?l \<cdot>\<^sub>v (x - y)" by simp
      then have "?z =  y  + ?l  \<cdot>\<^sub>v x - ?l \<cdot>\<^sub>v y "
        using smult_minus_distrib_vec[of x y ?l] x_n y_n by fastforce
      have "y  + ?l  \<cdot>\<^sub>v x - ?l \<cdot>\<^sub>v y = y   - ?l \<cdot>\<^sub>v y + ?l  \<cdot>\<^sub>v x"
        using x_n y_n by auto
      have "1  \<cdot>\<^sub>v y = y"
        by simp
      have "?z =  1  \<cdot>\<^sub>v y  - ?l \<cdot>\<^sub>v y  + ?l  \<cdot>\<^sub>v x"
        apply (auto simp:`1  \<cdot>\<^sub>v y = y`)
        using `?z =  y  + ?l  \<cdot>\<^sub>v x - ?l \<cdot>\<^sub>v y `
        by (simp add: `y  + ?l  \<cdot>\<^sub>v x - ?l \<cdot>\<^sub>v y = y   - ?l \<cdot>\<^sub>v y + ?l  \<cdot>\<^sub>v x`)
      then have "?z = (1 - ?l) \<cdot>\<^sub>v y + ?l  \<cdot>\<^sub>v x"
        using diff_smult_distrib_vec[of 1 ?l y] `?z =  y  + ?l  \<cdot>\<^sub>v x - ?l \<cdot>\<^sub>v y `
        by presburger
      have "0 < ?l" using x y
        by (meson less_iff_diff_less_0 order_le_less_trans zero_less_divide_iff)
      have "?l \<le> 1" using x y
        by auto
      have 5:"?z \<in> carrier_vec n"
        by (simp add: \<open>x \<in> carrier_vec n\<close> \<open>y \<in> carrier_vec n\<close>)
      have "A' \<in> carrier_mat (dim_row A') n"
        by (metis A carrier_matD(2) carrier_matI dim_col_subsyst_mat prod.sel(1) sub_A(1))
      then have 3:"A' *\<^sub>v ?z = b'"
        using linear_comb_holds_eq[of A' _ n x y ?z b' ?l]
          x y `?z = (1 - ?l) \<cdot>\<^sub>v y + ?l  \<cdot>\<^sub>v x` `?z \<in> carrier_vec n`
        by (smt (verit, ccfv_SIG) M.add.m_comm \<open>?l \<le> 1\<close> \<open>0 < ?l\<close> divide_nonneg_pos
            divide_nonpos_neg smult_closed zero_le_divide_iff zero_less_divide_iff
            zero_less_one_class.zero_le_one)
      have "C \<in> carrier_mat (dim_row C) n"
        by (metis A carrier_matD(2) carrier_mat_triv dim_col_subsyst_mat prod.sel(1) sub_C)
      then have " C *\<^sub>v ?z \<le> d"
        using linear_comb_holds_less_eq[of C _ n x y ?z d ?l]
          x y `?z = (1 - ?l) \<cdot>\<^sub>v y + ?l  \<cdot>\<^sub>v x` `?z \<in> carrier_vec n`
        by (simp add: M.add.m_comm  zero_le_divide_iff)
      then have "?z \<in> {x \<in> carrier_vec n. A' *\<^sub>v x = b' \<and> C *\<^sub>v x \<le> d \<and> row A i \<bullet> x \<le> b $ i}"
        by (simp add: 3 4 5)
      then have "?z \<in> F"
        using F_by_Cd by presburger
      then have "?z \<in> P" using `face P F`
        by (metis IntE gram_schmidt.face_def)
      have "i \<notin> I" using `I \<inter> I'' \<inter> {0..<nr}= {}`
        using \<open>i < nr \<and> i \<in> I'' \<and> row A'' j = row A i \<and> b'' $ j = b $ i\<close>
        by fastforce
      obtain C' d'  where "(C', d') = sub_system A b (I \<union> {i})"
        by (metis surj_pair)
      then have "{x. C' *\<^sub>v x = d'} = {x. A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i}"
        using insert_sub_system_eq[of A b i  A' b' I  C' d']
              \<open>i \<notin> I\<close> sub_A(1) A \<open>dim_vec b = nr\<close> i by blast
      then have 6:"{x. C' *\<^sub>v x = d' \<and> x \<in> P} = {x. A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i \<and> x \<in> P}"
        by blast
      have "?z \<in>  {x. A' *\<^sub>v x = b' \<and> row A i \<bullet> x = b $ i \<and> x \<in> P}"
        using `?z \<in> P`
        using \<open>A' *\<^sub>v ?z = b'\<close> \<open>row A i \<bullet> ?z = b $ i\<close> by blast
      then have "{x. C' *\<^sub>v x = d' \<and> x \<in> P} \<noteq> {}"
        using 6 by blast
      then have "face P {x. C' *\<^sub>v x = d' \<and> x \<in> P}" using char_face2
        using P_def \<open>(C', d') = sub_system A b (I \<union> {i})\<close> assms(1) b by blast
      have "{x. C' *\<^sub>v x = d' \<and> x \<in> P} \<subseteq> F"
        using 6 sub_A(2) by blast
      then have "{x. C' *\<^sub>v x = d' \<and> x \<in> P} = F"
        using \<open>face P {x. C' *\<^sub>v x = d' \<and> x \<in> P}\<close> assms(4) min_face_def by auto
      then have "(C', d') = sub_system A b (I\<union>{i}) \<and> F = {x. C' *\<^sub>v x = d' \<and> x \<in> P}"
        using \<open>(C', d') = sub_system A b (I \<union> {i})\<close> by fastforce
      then have "dim_vec d' \<in>
                {dim_vec d| C d I.  (C, d) = sub_system A b I \<and> F = {x. C *\<^sub>v x = d \<and> x \<in> P}}"
        by blast
      then have "dim_vec d' \<le>
                 Max {dim_vec d| C d I.  (C, d) = sub_system A b I \<and> F = {x. C *\<^sub>v x = d \<and> x \<in> P}}"
        using "7" by auto
      then have "dim_vec d' \<le> dim_vec b'"
        using sub_A(3) by presburger
      have "dim_vec d' = dim_vec b' + 1" using add_index_sub_system_dims
        using \<open>(C', d') = sub_system A b (I \<union> {i})\<close> \<open>i \<notin> I\<close> sub_A(1) \<open>dim_vec b = nr\<close> i by blast
      then show ?thesis
        using \<open>dim_vec d' \<le> dim_vec b'\<close> by linarith
    qed
  qed
    then have "\<exists> x. x\<in> {x.  A'' *\<^sub>v x \<le> b''}"
      using sub_A'' \<open>face P F\<close> face_non_empty by auto
    then have "{x.  A'' *\<^sub>v x \<le> b''} = UNIV" using `dim_vec b'' = 0`
      by (metis (no_types, lifting) UNIV_eq_I dim_mult_mat_vec less_eq_vec_def
          mem_Collect_eq vec_of_dim_1)
    then have "{x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A'' *\<^sub>v x \<le> b''}
                 = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}"
      by blast
    then have " F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}"
      using \<open>F = {x \<in> carrier_vec n. A' *\<^sub>v x = b' \<and> A'' *\<^sub>v x \<le> b''}\<close> by fastforce
    then show ?thesis
      using sub_A(1) that by blast
  qed

lemma eq_system_is_leq_system:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "dim_vec x = dim_col A"
  shows "A *\<^sub>v x = b \<longleftrightarrow> A *\<^sub>v x \<le> b \<and> (-A) *\<^sub>v x \<le> - b"
  apply safe
  using uminus_mult_mat_vec[of x A] assms
   apply simp
  using uminus_mult_mat_vec[of x A] assms
  apply simp
  apply (auto simp:less_eq_vec_def  order_le_imp_less_or_eq)
  apply rule
   apply (metis index_mult_mat_vec order_antisym_conv)
  by (metis dim_mult_mat_vec)

lemma face_is_polyhedron':
   fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
 assumes "(A', b') = sub_system A b I'"
  assumes " F = {x.  x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}"
  shows "F = polyhedron (A' @\<^sub>r (-A')) (b' @\<^sub>v (-b'))"
        "dim_row (A' @\<^sub>r (-A')) = dim_vec (b' @\<^sub>v (-b'))"
        "dim_col (A' @\<^sub>r (-A')) = n"
  unfolding polyhedron_def
proof(safe)
  show "\<And>x. x \<in> F \<Longrightarrow> x \<in> carrier_vec n"
    using assms(5) by blast
 have "dim_col A' = n" using dim_col_subsyst_mat A
      by (metis assms(4) carrier_matD(2) prod.sel(1))
    then have 1:"A' \<in> carrier_mat (dim_row A') n"
      by blast
    then have 2:"- A' \<in> carrier_mat (dim_row A') n"
      using uminus_carrier_mat by blast
    have 3:" b' \<in> carrier_vec (dim_row A')"
      by (metis A assms(4) b carrier_dim_vec carrier_matD(1) dims_subsyst_same')
  show "\<And>x. x \<in> F \<Longrightarrow> (A' @\<^sub>r - A') *\<^sub>v x \<le> b' @\<^sub>v - b'"
  proof -
    fix x
    assume "x \<in> F"
    have "dim_col A' = n" using dim_col_subsyst_mat A
      by (metis assms(4) carrier_matD(2) prod.sel(1))
    have 4:"x \<in> carrier_vec n" using `x \<in> F` assms(5) by blast
    have "A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b'" using eq_system_is_leq_system
      using \<open>dim_col A' = n\<close> \<open>x \<in> F\<close> assms(5) carrier_vecD by blast
    then show "(A' @\<^sub>r - A') *\<^sub>v x \<le> b' @\<^sub>v - b'"
      using append_rows_le[of A' "dim_row A'" n "-A'" "dim_row A'" b' x "-b'"]
      1 2 3 4
      by blast
  qed
  {
  fix x
  assume "x \<in> carrier_vec n" "(A' @\<^sub>r - A') *\<^sub>v x \<le> b' @\<^sub>v - b'"
  then have  "A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b'"
      using "1" "2" "3" append_rows_le by blast
    then have "A' *\<^sub>v x = b'" using eq_system_is_leq_system[of x A' b']
      using \<open>dim_col A' = n\<close> \<open>x \<in> carrier_vec n\<close> carrier_vecD by blast
  then show "x \<in> F"
    using \<open>x \<in> carrier_vec n\<close> assms(5) by blast
}
  show "dim_row (A' @\<^sub>r (-A')) = dim_vec (b' @\<^sub>v (-b'))"
    by (metis "1" "2" "3" append_carrier_vec carrier_append_rows carrier_matD(1)
 carrier_vecD uminus_carrier_vec)
  show "dim_col (A' @\<^sub>r (-A')) = n"
    by (meson "1" "2" carrier_append_rows carrier_matD(2))
qed

lemma eq_polyhedron_neg_indices:
   fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
 assumes "(A', b') = sub_system A b I'"
 assumes " F = {x.  x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}"
 assumes "i < dim_row (A' @\<^sub>r (-A'))"
 obtains j where "j < dim_row (A' @\<^sub>r (-A'))"
                 "row (A' @\<^sub>r (-A')) i = - (row (A' @\<^sub>r (-A')) j)"
                 "(b' @\<^sub>v (-b')) $ i = - ((b' @\<^sub>v (-b')) $ j)"
proof(cases "i < dim_row A'")
  case True
  have "row (A' @\<^sub>r (-A')) i = row A' i"
    by (meson True append_rows_nth(1) carrier_matI uminus_carrier_mat)
  have "i < dim_vec b'" using True assms(4) A b
    by (metis carrier_matD(1) carrier_vecD dims_subsyst_same')
  then have "(b' @\<^sub>v (-b')) $ i = b' $ i" using index_append_vec
    by (metis trans_less_add1)
  let ?i' = "i + dim_row A'"
  have "row (A' @\<^sub>r (-A')) ?i' = row (-A') i" using append_rows_nth(2)
    by (smt (verit, ccfv_threshold) True add.commute add_diff_cancel_right'
        add_less_le_mono carrier_matI index_uminus_mat(2) index_uminus_mat(3) trans_less_add1
        verit_comp_simplify1(2) verit_comp_simplify1(3))
  then have 2:"row (A' @\<^sub>r (-A')) i = - (row (A' @\<^sub>r (-A')) ?i')"
    by (metis True \<open>row (A' @\<^sub>r - A') i = row A' i\<close> row_uminus uminus_uminus_vec)
  have "?i' = i + dim_vec b'"
    by (metis A assms(4) b carrier_matD(1) carrier_vecD dims_subsyst_same')
  then have "(b' @\<^sub>v (-b')) $ ?i' = - b' $ i"
    by (simp add: \<open>i < dim_vec b'\<close>)
  then have 1:"(b' @\<^sub>v (-b')) $ i = - ((b' @\<^sub>v (-b')) $ ?i')"
    using R.minus_minus \<open>(b' @\<^sub>v - b') $ i = b' $ i\<close> by presburger
  have "?i' < dim_row (A' @\<^sub>r (-A'))"
    using A True \<open>i + dim_row A' = i + dim_vec b'\<close> assms(4) b face_is_polyhedron'(2) by auto
  then show ?thesis
    using 1 2 that by blast
next
  case False
  have 1:"i \<ge> dim_row A'" using False by auto
  have 2:"i < dim_row A' + dim_row (-A')"
    by (metis (mono_tags, lifting) A assms(4) assms(6) b carrier_matD(1) carrier_vecD
        dims_subsyst_same' face_is_polyhedron'(2) index_append_vec(2) index_uminus_mat(2)
        index_uminus_vec(2))
  let ?i' = "i - dim_row A'"
  have "row (A' @\<^sub>r (-A')) i = row (-A') ?i'"
    using append_rows_nth(2)[of A' "dim_row A'" _ "-A'" "dim_row (-A')" i]
    by (metis \<open>dim_row A' \<le> i\<close> \<open>i < dim_row A' + dim_row (- A')\<close> carrier_matI index_uminus_mat(3))
  then have 3:"row (A' @\<^sub>r (-A')) i = - (row (A' @\<^sub>r (-A')) ?i')"
    by (smt (verit, best) 1 2 append_rows_nth(1) carrier_matI index_uminus_mat(2)
        index_uminus_mat(3) less_diff_conv2 row_uminus)
  have "?i' = i - dim_vec b'"
    by (metis A assms(4) b carrier_matD(1) carrier_vecD dims_subsyst_same')
  then have "(b' @\<^sub>v (-b')) $ i = - b' $ ?i'"
    by (metis A False 1 2 assms(4) assms(6) b carrier_matD(1) carrier_vecD dims_subsyst_same'
        face_is_polyhedron'(2) index_append_vec(1) index_append_vec(2) index_uminus_mat(2)
        index_uminus_vec(1) less_diff_conv2)
  then have "(b' @\<^sub>v (-b')) $ i = - ((b' @\<^sub>v (-b')) $ ?i')"
    by (metis A 1 2 assms(4) b carrier_matD(1) carrier_vecD dims_subsyst_same'
        index_append_vec(1) index_uminus_mat(2) less_diff_conv2 trans_less_add1)
  then show ?thesis
    by (metis 1 3 add_lessD1 assms(6) ordered_cancel_comm_monoid_diff_class.diff_add that)
qed

lemma subset_is_face:
  assumes "face P F"
  assumes "face P F'"
  assumes "F' \<subseteq> F"
  shows "face F F'"
proof -
  have "F \<subseteq> P" using assms(1)
    by (simp add: face_subset_polyhedron)
  obtain \<alpha> \<beta> where \<alpha>_\<beta>:"valid_ineq P \<alpha> \<beta> \<and> F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> F \<noteq> {}"
    using assms(1)
    by (blast elim: faceE')
 obtain \<gamma> \<delta> where \<gamma>_\<delta>:"valid_ineq P \<gamma> \<delta> \<and> F' = P \<inter> {x |x. \<gamma> \<bullet> x = \<delta>} \<and> F' \<noteq> {}"
   using assms(2)
   by (blast elim: faceE')
  have "F' = F' \<inter> {x |x. \<alpha> \<bullet> x = \<beta>}"
    using \<alpha>_\<beta> assms(3) by blast
  then have "F' = P \<inter> {x |x. \<gamma> \<bullet> x = \<delta>} \<inter> {x |x. \<alpha> \<bullet> x = \<beta>}"
    using \<gamma>_\<delta> by fastforce
  then have "F' = F \<inter> {x |x. \<gamma> \<bullet> x = \<delta>}"
    using \<alpha>_\<beta> by fastforce
  have "valid_ineq F \<gamma> \<delta>"
    using \<open>F \<subseteq> P\<close> \<gamma>_\<delta> by blast
  then show "face F F'"
    using \<open>F' = F \<inter> {x |x. \<gamma> \<bullet> x = \<delta>}\<close> \<gamma>_\<delta> by blast
qed

lemma char_min_face2:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes " F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'}"
 assumes "(A', b') = sub_system A b I'"
 assumes "F \<subseteq> P"
 assumes "F \<noteq> {}"
 shows "min_face P F"
proof
  have "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
    using  assms(4) assms(6)
    unfolding P_def polyhedron_def
    by blast
  then show "face P F" using char_face2
    using A P_def assms(5) assms(7) b by blast
  show "\<not> (\<exists>F'\<subset>F. face P F')"
  proof(rule ccontr)
    assume "\<not> \<not> (\<exists>F'\<subset>F. face P F')"
    then obtain F' where "F'\<subset>F \<and> face P F'"
      by presburger
    then have "face F F'"
      by (meson \<open>face P F\<close> subset_is_face psubset_imp_subset)
    obtain C d where C_d:"F = polyhedron C d" "C = (A' @\<^sub>r (-A'))" "d = (b' @\<^sub>v (-b'))"
      using P_def \<open>face P F\<close> face_is_polyhedron'
      using A assms(4) assms(5) b
      by algebra
    then have "face (polyhedron C d) F'" using `face F F'`
      by presburger
    have 1:"dim_row C = dim_vec d"
      using P_def \<open>face P F\<close> face_is_polyhedron'(2)
      using A assms(4) assms(5) b
      using \<open>C = A' @\<^sub>r - A'\<close> \<open>d = b' @\<^sub>v - b'\<close> by blast
    have "F = {x. x \<in> carrier_vec n \<and> C *\<^sub>v x \<le> d }"
      using `F = polyhedron C d` unfolding polyhedron_def
      by blast
    have "C \<in> carrier_mat (dim_vec d) n"
 using P_def \<open>face P F\<close> face_is_polyhedron'(3)
      using A assms(4) assms(5) b
      using \<open>C = A' @\<^sub>r - A'\<close> \<open>d = b' @\<^sub>v - b'\<close>
      using \<open>dim_row C = dim_vec d\<close> by blast
    have "d \<in> carrier_vec (dim_vec d)"
      using carrier_vec_dim_vec by blast
    obtain C' d' I'' where C'_d':"((C', d') = sub_system C d I'')" "F' = {x. C' *\<^sub>v x = d' \<and> x \<in> F}"
      using char_face1[of C "dim_vec d" d F']
      using `F = polyhedron C d`
        `face (polyhedron C d) F'`
       `C \<in> carrier_mat (dim_vec d) n` `d \<in> carrier_vec (dim_vec d)`
      by blast
     obtain x where "x \<in> F - F'"
      using \<open>F' \<subset> F \<and> face P F'\<close> by blast
    then have x:"\<not> (C' *\<^sub>v x = d') \<and>  x \<in> carrier_vec n \<and> C *\<^sub>v x \<le> d"
  by (auto simp: P_def \<open>F = {x. x \<in> carrier_vec n \<and> C *\<^sub>v x \<le> d }\<close> \<open>F' = {x. C'*\<^sub>v x = d' \<and> x \<in> F}\<close>
          gram_schmidt.polyhedron_def)
  then obtain i where i: "i < dim_row C' \<and> \<not> (row C' i \<bullet> x = d' $ i)"
    using index_mult_mat_vec
    by (metis C'_d'(1) \<open>C \<in> carrier_mat (dim_vec d) n\<close> carrier_matD(1)
        dim_mult_mat_vec dims_subsyst_same' eq_vecI)
  then obtain j where j:"j < dim_row C \<and>  row C' i = row C j \<and> d' $ i = d $ j"
    using exist_index_in_A
    by (metis C'_d'(1) \<open>dim_row C = dim_vec d\<close> dims_subsyst_same fst_conv snd_conv)
  have "\<not> (row C j \<bullet> x = d $ j)"
    using \<open>j < dim_row C \<and> row C' i = row C j \<and> d' $ i = d $ j\<close> i by presburger
  then obtain j' where j :"j < dim_row C" "row C j = - (row C j')" "d $ j = - (d $ j')"
    using eq_polyhedron_neg_indices A \<open>C = A' @\<^sub>r - A'\<close> j assms(5) b \<open>d = b' @\<^sub>v - b'\<close>
    by metis
  have "x \<in>  carrier_vec n \<and> C *\<^sub>v x \<le> d"
    by (simp add: x)
  then have "row C j \<bullet> x \<le> d $ j \<and> row C j' \<bullet> x \<le> d $ j'"
    using A C_d j 1
    by (smt (verit, best) assms(5) b eq_polyhedron_neg_indices index_mult_mat_vec less_eq_vec_def
        neg_equal_iff_equal uminus_eq_vec)
  then have "row C j \<bullet> x \<le> d $ j \<and> - (row C j) \<bullet> x \<le> - d $ j"
    by (metis j(2-3) R.minus_minus uminus_uminus_vec)
  then have "row C j \<bullet> x \<le> d $ j \<and>  (row C j) \<bullet> x \<ge>  d $ j"
    by (metis \<open>C \<in> carrier_mat (dim_vec d) n\<close> \<open>x \<in> carrier_vec n \<and> C *\<^sub>v x \<le> d\<close> carrier_matD(2)
        carrier_vecD neg_le_iff_le row_carrier scalar_prod_uminus_left)
    then have "row C j \<bullet> x = d $ j"
      using nle_le by blast
    then show False
      by (simp add: \<open>row C j \<bullet> x \<noteq> d $ j\<close>)
  qed
qed

lemma char_min_face:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 shows "min_face P F \<longleftrightarrow> F \<subseteq> P \<and> F \<noteq> {} \<and>
        (\<exists> A' b' I'. (A', b') = sub_system A b I' \<and> F = {x. x \<in> carrier_vec n \<and> A' *\<^sub>v x = b'})"
  using char_min_face1 char_min_face2
  by (smt (verit, best) A P_def b face_non_empty face_subset_polyhedron min_face_elim(1))

lemma face_is_polyhedron'':
   fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
 assumes "(A', b') = sub_system A b I'"
  assumes " F = {x.  x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A *\<^sub>v x \<le> b}"
  shows "F = polyhedron ((A' @\<^sub>r (-A')) @\<^sub>r A) ((b' @\<^sub>v (-b')) @\<^sub>v b)"
        "dim_row ((A' @\<^sub>r (-A')) @\<^sub>r A) = dim_vec ((b' @\<^sub>v (-b')) @\<^sub>v b)"
        "dim_col ((A' @\<^sub>r (-A')) @\<^sub>r A) = n"
  unfolding polyhedron_def
proof(safe)
  show "\<And>x. x \<in> F \<Longrightarrow> x \<in> carrier_vec n"
    using assms(5) by blast
 have "dim_col A' = n" using dim_col_subsyst_mat A
      by (metis assms(4) carrier_matD(2) prod.sel(1))
    then have 1:"A' \<in> carrier_mat (dim_row A') n"
      by blast
    then have 2:"- A' \<in> carrier_mat (dim_row A') n"
      using uminus_carrier_mat by blast
    have 3:" b' \<in> carrier_vec (dim_row A')"
      by (metis A assms(4) b carrier_dim_vec carrier_matD(1) dims_subsyst_same')
  show "\<And>x. x \<in> F \<Longrightarrow> ((A' @\<^sub>r - A') @\<^sub>r A) *\<^sub>v x \<le> (b' @\<^sub>v - b') @\<^sub>v b"
  proof -
    fix x
    assume "x \<in> F"
    have "dim_col A' = n" using dim_col_subsyst_mat A
      by (metis assms(4) carrier_matD(2) prod.sel(1))
    have 4:"x \<in> carrier_vec n" using `x \<in> F` assms(5) by blast
    have "A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b'" using eq_system_is_leq_system
      using \<open>dim_col A' = n\<close> \<open>x \<in> F\<close> assms(5) carrier_vecD by blast
    then show "((A' @\<^sub>r - A') @\<^sub>r A) *\<^sub>v x \<le> (b' @\<^sub>v - b') @\<^sub>v b"
      using append_rows_le[of A' "dim_row A'" n "-A'" "dim_row A'" b' x "-b'"]
      1 2 3 4
      by (metis (no_types, lifting) A \<open>x \<in> F\<close> append_rows_le assms(4) assms(5) b carrier_matI
          carrier_vec_dim_vec face_is_polyhedron'(2) face_is_polyhedron'(3) mem_Collect_eq)
  qed
  {
  fix x
  assume "x \<in> carrier_vec n" "((A' @\<^sub>r - A') @\<^sub>r A) *\<^sub>v x \<le> (b' @\<^sub>v - b') @\<^sub>v b"
  then have  "A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b' \<and> A *\<^sub>v x \<le> b"
    using "1" "2" "3" append_rows_le
    by (smt (verit, ccfv_threshold) A assms(4) b carrier_matI carrier_vec_dim_vec
        face_is_polyhedron'(2) face_is_polyhedron'(3))
    then have "A' *\<^sub>v x = b'" using eq_system_is_leq_system[of x A' b']
      using \<open>dim_col A' = n\<close> \<open>x \<in> carrier_vec n\<close> carrier_vecD by blast
  then show "x \<in> F"
    using \<open>x \<in> carrier_vec n\<close> assms(5)
    using \<open>A' *\<^sub>v x \<le> b' \<and> - A' *\<^sub>v x \<le> - b' \<and> A *\<^sub>v x \<le> b\<close> by blast
}
  show "dim_row ((A' @\<^sub>r - A') @\<^sub>r A) = dim_vec ((b' @\<^sub>v - b') @\<^sub>v b)"
    using "1" "2" "3" append_carrier_vec carrier_append_rows carrier_matD(1)
      carrier_vecD uminus_carrier_vec
    by (smt (verit, ccfv_SIG) A b)
  show " dim_col ((A' @\<^sub>r - A') @\<^sub>r A) = n"
    using "1" "2" carrier_append_rows carrier_matD(2)
    by (metis append_rows_def index_mat_four_block(3) index_zero_mat(3))
qed

lemma face_is_polyhedron''2:
   fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
 assumes "(A', b') = sub_system A b I'"
  assumes " F = {x.  x \<in> carrier_vec n \<and> A' *\<^sub>v x = b' \<and> A *\<^sub>v x \<le> b}"
  shows "F = polyhedron (A @\<^sub>r (A' @\<^sub>r (-A'))) ( b @\<^sub>v(b' @\<^sub>v (-b')))"
        "dim_row (A @\<^sub>r(A' @\<^sub>r (-A'))) = dim_vec (b @\<^sub>v(b' @\<^sub>v (-b')))"
        "dim_col (A @\<^sub>r(A' @\<^sub>r (-A'))) = n"
proof -
have "dim_col A' = n" using dim_col_subsyst_mat A
      by (metis assms(4) carrier_matD(2) prod.sel(1))
    then have 1:"A' \<in> carrier_mat (dim_row A') n"
      by blast
    then have 2:"- A' \<in> carrier_mat (dim_row A') n"
      using uminus_carrier_mat by blast
  have "F = polyhedron ((A' @\<^sub>r (-A')) @\<^sub>r A) ((b' @\<^sub>v (-b')) @\<^sub>v b)"
    using face_is_polyhedron'' assms
    by blast
  then show "F = polyhedron (A @\<^sub>r A' @\<^sub>r - A') (b @\<^sub>v b' @\<^sub>v - b')"
    by (smt (verit, best) A Collect_cong append_rows_le assms(4) b carrier_matI
        carrier_vec_dim_vec face_is_polyhedron'(2) face_is_polyhedron'(3)
        gram_schmidt.polyhedron_def)
  have "dim_row ((A' @\<^sub>r - A') @\<^sub>r A) = dim_vec ((b' @\<^sub>v - b') @\<^sub>v b)"
    using face_is_polyhedron''(2) assms by blast
  have "dim_row ((A' @\<^sub>r - A') @\<^sub>r A) = dim_row (A @\<^sub>r (A' @\<^sub>r - A'))"
    unfolding append_rows_def
    by (simp add: add.commute)
  have "dim_vec ((b' @\<^sub>v - b') @\<^sub>v b) =  dim_vec (b @\<^sub>v b' @\<^sub>v - b')"
    unfolding append_vec_def
    by (metis add.commute dim_vec)
  then show "dim_row (A @\<^sub>r A' @\<^sub>r - A') = dim_vec (b @\<^sub>v b' @\<^sub>v - b')"
    by (metis \<open>dim_row ((A' @\<^sub>r - A') @\<^sub>r A) = dim_row (A @\<^sub>r A' @\<^sub>r - A')\<close>
        \<open>dim_row ((A' @\<^sub>r - A') @\<^sub>r A) = dim_vec ((b' @\<^sub>v - b') @\<^sub>v b)\<close>)
  show "dim_col (A @\<^sub>r(A' @\<^sub>r (-A'))) = n"
    using "1" "2" carrier_append_rows carrier_matD(2)
    using A by blast
qed

lemma face_is_polyhedron:
   fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
 fixes b
 assumes A: "A \<in> carrier_mat nr n"
 assumes b: "b \<in> carrier_vec nr"
 defines "P \<equiv> polyhedron A b"
 assumes "face P F"
 obtains A' b' where "F = polyhedron A' b'" "dim_row A' = dim_vec b'" "dim_col A' = n"
proof -
  obtain  A' b' I'  where  "(A', b') = sub_system A b I'"
                      " F = {x.  A' *\<^sub>v x = b' \<and> x \<in> P}"
    using char_face1[of A nr b F]
    using A P_def assms(4) b by blast
  then show ?thesis using face_is_polyhedron''
    by (smt (verit, best) A Collect_cong P_def b gram_schmidt.polyhedron_def mem_Collect_eq that)
qed

end
end


(*  Title:      ZF/Constructible/AC_in_L.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>The Axiom of Choice Holds in L!\<close>

theory AC_in_L imports Formula Separation begin

subsection\<open>Extending a Wellordering over a List -- Lexicographic Power\<close>

text\<open>This could be moved into a library.\<close>

consts
  rlist   :: "[i,i]=>i"

inductive
  domains "rlist(A,r)" \<subseteq> "list(A) * list(A)"
  intros
    shorterI:
      "[| length(l') < length(l); l' \<in> list(A); l \<in> list(A) |]
       ==> <l', l> \<in> rlist(A,r)"

    sameI:
      "[| <l',l> \<in> rlist(A,r); a \<in> A |]
       ==> <Cons(a,l'), Cons(a,l)> \<in> rlist(A,r)"

    diffI:
      "[| length(l') = length(l); <a',a> \<in> r;
          l' \<in> list(A); l \<in> list(A); a' \<in> A; a \<in> A |]
       ==> <Cons(a',l'), Cons(a,l)> \<in> rlist(A,r)"
  type_intros list.intros

subsubsection\<open>Type checking\<close>

lemmas rlist_type = rlist.dom_subset

lemmas field_rlist = rlist_type [THEN field_rel_subset]

subsubsection\<open>Linearity\<close>

lemma rlist_Nil_Cons [intro]:
    "[|a \<in> A; l \<in> list(A)|] ==> <[], Cons(a,l)> \<in> rlist(A, r)"
by (simp add: shorterI)

lemma linear_rlist:
  assumes r: "linear(A,r)" shows "linear(list(A),rlist(A,r))"
proof -
  { fix xs ys
    have "xs \<in> list(A) \<Longrightarrow> ys \<in> list(A) \<Longrightarrow> \<langle>xs,ys\<rangle> \<in> rlist(A,r) \<or> xs = ys \<or> \<langle>ys,xs\<rangle> \<in> rlist(A, r) "
    proof (induct xs arbitrary: ys rule: list.induct)
      case Nil
      thus ?case by (induct ys rule: list.induct) (auto simp add: shorterI)
    next
      case (Cons x xs)
      { fix y ys
        assume "y \<in> A" and "ys \<in> list(A)"
        with Cons
        have "\<langle>Cons(x,xs),Cons(y,ys)\<rangle> \<in> rlist(A,r) \<or> x=y & xs = ys \<or> \<langle>Cons(y,ys), Cons(x,xs)\<rangle> \<in> rlist(A,r)"
          apply (rule_tac i = "length(xs)" and j = "length(ys)" in Ord_linear_lt)
          apply (simp_all add: shorterI)
          apply (rule linearE [OF r, of x y])
          apply (auto simp add: diffI intro: sameI)
          done
      }
      note yConsCase = this
      show ?case using \<open>ys \<in> list(A)\<close>
        by (cases rule: list.cases) (simp_all add: Cons rlist_Nil_Cons yConsCase)
    qed
  }
  thus ?thesis by (simp add: linear_def)
qed

subsubsection\<open>Well-foundedness\<close>

text\<open>Nothing preceeds Nil in this ordering.\<close>
inductive_cases rlist_NilE: " <l,[]> \<in> rlist(A,r)"

inductive_cases rlist_ConsE: " <l', Cons(x,l)> \<in> rlist(A,r)"

lemma not_rlist_Nil [simp]: " <l,[]> \<notin> rlist(A,r)"
by (blast intro: elim: rlist_NilE)

lemma rlist_imp_length_le: "<l',l> \<in> rlist(A,r) ==> length(l') \<le> length(l)"
apply (erule rlist.induct)
apply (simp_all add: leI)
done

lemma wf_on_rlist_n:
  "[| n \<in> nat; wf[A](r) |] ==> wf[{l \<in> list(A). length(l) = n}](rlist(A,r))"
apply (induct_tac n)
 apply (rule wf_onI2, simp)
apply (rule wf_onI2, clarify)
apply (erule_tac a=y in list.cases, clarify)
 apply (simp (no_asm_use))
apply clarify
apply (simp (no_asm_use))
apply (subgoal_tac "\<forall>l2 \<in> list(A). length(l2) = x \<longrightarrow> Cons(a,l2) \<in> B", blast)
apply (erule_tac a=a in wf_on_induct, assumption)
apply (rule ballI)
apply (rule impI)
apply (erule_tac a=l2 in wf_on_induct, blast, clarify)
apply (rename_tac a' l2 l')
apply (drule_tac x="Cons(a',l')" in bspec, typecheck)
apply simp
apply (erule mp, clarify)
apply (erule rlist_ConsE, auto)
done

lemma list_eq_UN_length: "list(A) = (\<Union>n\<in>nat. {l \<in> list(A). length(l) = n})"
by (blast intro: length_type)

lemma wf_on_rlist: "wf[A](r) ==> wf[list(A)](rlist(A,r))"
apply (subst list_eq_UN_length)
apply (rule wf_on_Union)
  apply (rule wf_imp_wf_on [OF wf_Memrel [of nat]])
 apply (simp add: wf_on_rlist_n)
apply (frule rlist_type [THEN subsetD])
apply (simp add: length_type)
apply (drule rlist_imp_length_le)
apply (erule leE)
apply (simp_all add: lt_def)
done

lemma wf_rlist: "wf(r) ==> wf(rlist(field(r),r))"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A [OF _ field_rlist])
apply (blast intro: wf_on_rlist)
done

lemma well_ord_rlist:
     "well_ord(A,r) ==> well_ord(list(A), rlist(A,r))"
apply (rule well_ordI)
apply (simp add: well_ord_def wf_on_rlist)
apply (simp add: well_ord_def tot_ord_def linear_rlist)
done

subsection\<open>An Injection from Formulas into the Natural Numbers\<close>

text\<open>There is a well-known bijection between @{term "nat*nat"} and @{term
nat} given by the expression f(m,n) = triangle(m+n) + m, where triangle(k)
enumerates the triangular numbers and can be defined by triangle(0)=0,
triangle(succ(k)) = succ(k + triangle(k)).  Some small amount of effort is
needed to show that f is a bijection.  We already know that such a bijection exists by the theorem \<open>well_ord_InfCard_square_eq\<close>:
@{thm[display] well_ord_InfCard_square_eq[no_vars]}

However, this result merely states that there is a bijection between the two
sets.  It provides no means of naming a specific bijection.  Therefore, we
conduct the proofs under the assumption that a bijection exists.  The simplest
way to organize this is to use a locale.\<close>

text\<open>Locale for any arbitrary injection between @{term "nat*nat"}
      and @{term nat}\<close>
locale Nat_Times_Nat =
  fixes fn
  assumes fn_inj: "fn \<in> inj(nat*nat, nat)"

consts   enum :: "[i,i]=>i"
primrec
  "enum(f, Member(x,y)) = f ` <0, f ` <x,y>>"
  "enum(f, Equal(x,y)) = f ` <1, f ` <x,y>>"
  "enum(f, Nand(p,q)) = f ` <2, f ` <enum(f,p), enum(f,q)>>"
  "enum(f, Forall(p)) = f ` <succ(2), enum(f,p)>"

lemma (in Nat_Times_Nat) fn_type [TC,simp]:
    "[|x \<in> nat; y \<in> nat|] ==> fn`<x,y> \<in> nat"
by (blast intro: inj_is_fun [OF fn_inj] apply_funtype)

lemma (in Nat_Times_Nat) fn_iff:
    "[|x \<in> nat; y \<in> nat; u \<in> nat; v \<in> nat|]
     ==> (fn`<x,y> = fn`<u,v>) \<longleftrightarrow> (x=u & y=v)"
by (blast dest: inj_apply_equality [OF fn_inj])

lemma (in Nat_Times_Nat) enum_type [TC,simp]:
    "p \<in> formula ==> enum(fn,p) \<in> nat"
by (induct_tac p, simp_all)

lemma (in Nat_Times_Nat) enum_inject [rule_format]:
    "p \<in> formula ==> \<forall>q\<in>formula. enum(fn,p) = enum(fn,q) \<longrightarrow> p=q"
apply (induct_tac p, simp_all)
   apply (rule ballI)
   apply (erule formula.cases)
   apply (simp_all add: fn_iff)
  apply (rule ballI)
  apply (erule formula.cases)
  apply (simp_all add: fn_iff)
 apply (rule ballI)
 apply (erule_tac a=qa in formula.cases)
 apply (simp_all add: fn_iff)
 apply blast
apply (rule ballI)
apply (erule_tac a=q in formula.cases)
apply (simp_all add: fn_iff, blast)
done

lemma (in Nat_Times_Nat) inj_formula_nat:
    "(\<lambda>p \<in> formula. enum(fn,p)) \<in> inj(formula, nat)"
apply (simp add: inj_def lam_type)
apply (blast intro: enum_inject)
done

lemma (in Nat_Times_Nat) well_ord_formula:
    "well_ord(formula, measure(formula, enum(fn)))"
apply (rule well_ord_measure, simp)
apply (blast intro: enum_inject)
done

lemmas nat_times_nat_lepoll_nat =
    InfCard_nat [THEN InfCard_square_eqpoll, THEN eqpoll_imp_lepoll]

text\<open>Not needed--but interesting?\<close>
theorem formula_lepoll_nat: "formula \<lesssim> nat"
apply (insert nat_times_nat_lepoll_nat)
apply (unfold lepoll_def)
apply (blast intro: Nat_Times_Nat.inj_formula_nat Nat_Times_Nat.intro)
done

subsection\<open>Defining the Wellordering on @{term "DPow(A)"}\<close>

text\<open>The objective is to build a wellordering on @{term "DPow(A)"} from a
given one on @{term A}.  We first introduce wellorderings for environments,
which are lists built over @{term "A"}.  We combine it with the enumeration of
formulas.  The order type of the resulting wellordering gives us a map from
(environment, formula) pairs into the ordinals.  For each member of @{term
"DPow(A)"}, we take the minimum such ordinal.\<close>

definition
  env_form_r :: "[i,i,i]=>i" where
    \<comment>\<open>wellordering on (environment, formula) pairs\<close>
   "env_form_r(f,r,A) ==
      rmult(list(A), rlist(A, r),
            formula, measure(formula, enum(f)))"

definition
  env_form_map :: "[i,i,i,i]=>i" where
    \<comment>\<open>map from (environment, formula) pairs to ordinals\<close>
   "env_form_map(f,r,A,z)
      == ordermap(list(A) * formula, env_form_r(f,r,A)) ` z"

definition
  DPow_ord :: "[i,i,i,i,i]=>o" where
    \<comment>\<open>predicate that holds if @{term k} is a valid index for @{term X}\<close>
   "DPow_ord(f,r,A,X,k) ==
           \<exists>env \<in> list(A). \<exists>p \<in> formula.
             arity(p) \<le> succ(length(env)) &
             X = {x\<in>A. sats(A, p, Cons(x,env))} &
             env_form_map(f,r,A,<env,p>) = k"

definition
  DPow_least :: "[i,i,i,i]=>i" where
    \<comment>\<open>function yielding the smallest index for @{term X}\<close>
   "DPow_least(f,r,A,X) == \<mu> k. DPow_ord(f,r,A,X,k)"

definition
  DPow_r :: "[i,i,i]=>i" where
    \<comment>\<open>a wellordering on @{term "DPow(A)"}\<close>
   "DPow_r(f,r,A) == measure(DPow(A), DPow_least(f,r,A))"

lemma (in Nat_Times_Nat) well_ord_env_form_r:
    "well_ord(A,r)
     ==> well_ord(list(A) * formula, env_form_r(fn,r,A))"
by (simp add: env_form_r_def well_ord_rmult well_ord_rlist well_ord_formula)

lemma (in Nat_Times_Nat) Ord_env_form_map:
    "[|well_ord(A,r); z \<in> list(A) * formula|]
     ==> Ord(env_form_map(fn,r,A,z))"
by (simp add: env_form_map_def Ord_ordermap well_ord_env_form_r)

lemma DPow_imp_ex_DPow_ord:
    "X \<in> DPow(A) ==> \<exists>k. DPow_ord(fn,r,A,X,k)"
apply (simp add: DPow_ord_def)
apply (blast dest!: DPowD)
done

lemma (in Nat_Times_Nat) DPow_ord_imp_Ord:
     "[|DPow_ord(fn,r,A,X,k); well_ord(A,r)|] ==> Ord(k)"
apply (simp add: DPow_ord_def, clarify)
apply (simp add: Ord_env_form_map)
done

lemma (in Nat_Times_Nat) DPow_imp_DPow_least:
    "[|X \<in> DPow(A); well_ord(A,r)|]
     ==> DPow_ord(fn, r, A, X, DPow_least(fn,r,A,X))"
apply (simp add: DPow_least_def)
apply (blast dest: DPow_imp_ex_DPow_ord intro: DPow_ord_imp_Ord LeastI)
done

lemma (in Nat_Times_Nat) env_form_map_inject:
    "[|env_form_map(fn,r,A,u) = env_form_map(fn,r,A,v); well_ord(A,r);
       u \<in> list(A) * formula;  v \<in> list(A) * formula|]
     ==> u=v"
apply (simp add: env_form_map_def)
apply (rule inj_apply_equality [OF bij_is_inj, OF ordermap_bij,
                                OF well_ord_env_form_r], assumption+)
done

lemma (in Nat_Times_Nat) DPow_ord_unique:
    "[|DPow_ord(fn,r,A,X,k); DPow_ord(fn,r,A,Y,k); well_ord(A,r)|]
     ==> X=Y"
apply (simp add: DPow_ord_def, clarify)
apply (drule env_form_map_inject, auto)
done

lemma (in Nat_Times_Nat) well_ord_DPow_r:
    "well_ord(A,r) ==> well_ord(DPow(A), DPow_r(fn,r,A))"
apply (simp add: DPow_r_def)
apply (rule well_ord_measure)
 apply (simp add: DPow_least_def Ord_Least)
apply (drule DPow_imp_DPow_least, assumption)+
apply simp
apply (blast intro: DPow_ord_unique)
done

lemma (in Nat_Times_Nat) DPow_r_type:
    "DPow_r(fn,r,A) \<subseteq> DPow(A) * DPow(A)"
by (simp add: DPow_r_def measure_def, blast)

subsection\<open>Limit Construction for Well-Orderings\<close>

text\<open>Now we work towards the transfinite definition of wellorderings for
@{term "Lset(i)"}.  We assume as an inductive hypothesis that there is a family
of wellorderings for smaller ordinals.\<close>

definition
  rlimit :: "[i,i=>i]=>i" where
  \<comment>\<open>Expresses the wellordering at limit ordinals.  The conditional
      lets us remove the premise @{term "Limit(i)"} from some theorems.\<close>
    "rlimit(i,r) ==
       if Limit(i) then
         {z: Lset(i) * Lset(i).
          \<exists>x' x. z = <x',x> &
                 (lrank(x') < lrank(x) |
                  (lrank(x') = lrank(x) & <x',x> \<in> r(succ(lrank(x)))))}
       else 0"

definition
  Lset_new :: "i=>i" where
  \<comment>\<open>This constant denotes the set of elements introduced at level
      @{term "succ(i)"}\<close>
    "Lset_new(i) == {x \<in> Lset(succ(i)). lrank(x) = i}"

lemma Limit_Lset_eq2:
    "Limit(i) ==> Lset(i) = (\<Union>j\<in>i. Lset_new(j))"
apply (simp add: Limit_Lset_eq)
apply (rule equalityI)
 apply safe
 apply (subgoal_tac "Ord(y)")
  prefer 2 apply (blast intro: Ord_in_Ord Limit_is_Ord)
 apply (simp_all add: Limit_is_Ord Lset_iff_lrank_lt Lset_new_def
                      Ord_mem_iff_lt)
 apply (blast intro: lt_trans)
apply (rule_tac x = "succ(lrank(x))" in bexI)
 apply (simp add: Lset_succ_lrank_iff)
apply (blast intro: Limit_has_succ ltD)
done

lemma wf_on_Lset:
    "wf[Lset(succ(j))](r(succ(j))) ==> wf[Lset_new(j)](rlimit(i,r))"
apply (simp add: wf_on_def Lset_new_def)
apply (erule wf_subset)
apply (simp add: rlimit_def, force)
done

lemma wf_on_rlimit:
    "(\<forall>j<i. wf[Lset(j)](r(j))) ==> wf[Lset(i)](rlimit(i,r))"
apply (case_tac "Limit(i)")
 prefer 2
 apply (simp add: rlimit_def wf_on_any_0)
apply (simp add: Limit_Lset_eq2)
apply (rule wf_on_Union)
  apply (rule wf_imp_wf_on [OF wf_Memrel [of i]])
 apply (blast intro: wf_on_Lset Limit_has_succ Limit_is_Ord ltI)
apply (force simp add: rlimit_def Limit_is_Ord Lset_iff_lrank_lt Lset_new_def
                       Ord_mem_iff_lt)
done

lemma linear_rlimit:
    "[|Limit(i); \<forall>j<i. linear(Lset(j), r(j)) |]
     ==> linear(Lset(i), rlimit(i,r))"
apply (frule Limit_is_Ord)
apply (simp add: Limit_Lset_eq2 Lset_new_def)
apply (simp add: linear_def rlimit_def Ball_def lt_Ord Lset_iff_lrank_lt)
apply (simp add: ltI, clarify)
apply (rename_tac u v)
apply (rule_tac i="lrank(u)" and j="lrank(v)" in Ord_linear_lt, simp_all)
apply (drule_tac x="succ(lrank(u) \<union> lrank(v))" in ospec)
 apply (simp add: ltI)
apply (drule_tac x=u in spec, simp)
apply (drule_tac x=v in spec, simp)
done

lemma well_ord_rlimit:
    "[|Limit(i); \<forall>j<i. well_ord(Lset(j), r(j)) |]
     ==> well_ord(Lset(i), rlimit(i,r))"
by (blast intro: well_ordI wf_on_rlimit well_ord_is_wf
                           linear_rlimit well_ord_is_linear)

lemma rlimit_cong:
     "(!!j. j<i ==> r'(j) = r(j)) ==> rlimit(i,r) = rlimit(i,r')"
apply (simp add: rlimit_def, clarify)
apply (rule refl iff_refl Collect_cong ex_cong conj_cong)+
apply (simp add: Limit_is_Ord Lset_lrank_lt)
done

subsection\<open>Transfinite Definition of the Wellordering on @{term "L"}\<close>

definition
  L_r :: "[i, i] => i" where
  "L_r(f) == %i.
      transrec3(i, 0, \<lambda>x r. DPow_r(f, r, Lset(x)),
                \<lambda>x r. rlimit(x, \<lambda>y. r`y))"

subsubsection\<open>The Corresponding Recursion Equations\<close>

lemma [simp]: "L_r(f, succ(i)) = DPow_r(f, L_r(f,i), Lset(i))"
by (simp add: L_r_def)

text\<open>The limit case is non-trivial because of the distinction between
object-level and meta-level abstraction.\<close>
lemma [simp]: "Limit(i) ==> L_r(f,i) = rlimit(i, L_r(f))"
by (simp cong: rlimit_cong add: transrec3_Limit L_r_def ltD)

lemma (in Nat_Times_Nat) L_r_type:
    "Ord(i) ==> L_r(fn,i) \<subseteq> Lset(i) * Lset(i)"
apply (induct i rule: trans_induct3)
  apply (simp_all add: Lset_succ DPow_r_type well_ord_DPow_r rlimit_def
                       Transset_subset_DPow [OF Transset_Lset], blast)
done

lemma (in Nat_Times_Nat) well_ord_L_r:
    "Ord(i) ==> well_ord(Lset(i), L_r(fn,i))"
apply (induct i rule: trans_induct3)
apply (simp_all add: well_ord0 Lset_succ L_r_type well_ord_DPow_r
                     well_ord_rlimit ltD)
done

lemma well_ord_L_r:
    "Ord(i) ==> \<exists>r. well_ord(Lset(i), r)"
apply (insert nat_times_nat_lepoll_nat)
apply (unfold lepoll_def)
apply (blast intro: Nat_Times_Nat.well_ord_L_r Nat_Times_Nat.intro)
done

text\<open>Every constructible set is well-ordered! Therefore the Wellordering Theorem and
      the Axiom of Choice hold in @{term L}!!\<close>
theorem L_implies_AC: assumes x: "L(x)" shows "\<exists>r. well_ord(x,r)"
  using Transset_Lset x
apply (simp add: Transset_def L_def)
apply (blast dest!: well_ord_L_r intro: well_ord_subset)
done

interpretation L?: M_basic L by (rule M_basic_L)

theorem "\<forall>x[L]. \<exists>r. wellordered(L,x,r)"
proof
  fix x
  assume "L(x)"
  then obtain r where "well_ord(x,r)"
    by (blast dest: L_implies_AC)
  thus "\<exists>r. wellordered(L,x,r)"
    by (blast intro: well_ord_imp_relativized)
qed

text\<open>In order to prove @{term" \<exists>r[L]. wellordered(L,x,r)"}, it's necessary to know
that @{term r} is actually constructible. It follows from the assumption ``@{term V} equals @{term L''},
but this reasoning doesn't appear to work in Isabelle.\<close>

end